module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
clarifyErrors, prettyException, prettyError,
putStrLnError, putDocLnError,
withCurrentDirectory,
withUMask, askUser, stripCr,
showHexLen, addToErrorLoc,
maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
getViewer, editFile, runEditor,
PromptConfig(..), promptYorn, promptChar,
environmentHelpEditor, environmentHelpPager,
formatPath,
isFileReallySymlink, doesDirectoryReallyExist, doesFileReallyExist
, filterFilePaths, filterPaths
, treeHas, treeHasDir, treeHasFile, treeHasAnycase
) where
import Prelude hiding ( catch )
import Control.Exception.Extensible
( bracket, bracket_, catch, try,
IOException, SomeException, Exception(fromException) )
import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString )
import Darcs.SignalHandler ( catchNonSignal )
import Numeric ( showHex )
import System.Directory ( doesFileExist )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getEnv )
import System.IO ( hPutStrLn, stderr )
import Data.Char ( toUpper, toLower )
import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )
import Data.Maybe ( listToMaybe, isJust )
import Data.List ( group, sort )
import Control.Monad ( when, forM )
import Control.Monad.Error( catchError, MonadError )
import Exec ( execInteractive )
import Printer ( Doc, hPutDocLn )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt )
import qualified Data.ByteString.Char8 as BSC
import System.Posix.Files( getSymbolicLinkStatus, isRegularFile, isDirectory, isSymbolicLink )
import Progress ( withoutProgress )
import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,
getInputChar, outputStrLn )
import qualified Data.ByteString as B ( readFile )
import Control.Monad.State.Strict( gets )
import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath )
import Storage.Hashed.Monad( withDirectory, fileExists, exists, directoryExists
, virtualTreeMonad, currentDirectory
, TreeMonad, tree )
import Storage.Hashed.Tree( Tree, listImmediate, findTree )
showHexLen :: (Integral a) => Int -> a -> String
showHexLen n x = let s = showHex x ""
in replicate (n length s) ' ' ++ s
addToErrorLoc :: IOException -> String -> IOException
addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing
catchall :: IO a -> IO a -> IO a
a `catchall` b = a `catchNonSignal` (\_ -> b)
maybeGetEnv :: String -> IO (Maybe String)
maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing
firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
firstJustM [] = return Nothing
firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)
firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)
clarifyErrors :: IO a -> String -> IO a
clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])
prettyException :: SomeException -> String
prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe
prettyException e = show e
prettyError :: IOError -> String
prettyError e | isUserError e = ioeGetErrorString e
| otherwise = show e
ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
a `ortryrunning` b = do
ret <- try a
case ret of
(Right (ExitFailure 126)) -> b
(Right (ExitFailure 127)) -> b
(Right x) -> return x
(Left (_ :: SomeException)) -> b
putStrLnError :: String -> IO ()
putStrLnError = hPutStrLn stderr
putDocLnError :: Doc -> IO ()
putDocLnError = hPutDocLn stderr
withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
withCurrentDirectory name m =
bracket
(do cwd <- getCurrentDirectory
when (toFilePath name /= "") (setCurrentDirectory name)
return cwd)
(\oldwd -> setCurrentDirectory oldwd `catchall` return ())
(const m)
foreign import ccall unsafe "umask.h set_umask" set_umask
:: CString -> IO CInt
foreign import ccall unsafe "umask.h reset_umask" reset_umask
:: CInt -> IO CInt
withUMask :: String -> IO a -> IO a
withUMask umask job =
do rc <-withCString umask set_umask
when (rc < 0) (throwErrno "Couldn't set umask")
bracket_
(return ())
(reset_umask rc)
job
askUser :: String
-> IO String
askUser prompt = withoutProgress $ runInputT defaultSettings $
getInputLine prompt
>>= maybe (error "askUser: unexpected end of input") return
stripCr :: String -> String
stripCr "" = ""
stripCr "\r" = ""
stripCr (c:cs) = c : stripCr cs
firstNotBlank :: [String] -> Maybe String
firstNotBlank = listToMaybe . filter (not . null)
formatPath :: String -> String
formatPath path = "\"" ++ quote path ++ "\""
where quote "" = ""
quote (c:cs) = if c=='\\' || c=='"'
then '\\':c:quote cs
else c:quote cs
breakCommand :: String -> (String, [String])
breakCommand s = case words s of
(arg0:args) -> (arg0,args)
[] -> (s,[])
nubsort :: Ord a => [a] -> [a]
nubsort = map head . group . sort
editFile :: FilePathLike p => p -> IO ExitCode
editFile ff = do
old_content <- file_content
ec <- runEditor f
new_content <- file_content
when (new_content == old_content) $ do
yorn <- promptYorn "File content did not change. Continue anyway?"
when (yorn == 'n') $ do putStrLn "Aborted."
exitWith ExitSuccess
return ec
where f = toFilePath ff
file_content = do
exists <- doesFileExist f
if exists then do content <- B.readFile f
return $ Just content
else return Nothing
runEditor :: FilePath -> IO ExitCode
runEditor f = do
ed <- getEditor
execInteractive ed f
`ortryrunning` execInteractive "emacs" f
`ortryrunning` execInteractive "emacs -nw" f
`ortryrunning` execInteractive "nano" f
#ifdef WIN32
`ortryrunning` execInteractive "edit" f
#endif
getEditor :: IO String
getEditor = getEnv "DARCS_EDITOR" `catchall`
getEnv "DARCSEDITOR" `catchall`
getEnv "VISUAL" `catchall`
getEnv "EDITOR" `catchall` return "vi"
environmentHelpEditor :: ([String], [String])
environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[
"To edit a patch description of email comment, Darcs will invoke an",
"external editor. Your preferred editor can be set as any of the",
"environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",
"If none of these are set, vi(1) is used. If vi crashes or is not",
"found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",
"each tried in turn."])
getViewer :: IO String
getViewer = getEnv "DARCS_PAGER" `catchall`
getEnv "PAGER" `catchall` return "less"
environmentHelpPager :: ([String], [String])
environmentHelpPager = (["DARCS_PAGER", "PAGER"],[
"Darcs will sometimes invoke a pager if it deems output to be too long",
"to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER",
"or $PAGER. If neither are set, `less' will be used."])
data PromptConfig = PromptConfig { pPrompt :: String
, pBasicCharacters :: [Char]
, pAdvancedCharacters :: [Char]
, pDefault :: Maybe Char
, pHelp :: [Char]
}
promptYorn :: [Char] -> IO Char
promptYorn p = promptChar (PromptConfig p "yn" [] Nothing [])
promptChar :: PromptConfig -> IO Char
promptChar (PromptConfig p basic_chs adv_chs md help_chs) =
withoutProgress $ runInputT defaultSettings $ loopChar
where
chs = basic_chs ++ adv_chs
loopChar = do
let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))
prompt = p ++ " [" ++ chars ++ "]" ++ helpStr
a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input")
return
case () of
_ | a `elem` chs -> return a
| a == ' ' -> case md of Nothing -> tryAgain
Just d -> return d
| a `elem` help_chs -> return a
| otherwise -> tryAgain
helpStr = case help_chs of
[] -> ""
(h:_) | null adv_chs -> ", or " ++ (h:" for help: ")
| otherwise -> ", or " ++ (h:" for more options: ")
tryAgain = do outputStrLn "Invalid response, try again!"
loopChar
setDefault s = case md of Nothing -> s
Just d -> map (setUpper d) s
setUpper d c = if d == c then toUpper c else c
filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths files =
\p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files
filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool
filterFilePaths = filterPaths . map floatPath
isFileReallySymlink :: FilePath -> IO Bool
isFileReallySymlink f = do fs <- getSymbolicLinkStatus f
return (isSymbolicLink fs)
doesFileReallyExist :: FilePath -> IO Bool
doesFileReallyExist f = do fs <- getSymbolicLinkStatus f
return (isRegularFile fs)
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f
return (isDirectory fs)
treeHasAnycase :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
treeHasAnycase tree path = fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree
existsAnycase :: (MonadError e m, Functor m, Monad m) => AnchoredPath -> TreeMonad m Bool
existsAnycase (AnchoredPath []) = return True
existsAnycase (AnchoredPath (Name x:xs)) =
do wd <- currentDirectory
Just tree <- gets (flip findTree wd . tree)
let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree,
BSC.map toLower n == BSC.map toLower x ]
or `fmap` forM subs (\path -> do
file <- fileExists path
if file then return True
else withDirectory path (existsAnycase $ AnchoredPath xs))
treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
treeHas tree path = fst `fmap` virtualTreeMonad (exists $ floatPath path) tree
treeHasDir :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree
treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree