1 -- Various utility functions that do not belong anywhere else.
    2 
    3 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
    4 
    5 module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
    6                      clarify_errors, prettyException, prettyError,
    7                     putStrLnError, putDocLnError,
    8                     withCurrentDirectory,
    9                     withUMask, askUser, stripCr,
   10                     showHexLen, add_to_error_loc,
   11                     maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
   12                     isUnsupportedOperationError, isHardwareFaultError,
   13                     get_viewer, edit_file, promptYorn, promptCharFancy,
   14                     environmentHelpEditor, environmentHelpPager,
   15                     formatPath ) where
   16 
   17 import Prelude hiding ( catch )
   18 import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try )
   19 import GHC.IOBase ( IOException(ioe_location),
   20                     IOErrorType(UnsupportedOperation, HardwareFault) )
   21 import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString )
   22 
   23 import Darcs.SignalHandler ( catchNonSignal )
   24 import Numeric ( showHex )
   25 import System.Directory ( doesFileExist )
   26 import System.Exit ( exitWith, ExitCode(..) )
   27 import System.Environment ( getEnv )
   28 import System.IO ( hPutStrLn, stderr )
   29 import Data.Char ( toUpper )
   30 import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )
   31 import Data.Maybe ( listToMaybe, isJust )
   32 import Data.List ( group, sort )
   33 import Control.Monad ( when )
   34 import Exec ( exec_interactive )
   35 import Printer ( Doc, hPutDocLn )
   36 import Foreign.C.String ( CString, withCString )
   37 import Foreign.C.Error ( throwErrno )
   38 import Foreign.C.Types ( CInt )
   39 
   40 import Progress ( withoutProgress )
   41 
   42 import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,
   43                                   getInputChar, outputStrLn )
   44 import System.Console.Haskeline.Encoding ( encode )
   45 import qualified Data.ByteString as B ( readFile )
   46 import qualified Data.ByteString.Char8 as B ( unpack )
   47 
   48 showHexLen :: (Integral a) => Int -> a -> String
   49 showHexLen n x = let s = showHex x ""
   50                  in replicate (n - length s) ' ' ++ s
   51 
   52 add_to_error_loc :: Exception -> String -> Exception
   53 add_to_error_loc (IOException ioe) s
   54     = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe }
   55 add_to_error_loc e _ = e
   56 
   57 isUnsupportedOperationError :: IOError -> Bool
   58 isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType
   59 
   60 isUnsupportedOperationErrorType :: IOErrorType -> Bool
   61 isUnsupportedOperationErrorType UnsupportedOperation = True
   62 isUnsupportedOperationErrorType _ = False
   63 
   64 isHardwareFaultError :: IOError -> Bool
   65 isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType
   66 
   67 isHardwareFaultErrorType :: IOErrorType -> Bool
   68 isHardwareFaultErrorType HardwareFault = True
   69 isHardwareFaultErrorType _ = False
   70 
   71 catchall :: IO a -> IO a -> IO a
   72 a `catchall` b = a `catchNonSignal` (\_ -> b)
   73 
   74 maybeGetEnv :: String -> IO (Maybe String)
   75 maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing -- err can only be isDoesNotExist
   76 
   77 
   78 -- |The firstJustM returns the first Just entry in a list of monadic operations.  This is close to
   79 --  `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the
   80 --  list before passing it along (i.e. sequence is strict).  The firstJustM is lazy in that list
   81 --  member monads are only evaluated up to the point where the first Just entry is obtained.
   82 firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
   83 firstJustM [] = return Nothing
   84 firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)
   85 
   86 -- |The firstJustIO is a slight modification to firstJustM: the
   87 --  entries in the list must be IO monad operations and the
   88 --  firstJustIO will silently turn any monad call that throws an
   89 --  exception into Nothing, basically causing it to be ignored.
   90 firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
   91 firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)
   92 
   93 
   94 clarify_errors :: IO a -> String -> IO a
   95 clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])
   96 
   97 prettyException :: Control.Exception.Exception -> String
   98 prettyException (IOException e) | isUserError e = ioeGetErrorString e
   99 prettyException e = show e
  100 
  101 prettyError :: IOError -> String
  102 prettyError e | isUserError e = ioeGetErrorString e
  103               | otherwise = show e
  104 
  105 -- | Given two shell commands as arguments, execute the former.  The
  106 -- latter is then executed if the former failed because the executable
  107 -- wasn't found (code 127), wasn't executable (code 126) or some other
  108 -- exception occurred.  Other failures (such as the user holding ^C)
  109 -- do not cause the second command to be tried.
  110 ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
  111 a `ortryrunning` b = do
  112   ret <- try a
  113   case ret of
  114     (Right (ExitFailure 126)) -> b -- command not executable
  115     (Right (ExitFailure 127)) -> b -- command not found
  116     (Right x) -> return x          -- legitimate success/failure
  117     (Left _) -> b                  -- an exception
  118 
  119 putStrLnError :: String -> IO ()
  120 putStrLnError = hPutStrLn stderr
  121 
  122 putDocLnError :: Doc -> IO ()
  123 putDocLnError = hPutDocLn stderr
  124 
  125 withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
  126 withCurrentDirectory name m =
  127     bracket
  128         (do cwd <- getCurrentDirectory
  129             when (toFilePath name /= "") (setCurrentDirectory name)
  130             return cwd)
  131         (\oldwd -> setCurrentDirectory oldwd `catchall` return ())
  132         (const m)
  133 
  134 foreign import ccall unsafe "umask.h set_umask" set_umask
  135     :: CString -> IO CInt
  136 foreign import ccall unsafe "umask.h reset_umask" reset_umask
  137     :: CInt -> IO CInt
  138 
  139 withUMask :: String -> IO a -> IO a
  140 withUMask umask job =
  141     do rc <-withCString umask set_umask
  142        when (rc < 0) (throwErrno "Couldn't set umask")
  143        bracket_
  144            (return ())
  145            (reset_umask rc)
  146            job
  147 
  148 askUser :: String -> IO String
  149 askUser prompt = withoutProgress $ runInputT defaultSettings $
  150                     getInputLine prompt
  151                         >>= maybe (error "askUser: unexpected end of input") return
  152             -- Return the input as encoded, 8-bit Chars (same as the
  153             -- non-Haskeline backend).
  154                         >>= fmap B.unpack . encode
  155 
  156 stripCr :: String -> String
  157 stripCr ""     = ""
  158 stripCr "\r"   = ""
  159 stripCr (c:cs) = c : stripCr cs
  160 
  161 -- |Returns Just l where l is first non-blank string in input array; Nothing if no non-blank entries
  162 firstNotBlank :: [String] -> Maybe String
  163 firstNotBlank = listToMaybe . filter (not . null)
  164 
  165 
  166 -- Format a path for screen output,
  167 -- so that the user sees where the path begins and ends.
  168 -- Could (should?) also warn about unprintable characters here.
  169 formatPath :: String -> String
  170 formatPath path = "\"" ++ quote path ++ "\""
  171     where quote "" = ""
  172           quote (c:cs) = if c=='\\' || c=='"'
  173                          then '\\':c:quote cs
  174                          else c:quote cs
  175 
  176 breakCommand :: String -> (String, [String])
  177 breakCommand s = case words s of
  178                    (arg0:args) -> (arg0,args)
  179                    [] -> (s,[])
  180 
  181 nubsort :: Ord a => [a] -> [a]
  182 nubsort = map head . group . sort
  183 
  184 
  185 edit_file :: FilePathLike p => p -> IO ExitCode
  186 edit_file ff = do
  187   ed <- get_editor
  188   old_content <- file_content
  189   ec <- exec_interactive ed f
  190              `ortryrunning` exec_interactive "emacs" f
  191              `ortryrunning` exec_interactive "emacs -nw" f
  192              `ortryrunning` exec_interactive "nano" f
  193 #ifdef WIN32
  194              `ortryrunning` exec_interactive "edit" f
  195 #endif
  196   new_content <- file_content
  197   when (new_content == old_content) $ do
  198     yorn <- promptYorn "File content did not change. Continue anyway?"
  199     when (yorn == 'n') $ do putStrLn "Aborted."
  200                             exitWith ExitSuccess
  201   return ec
  202       where f = toFilePath ff
  203             file_content = do
  204               exists <- doesFileExist f
  205               if exists then do content <- B.readFile f
  206                                 return $ Just content
  207                         else return Nothing
  208 
  209 get_editor :: IO String
  210 get_editor = getEnv "DARCS_EDITOR" `catchall`
  211              getEnv "DARCSEDITOR" `catchall`
  212              getEnv "VISUAL" `catchall`
  213              getEnv "EDITOR" `catchall` return "vi"
  214 
  215 environmentHelpEditor :: ([String], [String])
  216 environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[
  217  "To edit a patch description of email comment, Darcs will invoke an",
  218  "external editor.  Your preferred editor can be set as any of the",
  219  "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",
  220  "If none of these are set, vi(1) is used.  If vi crashes or is not",
  221  "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",
  222  "each tried in turn."])
  223 
  224 get_viewer :: IO String
  225 get_viewer = getEnv "DARCS_PAGER" `catchall`
  226              getEnv "PAGER" `catchall` return "less"
  227 
  228 environmentHelpPager :: ([String], [String])
  229 environmentHelpPager = (["DARCS_PAGER", "PAGER"],[
  230  "Darcs will sometimes invoke a pager if it deems output to be too long",
  231  "to fit onscreen.  Darcs will use the pager specified by $DARCS_PAGER",
  232  "or $PAGER.  If neither are set, `less' will be used."])
  233 
  234 promptYorn :: [Char] -> IO Char
  235 promptYorn p = promptCharFancy p "yn" Nothing []
  236 
  237 promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char
  238 promptCharFancy p chs md help_chs = withoutProgress $ runInputT defaultSettings $
  239                                         loopChar
  240  where
  241  loopChar = do
  242     let prompt = p ++ " [" ++ setDefault chs ++ "]" ++ helpStr
  243     a <- getInputChar prompt >>= maybe (error "promptCharFancy: unexpected end of input")
  244                                     return
  245     case () of 
  246      _ | a `elem` chs                   -> return a
  247        | a == ' ' -> case md of Nothing -> tryAgain 
  248                                 Just d  -> return d
  249        | a `elem` help_chs              -> return a
  250        | otherwise                      -> tryAgain
  251  helpStr = case help_chs of
  252            []    -> ""
  253            (h:_) -> ", or " ++ (h:" for help: ")
  254  tryAgain = do outputStrLn "Invalid response, try again!"
  255                loopChar
  256  setDefault s = case md of Nothing -> s
  257                            Just d  -> map (setUpper d) s
  258  setUpper d c = if d == c then toUpper c else c