module Darcs.Utils
(
ortryrunning
, nubsort
, breakCommand
, showHexLen
, maybeGetEnv
, formatPath
, firstJustIO
, askEnter
, askUser
, askUserListItem
, PromptConfig(..)
, promptYorn
, promptChar
, getViewer
, editFile
, runEditor
, stripCr
, environmentHelpEditor
, environmentHelpPager
, catchall
, clarifyErrors
, prettyException
, prettyError
, addToErrorLoc
, getFileStatus
, withCurrentDirectory
, withUMask
, setDarcsEncodings
, getSystemEncoding
, isUTF8Locale
, filterFilePaths
, filterPaths
, treeHas
, treeHasDir
, treeHasFile
, treeHasAnycase
) where
import Prelude hiding ( catch )
import Control.Exception.Extensible
( bracket, bracket_, catch, try,
IOException, SomeException, Exception(fromException) )
import Control.Monad ( when, forM )
import Control.Monad.Error( MonadError )
import Control.Monad.State.Strict( gets )
import qualified Data.ByteString as B ( readFile )
import qualified Data.ByteString.Char8 as BSC
import Data.Char ( toUpper, toLower, isSpace )
import Data.List ( group, sort )
import Data.Maybe ( isJust )
import Foreign.C.String ( CString, withCString, peekCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt )
#ifdef FORCE_CHAR8_ENCODING
import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 )
#endif
import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath )
import Storage.Hashed.Monad( withDirectory, fileExists, directoryExists
, virtualTreeMonad, currentDirectory
, TreeMonad )
import qualified Storage.Hashed.Monad as HS ( exists, tree )
import Storage.Hashed.Tree( Tree, listImmediate, findTree )
import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,
getInputChar, outputStr, outputStrLn )
import System.Directory ( doesFileExist )
import System.Environment ( getEnv )
import System.Exit ( ExitCode(..) )
import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString
, isDoesNotExistError, ioeGetFileName )
import System.Posix.Files( getSymbolicLinkStatus, FileStatus )
import Text.Regex
import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )
import Darcs.SignalHandler ( catchNonSignal )
import Exec ( execInteractive )
import Numeric ( showHex )
import Progress ( withoutProgress )
showHexLen :: (Integral a, Show 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 = fmap Just (getEnv s) `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 (`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 | Just ioe <- fromException e, isDoesNotExistError ioe =
case ioeGetFileName ioe of
Just f -> f ++ " does not exist"
Nothing -> show e
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
#ifdef WIN32
(Right (ExitFailure 9009)) -> b
#endif
(Right x) -> return x
(Left (_ :: SomeException)) -> b
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
askEnter :: String
-> IO ()
askEnter prompt = askUser prompt >> return ()
askUserListItem :: String
-> [String]
-> IO String
askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do
outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs
loop
where
loop = do
answer <- getInputLine prompt
>>= maybe (error "askUser: unexpected end of input") return
case maybeRead answer of
Just n | n > 0 && n <= length xs -> return (xs !! (n1))
_ -> outputStrLn "Invalid response, try again!" >> loop
maybeRead :: Read a
=> String
-> Maybe a
maybeRead s = case reads s of
[(x, rest)] | all isSpace rest -> Just x
_ -> Nothing
stripCr :: String
-> String
stripCr "" = ""
stripCr "\r" = ""
stripCr (c:cs) = c : stripCr cs
formatPath :: String
-> String
formatPath path = "\"" ++ quote path ++ "\""
where quote "" = ""
quote (c:cs) = if c `elem` ['\\', '"']
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, Bool)
editFile ff = do
old_content <- file_content
ec <- runEditor f
new_content <- file_content
return (ec, new_content /= old_content)
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 Bool
promptYorn p = (== 'y') `fmap` 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 == ' ' -> maybe tryAgain return md
| 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
getFileStatus :: FilePath
-> IO (Maybe FileStatus)
getFileStatus f =
Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing
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
do wd <- currentDirectory
Just tree <- gets (flip findTree wd . HS.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 (HS.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
setDarcsEncodings :: IO ()
setDarcsEncodings = do
#ifdef FORCE_CHAR8_ENCODING
setFileSystemEncoding char8
setForeignEncoding char8
#endif
return ()
foreign import ccall "system_encoding.h get_system_encoding"
get_system_encoding :: IO CString
getSystemEncoding :: IO String
getSystemEncoding = do
enc <- get_system_encoding
peekCString enc
isUTF8Locale :: String -> Bool
isUTF8Locale codeName = case (normalizeEncoding codeName) of
"ascii" -> True
"646" -> True
"ansi_x3_4_1968" -> True
"ansi_x3.4_1986" -> True
"cp367" -> True
"csascii" -> True
"ibm367" -> True
"iso646_us" -> True
"iso_646.irv_1991" -> True
"iso_ir_6" -> True
"us" -> True
"us_ascii" -> True
"utf_8" -> True
"u8" -> True
"utf" -> True
"utf8" -> True
"utf8_ucs2" -> True
"utf8_ucs4" -> True
_ -> False
where
normalizeEncoding s = map toLower $ subRegex sep s "_"
sep = mkRegex "[^0-9A-Za-z]+"