diff --git a/Shelly.hs b/Shelly.hs deleted file mode 100644 --- a/Shelly.hs +++ /dev/null @@ -1,988 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings, - MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies, IncoherentInstances, - GADTs - #-} - --- | A module for shell-like / perl-like programming in Haskell. --- Shelly's focus is entirely on ease of use for those coming from shell scripting. --- However, it also tries to use modern libraries and techniques to keep things efficient. --- --- The functionality provided by --- this module is (unlike standard Haskell filesystem functionality) --- thread-safe: each Sh maintains its own environment and its own working --- directory. --- --- I highly recommend putting the following at the top of your program, --- otherwise you will likely need either type annotations or type conversions --- --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE ExtendedDefaultRules #-} --- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- > import Shelly --- > import Data.Text.Lazy as LT --- > default (LT.Text) -module Shelly - ( - -- * Entering Sh. - Sh, ShIO, shelly, shellyNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit - - -- * Running external commands. - , run, run_, runFoldLines, cmd, FoldCallback - , (-|-), lastStderr, setStdin, lastExitCode - , command, command_, command1, command1_ - , sshPairs, sshPairs_ - , ShellArg (..) - - -- * Modifying and querying environment. - , setenv, get_env, get_env_text, getenv, get_env_def, appendToPath - - -- * Environment directory - , cd, chdir, pwd - - -- * Printing - , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err - , tag, trace, show_command - - -- * Querying filesystem. - , ls, lsT, test_e, test_f, test_d, test_s, which - - -- * Filename helpers - , absPath, (), (<.>), canonic, canonicalize, relPath, relativeTo, path - , hasExt - - -- * Manipulating filesystem. - , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree - - -- * reading/writing Files - , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir - - -- * exiting the program - , exit, errorExit, quietExit, terror - - -- * Exceptions - , catchany, catch_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh - - -- * convert between Text and FilePath - , toTextIgnore, toTextWarn, fromText - - -- * Utility Functions - , whenM, unlessM, time, sleep - - -- * Re-exported for your convenience - , liftIO, when, unless, FilePath, (<$>) - - -- * internal functions for writing extensions - , get, put - - -- * find functions - , find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter - ) where - -import Shelly.Base -import Shelly.Find -import Control.Monad ( when, unless ) -import Control.Monad.Trans ( MonadIO ) -import Control.Monad.Reader (ask) -import Prelude hiding ( catch, readFile, FilePath ) -import Data.Char( isAlphaNum, isSpace ) -import Data.Typeable -import Data.IORef -import Data.Maybe -import System.IO ( hClose, stderr, stdout, openTempFile ) -import System.Exit -import System.Environment -import Control.Applicative -import Control.Exception hiding (handle) -import Control.Concurrent -import Data.Time.Clock( getCurrentTime, diffUTCTime ) - -import qualified Data.Text.Lazy.IO as TIO -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TE -import System.Process( CmdSpec(..), StdStream(CreatePipe), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle ) -import System.IO.Error (isPermissionError) - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text as T -import qualified Data.ByteString as BS -import Data.ByteString (ByteString) -import Data.Monoid (mappend) - -import Filesystem.Path.CurrentOS hiding (concat, fromText, (), (<.>)) -import Filesystem hiding (canonicalizePath) -import qualified Filesystem.Path.CurrentOS as FP - -import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, findExecutable ) -import Data.Char (isDigit) - -import Data.Tree(Tree(..)) - -{- GHC won't default to Text with this, even with extensions! - - see: http://hackage.haskell.org/trac/ghc/ticket/6030 -class ShellArgs a where - toTextArgs :: a -> [Text] - -instance ShellArgs Text where toTextArgs t = [t] -instance ShellArgs FilePath where toTextArgs t = [toTextIgnore t] -instance ShellArgs [Text] where toTextArgs = id -instance ShellArgs [FilePath] where toTextArgs = map toTextIgnore - -instance ShellArgs (Text, Text) where - toTextArgs (t1,t2) = [t1, t2] -instance ShellArgs (FilePath, FilePath) where - toTextArgs (fp1,fp2) = [toTextIgnore fp1, toTextIgnore fp2] -instance ShellArgs (Text, FilePath) where - toTextArgs (t1, fp1) = [t1, toTextIgnore fp1] -instance ShellArgs (FilePath, Text) where - toTextArgs (fp1,t1) = [toTextIgnore fp1, t1] - -cmd :: (ShellArgs args) => FilePath -> args -> Sh Text -cmd fp args = run fp $ toTextArgs args --} - --- | Argument converter for the variadic argument version of 'run' called 'cmd'. --- Useful for a type signature of a function that uses 'cmd' -class ShellArg a where toTextArg :: a -> Text -instance ShellArg Text where toTextArg = id -instance ShellArg FilePath where toTextArg = toTextIgnore -instance ShellArg String where toTextArg = LT.pack - - --- | used to create the variadic function 'cmd' -class ShellCommand t where - cmdAll :: FilePath -> [Text] -> t - -instance ShellCommand (Sh Text) where - cmdAll = run - -instance (s ~ Text, Show s) => ShellCommand (Sh s) where - cmdAll = run - --- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature -instance ShellCommand (Sh ()) where - cmdAll = run_ - -instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where - cmdAll fp acc x = cmdAll fp (acc ++ [toTextArg x]) - - --- | variadic argument version of 'run'. --- The syntax is more convenient, but more importantly it also allows the use of a FilePath as a command argument. --- So an argument can be a Text or a FilePath without manual conversions. --- a FilePath is automatically converted to Text with 'toTextIgnore'. --- You will need to add the following to your module: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE ExtendedDefaultRules #-} --- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- > import Shelly --- > import Data.Text.Lazy as LT --- > default (LT.Text) --- -cmd :: (ShellCommand result) => FilePath -> result -cmd fp = cmdAll fp [] - --- | Helper to convert a Text to a FilePath. Used by '()' and '(<.>)' -class ToFilePath a where - toFilePath :: a -> FilePath - -instance ToFilePath FilePath where toFilePath = id -instance ToFilePath Text where toFilePath = fromText -instance ToFilePath T.Text where toFilePath = FP.fromText -instance ToFilePath String where toFilePath = FP.fromText . T.pack - - --- | uses System.FilePath.CurrentOS, but can automatically convert a Text -() :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath -x y = toFilePath x FP. toFilePath y - --- | uses System.FilePath.CurrentOS, but can automatically convert a Text -(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath -x <.> y = toFilePath x FP.<.> LT.toStrict y - - - -toTextWarn :: FilePath -> Sh Text -toTextWarn efile = fmap lazy $ case toText efile of - Left f -> encodeError f >> return f - Right f -> return f - where - encodeError f = echo ("Invalid encoding for file: " `mappend` lazy f) - lazy = LT.fromStrict - -fromText :: Text -> FilePath -fromText = FP.fromText . LT.toStrict - -printGetContent :: Handle -> Handle -> IO Text -printGetContent rH wH = - fmap B.toLazyText $ printFoldHandleLines (B.fromText "") foldBuilder rH wH - -{- -getContent :: Handle -> IO Text -getContent h = fmap B.toLazyText $ foldHandleLines (B.fromText "") foldBuilder h --} - -type FoldCallback a = ((a, Text) -> a) - -printFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a -printFoldHandleLines start foldLine readHandle writeHandle = go start - where - go acc = do - line <- TIO.hGetLine readHandle - TIO.hPutStrLn writeHandle line >> go (foldLine (acc, line)) - `catchany` \_ -> return acc - -foldHandleLines :: a -> FoldCallback a -> Handle -> IO a -foldHandleLines start foldLine readHandle = go start - where - go acc = do - line <- TIO.hGetLine readHandle - go $ foldLine (acc, line) - `catchany` \_ -> return acc - --- | same as 'trace', but use it combinator style -tag :: Sh a -> Text -> Sh a -tag action msg = do - trace msg - action - -put :: State -> Sh () -put newState = do - stateVar <- ask - liftIO (writeIORef stateVar newState) - --- FIXME: find the full path to the exe from PATH -runCommand :: State -> FilePath -> [Text] -> IO (Handle, Handle, Handle, ProcessHandle) -runCommand st exe args = shellyProcess st $ - RawCommand (unpack exe) (map LT.unpack args) - -runCommandNoEscape :: State -> FilePath -> [Text] -> IO (Handle, Handle, Handle, ProcessHandle) -runCommandNoEscape st exe args = shellyProcess st $ - ShellCommand $ LT.unpack $ LT.intercalate " " (toTextIgnore exe : args) - - -shellyProcess :: State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle) -shellyProcess st cmdSpec = do - (Just hin, Just hout, Just herr, pHandle) <- createProcess CreateProcess { - cmdspec = cmdSpec - , cwd = Just $ unpack $ sDirectory st - , env = Just $ sEnvironment st - , std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe - , close_fds = False -#if MIN_VERSION_process(1,1,0) - , create_group = False -#endif - } - return (hin, hout, herr, pHandle) - -{- --- | use for commands requiring usage of sudo. see 'run_sudo'. --- Use this pattern for priveledge separation -newtype Sudo a = Sudo { sudo :: Sh a } - --- | require that the caller explicitly state 'sudo' -run_sudo :: Text -> [Text] -> Sudo Text -run_sudo cmd args = Sudo $ run "/usr/bin/sudo" (cmd:args) --} - --- | Same as a normal 'catch' but specialized for the Sh monad. -catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a -catch_sh action handle = do - ref <- ask - liftIO $ catch (runSh action ref) (\e -> runSh (handle e) ref) - --- | Same as a normal 'finally' but specialized for the 'Sh' monad. -finally_sh :: Sh a -> Sh b -> Sh a -finally_sh action handle = do - ref <- ask - liftIO $ finally (runSh action ref) (runSh handle ref) - - --- | You need to wrap exception handlers with this when using 'catches_sh'. -data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a) - --- | Same as a normal 'catches', but specialized for the 'Sh' monad. -catches_sh :: Sh a -> [ShellyHandler a] -> Sh a -catches_sh action handlers = do - ref <- ask - let runner a = runSh a ref - liftIO $ catches (runner action) $ map (toHandler runner) handlers - where - toHandler :: (Sh a -> IO a) -> ShellyHandler a -> Handler a - toHandler runner (ShellyHandler handle) = Handler (\e -> runner (handle e)) - --- | Catch an exception in the Sh monad. -catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a -catchany_sh = catch_sh - --- | Change current working directory of Sh. This does *not* change the --- working directory of the process we are running it. Instead, Sh keeps --- track of its own working directory and builds absolute paths internally --- instead of passing down relative paths. This may have performance --- repercussions if you are doing hundreds of thousands of filesystem --- operations. You will want to handle these issues differently in those cases. -cd :: FilePath -> Sh () -cd = canonic >=> cd' - where - cd' dir = do - trace $ "cd " `mappend` tdir - unlessM (test_d dir) $ errorExit $ "not a directory: " `mappend` tdir - modify $ \st -> st { sDirectory = dir } - where - tdir = toTextIgnore dir - --- | 'cd', execute a Sh action in the new directory and then pop back to the original directory -chdir :: FilePath -> Sh a -> Sh a -chdir dir action = do - d <- gets sDirectory - cd dir - action `finally_sh` cd d - --- | chdir, but first create the directory if it does not exit -chdir_p :: FilePath -> Sh a -> Sh a -chdir_p d action = mkdir_p d >> chdir d action - - --- | apply a String IO operations to a Text FilePath -{- -liftStringIO :: (String -> IO String) -> FilePath -> Sh FilePath -liftStringIO f = liftIO . f . unpack >=> return . pack - --- | @asString f = pack . f . unpack@ -asString :: (String -> String) -> FilePath -> FilePath -asString f = pack . f . unpack --} - -pack :: String -> FilePath -pack = decodeString - --- | Move a file. The second path could be a directory, in which case the --- original file is moved into that directory. --- wraps system-fileio 'FileSystem.rename', which may not work across FS boundaries -mv :: FilePath -> FilePath -> Sh () -mv from' to' = do - from <- absPath from' - to <- absPath to' - trace $ "mv " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to - to_dir <- test_d to - let to_loc = if not to_dir then to else to FP. filename from - liftIO $ rename from to_loc - `catchany` (\e -> throwIO $ - ReThrownException e (extraMsg to_loc from) - ) - where - extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t - --- | Get back [Text] instead of [FilePath] -lsT :: FilePath -> Sh [Text] -lsT = ls >=> mapM toTextWarn - --- | Obtain the current (Sh) working directory. -pwd :: Sh FilePath -pwd = gets sDirectory `tag` "pwd" - --- | exit 0 means no errors, all other codes are error conditions -exit :: Int -> Sh a -exit 0 = liftIO exitSuccess `tag` "exit 0" -exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " `mappend` LT.pack (show n)) - --- | echo a message and exit with status 1 -errorExit :: Text -> Sh a -errorExit msg = echo msg >> exit 1 - --- | for exiting with status > 0 without printing debug information -quietExit :: Int -> Sh a -quietExit 0 = exit 0 -quietExit n = throw $ QuietExit n - --- | fail that takes a Text -terror :: Text -> Sh a -terror = fail . LT.unpack - --- | Create a new directory (fails if the directory exists). -mkdir :: FilePath -> Sh () -mkdir = absPath >=> \fp -> do - trace $ "mkdir " `mappend` toTextIgnore fp - liftIO $ createDirectory False fp - --- | Create a new directory, including parents (succeeds if the directory --- already exists). -mkdir_p :: FilePath -> Sh () -mkdir_p = absPath >=> \fp -> do - trace $ "mkdir -p " `mappend` toTextIgnore fp - liftIO $ createTree fp - --- | Create a new directory tree. You can describe a bunch of directories as --- a tree and this function will create all subdirectories. An example: --- --- > exec = mkTree $ --- > "package" # [ --- > "src" # [ --- > "Data" # leaves ["Tree", "List", "Set", "Map"] --- > ], --- > "test" # leaves ["QuickCheck", "HUnit"], --- > "dist/doc/html" # [] --- > ] --- > where (#) = Node --- > leaves = map (# []) --- -mkdirTree :: Tree FilePath -> Sh () -mkdirTree = mk . unrollPath - where mk :: Tree FilePath -> Sh () - mk (Node a ts) = do - b <- test_d a - unless b $ mkdir a - chdir a $ mapM_ mkdirTree ts - - unrollPath :: Tree FilePath -> Tree FilePath - unrollPath (Node v ts) = unrollRoot v $ map unrollPath ts - where unrollRoot x = foldr1 phi $ map Node $ splitDirectories x - phi a b = a . return . b - --- | Get a full path to an executable on @PATH@, if exists. FIXME does not --- respect setenv'd environment and uses @findExecutable@ which uses the @PATH@ inherited from the process --- environment. --- FIXME: findExecutable does not maintain a hash of existing commands and does a ton of file stats -which :: FilePath -> Sh (Maybe FilePath) -which fp = do - (trace . mappend "which " . toTextIgnore) fp - (liftIO . findExecutable . unpack >=> return . fmap pack) fp - --- | A monadic-conditional version of the 'unless' guard. -unlessM :: Monad m => m Bool -> m () -> m () -unlessM c a = c >>= \res -> unless res a - --- | Does a path point to an existing filesystem object? -test_e :: FilePath -> Sh Bool -test_e = absPath >=> \f -> - liftIO $ do - file <- isFile f - if file then return True else isDirectory f - --- | Does a path point to an existing file? -test_f :: FilePath -> Sh Bool -test_f = absPath >=> liftIO . isFile - --- | A swiss army cannon for removing things. Actually this goes farther than a --- normal rm -rf, as it will circumvent permission problems for the files we --- own. Use carefully. --- Uses 'removeTree' -rm_rf :: FilePath -> Sh () -rm_rf = absPath >=> \f -> do - trace $ "rm -rf " `mappend` toTextIgnore f - isDir <- (test_d f) - if not isDir then whenM (test_f f) $ rm_f f - else - (liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) -> - when (isPermissionError e) $ do - find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ()) - liftIO $ removeTree f - ) - where fixPermissions file = - do permissions <- liftIO $ getPermissions file - let deletable = permissions { readable = True, writable = True, executable = True } - liftIO $ setPermissions file deletable - --- | Remove a file. Does not fail if the file does not exist. --- Does fail if the file is not a file. -rm_f :: FilePath -> Sh () -rm_f = absPath >=> \f -> do - trace $ "rm -f " `mappend` toTextIgnore f - whenM (test_e f) $ canonic f >>= liftIO . removeFile - --- | Remove a file. --- Does fail if the file does not exist (use 'rm_f' instead) or is not a file. -rm :: FilePath -> Sh () -rm = absPath >=> \f -> do - trace $ "rm" `mappend` toTextIgnore f - -- TODO: better error message for removeFile (give filename) - canonic f >>= liftIO . removeFile - --- | Set an environment variable. The environment is maintained in Sh --- internally, and is passed to any external commands to be executed. -setenv :: Text -> Text -> Sh () -setenv k v = - let (kStr, vStr) = (LT.unpack k, LT.unpack v) - wibble environment = (kStr, vStr) : filter ((/=kStr).fst) environment - in modify $ \x -> x { sEnvironment = wibble $ sEnvironment x } - --- | add the filepath onto the PATH env variable --- FIXME: only effects the PATH once the process is ran, as per comments in 'which' --- TODO: use cross-platform searchPathSeparator -appendToPath :: FilePath -> Sh () -appendToPath = absPath >=> \filepath -> do - tp <- toTextWarn filepath - pe <- get_env_text path_env - setenv path_env $ pe `mappend` ":" `mappend` tp - where - path_env = "PATH" - --- | Fetch the current value of an environment variable. --- if non-existant or empty text, will be Nothing -get_env :: Text -> Sh (Maybe Text) -get_env k = do - mval <- return . fmap LT.pack . lookup (LT.unpack k) =<< gets sEnvironment - return $ case mval of - Nothing -> Nothing - j@(Just val) -> if LT.null val then Nothing else j - --- | deprecated -getenv :: Text -> Sh Text -getenv k = get_env_def k "" -{-# DEPRECATED getenv "use get_env or get_env_text" #-} - --- | Fetch the current value of an environment variable. Both empty and --- non-existent variables give empty string as a result. -get_env_text :: Text -> Sh Text -get_env_text = get_env_def "" - --- | Fetch the current value of an environment variable. Both empty and --- non-existent variables give the default Text value as a result -get_env_def :: Text -> Text -> Sh Text -get_env_def d = get_env >=> return . fromMaybe d -{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-} - - --- | Create a sub-Sh in which external command outputs are not echoed and --- commands are not printed. --- See 'sub'. -silently :: Sh a -> Sh a -silently a = sub $ modify (\x -> x { sPrintStdout = False, sPrintCommands = False }) >> a - --- | Create a sub-Sh in which external command outputs are echoed and --- Executed commands are printed --- See 'sub'. -verbosely :: Sh a -> Sh a -verbosely a = sub $ modify (\x -> x { sPrintStdout = True, sPrintCommands = True }) >> a - --- | Create a sub-Sh with stdout printing on or off --- Defaults to True. -print_stdout :: Bool -> Sh a -> Sh a -print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a - - --- | Create a sub-Sh with command echoing on or off --- Defaults to False, set to True by 'verbosely' -print_commands :: Bool -> Sh a -> Sh a -print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a - --- | Enter a sub-Sh that inherits the environment --- The original state will be restored when the sub-Sh completes. --- Exceptions are propagated normally. -sub :: Sh a -> Sh a -sub a = do - oldState <- get - modify $ \st -> st { sTrace = B.fromText "" } - a `finally_sh` restoreState oldState - where - restoreState oldState = do - newState <- get - put oldState { - -- avoid losing the log - sTrace = sTrace oldState `mappend` sTrace newState - -- latest command execution: not make sense to restore these to old settings - , sCode = sCode newState - , sStderr = sStderr newState - -- it is questionable what the behavior of stdin should be - , sStdin = sStdin newState - } - --- | Create a sub-Sh where commands are not traced --- Defaults to True. --- You should only set to False temporarily for very specific reasons -tracing :: Bool -> Sh a -> Sh a -tracing shouldTrace action = sub $ do - modify $ \st -> st { sTracing = shouldTrace } - action - --- | Create a sub-Sh with shell character escaping on or off. --- Defaults to True. --- Setting to False allows for shell wildcard such as * to be expanded by the shell along with any other special shell characters. -escaping :: Bool -> Sh a -> Sh a -escaping shouldEscape action = sub $ do - modify $ \st -> st { sRun = - if shouldEscape - then runCommand - else runCommandNoEscape - } - action - --- | named after bash -e errexit. Defaults to @True@. --- When @True@, throw an exception on a non-zero exit code. --- When @False@, ignore a non-zero exit code. --- Not recommended to set to @False@ unless you are specifically checking the error code with 'lastExitCode'. -errExit :: Bool -> Sh a -> Sh a -errExit shouldExit action = sub $ do - modify $ \st -> st { sErrExit = shouldExit } - action - -data ShellyOpts = ShellyOpts { failToDir :: Bool } - --- avoid data-default dependency for now --- instance Default ShellyOpts where -shellyOpts :: ShellyOpts -shellyOpts = ShellyOpts { failToDir = True } - --- | Using this entry point does not create a @.shelly@ directory in the case --- of failure. Instead it logs directly into the standard error stream (@stderr@). -shellyNoDir :: MonadIO m => Sh a -> m a -shellyNoDir = shelly' shellyOpts { failToDir = False } - --- | Enter a Sh from (Monad)IO. The environment and working directories are --- inherited from the current process-wide values. Any subsequent changes in --- processwide working directory or environment are not reflected in the --- running Sh. -shelly :: MonadIO m => Sh a -> m a -shelly = shelly' shellyOpts - -shelly' :: MonadIO m => ShellyOpts -> Sh a -> m a -shelly' opts action = do - environment <- liftIO getEnvironment - dir <- liftIO getWorkingDirectory - let def = State { sCode = 0 - , sStdin = Nothing - , sStderr = LT.empty - , sPrintStdout = True - , sPrintCommands = False - , sRun = runCommand - , sEnvironment = environment - , sTracing = True - , sTrace = B.fromText "" - , sDirectory = dir - , sErrExit = True - } - stref <- liftIO $ newIORef def - let caught = - action `catches_sh` [ - ShellyHandler (\ex -> - case ex of - ExitSuccess -> liftIO $ throwIO ex - ExitFailure _ -> throwExplainedException ex - ) - , ShellyHandler (\ex -> case ex of - QuietExit n -> liftIO $ throwIO $ ExitFailure n) - , ShellyHandler (\(ex::SomeException) -> throwExplainedException ex) - ] - liftIO $ runSh caught stref - where - throwExplainedException :: Exception exception => exception -> Sh a - throwExplainedException ex = get >>= errorMsg >>= liftIO . throwIO . ReThrownException ex - errorMsg st = - if not (failToDir opts) then ranCommands else do - d <- pwd - sf <- shellyFile - let logFile = dshelly_dirsf - (writefile logFile trc >> return ("log of commands saved to: " `mappend` encodeString logFile)) - `catchany_sh` (\_ -> ranCommands) - - where - trc = B.toLazyText . sTrace $ st - ranCommands = return . mappend "Ran commands: \n" . LT.unpack $ trc - - shelly_dir = ".shelly" - shellyFile = chdir_p shelly_dir $ do - fs <- ls "." - return $ pack $ show (nextNum fs) `mappend` ".txt" - - nextNum :: [FilePath] -> Int - nextNum [] = 1 - nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . unpack . filename) $ fs - --- from safe package -readDef :: Read a => a -> String -> a -readDef def = fromMaybe def . readMay - where - readMay :: Read a => String -> Maybe a - readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> Just x - _ -> Nothing - -data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable) - -instance Show RunFailed where - show (RunFailed exe args code errs) = - let codeMsg = case code of - 127 -> ". exit code 127 usually means the command does not exist (in the PATH)" - _ -> "" - in "error running: " ++ LT.unpack (show_command exe args) ++ - "\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ LT.unpack errs - -instance Exception RunFailed - -show_command :: FilePath -> [Text] -> Text -show_command exe args = - LT.intercalate " " $ map quote (toTextIgnore exe : args) - where - quote t | LT.any (== '\'') t = t - quote t | LT.any isSpace t = surround '\'' t - quote t | otherwise = t - -surround :: Char -> Text -> Text -surround c t = LT.cons c $ LT.snoc t c - --- | same as 'sshPairs', but returns () -sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh () -sshPairs_ _ [] = return () -sshPairs_ server cmds = sshPairs' run_ server cmds - --- | run commands over SSH. --- An ssh executable is expected in your path. --- Commands are in the same form as 'run', but given as pairs --- --- > sshPairs "server-name" [("cd", "dir"), ("rm",["-r","dir2"])] --- --- This interface is crude, but it works for now. --- --- Please note this sets 'escaping' to False: the commands will not be shell escaped. --- Internally the list of commands are combined with the string @&&@ before given to ssh. -sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text -sshPairs _ [] = return "" -sshPairs server cmds = sshPairs' run server cmds - -sshPairs' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a -sshPairs' run' server actions = escaping False $ do - let ssh_commands = surround '\'' $ foldl1 - (\memo next -> memo `mappend` " && " `mappend` next) - (map toSSH actions) - run' "ssh" [server, ssh_commands] - where - toSSH (exe,args) = show_command exe args - - -data QuietExit = QuietExit Int deriving (Show, Typeable) -instance Exception QuietExit - -data ReThrownException e = ReThrownException e String deriving (Typeable) -instance Exception e => Exception (ReThrownException e) -instance Exception e => Show (ReThrownException e) where - show (ReThrownException ex msg) = "\n" ++ - msg ++ "\n" ++ "Exception: " ++ show ex - --- | Execute an external command. Takes the command name (no shell allowed, --- just a name of something that can be found via @PATH@; FIXME: setenv'd --- @PATH@ is not taken into account when finding the exe name) --- --- 'stdout' and 'stderr' are collected. The 'stdout' is returned as --- a result of 'run', and complete stderr output is available after the fact using --- 'lastStderr' --- --- All of the stdout output will be loaded into memory --- You can avoid this but still consume the result by using 'run_', --- If you want to avoid the memory and need to process the output then use 'runFoldLines'. -run :: FilePath -> [Text] -> Sh Text -run exe args = fmap B.toLazyText $ runFoldLines (B.fromText "") foldBuilder exe args - -foldBuilder :: (B.Builder, Text) -> B.Builder -foldBuilder (b, line) = b `mappend` B.fromLazyText line `mappend` B.singleton '\n' - - --- | bind some arguments to run for re-use. Example: --- --- > monit = command "monit" ["-c", "monitrc"] --- > monit ["stop", "program"] -command :: FilePath -> [Text] -> [Text] -> Sh Text -command com args more_args = run com (args ++ more_args) - --- | bind some arguments to 'run_' for re-use. Example: --- --- > monit_ = command_ "monit" ["-c", "monitrc"] --- > monit_ ["stop", "program"] -command_ :: FilePath -> [Text] -> [Text] -> Sh () -command_ com args more_args = run_ com (args ++ more_args) - --- | bind some arguments to run for re-use, and require 1 argument. Example: --- --- > git = command1 "git" []; git "pull" ["origin", "master"] -command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text -command1 com args one_arg more_args = run com ([one_arg] ++ args ++ more_args) - --- | bind some arguments to run for re-use, and require 1 argument. Example: --- --- > git_ = command1_ "git" []; git "pull" ["origin", "master"] -command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh () -command1_ com args one_arg more_args = run_ com ([one_arg] ++ args ++ more_args) - --- | the same as 'run', but return @()@ instead of the stdout content --- stdout will be read and discarded line-by-line -run_ :: FilePath -> [Text] -> Sh () -run_ = runFoldLines () (\(_, _) -> ()) - -liftIO_ :: IO a -> Sh () -liftIO_ action = liftIO action >> return () - --- | used by 'run'. fold over stdout line-by-line as it is read to avoid keeping it in memory --- stderr is still being placed in memory under the assumption it is always relatively small -runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a -runFoldLines start cb exe args = do - -- clear stdin before beginning command execution - origstate <- get - let mStdin = sStdin origstate - put $ origstate { sStdin = Nothing, sCode = 0, sStderr = LT.empty } - state <- get - - let cmdString = show_command exe args - when (sPrintCommands state) $ echo cmdString - trace cmdString - - (ex, errs, outV) <- liftIO $ bracketOnWindowsError - (sRun state state exe args) - (\(_,_,_,procH) -> (terminateProcess procH)) - (\(inH,outH,errH,procH) -> do - case mStdin of - Just input -> - TIO.hPutStr inH input >> hClose inH - -- stdin is cleared from state below - Nothing -> return () - - errV <- newEmptyMVar - outV' <- newEmptyMVar - - _ <- forkIO $ printGetContent errH stderr >>= putMVar errV - -- liftIO_ $ forkIO $ getContent errH >>= putMVar errV - _ <- if sPrintStdout state - then - forkIO $ printFoldHandleLines start cb outH stdout >>= putMVar outV' - else - forkIO $ foldHandleLines start cb outH >>= putMVar outV' - - errs' <- takeMVar errV - ex' <- waitForProcess procH - return (ex', errs', outV') - ) - - let code = case ex of - ExitSuccess -> 0 - ExitFailure n -> n - modify $ \state' -> state' { sStderr = errs , sCode = code } - liftIO $ case (sErrExit state, ex) of - (True, ExitFailure n) -> throwIO $ RunFailed exe args n errs - _ -> takeMVar outV - - where -- Windows does not terminate spawned processes, so we must bracket. -#if defined(mingw32_HOST_OS) - bracketOnWindowsError = bracketOnError -#else - bracketOnWindowsError acquire _ main = acquire >>= main -#endif - - --- | The output of last external command. See 'run'. -lastStderr :: Sh Text -lastStderr = gets sStderr - --- | The exit code from the last command. --- Unless you set 'errExit' to False you won't get a chance to use this: a non-zero exit code will throw an exception. -lastExitCode :: Sh Int -lastExitCode = gets sCode - --- | set the stdin to be used and cleared by the next 'run'. -setStdin :: Text -> Sh () -setStdin input = modify $ \st -> st { sStdin = Just input } - --- | Pipe operator. set the stdout the first command as the stdin of the second. --- This does not create a shell-level pipe, but hopefully it will in the future. --- To create a shell level pipe you can set @escaping False@ and use a pipe @|@ character in a command. -(-|-) :: Sh Text -> Sh b -> Sh b -one -|- two = do - res <- print_stdout False one - setStdin res - two - --- | Copy a file, or a directory recursively. --- uses 'cp' -cp_r :: FilePath -> FilePath -> Sh () -cp_r from' to' = do - from <- absPath from' - fromIsDir <- (test_d from) - if not fromIsDir then cp from' to' else do - to <- absPath to' - trace $ "cp -r " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to - toIsDir <- test_d to - - when (from == to) $ liftIO $ throwIO $ userError $ LT.unpack $ "cp_r: " `mappend` - toTextIgnore from `mappend` " and " `mappend` toTextIgnore to `mappend` " are identical" - - finalTo <- if not toIsDir then mkdir to >> return to else do - let d = to dirname (addTrailingSlash from) - mkdir_p d >> return d - - ls from >>= mapM_ (\item -> cp_r (from FP. filename item) (finalTo FP. filename item)) - --- | Copy a file. The second path could be a directory, in which case the --- original file name is used, in that directory. -cp :: FilePath -> FilePath -> Sh () -cp from' to' = do - from <- absPath from' - to <- absPath to' - trace $ "cp " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to - to_dir <- test_d to - let to_loc = if to_dir then to FP. filename from else to - liftIO $ copyFile from to_loc `catchany` (\e -> throwIO $ - ReThrownException e (extraMsg to_loc from) - ) - where - extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t - - - --- | Create a temporary directory and pass it as a parameter to a Sh --- computation. The directory is nuked afterwards. -withTmpDir :: (FilePath -> Sh a) -> Sh a -withTmpDir act = do - trace "withTmpDir" - dir <- liftIO getTemporaryDirectory - tid <- liftIO myThreadId - (pS, handle) <- liftIO $ openTempFile dir ("tmp"++filter isAlphaNum (show tid)) - let p = pack pS - liftIO $ hClose handle -- required on windows - rm_f p - mkdir p - act p `finally_sh` rm_rf p - --- | Write a Lazy Text to a file. -writefile :: FilePath -> Text -> Sh () -writefile f' bits = absPath f' >>= \f -> do - trace $ "writefile " `mappend` toTextIgnore f - liftIO (TIO.writeFile (unpack f) bits) - --- | Update a file, creating (a blank file) if it does not exist. -touchfile :: FilePath -> Sh () -touchfile = absPath >=> flip appendfile "" - --- | Append a Lazy Text to a file. -appendfile :: FilePath -> Text -> Sh () -appendfile f' bits = absPath f' >>= \f -> do - trace $ "appendfile " `mappend` toTextIgnore f - liftIO (TIO.appendFile (unpack f) bits) - --- | (Strictly) read file into a Text. --- All other functions use Lazy Text. --- Internally this reads a file as strict text and then converts it to lazy text, which is inefficient -readfile :: FilePath -> Sh Text -readfile = absPath >=> \fp -> do - trace $ "readfile " `mappend` toTextIgnore fp - readBinary fp >>= - return . LT.fromStrict . TE.decodeUtf8With TE.lenientDecode - --- | wraps ByteSting readFile -readBinary :: FilePath -> Sh ByteString -readBinary = absPath >=> liftIO . BS.readFile . unpack - --- | flipped hasExtension for Text -hasExt :: Text -> FilePath -> Bool -hasExt = flip hasExtension . LT.toStrict - --- | Run a Sh computation and collect timing information. -time :: Sh a -> Sh (Double, a) -time what = sub $ do - trace "time" - t <- liftIO getCurrentTime - res <- what - t' <- liftIO getCurrentTime - return (realToFrac $ diffUTCTime t' t, res) - --- | threadDelay wrapper that uses seconds -sleep :: Int -> Sh () -sleep = liftIO . threadDelay . (1000 * 1000 *) diff --git a/Shelly/Base.hs b/Shelly/Base.hs deleted file mode 100644 --- a/Shelly/Base.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | I started exposing multiple module (starting with one for finding) --- Base prevented circular dependencies --- However, Shelly went back to exposing a single module -module Shelly.Base - ( - ShIO, Sh, unSh, runSh, State(..), FilePath, Text, - relPath, path, absPath, canonic, canonicalize, - test_d, test_s, - unpack, gets, get, modify, trace, - ls, lsRelAbs, - toTextIgnore, - echo, echo_n, echo_err, echo_n_err, inspect, inspect_err, - catchany, - liftIO, (>=>), - eitherRelativeTo, relativeTo, maybeRelativeTo, - whenM - -- * utilities not yet exported - , addTrailingSlash - ) where - -import Prelude hiding ( FilePath, catch ) -import Data.Text.Lazy (Text) -import System.Process( ProcessHandle ) -import System.IO ( Handle, hFlush, stderr, stdout ) - -import Control.Monad (when, (>=>) ) -import Control.Applicative (Applicative, (<$>)) -import Filesystem (isDirectory, listDirectory) -import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink ) -import Filesystem.Path.CurrentOS (FilePath, encodeString, relative) -import qualified Filesystem.Path.CurrentOS as FP -import qualified Filesystem as FS -import Data.IORef (readIORef, modifyIORef, IORef) -import Data.Monoid (mappend) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.IO as TIO -import Control.Exception (SomeException, catch) -import Data.Maybe (fromMaybe) -import Control.Monad.Trans ( MonadIO, liftIO ) -import Control.Monad.Reader (MonadReader, runReaderT, ask, ReaderT) - --- | ShIO is Deprecated in favor of 'Sh', which is easier to type. -type ShIO a = Sh a -{- don't need to turn on deprecation. It will cause a lot of warnings while compiling existing code. - - # DEPRECATED ShIO, "Use Sh instead of ShIO" # -} - -newtype Sh a = Sh { - unSh :: ReaderT (IORef State) IO a - } deriving (Applicative, Monad, MonadIO, MonadReader (IORef State), Functor) - -runSh :: Sh a -> IORef State -> IO a -runSh = runReaderT . unSh - -data State = State - { sCode :: Int -- ^ exit code for command that ran - , sStdin :: Maybe Text -- ^ stdin for the command to be run - , sStderr :: Text -- ^ stderr for command that ran - , sDirectory :: FilePath -- ^ working directory - , sPrintStdout :: Bool -- ^ print stdout of command that is executed - , sPrintCommands :: Bool -- ^ print command that is executed - , sRun :: State -> FilePath -> [Text] -> IO (Handle, Handle, Handle, ProcessHandle) -- ^ command runner, a different runner is used when escaping, probably better to just hold the escaping flag - , sEnvironment :: [(String, String)] - , sTracing :: Bool -- ^ should we trace command execution - , sTrace :: B.Builder -- ^ the trace of command execution - , sErrExit :: Bool -- ^ should we exit immediately on any error - } - --- | A monadic-conditional version of the "when" guard. -whenM :: Monad m => m Bool -> m () -> m () -whenM c a = c >>= \res -> when res a - --- | Makes a relative path relative to the current Sh working directory. --- An absolute path is returned as is. --- To create an absolute path, use 'absPath' -relPath :: FilePath -> Sh FilePath -relPath fp = do - wd <- gets sDirectory - rel <- eitherRelativeTo wd fp - return $ case rel of - Right p -> p - Left p -> p - -eitherRelativeTo :: FilePath -- ^ anchor path, the prefix - -> FilePath -- ^ make this relative to anchor path - -> Sh (Either FilePath FilePath) -- ^ Left is canonic of second path -eitherRelativeTo relativeFP fp = do - let fullFp = relativeFP FP. fp - let relDir = addTrailingSlash relativeFP - stripIt relativeFP fp $ - stripIt relativeFP fullFp $ - stripIt relDir fp $ - stripIt relDir fullFp $ do - relCan <- canonic relDir - fpCan <- canonic fullFp - stripIt relCan fpCan $ return $ Left fpCan - where - stripIt rel toStrip nada = - case FP.stripPrefix rel toStrip of - Just stripped -> - if stripped == toStrip then nada - else return $ Right stripped - Nothing -> nada - --- | make the second path relative to the first --- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary -relativeTo :: FilePath -- ^ anchor path, the prefix - -> FilePath -- ^ make this relative to anchor path - -> Sh FilePath -relativeTo relativeFP fp = - fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp - -maybeRelativeTo :: FilePath -- ^ anchor path, the prefix - -> FilePath -- ^ make this relative to anchor path - -> Sh (Maybe FilePath) -maybeRelativeTo relativeFP fp = do - epath <- eitherRelativeTo relativeFP fp - return $ case epath of - Right p -> Just p - Left _ -> Nothing - - --- | add a trailing slash to ensure the path indicates a directory -addTrailingSlash :: FilePath -> FilePath -addTrailingSlash p = - if FP.null (FP.filename p) then p else - p FP. FP.empty - --- | makes an absolute path. --- Like 'canonicalize', but on an exception returns 'absPath' -canonic :: FilePath -> Sh FilePath -canonic fp = do - p <- absPath fp - liftIO $ canonicalizePath p `catchany` \_ -> return p - --- | Obtain a (reasonably) canonic file path to a filesystem object. Based on --- "canonicalizePath" in system-fileio. -canonicalize :: FilePath -> Sh FilePath -canonicalize = absPath >=> liftIO . canonicalizePath - --- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash -canonicalizePath :: FilePath -> IO FilePath -canonicalizePath p = let was_dir = FP.null (FP.filename p) in - if not was_dir then FS.canonicalizePath p - else addTrailingSlash `fmap` FS.canonicalizePath p - --- | Make a relative path absolute by combining with the working directory. --- An absolute path is returned as is. --- To create a relative path, use 'relPath'. -absPath :: FilePath -> Sh FilePath -absPath p | relative p = (FP. p) <$> gets sDirectory - | otherwise = return p - --- | deprecated -path :: FilePath -> Sh FilePath -path = absPath -{-# DEPRECATED path "use absPath, canonic, or relPath instead" #-} - --- | Does a path point to an existing directory? -test_d :: FilePath -> Sh Bool -test_d = absPath >=> liftIO . isDirectory - --- | Does a path point to a symlink? -test_s :: FilePath -> Sh Bool -test_s = absPath >=> liftIO . \f -> do - stat <- getSymbolicLinkStatus (unpack f) - return $ isSymbolicLink stat - -unpack :: FilePath -> String -unpack = encodeString - -gets :: (State -> a) -> Sh a -gets f = f <$> get - -get :: Sh State -get = do - stateVar <- ask - liftIO (readIORef stateVar) - -modify :: (State -> State) -> Sh () -modify f = do - state <- ask - liftIO (modifyIORef state f) - --- | internally log what occurred. --- Log will be re-played on failure. -trace :: Text -> Sh () -trace msg = - whenM (gets sTracing) $ modify $ - \st -> st { sTrace = sTrace st `mappend` B.fromLazyText msg `mappend` "\n" } - --- | List directory contents. Does *not* include \".\" and \"..\", but it does --- include (other) hidden files. -ls :: FilePath -> Sh [FilePath] --- it is important to use path and not absPath so that the listing can remain relative -ls fp = do - trace $ "ls " `mappend` toTextIgnore fp - fmap fst $ lsRelAbs fp - -lsRelAbs :: FilePath -> Sh ([FilePath], [FilePath]) -lsRelAbs f = absPath f >>= \fp -> do - filt <- if not (relative f) then return return - else do - wd <- gets sDirectory - return (relativeTo wd) - absolute <- liftIO $ listDirectory fp - relativized <- mapM filt absolute - return (relativized, absolute) - --- | silently uses the Right or Left value of "Filesystem.Path.CurrentOS.toText" -toTextIgnore :: FilePath -> Text -toTextIgnore fp = LT.fromStrict $ case FP.toText fp of - Left f -> f - Right f -> f - --- | a print lifted into 'Sh' -inspect :: (Show s) => s -> Sh () -inspect x = do - (trace . LT.pack . show) x - liftIO $ print x - --- | a print lifted into 'Sh' using stderr -inspect_err :: (Show s) => s -> Sh () -inspect_err x = do - let shown = LT.pack $ show x - trace shown - echo_err shown - --- | Echo text to standard (error, when using _err variants) output. The _n --- variants do not print a final newline. -echo, echo_n, echo_err, echo_n_err :: Text -> Sh () -echo = traceLiftIO TIO.putStrLn -echo_n = traceLiftIO $ (>> hFlush stdout) . TIO.putStr -echo_err = traceLiftIO $ TIO.hPutStrLn stderr -echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr - -traceLiftIO :: (Text -> IO ()) -> Text -> Sh () -traceLiftIO f msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'") >> liftIO (f msg) - --- | A helper to catch any exception (same as --- @... `catch` \(e :: SomeException) -> ...@). -catchany :: IO a -> (SomeException -> IO a) -> IO a -catchany = catch - diff --git a/Shelly/Find.hs b/Shelly/Find.hs deleted file mode 100644 --- a/Shelly/Find.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | File finding utiliites for Shelly --- The basic 'find' takes a dir and gives back a list of files. --- If you don't just want a list, use the folding variants like 'findFold'. --- If you want to avoid traversing certain directories, use the directory filtering variants like 'findDirFilter' -module Shelly.Find - ( - find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter - ) where - -import Prelude hiding (FilePath) -import Shelly.Base -import Control.Monad (foldM) -import Data.Monoid (mappend) -import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink ) -import Filesystem (isDirectory) - --- | List directory recursively (like the POSIX utility "find"). --- listing is relative if the path given is relative. --- If you want to filter out some results or fold over them you can do that with the returned files. --- A more efficient approach is to use one of the other find functions. -find :: FilePath -> Sh [FilePath] -find = findFold (\paths fp -> return $ paths ++ [fp]) [] - --- | 'find' that filters the found files as it finds. --- Files must satisfy the given filter to be returned in the result. -findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath] -findWhen = findDirFilterWhen (const $ return True) - --- | Fold an arbitrary folding function over files froma a 'find'. --- Like 'findWhen' but use a more general fold rather than a filter. -findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a -findFold folder startValue = findFoldDirFilter folder startValue (const $ return True) - --- | 'find' that filters out directories as it finds --- Filtering out directories can make a find much more efficient by avoiding entire trees of files. -findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath] -findDirFilter filt = findDirFilterWhen filt (const $ return True) - --- | similar 'findWhen', but also filter out directories --- Alternatively, similar to 'findDirFilter', but also filter out files --- Filtering out directories makes the find much more efficient -findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter - -> (FilePath -> Sh Bool) -- ^ file filter - -> FilePath -- ^ directory - -> Sh [FilePath] -findDirFilterWhen dirFilt fileFilter = findFoldDirFilter filterIt [] dirFilt - where - filterIt paths fp = do - yes <- fileFilter fp - return $ if yes then paths ++ [fp] else paths - --- | like 'findDirFilterWhen' but use a folding function rather than a filter --- The most general finder: you likely want a more specific one -findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a -findFoldDirFilter folder startValue dirFilter dir = do - absDir <- absPath dir - trace ("find " `mappend` toTextIgnore absDir) - filt <- dirFilter absDir - if not filt then return startValue - -- use possible relative path, not absolute so that listing will remain relative - else do - (rPaths, aPaths) <- lsRelAbs dir - foldM traverse startValue (zip rPaths aPaths) - where - traverse acc (relativePath, absolutePath) = do - -- optimization: don't use Shelly API since our path is already good - isDir <- liftIO $ isDirectory absolutePath - sym <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus (unpack absolutePath) - newAcc <- folder acc relativePath - if isDir && not sym - then findFoldDirFilter folder newAcc - dirFilter relativePath - else return newAcc diff --git a/Shelly/Pipe.hs b/Shelly/Pipe.hs deleted file mode 100644 --- a/Shelly/Pipe.hs +++ /dev/null @@ -1,741 +0,0 @@ -{-# LANGUAGE - FlexibleInstances, - TypeSynonymInstances, - TypeFamilies, - ExistentialQuantification #-} --- | This module is a wrapper for the module "Shelly". --- The only difference is a main type "Sh". In this module --- "Sh" contains a list of results. Actual definition of the type "Sh" is: --- --- > import qualified Shelly as S --- > --- > newtype Sh a = Sh { unSh :: S.Sh [a] } --- --- This definition can simplify some filesystem commands. --- A monad bind operator becomes a pipe operator and we can write --- --- > findExt ext = findWhen (pure . hasExt ext) --- > --- > main :: IO () --- > main = shs $ do --- > mkdir "new" --- > findExt "hs" "." >>= flip cp "new" --- > findExt "cpp" "." >>= rm_f --- > liftIO $ putStrLn "done" --- --- Monad methods "return" and ">>=" behave like methods for --- @ListT Shelly.Sh@, but ">>" forgets the number of --- the empty effects. So the last line prints @\"done\"@ only once. --- --- I highly recommend putting the following at the top of your program, --- otherwise you will likely need either type annotations or type conversions --- --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE ExtendedDefaultRules #-} --- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- > import Shelly --- > import Data.Text.Lazy as LT --- > default (LT.Text) -module Shelly.Pipe - ( - -- * Entering Sh. - Sh, shs, shelly,shellyNoDir, shsNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit - -- * List functions - , roll, unroll, liftSh - -- * Running external commands. - , FoldCallback - , run, run_, runFoldLines, cmd - , (-|-), lastStderr, setStdin, lastExitCode - , command, command_, command1, command1_ - , sshPairs, sshPairs_ - - -- * Modifying and querying environment. - , setenv, get_env, get_env_text, get_env_def, appendToPath - - -- * Environment directory - , cd, chdir, pwd - - -- * Printing - , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err - , tag, trace, show_command - - -- * Querying filesystem. - , ls, lsT, test_e, test_f, test_d, test_s, which - - -- * Filename helpers - , absPath, (), (<.>), canonic, canonicalize, relPath, relativeTo - , hasExt - - -- * Manipulating filesystem. - , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree - - -- * reading/writing Files - , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir - - -- * exiting the program - , exit, errorExit, quietExit, terror - - -- * Exceptions - , catchany, catch_sh, finally_sh - , ShellyHandler(..), catches_sh - , catchany_sh - - -- * convert between Text and FilePath - , toTextIgnore, toTextWarn, fromText - - -- * Utilities. - , (<$>), whenM, unlessM, time - - -- * Re-exported for your convenience - , liftIO, when, unless, FilePath - - -- * internal functions for writing extensions - , get, put - - -- * find functions - , find, findWhen, findFold - , findDirFilter, findDirFilterWhen, findFoldDirFilter - ) where - -import Prelude hiding (FilePath) - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans -import Control.Exception hiding (handle) - -import Filesystem.Path(FilePath) - -import qualified Shelly as S - -import Shelly( - (), (<.>), hasExt - , whenM, unlessM, toTextIgnore - , fromText, catchany - , FoldCallback) - -import Data.Maybe(fromMaybe) -import Shelly.Base(State) -import Data.ByteString (ByteString) - -import Data.Tree(Tree) - -import Data.Text.Lazy as LT hiding (concat, all, find, cons) - -default (LT.Text) - - --- | This type is a simple wrapper for a type "Shelly.Sh". --- "Sh" contains a list of results. -newtype Sh a = Sh { unSh :: S.Sh [a] } - -instance Functor Sh where - fmap f = Sh . fmap (fmap f) . unSh - -instance Monad Sh where - return = Sh . return . return - a >>= f = Sh $ fmap concat $ mapM (unSh . f) =<< unSh a - a >> b = Sh $ unSh a >> unSh b - -instance Applicative Sh where - pure = return - (<*>) = ap - -instance MonadPlus Sh where - mzero = Sh $ return [] - mplus a b = Sh $ liftA2 (++) (unSh a) (unSh b) - -instance MonadIO Sh where - liftIO = sh1 liftIO - -------------------------------------------------------- --- converters - -sh0 :: S.Sh a -> Sh a -sh0 = Sh . fmap return - -sh1 :: (a -> S.Sh b) -> (a -> Sh b) -sh1 f = \a -> sh0 (f a) - -sh2 :: (a1 -> a2 -> S.Sh b) -> (a1 -> a2 -> Sh b) -sh2 f = \a b -> sh0 (f a b) - -sh3 :: (a1 -> a2 -> a3 -> S.Sh b) -> (a1 -> a2 -> a3 -> Sh b) -sh3 f = \a b c -> sh0 (f a b c) - -sh4 :: (a1 -> a2 -> a3 -> a4 -> S.Sh b) -> (a1 -> a2 -> a3 -> a4 -> Sh b) -sh4 f = \a b c d -> sh0 (f a b c d) - -sh0s :: S.Sh [a] -> Sh a -sh0s = Sh - -sh1s :: (a -> S.Sh [b]) -> (a -> Sh b) -sh1s f = \a -> sh0s (f a) - -{- Just in case ... -sh2s :: (a1 -> a2 -> S.Sh [b]) -> (a1 -> a2 -> Sh b) -sh2s f = \a b -> sh0s (f a b) - -sh3s :: (a1 -> a2 -> a3 -> S.Sh [b]) -> (a1 -> a2 -> a3 -> Sh b) -sh3s f = \a b c -> sh0s (f a b c) --} - -lift1 :: (S.Sh a -> S.Sh b) -> (Sh a -> Sh b) -lift1 f = Sh . (mapM (f . return) =<< ) . unSh - -lift2 :: (S.Sh a -> S.Sh b -> S.Sh c) -> (Sh a -> Sh b -> Sh c) -lift2 f a b = Sh $ join $ liftA2 (mapM2 f') (unSh a) (unSh b) - where f' = \x y -> f (return x) (return y) - -mapM2 :: Monad m => (a -> b -> m c)-> [a] -> [b] -> m [c] -mapM2 f as bs = sequence $ liftA2 f as bs - ------------------------------------------------------------ - --- | Unpack list of results. -unroll :: Sh a -> Sh [a] -unroll = Sh . fmap return . unSh - --- | Pack list of results. It performs "concat" inside "Sh". -roll :: Sh [a] -> Sh a -roll = Sh . fmap concat . unSh - --- | Transform result as list. It can be useful for filtering. -liftSh :: ([a] -> [b]) -> Sh a -> Sh b -liftSh f = Sh . fmap f . unSh - ------------------------------------------------------------------- --- Entering Sh - --- | Enter a Sh from (Monad)IO. The environment and working directories are --- inherited from the current process-wide values. Any subsequent changes in --- processwide working directory or environment are not reflected in the --- running Sh. -shelly :: MonadIO m => Sh a -> m [a] -shelly = S.shelly . unSh - --- | Performs "shelly" and then an empty action @return ()@. -shs :: MonadIO m => Sh () -> m () -shs a = shelly a >> return () - --- | Using this entry point does not create a @.shelly@ directory in the case --- of failure. Instead it logs directly into the standard error stream (@stderr@). -shellyNoDir :: MonadIO m => Sh a -> m [a] -shellyNoDir = S.shellyNoDir . unSh - --- | Performs "shellyNoDir" and then an empty action @return ()@. -shsNoDir :: MonadIO m => Sh () -> m () -shsNoDir a = shellyNoDir a >> return () - --- | Enter a sub-Sh that inherits the environment --- The original state will be restored when the sub-Sh completes. --- Exceptions are propagated normally. -sub :: Sh a -> Sh a -sub = lift1 S.sub - --- | Create a sub-Sh in which external command outputs are not echoed. --- Also commands are not printed. --- See "sub". -silently :: Sh a -> Sh a -silently = lift1 S.silently - --- | Create a sub-Sh in which external command outputs are echoed. --- Executed commands are printed --- See "sub". -verbosely :: Sh a -> Sh a -verbosely = lift1 S.verbosely - --- | Create a sub-Sh with shell character escaping on or off -escaping :: Bool -> Sh a -> Sh a -escaping b = lift1 (S.escaping b) - --- | Create a sub-Sh with stdout printing on or off -print_stdout :: Bool -> Sh a -> Sh a -print_stdout b = lift1 (S.print_stdout b) - --- | Create a sub-Sh with command echoing on or off -print_commands :: Bool -> Sh a -> Sh a -print_commands b = lift1 (S.print_commands b) - --- | Create a sub-Sh where commands are not traced --- Defaults to True. --- You should only set to False temporarily for very specific reasons -tracing :: Bool -> Sh a -> Sh a -tracing b = lift1 (S.tracing b) - --- | named after bash -e errexit. Defaults to @True@. --- When @True@, throw an exception on a non-zero exit code. --- When @False@, ignore a non-zero exit code. --- Not recommended to set to @False@ unless you are specifically checking the error code with 'lastExitCode'. -errExit :: Bool -> Sh a -> Sh a -errExit b = lift1 (S.errExit b) - - ------------------------------------------------------------------- --- Running external commands. - --- | Execute an external command. Takes the command name (no shell allowed, --- just a name of something that can be found via @PATH@; FIXME: setenv'd --- @PATH@ is not taken into account when finding the exe name) --- --- "stdout" and "stderr" are collected. The "stdout" is returned as --- a result of "run", and complete stderr output is available after the fact using --- "lastStderr" --- --- All of the stdout output will be loaded into memory --- You can avoid this but still consume the result by using "run_", --- If you want to avoid the memory and need to process the output then use "runFoldLines". -run :: FilePath -> [Text] -> Sh Text -run a b = sh0 $ S.run a b - --- | The same as "run", but return () instead of the stdout content. -run_ :: FilePath -> [Text] -> Sh () -run_ a b = sh0 $ S.run_ a b - --- | used by 'run'. fold over stdout line-by-line as it is read to avoid keeping it in memory --- stderr is still being placed in memory under the assumption it is always relatively small -runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a -runFoldLines a cb fp ts = sh0 $ S.runFoldLines a cb fp ts - --- | Pipe operator. set the stdout the first command as the stdin of the second. -(-|-) :: Sh Text -> Sh b -> Sh b -(-|-) = lift2 (S.-|-) - --- | The output of last external command. See "run". -lastStderr :: Sh Text -lastStderr = sh0 S.lastStderr - --- | set the stdin to be used and cleared by the next "run". -setStdin :: Text -> Sh () -setStdin = sh1 S.setStdin - --- | The exit code from the last command. --- Unless you set 'errExit' to False you won't get a chance to use this: a non-zero exit code will throw an exception. -lastExitCode :: Sh Int -lastExitCode = sh0 S.lastExitCode - --- | bind some arguments to run for re-use --- Example: @monit = command "monit" ["-c", "monitrc"]@ -command :: FilePath -> [Text] -> [Text] -> Sh Text -command = sh3 S.command - --- | bind some arguments to "run_" for re-use --- Example: @monit_ = command_ "monit" ["-c", "monitrc"]@ -command_ :: FilePath -> [Text] -> [Text] -> Sh () -command_ = sh3 S.command_ - - --- | bind some arguments to run for re-use, and expect 1 argument --- Example: @git = command1 "git" []; git "pull" ["origin", "master"]@ -command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text -command1 = sh4 S.command1 - --- | bind some arguments to run for re-use, and expect 1 argument --- Example: @git_ = command1_ "git" []; git+ "pull" ["origin", "master"]@ -command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh () -command1_ = sh4 S.command1_ - --- | run commands over SSH. --- An ssh executable is expected in your path. --- Commands are in the same form as 'run', but given as pairs --- --- > sshPairs "server-name" [("cd", "dir"), ("rm",["-r","dir2"])] --- --- This interface is crude, but it works for now. --- --- Please note this sets 'escaping' to False: the commands will not be shell escaped. --- Internally the list of commands are combined with the string " && " before given to ssh. -sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text -sshPairs = sh2 S.sshPairs - --- | same as 'sshPairs', but returns () -sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh () -sshPairs_ = sh2 S.sshPairs_ - -------------------------------------------------------------------- --- Modifying and querying environment. - --- | Set an environment variable. The environment is maintained in Sh --- internally, and is passed to any external commands to be executed. -setenv :: Text -> Text -> Sh () -setenv = sh2 S.setenv - --- | Fetch the current value of an environment variable. --- if non-existant or empty text, will be Nothing -get_env :: Text -> Sh (Maybe Text) -get_env = sh1 S.get_env - --- | Fetch the current value of an environment variable. Both empty and --- non-existent variables give empty string as a result. -get_env_text :: Text -> Sh Text -get_env_text = sh1 S.get_env_text - --- | Fetch the current value of an environment variable. Both empty and --- non-existent variables give the default value as a result -get_env_def :: Text -> Text -> Sh Text -get_env_def a d = sh0 $ fmap (fromMaybe d) $ S.get_env a -{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-} - --- | add the filepath onto the PATH env variable --- FIXME: only effects the PATH once the process is ran, as per comments in 'which' -appendToPath :: FilePath -> Sh () -appendToPath = sh1 S.appendToPath - -------------------------------------------------------------- --- Environment directory - --- | Change current working directory of Sh. This does *not* change the --- working directory of the process we are running it. Instead, Sh keeps --- track of its own working directory and builds absolute paths internally --- instead of passing down relative paths. This may have performance --- repercussions if you are doing hundreds of thousands of filesystem --- operations. You will want to handle these issues differently in those cases. -cd :: FilePath -> Sh () -cd = sh1 S.cd - --- | "cd", execute a Sh action in the new directory and then pop back to the original directory -chdir :: FilePath -> Sh a -> Sh a -chdir p = lift1 (S.chdir p) - --- | Obtain the current (Sh) working directory. -pwd :: Sh FilePath -pwd = sh0 S.pwd - ------------------------------------------------------------------ --- Printing - --- | Echo text to standard (error, when using _err variants) output. The _n --- variants do not print a final newline. -echo, echo_n_err, echo_err, echo_n :: Text -> Sh () - -echo = sh1 S.echo -echo_n_err = sh1 S.echo_n_err -echo_err = sh1 S.echo_err -echo_n = sh1 S.echo_n - --- | a print lifted into Sh -inspect :: Show s => s -> Sh () -inspect = sh1 S.inspect - --- | a print lifted into Sh using stderr -inspect_err :: Show s => s -> Sh () -inspect_err = sh1 S.inspect_err - --- | same as 'trace', but use it combinator style -tag :: Sh a -> Text -> Sh a -tag a t = lift1 (flip S.tag t) a - --- | internally log what occured. --- Log will be re-played on failure. -trace :: Text -> Sh () -trace = sh1 S.trace - -show_command :: FilePath -> [Text] -> Text -show_command = S.show_command - ------------------------------------------------------------------- --- Querying filesystem - --- | List directory contents. Does *not* include \".\" and \"..\", but it does --- include (other) hidden files. -ls :: FilePath -> Sh FilePath -ls = sh1s S.ls - --- | Get back [Text] instead of [FilePath] -lsT :: FilePath -> Sh Text -lsT = sh1s S.lsT - --- | Does a path point to an existing filesystem object? -test_e :: FilePath -> Sh Bool -test_e = sh1 S.test_e - --- | Does a path point to an existing file? -test_f :: FilePath -> Sh Bool -test_f = sh1 S.test_f - --- | Does a path point to an existing directory? -test_d :: FilePath -> Sh Bool -test_d = sh1 S.test_d - --- | Does a path point to a symlink? -test_s :: FilePath -> Sh Bool -test_s = sh1 S.test_s - --- | Get a full path to an executable on @PATH@, if exists. FIXME does not --- respect setenv'd environment and uses @findExecutable@ which uses the @PATH@ inherited from the process --- environment. --- FIXME: findExecutable does not maintain a hash of existing commands and does a ton of file stats -which :: FilePath -> Sh (Maybe FilePath) -which = sh1 S.which - ---------------------------------------------------------------------- --- Filename helpers - --- | Make a relative path absolute by combining with the working directory. --- An absolute path is returned as is. --- To create a relative path, use 'path'. -absPath :: FilePath -> Sh FilePath -absPath = sh1 S.absPath - --- | makes an absolute path. --- Like 'canonicalize', but on an exception returns 'path' -canonic :: FilePath -> Sh FilePath -canonic = sh1 S.canonic - --- | Obtain a (reasonably) canonic file path to a filesystem object. Based on --- "canonicalizePath" in system-fileio. -canonicalize :: FilePath -> Sh FilePath -canonicalize = sh1 S.canonicalize - --- | Makes a relative path relative to the current Sh working directory. --- An absolute path is returned as is. --- To create an absolute path, use 'absPath' -relPath :: FilePath -> Sh FilePath -relPath = sh1 S.relPath - --- | make the second path relative to the first --- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary -relativeTo :: FilePath -- ^ anchor path, the prefix - -> FilePath -- ^ make this relative to anchor path - -> Sh FilePath -relativeTo = sh2 S.relativeTo - -------------------------------------------------------------- --- Manipulating filesystem - --- | Currently a "renameFile" wrapper. TODO: Support cross-filesystem --- move. TODO: Support directory paths in the second parameter, like in "cp". -mv :: FilePath -> FilePath -> Sh () -mv = sh2 S.mv - --- | Remove a file. --- Does fail if the file does not exist (use 'rm_f' instead) or is not a file. -rm :: FilePath -> Sh () -rm = sh1 S.rm - --- | Remove a file. Does not fail if the file does not exist. --- Does fail if the file is not a file. -rm_f :: FilePath -> Sh () -rm_f = sh1 S.rm_f - --- | A swiss army cannon for removing things. Actually this goes farther than a --- normal rm -rf, as it will circumvent permission problems for the files we --- own. Use carefully. --- Uses 'removeTree' -rm_rf :: FilePath -> Sh () -rm_rf = sh1 S.rm_rf - --- | Copy a file. The second path could be a directory, in which case the --- original file name is used, in that directory. -cp :: FilePath -> FilePath -> Sh () -cp = sh2 S.cp - --- | Copy a file, or a directory recursively. -cp_r :: FilePath -> FilePath -> Sh () -cp_r = sh2 S.cp_r - --- | Create a new directory (fails if the directory exists). -mkdir :: FilePath -> Sh () -mkdir = sh1 S.mkdir - --- | Create a new directory, including parents (succeeds if the directory --- already exists). -mkdir_p :: FilePath -> Sh () -mkdir_p = sh1 S.mkdir_p - --- | Create a new directory tree. You can describe a bunch of directories as --- a tree and this function will create all subdirectories. An example: --- --- > exec = mkTree $ --- > "package" # [ --- > "src" # [ --- > "Data" # leaves ["Tree", "List", "Set", "Map"] --- > ], --- > "test" # leaves ["QuickCheck", "HUnit"], --- > "dist/doc/html" # [] --- > ] --- > where (#) = Node --- > leaves = map (# []) --- -mkdirTree :: Tree FilePath -> Sh () -mkdirTree = sh1 S.mkdirTree - --- | (Strictly) read file into a Text. --- All other functions use Lazy Text. --- So Internally this reads a file as strict text and then converts it to lazy text, which is inefficient -readfile :: FilePath -> Sh Text -readfile = sh1 S.readfile - --- | wraps ByteSting readFile -readBinary :: FilePath -> Sh ByteString -readBinary = sh1 S.readBinary - --- | Write a Lazy Text to a file. -writefile :: FilePath -> Text -> Sh () -writefile = sh2 S.writefile - --- | Update a file, creating (a blank file) if it does not exist. -touchfile :: FilePath -> Sh () -touchfile = sh1 S.touchfile - --- | Append a Lazy Text to a file. -appendfile :: FilePath -> Text -> Sh () -appendfile = sh2 S.appendfile - --- | Create a temporary directory and pass it as a parameter to a Sh --- computation. The directory is nuked afterwards. -withTmpDir :: (FilePath -> Sh a) -> Sh a -withTmpDir f = Sh $ S.withTmpDir (unSh . f) - ------------------------------------------------------------------ --- find - --- | List directory recursively (like the POSIX utility "find"). --- listing is relative if the path given is relative. --- If you want to filter out some results or fold over them you can do that with the returned files. --- A more efficient approach is to use one of the other find functions. -find :: FilePath -> Sh FilePath -find = sh1s S.find - --- | 'find' that filters the found files as it finds. --- Files must satisfy the given filter to be returned in the result. -findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath -findWhen p a = Sh $ S.findWhen (fmap and . unSh . p) a - --- | Fold an arbitrary folding function over files froma a 'find'. --- Like 'findWhen' but use a more general fold rather than a filter. -findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a -findFold cons nil a = Sh $ S.findFold cons' nil' a - where nil' = return nil - cons' as dir = unSh $ roll $ mapM (flip cons dir) as - --- | 'find' that filters out directories as it finds --- Filtering out directories can make a find much more efficient by avoiding entire trees of files. -findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath -findDirFilter p a = Sh $ S.findDirFilter (fmap and . unSh . p) a - --- | similar 'findWhen', but also filter out directories --- Alternatively, similar to 'findDirFilter', but also filter out files --- Filtering out directories makes the find much more efficient -findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter - -> (FilePath -> Sh Bool) -- ^ file filter - -> FilePath -- ^ directory - -> Sh FilePath -findDirFilterWhen dirPred filePred a = - Sh $ S.findDirFilterWhen - (fmap and . unSh . dirPred) - (fmap and . unSh . filePred) - a - - --- | like 'findDirFilterWhen' but use a folding function rather than a filter --- The most general finder: you likely want a more specific one -findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a -findFoldDirFilter cons nil p a = Sh $ S.findFoldDirFilter cons' nil' p' a - where p' = fmap and . unSh . p - nil' = return nil - cons' as dir = unSh $ roll $ mapM (flip cons dir) as - ------------------------------------------------------------ --- exiting the program - -exit :: Int -> Sh () -exit = sh1 S.exit - -errorExit :: Text -> Sh () -errorExit = sh1 S.errorExit - --- | for exiting with status > 0 without printing debug information -quietExit :: Int -> Sh () -quietExit = sh1 S.quietExit - --- | fail that takes a Text -terror :: Text -> Sh a -terror = sh1 S.terror - ------------------------------------------------------------- --- Utilities - --- | Catch an exception in the Sh monad. -catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a -catch_sh a f = Sh $ S.catch_sh (unSh a) (unSh . f) - --- | Catch an exception in the Sh monad. -catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a -catchany_sh = catch_sh - - --- | Catch an exception in the Sh monad. -finally_sh :: Sh a -> Sh b -> Sh a -finally_sh = lift2 S.finally_sh - --- | Run a Sh computation and collect timing information. -time :: Sh a -> Sh (Double, a) -time = lift1 S.time - --- | You need this when using 'catches_sh'. -data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a) - --- | Catch multiple exceptions in the Sh monad. -catches_sh :: Sh a -> [ShellyHandler a] -> Sh a -catches_sh a hs = Sh $ S.catches_sh (unSh a) (fmap convert hs) - where convert :: ShellyHandler a -> S.ShellyHandler [a] - convert (ShellyHandler f) = S.ShellyHandler (unSh . f) - ------------------------------------------------------------- --- convert between Text and FilePath - -toTextWarn :: FilePath -> Sh Text -toTextWarn = sh1 S.toTextWarn - -------------------------------------------------------------- --- internal functions for writing extension - -get :: Sh State -get = sh0 S.get - -put :: State -> Sh () -put = sh1 S.put - --------------------------------------------------------- --- polyvariadic vodoo - --- | Converter for the variadic argument version of 'run' called 'cmd'. -class ShellArg a where toTextArg :: a -> Text -instance ShellArg Text where toTextArg = id -instance ShellArg FilePath where toTextArg = toTextIgnore - - --- Voodoo to create the variadic function 'cmd' -class ShellCommand t where - cmdAll :: FilePath -> [Text] -> t - -instance ShellCommand (Sh Text) where - cmdAll fp args = run fp args - -instance (s ~ Text, Show s) => ShellCommand (Sh s) where - cmdAll fp args = run fp args - --- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature -instance ShellCommand (Sh ()) where - cmdAll fp args = run_ fp args - -instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where - cmdAll fp acc = \x -> cmdAll fp (acc ++ [toTextArg x]) - --- | variadic argument version of run. --- The syntax is more convenient, but more importantly it also allows the use of a FilePath as a command argument. --- So an argument can be a Text or a FilePath. --- a FilePath is converted to Text with 'toTextIgnore'. --- You will need to add the following to your module: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE ExtendedDefaultRules #-} --- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- > import Shelly --- > import Data.Text.Lazy as LT --- > default (LT.Text) --- -cmd :: (ShellCommand result) => FilePath -> result -cmd fp = cmdAll fp [] - diff --git a/shelly.cabal b/shelly.cabal --- a/shelly.cabal +++ b/shelly.cabal @@ -1,6 +1,6 @@ Name: shelly -Version: 0.15.4.1 +Version: 1.0.0.0 Synopsis: shell-like (systems) programming in Haskell Description: Shelly provides convenient systems programming in Haskell, @@ -35,48 +35,35 @@ Library Exposed-modules: Shelly, Shelly.Pipe other-modules: Shelly.Base, Shelly.Find + hs-source-dirs: src - Build-depends: base >= 4 && < 5, containers - , time, directory, text, mtl >= 2 - , process >= 1.0 - , unix-compat < 0.5 - , system-filepath >= 0.4.7 && < 0.5 - , system-fileio < 0.4 - , bytestring + Build-depends: + containers >= 0.5.0.0, + time >= 1.3 && < 1.5, + directory >= 1.1.0.0 && < 1.3.0.0, + text, + mtl >= 2, + process >= 1.0, + unix-compat < 0.5, + system-filepath >= 0.4.7 && < 0.5, + system-fileio < 0.4, + bytestring - ghc-options: -Wall + if impl(ghc >= 7.6.1) + build-depends: + base >= 4.6 && < 5 + else + build-depends: + base >= 4 && < 5 -test-suite test - type: exitcode-stdio-1.0 - main-is: main.hs - hs-source-dirs: ., test - ghc-options: -Wall + ghc-options: -Wall - Build-depends: base >= 4 && < 5, containers - , time, directory, text, mtl, process - , unix-compat < 0.5 - , system-filepath >= 0.4.7 && < 0.5 - , system-fileio < 0.4 - , bytestring - , hspec >= 1.4 - , HUnit + if impl(ghc >= 7.6.1) + CPP-Options: -DNO_PRELUDE_CATCH --- test out kiling while sleeping -test-suite sleep - type: exitcode-stdio-1.0 - main-is: test/sleep.hs - Build-depends: base >= 4 && < 5, containers - , time, directory, text, mtl - , process >= 1.0 - , unix-compat < 0.5 - , system-filepath >= 0.4.7 && < 0.5 - , system-fileio < 0.4 - , bytestring + extensions: + CPP --- demonstarated that command output in Shellish was not shown until after the command finished --- not necessary anymore --- Executable drain --- main-is: test/drain.hs source-repository head type: git diff --git a/src/Shelly.hs b/src/Shelly.hs new file mode 100644 --- /dev/null +++ b/src/Shelly.hs @@ -0,0 +1,1149 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings, + MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, + TypeFamilies, IncoherentInstances, GADTs #-} + +-- | A module for shell-like programming in Haskell. +-- Shelly's focus is entirely on ease of use for those coming from shell scripting. +-- However, it also tries to use modern libraries and techniques to keep things efficient. +-- +-- The functionality provided by +-- this module is (unlike standard Haskell filesystem functionality) +-- thread-safe: each Sh maintains its own environment and its own working +-- directory. +-- +-- Recommended usage includes putting the following at the top of your program, +-- otherwise you will likely need either type annotations or type conversions +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE ExtendedDefaultRules #-} +-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- > import Shelly +-- > import qualified Data.Text as T +-- > default (T.Text) +module Shelly + ( + -- * Entering Sh. + Sh, ShIO, shelly, shellyNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit + + -- * Running external commands. + , run, run_, runFoldLines, cmd, FoldCallback, runHandle, runHandles + , (-|-), lastStderr, setStdin, lastExitCode + , command, command_, command1, command1_ + , sshPairs, sshPairs_ + , ShellArg (..) + + -- * Modifying and querying environment. + , setenv, get_env, get_env_text, getenv, get_env_def, appendToPath + + -- * Environment directory + , cd, chdir, pwd + + -- * Printing + , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err + , tag, trace, show_command + + -- * Querying filesystem. + , ls, lsT, test_e, test_f, test_d, test_s, which + + -- * Filename helpers + , absPath, (), (<.>), canonic, canonicalize, relPath, relativeTo, path + , hasExt + + -- * Manipulating filesystem. + , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree + + -- * reading/writing Files + , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir + + -- * exiting the program + , exit, errorExit, quietExit, terror + + -- * Exceptions + , catchany, catch_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh + + -- * convert between Text and FilePath + , toTextIgnore, toTextWarn, fromText + + -- * Utility Functions + , whenM, unlessM, time, sleep + + -- * Re-exported for your convenience + , liftIO, when, unless, FilePath, (<$>) + + -- * internal functions for writing extensions + , get, put + + -- * find functions + , find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter + ) where + +import Shelly.Base +import Shelly.Find +import Control.Monad ( when, unless, void, forM, filterM ) +import Control.Monad.Trans ( MonadIO ) +import Control.Monad.Reader (ask) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 +import Prelude hiding ( readFile, FilePath, catch) +#else +import Prelude hiding ( readFile, FilePath) +#endif +import Data.Char ( isAlphaNum, isSpace ) +import Data.Typeable +import Data.IORef +import Data.Maybe +import System.IO ( hClose, stderr, stdout, openTempFile ) +import System.Exit +import System.Environment +import Control.Applicative +import Control.Exception hiding (handle) +import Control.Concurrent +import Data.Time.Clock( getCurrentTime, diffUTCTime ) + +import qualified Data.Text.IO as TIO +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TE +import System.Process( CmdSpec(..), StdStream(CreatePipe, UseHandle), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle ) +import System.IO.Error (isPermissionError) + +import qualified Data.Text as T +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) + +#if __GLASGOW_HASKELL__ < 704 +import Data.Monoid (Monoid, mappend) +infixr 5 <> +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +#else +import Data.Monoid ( mappend, (<>)) +#endif + +import Filesystem.Path.CurrentOS hiding (concat, fromText, (), (<.>)) +import Filesystem hiding (canonicalizePath) +import qualified Filesystem.Path.CurrentOS as FP + +import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory ) +import Data.Char (isDigit) + +import Data.Tree(Tree(..)) +import qualified Data.Set as S +import qualified Data.List as L + +searchPathSeparator :: Char +#if defined(mingw32_HOST_OS) +searchPathSeparator = ';' +#else +searchPathSeparator = ':' +#endif + +{- GHC won't default to Text with this, even with extensions! + - see: http://hackage.haskell.org/trac/ghc/ticket/6030 +class ShellArgs a where + toTextArgs :: a -> [Text] + +instance ShellArgs Text where toTextArgs t = [t] +instance ShellArgs FilePath where toTextArgs t = [toTextIgnore t] +instance ShellArgs [Text] where toTextArgs = id +instance ShellArgs [FilePath] where toTextArgs = map toTextIgnore + +instance ShellArgs (Text, Text) where + toTextArgs (t1,t2) = [t1, t2] +instance ShellArgs (FilePath, FilePath) where + toTextArgs (fp1,fp2) = [toTextIgnore fp1, toTextIgnore fp2] +instance ShellArgs (Text, FilePath) where + toTextArgs (t1, fp1) = [t1, toTextIgnore fp1] +instance ShellArgs (FilePath, Text) where + toTextArgs (fp1,t1) = [toTextIgnore fp1, t1] + +cmd :: (ShellArgs args) => FilePath -> args -> Sh Text +cmd fp args = run fp $ toTextArgs args +-} + +-- | Argument converter for the variadic argument version of 'run' called 'cmd'. +-- Useful for a type signature of a function that uses 'cmd' +class ShellArg a where toTextArg :: a -> Text +instance ShellArg Text where toTextArg = id +instance ShellArg FilePath where toTextArg = toTextIgnore +instance ShellArg String where toTextArg = T.pack + + +-- | used to create the variadic function 'cmd' +class ShellCommand t where + cmdAll :: FilePath -> [Text] -> t + +instance ShellCommand (Sh Text) where + cmdAll = run + +instance (s ~ Text, Show s) => ShellCommand (Sh s) where + cmdAll = run + +-- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature +instance ShellCommand (Sh ()) where + cmdAll = run_ + +instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where + cmdAll fp acc x = cmdAll fp (acc ++ [toTextArg x]) + + +-- | variadic argument version of 'run'. +-- Please see the documenation for 'run'. +-- +-- The syntax is more convenient, but more importantly it also allows the use of a FilePath as a command argument. +-- So an argument can be a Text or a FilePath without manual conversions. +-- a FilePath is automatically converted to Text with 'toTextIgnore'. +-- +-- Convenient usage of 'cmd' requires the following: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE ExtendedDefaultRules #-} +-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- > import Shelly +-- > import qualified Data.Text as T +-- > default (T.Text) +-- +cmd :: (ShellCommand result) => FilePath -> result +cmd fp = cmdAll fp [] + +-- | Helper to convert a Text to a FilePath. Used by '()' and '(<.>)' +class ToFilePath a where + toFilePath :: a -> FilePath + +instance ToFilePath FilePath where toFilePath = id +instance ToFilePath Text where toFilePath = FP.fromText +instance ToFilePath String where toFilePath = FP.fromText . T.pack + + +-- | uses System.FilePath.CurrentOS, but can automatically convert a Text +() :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath +x y = toFilePath x FP. toFilePath y + +-- | uses System.FilePath.CurrentOS, but can automatically convert a Text +(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath +x <.> y = toFilePath x FP.<.> y + + + +toTextWarn :: FilePath -> Sh Text +toTextWarn efile = case toText efile of + Left f -> encodeError f >> return f + Right f -> return f + where + encodeError f = echo ("Invalid encoding for file: " <> f) + +fromText :: Text -> FilePath +fromText = FP.fromText + +printGetContent :: Handle -> Handle -> IO Text +printGetContent = printFoldHandleLines T.empty foldText + +{- +getContent :: Handle -> IO Text +getContent h = fmap B.toLazyText $ foldHandleLines (B.fromText "") foldBuilder h +-} + +type FoldCallback a = ((a, Text) -> a) + +printFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a +printFoldHandleLines start foldLine readHandle writeHandle = go start + where + go acc = do + line <- TIO.hGetLine readHandle + TIO.hPutStrLn writeHandle line >> go (foldLine (acc, line)) + `catchany` \_ -> return acc + +foldHandleLines :: a -> FoldCallback a -> Handle -> IO a +foldHandleLines start foldLine readHandle = go start + where + go acc = do + line <- TIO.hGetLine readHandle + go $ foldLine (acc, line) + `catchany` \_ -> return acc + +-- | same as 'trace', but use it combinator style +tag :: Sh a -> Text -> Sh a +tag action msg = do + trace msg + action + +put :: State -> Sh () +put newState = do + stateVar <- ask + liftIO (writeIORef stateVar newState) + +runCommandNoEscape :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) +runCommandNoEscape mstdin st exe args = liftIO $ shellyProcess mstdin st $ + ShellCommand $ T.unpack $ T.intercalate " " (toTextIgnore exe : args) + +runCommand :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) +runCommand mstdin st exe args = findExe exe >>= \fullExe -> + liftIO $ shellyProcess mstdin st $ + RawCommand (unpack fullExe) (map T.unpack args) + where + findExe :: FilePath -> Sh FilePath + findExe fp = do +#if defined(mingw32_HOST_OS) + let fullExe = case extension fp of + Nothing -> fp <.> "exe" + Just _ -> fp + mExe <- which fullExe + return $ case mExe of + Just execFp -> execFp + -- windows looks in extra places besides the PATH, so just give + -- up even if the behavior is not properly specified anymore + Nothing -> fp +#else + mExe <- which exe + case mExe of + Just execFp -> return execFp + Nothing -> liftIO $ throwIO $ userError $ + "shelly did not find " `mappend` encodeString fp `mappend` + if absolute exe then "" else " in the PATH" +#endif + + + + +shellyProcess :: (Maybe Handle) -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle) +shellyProcess mstdin st cmdSpec = do + (Just hin, Just hout, Just herr, pHandle) <- createProcess CreateProcess { + cmdspec = cmdSpec + , cwd = Just $ unpack $ sDirectory st + , env = Just $ sEnvironment st + , std_in = case mstdin of + Nothing -> CreatePipe + Just handle -> UseHandle handle + , std_out = CreatePipe, std_err = CreatePipe + , close_fds = False +#if MIN_VERSION_process(1,1,0) + , create_group = False +#endif + } + return (hin, hout, herr, pHandle) + +{- +-- | use for commands requiring usage of sudo. see 'run_sudo'. +-- Use this pattern for priveledge separation +newtype Sudo a = Sudo { sudo :: Sh a } + +-- | require that the caller explicitly state 'sudo' +run_sudo :: Text -> [Text] -> Sudo Text +run_sudo cmd args = Sudo $ run "/usr/bin/sudo" (cmd:args) +-} + +-- | Same as a normal 'catch' but specialized for the Sh monad. +catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a +catch_sh action handle = do + ref <- ask + liftIO $ catch (runSh action ref) (\e -> runSh (handle e) ref) + +-- | Same as a normal 'finally' but specialized for the 'Sh' monad. +finally_sh :: Sh a -> Sh b -> Sh a +finally_sh action handle = do + ref <- ask + liftIO $ finally (runSh action ref) (runSh handle ref) + + +-- | You need to wrap exception handlers with this when using 'catches_sh'. +data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a) + +-- | Same as a normal 'catches', but specialized for the 'Sh' monad. +catches_sh :: Sh a -> [ShellyHandler a] -> Sh a +catches_sh action handlers = do + ref <- ask + let runner a = runSh a ref + liftIO $ catches (runner action) $ map (toHandler runner) handlers + where + toHandler :: (Sh a -> IO a) -> ShellyHandler a -> Handler a + toHandler runner (ShellyHandler handle) = Handler (\e -> runner (handle e)) + +-- | Catch an exception in the Sh monad. +catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a +catchany_sh = catch_sh + +-- | Change current working directory of Sh. This does *not* change the +-- working directory of the process we are running it. Instead, Sh keeps +-- track of its own working directory and builds absolute paths internally +-- instead of passing down relative paths. +cd :: FilePath -> Sh () +cd = canonic >=> cd' + where + cd' dir = do + trace $ "cd " <> tdir + unlessM (test_d dir) $ errorExit $ "not a directory: " <> tdir + modify $ \st -> st { sDirectory = dir, sPathExecutables = Nothing } + where + tdir = toTextIgnore dir + +-- | 'cd', execute a Sh action in the new directory and then pop back to the original directory +chdir :: FilePath -> Sh a -> Sh a +chdir dir action = do + d <- gets sDirectory + cd dir + action `finally_sh` cd d + +-- | 'chdir', but first create the directory if it does not exit +chdir_p :: FilePath -> Sh a -> Sh a +chdir_p d action = mkdir_p d >> chdir d action + + +-- | apply a String IO operations to a Text FilePath +{- +liftStringIO :: (String -> IO String) -> FilePath -> Sh FilePath +liftStringIO f = liftIO . f . unpack >=> return . pack + +-- | @asString f = pack . f . unpack@ +asString :: (String -> String) -> FilePath -> FilePath +asString f = pack . f . unpack +-} + +pack :: String -> FilePath +pack = decodeString + +-- | Move a file. The second path could be a directory, in which case the +-- original file is moved into that directory. +-- wraps system-fileio 'FileSystem.rename', which may not work across FS boundaries +mv :: FilePath -> FilePath -> Sh () +mv from' to' = do + from <- absPath from' + to <- absPath to' + trace $ "mv " <> toTextIgnore from <> " " <> toTextIgnore to + to_dir <- test_d to + let to_loc = if not to_dir then to else to FP. filename from + liftIO $ rename from to_loc + `catchany` (\e -> throwIO $ + ReThrownException e (extraMsg to_loc from) + ) + where + extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t + +-- | Get back [Text] instead of [FilePath] +lsT :: FilePath -> Sh [Text] +lsT = ls >=> mapM toTextWarn + +-- | Obtain the current (Sh) working directory. +pwd :: Sh FilePath +pwd = gets sDirectory `tag` "pwd" + +-- | exit 0 means no errors, all other codes are error conditions +exit :: Int -> Sh a +exit 0 = liftIO exitSuccess `tag` "exit 0" +exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " <> T.pack (show n)) + +-- | echo a message and exit with status 1 +errorExit :: Text -> Sh a +errorExit msg = echo msg >> exit 1 + +-- | for exiting with status > 0 without printing debug information +quietExit :: Int -> Sh a +quietExit 0 = exit 0 +quietExit n = throw $ QuietExit n + +-- | fail that takes a Text +terror :: Text -> Sh a +terror = fail . T.unpack + +-- | Create a new directory (fails if the directory exists). +mkdir :: FilePath -> Sh () +mkdir = absPath >=> \fp -> do + trace $ "mkdir " <> toTextIgnore fp + liftIO $ createDirectory False fp + +-- | Create a new directory, including parents (succeeds if the directory +-- already exists). +mkdir_p :: FilePath -> Sh () +mkdir_p = absPath >=> \fp -> do + trace $ "mkdir -p " <> toTextIgnore fp + liftIO $ createTree fp + +-- | Create a new directory tree. You can describe a bunch of directories as +-- a tree and this function will create all subdirectories. An example: +-- +-- > exec = mkTree $ +-- > "package" # [ +-- > "src" # [ +-- > "Data" # leaves ["Tree", "List", "Set", "Map"] +-- > ], +-- > "test" # leaves ["QuickCheck", "HUnit"], +-- > "dist/doc/html" # [] +-- > ] +-- > where (#) = Node +-- > leaves = map (# []) +-- +mkdirTree :: Tree FilePath -> Sh () +mkdirTree = mk . unrollPath + where mk :: Tree FilePath -> Sh () + mk (Node a ts) = do + b <- test_d a + unless b $ mkdir a + chdir a $ mapM_ mkdirTree ts + + unrollPath :: Tree FilePath -> Tree FilePath + unrollPath (Node v ts) = unrollRoot v $ map unrollPath ts + where unrollRoot x = foldr1 phi $ map Node $ splitDirectories x + phi a b = a . return . b + +-- | Get a full path to an executable by looking at the @PATH@ environement +-- variable. Windows normally looks in additional places besides the +-- @PATH@: this does not duplicate that behavior. +which :: FilePath -> Sh (Maybe FilePath) +which fp = (trace . mappend "which " . toTextIgnore) fp >> whichUntraced + where + whichUntraced | absolute fp = checkFile + | length (splitDirectories fp) > 0 = lookupPath + | otherwise = lookupCache + checkFile = do + exists <- liftIO $ isFile fp + return $ if exists then Just fp else Nothing + + lookupPath = + pathDirs >>= findMapM (\dir -> do + let fullFp = dir fp + res <- liftIO $ isExecutable $ encodeString $ fullFp + return $ if res then Just fullFp else Nothing + ) + + lookupCache = do + pathExecutables <- cachedPathExecutables + liftIO $ print pathExecutables + return $ fmap (flip () fp . fst) $ + L.find (S.member fp . snd) pathExecutables + + + pathDirs = mapM absPath =<< ((map fromText . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH") + + isExecutable f = (executable `fmap` getPermissions f) `catch` + (\(_ :: IOError) -> return False) + + cachedPathExecutables :: Sh [(FilePath, S.Set FilePath)] + cachedPathExecutables = do + mPathExecutables <- gets sPathExecutables + case mPathExecutables of + Just pExecutables -> return pExecutables + Nothing -> do + dirs <- pathDirs + executables <- forM dirs (\dir -> do + files <- (liftIO . listDirectory) dir `catch_sh` (\(_ :: IOError) -> return []) + exes <- fmap (map snd) $ liftIO $ filterM (isExecutable . fst) $ + map (\f -> (encodeString f, filename f)) files + return $ S.fromList exes + ) + let cachedExecutables = zip dirs executables + modify $ \x -> x { sPathExecutables = Just cachedExecutables } + return $ cachedExecutables + + +-- | A monadic findMap, taken from MissingM package +findMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +findMapM _ [] = return Nothing +findMapM f (x:xs) = + do + mb <- f x + if (isJust mb) + then return mb + else findMapM f xs + +-- | A monadic-conditional version of the 'unless' guard. +unlessM :: Monad m => m Bool -> m () -> m () +unlessM c a = c >>= \res -> unless res a + +-- | Does a path point to an existing filesystem object? +test_e :: FilePath -> Sh Bool +test_e = absPath >=> \f -> + liftIO $ do + file <- isFile f + if file then return True else isDirectory f + +-- | Does a path point to an existing file? +test_f :: FilePath -> Sh Bool +test_f = absPath >=> liftIO . isFile + +-- | A swiss army cannon for removing things. Actually this goes farther than a +-- normal rm -rf, as it will circumvent permission problems for the files we +-- own. Use carefully. +-- Uses 'removeTree' +rm_rf :: FilePath -> Sh () +rm_rf = absPath >=> \f -> do + trace $ "rm -rf " <> toTextIgnore f + isDir <- (test_d f) + if not isDir then whenM (test_f f) $ rm_f f + else + (liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) -> + when (isPermissionError e) $ do + find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ()) + liftIO $ removeTree f + ) + where fixPermissions file = + do permissions <- liftIO $ getPermissions file + let deletable = permissions { readable = True, writable = True, executable = True } + liftIO $ setPermissions file deletable + +-- | Remove a file. Does not fail if the file does not exist. +-- Does fail if the file is not a file. +rm_f :: FilePath -> Sh () +rm_f = absPath >=> \f -> do + trace $ "rm -f " <> toTextIgnore f + whenM (test_e f) $ canonic f >>= liftIO . removeFile + +-- | Remove a file. +-- Does fail if the file does not exist (use 'rm_f' instead) or is not a file. +rm :: FilePath -> Sh () +rm = absPath >=> \f -> do + trace $ "rm" <> toTextIgnore f + -- TODO: better error message for removeFile (give filename) + canonic f >>= liftIO . removeFile + +-- | Set an environment variable. The environment is maintained in Sh +-- internally, and is passed to any external commands to be executed. +setenv :: Text -> Text -> Sh () +setenv k v = + if k == path_env then setPath v else do + let (kStr, vStr) = (T.unpack k, T.unpack v) + wibble environment = (kStr, vStr) : filter ((/=kStr) . fst) environment + in modify $ \x -> x { sEnvironment = wibble $ sEnvironment x } + +setPath :: Text -> Sh () +setPath newPath = do + modify $ \x -> x{ sPathExecutables = Nothing } + setenv path_env newPath + +path_env :: Text +path_env = "PATH" + +-- | add the filepath onto the PATH env variable +appendToPath :: FilePath -> Sh () +appendToPath = absPath >=> \filepath -> do + tp <- toTextWarn filepath + pe <- get_env_text path_env + setPath $ pe <> T.singleton searchPathSeparator <> tp + +-- | Fetch the current value of an environment variable. +-- if non-existant or empty text, will be Nothing +get_env :: Text -> Sh (Maybe Text) +get_env k = do + mval <- return . fmap T.pack . lookup (T.unpack k) =<< gets sEnvironment + return $ case mval of + Nothing -> Nothing + j@(Just val) -> if T.null val then Nothing else j + +-- | deprecated +getenv :: Text -> Sh Text +getenv k = get_env_def k "" +{-# DEPRECATED getenv "use get_env or get_env_text" #-} + +-- | Fetch the current value of an environment variable. Both empty and +-- non-existent variables give empty string as a result. +get_env_text :: Text -> Sh Text +get_env_text = get_env_def "" + +-- | Fetch the current value of an environment variable. Both empty and +-- non-existent variables give the default Text value as a result +get_env_def :: Text -> Text -> Sh Text +get_env_def d = get_env >=> return . fromMaybe d +{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-} + + +-- | Create a sub-Sh in which external command outputs are not echoed and +-- commands are not printed. +-- See 'sub'. +silently :: Sh a -> Sh a +silently a = sub $ modify (\x -> x { sPrintStdout = False, sPrintCommands = False }) >> a + +-- | Create a sub-Sh in which external command outputs are echoed and +-- Executed commands are printed +-- See 'sub'. +verbosely :: Sh a -> Sh a +verbosely a = sub $ modify (\x -> x { sPrintStdout = True, sPrintCommands = True }) >> a + +-- | Create a sub-Sh with stdout printing on or off +-- Defaults to True. +print_stdout :: Bool -> Sh a -> Sh a +print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a + + +-- | Create a sub-Sh with command echoing on or off +-- Defaults to False, set to True by 'verbosely' +print_commands :: Bool -> Sh a -> Sh a +print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a + +-- | Enter a sub-Sh that inherits the environment +-- The original state will be restored when the sub-Sh completes. +-- Exceptions are propagated normally. +sub :: Sh a -> Sh a +sub a = do + oldState <- get + modify $ \st -> st { sTrace = T.empty } + a `finally_sh` restoreState oldState + where + restoreState oldState = do + newState <- get + put oldState { + -- avoid losing the log + sTrace = sTrace oldState <> sTrace newState + -- latest command execution: not make sense to restore these to old settings + , sCode = sCode newState + , sStderr = sStderr newState + -- it is questionable what the behavior of stdin should be + , sStdin = sStdin newState + } + +-- | Create a sub-Sh where commands are not traced +-- Defaults to True. +-- You should only set to False temporarily for very specific reasons +tracing :: Bool -> Sh a -> Sh a +tracing shouldTrace action = sub $ do + modify $ \st -> st { sTracing = shouldTrace } + action + +-- | Create a sub-Sh with shell character escaping on or off. +-- Defaults to @True@. +-- +-- Setting to @False@ allows for shell wildcard such as * to be expanded by the shell along with any other special shell characters. +-- As a side-effect, setting to @False@ causes changes to @PATH@ to be ignored: +-- see the 'run' documentation. +escaping :: Bool -> Sh a -> Sh a +escaping shouldEscape action = sub $ do + modify $ \st -> st { sRun = + if shouldEscape then runCommand else runCommandNoEscape + } + action + +-- | named after bash -e errexit. Defaults to @True@. +-- When @True@, throw an exception on a non-zero exit code. +-- When @False@, ignore a non-zero exit code. +-- Not recommended to set to @False@ unless you are specifically checking the error code with 'lastExitCode'. +errExit :: Bool -> Sh a -> Sh a +errExit shouldExit action = sub $ do + modify $ \st -> st { sErrExit = shouldExit } + action + +data ShellyOpts = ShellyOpts { failToDir :: Bool } + +-- avoid data-default dependency for now +-- instance Default ShellyOpts where +shellyOpts :: ShellyOpts +shellyOpts = ShellyOpts { failToDir = True } + +-- | Using this entry point does not create a @.shelly@ directory in the case +-- of failure. Instead it logs directly into the standard error stream (@stderr@). +shellyNoDir :: MonadIO m => Sh a -> m a +shellyNoDir = shelly' shellyOpts { failToDir = False } + +-- | Enter a Sh from (Monad)IO. The environment and working directories are +-- inherited from the current process-wide values. Any subsequent changes in +-- processwide working directory or environment are not reflected in the +-- running Sh. +shelly :: MonadIO m => Sh a -> m a +shelly = shelly' shellyOpts + +shelly' :: MonadIO m => ShellyOpts -> Sh a -> m a +shelly' opts action = do + environment <- liftIO getEnvironment + dir <- liftIO getWorkingDirectory + let def = State { sCode = 0 + , sStdin = Nothing + , sStderr = T.empty + , sPrintStdout = True + , sPrintCommands = False + , sRun = runCommand + , sEnvironment = environment + , sTracing = True + , sTrace = T.empty + , sDirectory = dir + , sPathExecutables = Nothing + , sErrExit = True + } + stref <- liftIO $ newIORef def + let caught = + action `catches_sh` [ + ShellyHandler (\ex -> + case ex of + ExitSuccess -> liftIO $ throwIO ex + ExitFailure _ -> throwExplainedException ex + ) + , ShellyHandler (\ex -> case ex of + QuietExit n -> liftIO $ throwIO $ ExitFailure n) + , ShellyHandler (\(ex::SomeException) -> throwExplainedException ex) + ] + liftIO $ runSh caught stref + where + throwExplainedException :: Exception exception => exception -> Sh a + throwExplainedException ex = get >>= errorMsg >>= liftIO . throwIO . ReThrownException ex + errorMsg st = + if not (failToDir opts) then ranCommands else do + d <- pwd + sf <- shellyFile + let logFile = dshelly_dirsf + (writefile logFile trc >> return ("log of commands saved to: " <> encodeString logFile)) + `catchany_sh` (\_ -> ranCommands) + + where + trc = sTrace st + ranCommands = return . mappend "Ran commands: \n" . T.unpack $ trc + + shelly_dir = ".shelly" + shellyFile = chdir_p shelly_dir $ do + fs <- ls "." + return $ pack $ show (nextNum fs) <> ".txt" + + nextNum :: [FilePath] -> Int + nextNum [] = 1 + nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . unpack . filename) $ fs + +-- from safe package +readDef :: Read a => a -> String -> a +readDef def = fromMaybe def . readMay + where + readMay :: Read a => String -> Maybe a + readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> Just x + _ -> Nothing + +data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable) + +instance Show RunFailed where + show (RunFailed exe args code errs) = + let codeMsg = case code of + 127 -> ". exit code 127 usually means the command does not exist (in the PATH)" + _ -> "" + in "error running: " ++ T.unpack (show_command exe args) ++ + "\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ T.unpack errs + +instance Exception RunFailed + +show_command :: FilePath -> [Text] -> Text +show_command exe args = + T.intercalate " " $ map quote (toTextIgnore exe : args) + where + quote t | T.any (== '\'') t = t + quote t | T.any isSpace t = surround '\'' t + quote t | otherwise = t + +surround :: Char -> Text -> Text +surround c t = T.cons c $ T.snoc t c + +-- | same as 'sshPairs', but returns () +sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh () +sshPairs_ _ [] = return () +sshPairs_ server cmds = sshPairs' run_ server cmds + +-- | run commands over SSH. +-- An ssh executable is expected in your path. +-- Commands are in the same form as 'run', but given as pairs +-- +-- > sshPairs "server-name" [("cd", "dir"), ("rm",["-r","dir2"])] +-- +-- This interface is crude, but it works for now. +-- +-- Please note this sets 'escaping' to False: the commands will not be shell escaped. +-- Internally the list of commands are combined with the string @&&@ before given to ssh. +sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text +sshPairs _ [] = return "" +sshPairs server cmds = sshPairs' run server cmds + +sshPairs' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a +sshPairs' run' server actions = escaping False $ do + let ssh_commands = surround '\'' $ foldl1 + (\memo next -> memo <> " && " <> next) + (map toSSH actions) + run' "ssh" [server, ssh_commands] + where + toSSH (exe,args) = show_command exe args + + +data QuietExit = QuietExit Int deriving (Show, Typeable) +instance Exception QuietExit + +data ReThrownException e = ReThrownException e String deriving (Typeable) +instance Exception e => Exception (ReThrownException e) +instance Exception e => Show (ReThrownException e) where + show (ReThrownException ex msg) = "\n" ++ + msg ++ "\n" ++ "Exception: " ++ show ex + +-- | Execute an external command. +-- Takes the command name and arguments. +-- +-- You may prefer using 'cmd' instead, which is a variadic argument version +-- of this function. +-- +-- 'stdout' and 'stderr' are collected. The 'stdout' is returned as +-- a result of 'run', and complete stderr output is available after the fact using +-- 'lastStderr' +-- +-- All of the stdout output will be loaded into memory. +-- You can avoid this if you don't need stdout by using 'run_', +-- If you want to avoid the memory and need to process the output then use 'runFoldLines' or 'runHandle' or 'runHandles'. +-- +-- By default shell characters are escaped and +-- the command name is a name of a program that can be found via @PATH@. +-- Shelly will look through the @PATH@ itself to find the command. +-- +-- When 'escaping' is set to @False@, shell characters are allowed. +-- Since there is no longer a guarantee that a single program name is +-- given, Shelly cannot look in the @PATH@ for it. +-- a @PATH@ modified by setenv is not taken into account when finding the exe name. +-- Instead the original Haskell program @PATH@ is used. +-- On a Posix system the @env@ command can be used to make the 'setenv' PATH used when 'escaping' is set to False. @env echo hello@ instead of @echo hello@ +-- +run :: FilePath -> [Text] -> Sh Text +run = runFoldLines T.empty foldText + +foldText :: (Text, Text) -> Text +foldText (t, line) = t <> line <> T.singleton '\n' + + +-- | bind some arguments to run for re-use. Example: +-- +-- > monit = command "monit" ["-c", "monitrc"] +-- > monit ["stop", "program"] +command :: FilePath -> [Text] -> [Text] -> Sh Text +command com args more_args = run com (args ++ more_args) + +-- | bind some arguments to 'run_' for re-use. Example: +-- +-- > monit_ = command_ "monit" ["-c", "monitrc"] +-- > monit_ ["stop", "program"] +command_ :: FilePath -> [Text] -> [Text] -> Sh () +command_ com args more_args = run_ com (args ++ more_args) + +-- | bind some arguments to run for re-use, and require 1 argument. Example: +-- +-- > git = command1 "git" []; git "pull" ["origin", "master"] +command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text +command1 com args one_arg more_args = run com ([one_arg] ++ args ++ more_args) + +-- | bind some arguments to run for re-use, and require 1 argument. Example: +-- +-- > git_ = command1_ "git" []; git "pull" ["origin", "master"] +command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh () +command1_ com args one_arg more_args = run_ com ([one_arg] ++ args ++ more_args) + +-- | the same as 'run', but return @()@ instead of the stdout content +-- stdout will be read and discarded line-by-line +run_ :: FilePath -> [Text] -> Sh () +run_ = runFoldLines () (\(_, _) -> ()) + +liftIO_ :: IO a -> Sh () +liftIO_ action = void (liftIO action) + +-- | Similar to 'run' but gives the raw stdout handle in a callback. +-- If you want even more control, use 'runHandles'. +runHandle :: FilePath -- ^ command + -> [Text] -- ^ arguments + -> (Handle -> Sh a) -- ^ stdout handle + -> Sh a +runHandle exe args withHandle = + runHandles exe args Nothing $ \outH errH -> do + errVar <- liftIO $ do + errVar' <- newEmptyMVar + _ <- forkIO $ printGetContent errH stderr >>= putMVar errVar' + return errVar' + -- liftIO_ $ forkIO $ getContent errH >>= putMVar errVar + -- + res <- withHandle outH + + errs <- liftIO $ takeMVar errVar + + modify $ \state' -> state' { sStderr = errs } + return res + +-- | Similar to 'run' but gives direct access to all input and output handles. +runHandles :: FilePath -- ^ command + -> [Text] -- ^ arguments + -> (Maybe Handle) -- ^ stdin + -> (Handle -> Handle -> Sh a) -- ^ stdout and stderr + -> Sh a +runHandles exe args mStdinHandle withHandles = do + -- clear stdin before beginning command execution + origstate <- get + let mStdin = sStdin origstate + put $ origstate { sStdin = Nothing, sCode = 0, sStderr = T.empty } + state <- get + + let cmdString = show_command exe args + when (sPrintCommands state) $ echo cmdString + trace cmdString + + bracketOnWindowsError + ((sRun state) mStdinHandle state exe args) + (\(_,_,_,procH) -> (liftIO $ terminateProcess procH)) + (\(inH,outH,errH,procH) -> do + liftIO $ case mStdin of + Just input -> + TIO.hPutStr inH input >> hClose inH + -- stdin is cleared from state below + Nothing -> return () + + result <- withHandles outH errH + + (ex, code) <- liftIO $ do + hClose outH + hClose errH + + ex' <- waitForProcess procH + return $ case ex' of + ExitSuccess -> (ex', 0) + ExitFailure n -> (ex', n) + + modify $ \state' -> state' { sCode = code } + + case (sErrExit state, ex) of + (True, ExitFailure n) -> do + newState <- get + liftIO $ throwIO $ RunFailed exe args n (sStderr newState) + _ -> return result + ) + where -- Windows does not terminate spawned processes, so we must bracket. +#if defined(mingw32_HOST_OS) + bracketOnWindowsError acquire release main = do + resource <- acquire + main resource `catchany_sh` (\e -> do + _ <- release resource + liftIO $ throwIO e + ) +#else + bracketOnWindowsError :: Sh a -> (a -> Sh ()) -> (a -> Sh b) -> Sh b + bracketOnWindowsError acquire _ main = acquire >>= main +#endif + + +-- | used by 'run'. fold over stdout line-by-line as it is read to avoid keeping it in memory +-- stderr is still being placed in memory under the assumption it is always relatively small +runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a +runFoldLines start cb exe args = + runHandles exe args Nothing $ \outH errH -> do + (errVar, outVar) <- liftIO $ do + errVar' <- newEmptyMVar + outVar' <- newEmptyMVar + _ <- forkIO $ printGetContent errH stderr >>= putMVar errVar' + return (errVar', outVar') + -- liftIO_ $ forkIO $ getContent errH >>= putMVar errVar + + state <- get + errs <- liftIO $ do + void $ if sPrintStdout state + then + forkIO $ printFoldHandleLines start cb outH stdout >>= putMVar outVar + else + forkIO $ foldHandleLines start cb outH >>= putMVar outVar + takeMVar errVar + + modify $ \state' -> state' { sStderr = errs } + liftIO $ takeMVar outVar + + + +-- | The output of last external command. See 'run'. +lastStderr :: Sh Text +lastStderr = gets sStderr + +-- | The exit code from the last command. +-- Unless you set 'errExit' to False you won't get a chance to use this: a non-zero exit code will throw an exception. +lastExitCode :: Sh Int +lastExitCode = gets sCode + +-- | set the stdin to be used and cleared by the next 'run'. +setStdin :: Text -> Sh () +setStdin input = modify $ \st -> st { sStdin = Just input } + +-- | Pipe operator. set the stdout the first command as the stdin of the second. +-- This does not create a shell-level pipe, but hopefully it will in the future. +-- To create a shell level pipe you can set @escaping False@ and use a pipe @|@ character in a command. +(-|-) :: Sh Text -> Sh b -> Sh b +one -|- two = do + res <- print_stdout False one + setStdin res + two + +-- | Copy a file, or a directory recursively. +-- uses 'cp' +cp_r :: FilePath -> FilePath -> Sh () +cp_r from' to' = do + from <- absPath from' + fromIsDir <- (test_d from) + if not fromIsDir then cp from' to' else do + to <- absPath to' + trace $ "cp -r " <> toTextIgnore from <> " " <> toTextIgnore to + toIsDir <- test_d to + + when (from == to) $ liftIO $ throwIO $ userError $ show $ "cp_r: " <> + toTextIgnore from <> " and " <> toTextIgnore to <> " are identical" + + finalTo <- if not toIsDir then mkdir to >> return to else do + let d = to dirname (addTrailingSlash from) + mkdir_p d >> return d + + ls from >>= mapM_ (\item -> cp_r (from FP. filename item) (finalTo FP. filename item)) + +-- | Copy a file. The second path could be a directory, in which case the +-- original file name is used, in that directory. +cp :: FilePath -> FilePath -> Sh () +cp from' to' = do + from <- absPath from' + to <- absPath to' + trace $ "cp " <> toTextIgnore from <> " " <> toTextIgnore to + to_dir <- test_d to + let to_loc = if to_dir then to FP. filename from else to + liftIO $ copyFile from to_loc `catchany` (\e -> throwIO $ + ReThrownException e (extraMsg to_loc from) + ) + where + extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t + + + +-- | Create a temporary directory and pass it as a parameter to a Sh +-- computation. The directory is nuked afterwards. +withTmpDir :: (FilePath -> Sh a) -> Sh a +withTmpDir act = do + trace "withTmpDir" + dir <- liftIO getTemporaryDirectory + tid <- liftIO myThreadId + (pS, handle) <- liftIO $ openTempFile dir ("tmp"++filter isAlphaNum (show tid)) + let p = pack pS + liftIO $ hClose handle -- required on windows + rm_f p + mkdir p + act p `finally_sh` rm_rf p + +-- | Write a Lazy Text to a file. +writefile :: FilePath -> Text -> Sh () +writefile f' bits = absPath f' >>= \f -> do + trace $ "writefile " <> toTextIgnore f + liftIO (TIO.writeFile (unpack f) bits) + +-- | Update a file, creating (a blank file) if it does not exist. +touchfile :: FilePath -> Sh () +touchfile = absPath >=> flip appendfile "" + +-- | Append a Lazy Text to a file. +appendfile :: FilePath -> Text -> Sh () +appendfile f' bits = absPath f' >>= \f -> do + trace $ "appendfile " <> toTextIgnore f + liftIO (TIO.appendFile (unpack f) bits) + +readfile :: FilePath -> Sh Text +readfile = absPath >=> \fp -> do + trace $ "readfile " <> toTextIgnore fp + readBinary fp >>= + return . TE.decodeUtf8With TE.lenientDecode + +-- | wraps ByteSting readFile +readBinary :: FilePath -> Sh ByteString +readBinary = absPath >=> liftIO . BS.readFile . unpack + +-- | flipped hasExtension for Text +hasExt :: Text -> FilePath -> Bool +hasExt = flip hasExtension + +-- | Run a Sh computation and collect timing information. +time :: Sh a -> Sh (Double, a) +time what = sub $ do + trace "time" + t <- liftIO getCurrentTime + res <- what + t' <- liftIO getCurrentTime + return (realToFrac $ diffUTCTime t' t, res) + +-- | threadDelay wrapper that uses seconds +sleep :: Int -> Sh () +sleep = liftIO . threadDelay . (1000 * 1000 *) diff --git a/src/Shelly/Base.hs b/src/Shelly/Base.hs new file mode 100644 --- /dev/null +++ b/src/Shelly/Base.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | I started exposing multiple module (starting with one for finding) +-- Base prevented circular dependencies +-- However, Shelly went back to exposing a single module +module Shelly.Base + ( + ShIO, Sh, unSh, runSh, State(..), FilePath, Text, + relPath, path, absPath, canonic, canonicalize, + test_d, test_s, + unpack, gets, get, modify, trace, + ls, lsRelAbs, + toTextIgnore, + echo, echo_n, echo_err, echo_n_err, inspect, inspect_err, + catchany, + liftIO, (>=>), + eitherRelativeTo, relativeTo, maybeRelativeTo, + whenM + -- * utilities not yet exported + , addTrailingSlash + ) where + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 +import Prelude hiding (FilePath, catch) +#else +import Prelude hiding (FilePath) +#endif + +import Data.Text (Text) +import System.Process( ProcessHandle ) +import System.IO ( Handle, hFlush, stderr, stdout ) + +import Control.Monad (when, (>=>) ) +import Control.Applicative (Applicative, (<$>)) +import Filesystem (isDirectory, listDirectory) +import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink ) +import Filesystem.Path.CurrentOS (FilePath, encodeString, relative) +import qualified Filesystem.Path.CurrentOS as FP +import qualified Filesystem as FS +import Data.IORef (readIORef, modifyIORef, IORef) +import Data.Monoid (mappend) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Control.Exception (SomeException, catch) +import Data.Maybe (fromMaybe) +import Control.Monad.Trans ( MonadIO, liftIO ) +import Control.Monad.Reader (MonadReader, runReaderT, ask, ReaderT) +import qualified Data.Set as S + +-- | ShIO is Deprecated in favor of 'Sh', which is easier to type. +type ShIO a = Sh a +{- don't need to turn on deprecation. It will cause a lot of warnings while compiling existing code. + - # DEPRECATED ShIO, "Use Sh instead of ShIO" # -} + +newtype Sh a = Sh { + unSh :: ReaderT (IORef State) IO a + } deriving (Applicative, Monad, MonadIO, MonadReader (IORef State), Functor) + +runSh :: Sh a -> IORef State -> IO a +runSh = runReaderT . unSh + +data State = State + { sCode :: Int -- ^ exit code for command that ran + , sStdin :: Maybe Text -- ^ stdin for the command to be run + , sStderr :: Text -- ^ stderr for command that ran + , sDirectory :: FilePath -- ^ working directory + , sPrintStdout :: Bool -- ^ print stdout of command that is executed + , sPrintCommands :: Bool -- ^ print command that is executed + , sRun :: (Maybe Handle) -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) -- ^ command runner, a different runner is used when escaping, probably better to just hold the escaping flag + , sEnvironment :: [(String, String)] + , sPathExecutables :: Maybe [(FilePath, S.Set FilePath)] -- ^ cache of executables in the PATH + , sTracing :: Bool -- ^ should we trace command execution + , sTrace :: Text -- ^ the trace of command execution + , sErrExit :: Bool -- ^ should we exit immediately on any error + } + +-- | A monadic-conditional version of the "when" guard. +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = c >>= \res -> when res a + +-- | Makes a relative path relative to the current Sh working directory. +-- An absolute path is returned as is. +-- To create an absolute path, use 'absPath' +relPath :: FilePath -> Sh FilePath +relPath fp = do + wd <- gets sDirectory + rel <- eitherRelativeTo wd fp + return $ case rel of + Right p -> p + Left p -> p + +eitherRelativeTo :: FilePath -- ^ anchor path, the prefix + -> FilePath -- ^ make this relative to anchor path + -> Sh (Either FilePath FilePath) -- ^ Left is canonic of second path +eitherRelativeTo relativeFP fp = do + let fullFp = relativeFP FP. fp + let relDir = addTrailingSlash relativeFP + stripIt relativeFP fp $ + stripIt relativeFP fullFp $ + stripIt relDir fp $ + stripIt relDir fullFp $ do + relCan <- canonic relDir + fpCan <- canonic fullFp + stripIt relCan fpCan $ return $ Left fpCan + where + stripIt rel toStrip nada = + case FP.stripPrefix rel toStrip of + Just stripped -> + if stripped == toStrip then nada + else return $ Right stripped + Nothing -> nada + +-- | make the second path relative to the first +-- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary +relativeTo :: FilePath -- ^ anchor path, the prefix + -> FilePath -- ^ make this relative to anchor path + -> Sh FilePath +relativeTo relativeFP fp = + fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp + +maybeRelativeTo :: FilePath -- ^ anchor path, the prefix + -> FilePath -- ^ make this relative to anchor path + -> Sh (Maybe FilePath) +maybeRelativeTo relativeFP fp = do + epath <- eitherRelativeTo relativeFP fp + return $ case epath of + Right p -> Just p + Left _ -> Nothing + + +-- | add a trailing slash to ensure the path indicates a directory +addTrailingSlash :: FilePath -> FilePath +addTrailingSlash p = + if FP.null (FP.filename p) then p else + p FP. FP.empty + +-- | makes an absolute path. +-- Like 'canonicalize', but on an exception returns 'absPath' +canonic :: FilePath -> Sh FilePath +canonic fp = do + p <- absPath fp + liftIO $ canonicalizePath p `catchany` \_ -> return p + +-- | Obtain a (reasonably) canonic file path to a filesystem object. Based on +-- "canonicalizePath" in system-fileio. +canonicalize :: FilePath -> Sh FilePath +canonicalize = absPath >=> liftIO . canonicalizePath + +-- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath p = let was_dir = FP.null (FP.filename p) in + if not was_dir then FS.canonicalizePath p + else addTrailingSlash `fmap` FS.canonicalizePath p + +-- | Make a relative path absolute by combining with the working directory. +-- An absolute path is returned as is. +-- To create a relative path, use 'relPath'. +absPath :: FilePath -> Sh FilePath +absPath p | relative p = (FP. p) <$> gets sDirectory + | otherwise = return p + +-- | deprecated +path :: FilePath -> Sh FilePath +path = absPath +{-# DEPRECATED path "use absPath, canonic, or relPath instead" #-} + +-- | Does a path point to an existing directory? +test_d :: FilePath -> Sh Bool +test_d = absPath >=> liftIO . isDirectory + +-- | Does a path point to a symlink? +test_s :: FilePath -> Sh Bool +test_s = absPath >=> liftIO . \f -> do + stat <- getSymbolicLinkStatus (unpack f) + return $ isSymbolicLink stat + +unpack :: FilePath -> String +unpack = encodeString + +gets :: (State -> a) -> Sh a +gets f = f <$> get + +get :: Sh State +get = do + stateVar <- ask + liftIO (readIORef stateVar) + +modify :: (State -> State) -> Sh () +modify f = do + state <- ask + liftIO (modifyIORef state f) + +-- | internally log what occurred. +-- Log will be re-played on failure. +trace :: Text -> Sh () +trace msg = + whenM (gets sTracing) $ modify $ + \st -> st { sTrace = sTrace st `mappend` msg `mappend` "\n" } + +-- | List directory contents. Does *not* include \".\" and \"..\", but it does +-- include (other) hidden files. +ls :: FilePath -> Sh [FilePath] +-- it is important to use path and not absPath so that the listing can remain relative +ls fp = do + trace $ "ls " `mappend` toTextIgnore fp + fmap fst $ lsRelAbs fp + +lsRelAbs :: FilePath -> Sh ([FilePath], [FilePath]) +lsRelAbs f = absPath f >>= \fp -> do + filt <- if not (relative f) then return return + else do + wd <- gets sDirectory + return (relativeTo wd) + absolute <- liftIO $ listDirectory fp + relativized <- mapM filt absolute + return (relativized, absolute) + +-- | silently uses the Right or Left value of "Filesystem.Path.CurrentOS.toText" +toTextIgnore :: FilePath -> Text +toTextIgnore fp = case FP.toText fp of + Left f -> f + Right f -> f + +-- | a print lifted into 'Sh' +inspect :: (Show s) => s -> Sh () +inspect x = do + (trace . T.pack . show) x + liftIO $ print x + +-- | a print lifted into 'Sh' using stderr +inspect_err :: (Show s) => s -> Sh () +inspect_err x = do + let shown = T.pack $ show x + trace shown + echo_err shown + +-- | Echo text to standard (error, when using _err variants) output. The _n +-- variants do not print a final newline. +echo, echo_n, echo_err, echo_n_err :: Text -> Sh () +echo = traceLiftIO TIO.putStrLn +echo_n = traceLiftIO $ (>> hFlush stdout) . TIO.putStr +echo_err = traceLiftIO $ TIO.hPutStrLn stderr +echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr + +traceLiftIO :: (Text -> IO ()) -> Text -> Sh () +traceLiftIO f msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'") >> liftIO (f msg) + +-- | A helper to catch any exception (same as +-- @... `catch` \(e :: SomeException) -> ...@). +catchany :: IO a -> (SomeException -> IO a) -> IO a +catchany = catch + diff --git a/src/Shelly/Find.hs b/src/Shelly/Find.hs new file mode 100644 --- /dev/null +++ b/src/Shelly/Find.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | File finding utiliites for Shelly +-- The basic 'find' takes a dir and gives back a list of files. +-- If you don't just want a list, use the folding variants like 'findFold'. +-- If you want to avoid traversing certain directories, use the directory filtering variants like 'findDirFilter' +module Shelly.Find + ( + find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter + ) where + +import Prelude hiding (FilePath) +import Shelly.Base +import Control.Monad (foldM) +import Data.Monoid (mappend) +import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink ) +import Filesystem (isDirectory) + +-- | List directory recursively (like the POSIX utility "find"). +-- listing is relative if the path given is relative. +-- If you want to filter out some results or fold over them you can do that with the returned files. +-- A more efficient approach is to use one of the other find functions. +find :: FilePath -> Sh [FilePath] +find = findFold (\paths fp -> return $ paths ++ [fp]) [] + +-- | 'find' that filters the found files as it finds. +-- Files must satisfy the given filter to be returned in the result. +findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath] +findWhen = findDirFilterWhen (const $ return True) + +-- | Fold an arbitrary folding function over files froma a 'find'. +-- Like 'findWhen' but use a more general fold rather than a filter. +findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a +findFold folder startValue = findFoldDirFilter folder startValue (const $ return True) + +-- | 'find' that filters out directories as it finds +-- Filtering out directories can make a find much more efficient by avoiding entire trees of files. +findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath] +findDirFilter filt = findDirFilterWhen filt (const $ return True) + +-- | similar 'findWhen', but also filter out directories +-- Alternatively, similar to 'findDirFilter', but also filter out files +-- Filtering out directories makes the find much more efficient +findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter + -> (FilePath -> Sh Bool) -- ^ file filter + -> FilePath -- ^ directory + -> Sh [FilePath] +findDirFilterWhen dirFilt fileFilter = findFoldDirFilter filterIt [] dirFilt + where + filterIt paths fp = do + yes <- fileFilter fp + return $ if yes then paths ++ [fp] else paths + +-- | like 'findDirFilterWhen' but use a folding function rather than a filter +-- The most general finder: you likely want a more specific one +findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a +findFoldDirFilter folder startValue dirFilter dir = do + absDir <- absPath dir + trace ("find " `mappend` toTextIgnore absDir) + filt <- dirFilter absDir + if not filt then return startValue + -- use possible relative path, not absolute so that listing will remain relative + else do + (rPaths, aPaths) <- lsRelAbs dir + foldM traverse startValue (zip rPaths aPaths) + where + traverse acc (relativePath, absolutePath) = do + -- optimization: don't use Shelly API since our path is already good + isDir <- liftIO $ isDirectory absolutePath + sym <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus (unpack absolutePath) + newAcc <- folder acc relativePath + if isDir && not sym + then findFoldDirFilter folder newAcc + dirFilter relativePath + else return newAcc diff --git a/src/Shelly/Pipe.hs b/src/Shelly/Pipe.hs new file mode 100644 --- /dev/null +++ b/src/Shelly/Pipe.hs @@ -0,0 +1,625 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, + TypeFamilies, ExistentialQuantification #-} +-- | This module is a wrapper for the module "Shelly". +-- The only difference is a main type 'Sh'. In this module +-- 'Sh' contains a list of results. Actual definition of the type 'Sh' is: +-- +-- > import qualified Shelly as S +-- > +-- > newtype Sh a = Sh { unSh :: S.Sh [a] } +-- +-- This definition can simplify some filesystem commands. +-- A monad bind operator becomes a pipe operator and we can write +-- +-- > findExt ext = findWhen (pure . hasExt ext) +-- > +-- > main :: IO () +-- > main = shs $ do +-- > mkdir "new" +-- > findExt "hs" "." >>= flip cp "new" +-- > findExt "cpp" "." >>= rm_f +-- > liftIO $ putStrLn "done" +-- +-- Monad methods "return" and ">>=" behave like methods for +-- @ListT Shelly.Sh@, but ">>" forgets the number of +-- the empty effects. So the last line prints @\"done\"@ only once. +-- +-- Documentation in this module mostly just reference documentation from +-- the main "Shelly" module. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE ExtendedDefaultRules #-} +-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- > import Shelly +-- > import Data.Text as T +-- > default (T.Text) +module Shelly.Pipe + ( + -- * Entering Sh. + Sh, shs, shelly,shellyNoDir, shsNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit + -- * List functions + , roll, unroll, liftSh + -- * Running external commands. + , FoldCallback + , run, run_, runFoldLines, cmd + , (-|-), lastStderr, setStdin, lastExitCode + , command, command_, command1, command1_ + , sshPairs, sshPairs_ + + -- * Modifying and querying environment. + , setenv, get_env, get_env_text, get_env_def, appendToPath + + -- * Environment directory + , cd, chdir, pwd + + -- * Printing + , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err + , tag, trace, show_command + + -- * Querying filesystem. + , ls, lsT, test_e, test_f, test_d, test_s, which + + -- * Filename helpers + , absPath, (), (<.>), canonic, canonicalize, relPath, relativeTo + , hasExt + + -- * Manipulating filesystem. + , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree + + -- * reading/writing Files + , readfile, readBinary, writefile, appendfile, touchfile, withTmpDir + + -- * exiting the program + , exit, errorExit, quietExit, terror + + -- * Exceptions + , catchany, catch_sh, finally_sh + , ShellyHandler(..), catches_sh + , catchany_sh + + -- * convert between Text and FilePath + , toTextIgnore, toTextWarn, fromText + + -- * Utilities. + , (<$>), whenM, unlessM, time + + -- * Re-exported for your convenience + , liftIO, when, unless, FilePath + + -- * internal functions for writing extensions + , get, put + + -- * find functions + , find, findWhen, findFold + , findDirFilter, findDirFilterWhen, findFoldDirFilter + ) where + +import Prelude hiding (FilePath) + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Exception hiding (handle) + +import Filesystem.Path(FilePath) + +import qualified Shelly as S + +import Shelly( + (), (<.>), hasExt + , whenM, unlessM, toTextIgnore + , fromText, catchany + , FoldCallback) + +import Data.Maybe(fromMaybe) +import Shelly.Base(State) +import Data.ByteString (ByteString) + +import Data.Tree(Tree) + +import Data.Text as T hiding (concat, all, find, cons) + +default (T.Text) + + +-- | This type is a simple wrapper for a type @Shelly.Sh@. +-- 'Sh' contains a list of results. +newtype Sh a = Sh { unSh :: S.Sh [a] } + +instance Functor Sh where + fmap f = Sh . fmap (fmap f) . unSh + +instance Monad Sh where + return = Sh . return . return + a >>= f = Sh $ fmap concat $ mapM (unSh . f) =<< unSh a + a >> b = Sh $ unSh a >> unSh b + +instance Applicative Sh where + pure = return + (<*>) = ap + +instance MonadPlus Sh where + mzero = Sh $ return [] + mplus a b = Sh $ liftA2 (++) (unSh a) (unSh b) + +instance MonadIO Sh where + liftIO = sh1 liftIO + +------------------------------------------------------- +-- converters + +sh0 :: S.Sh a -> Sh a +sh0 = Sh . fmap return + +sh1 :: (a -> S.Sh b) -> (a -> Sh b) +sh1 f = \a -> sh0 (f a) + +sh2 :: (a1 -> a2 -> S.Sh b) -> (a1 -> a2 -> Sh b) +sh2 f = \a b -> sh0 (f a b) + +sh3 :: (a1 -> a2 -> a3 -> S.Sh b) -> (a1 -> a2 -> a3 -> Sh b) +sh3 f = \a b c -> sh0 (f a b c) + +sh4 :: (a1 -> a2 -> a3 -> a4 -> S.Sh b) -> (a1 -> a2 -> a3 -> a4 -> Sh b) +sh4 f = \a b c d -> sh0 (f a b c d) + +sh0s :: S.Sh [a] -> Sh a +sh0s = Sh + +sh1s :: (a -> S.Sh [b]) -> (a -> Sh b) +sh1s f = \a -> sh0s (f a) + +{- Just in case ... +sh2s :: (a1 -> a2 -> S.Sh [b]) -> (a1 -> a2 -> Sh b) +sh2s f = \a b -> sh0s (f a b) + +sh3s :: (a1 -> a2 -> a3 -> S.Sh [b]) -> (a1 -> a2 -> a3 -> Sh b) +sh3s f = \a b c -> sh0s (f a b c) +-} + +lift1 :: (S.Sh a -> S.Sh b) -> (Sh a -> Sh b) +lift1 f = Sh . (mapM (f . return) =<< ) . unSh + +lift2 :: (S.Sh a -> S.Sh b -> S.Sh c) -> (Sh a -> Sh b -> Sh c) +lift2 f a b = Sh $ join $ liftA2 (mapM2 f') (unSh a) (unSh b) + where f' = \x y -> f (return x) (return y) + +mapM2 :: Monad m => (a -> b -> m c)-> [a] -> [b] -> m [c] +mapM2 f as bs = sequence $ liftA2 f as bs + +----------------------------------------------------------- + +-- | Unpack list of results. +unroll :: Sh a -> Sh [a] +unroll = Sh . fmap return . unSh + +-- | Pack list of results. It performs @concat@ inside 'Sh'. +roll :: Sh [a] -> Sh a +roll = Sh . fmap concat . unSh + +-- | Transform result as list. It can be useful for filtering. +liftSh :: ([a] -> [b]) -> Sh a -> Sh b +liftSh f = Sh . fmap f . unSh + +------------------------------------------------------------------ +-- Entering Sh + +-- | see 'S.shelly' +shelly :: MonadIO m => Sh a -> m [a] +shelly = S.shelly . unSh + +-- | Performs 'shelly' and then an empty action @return ()@. +shs :: MonadIO m => Sh () -> m () +shs a = shelly a >> return () + +-- | see 'S.shellyNoDir' +shellyNoDir :: MonadIO m => Sh a -> m [a] +shellyNoDir = S.shellyNoDir . unSh + +-- | Performs 'shellyNoDir' and then an empty action @return ()@. +shsNoDir :: MonadIO m => Sh () -> m () +shsNoDir a = shellyNoDir a >> return () + +-- | see 'S.sub' +sub :: Sh a -> Sh a +sub = lift1 S.sub + +-- See 'S.siliently' +silently :: Sh a -> Sh a +silently = lift1 S.silently + +-- See 'S.verbosely +verbosely :: Sh a -> Sh a +verbosely = lift1 S.verbosely + +-- | see 'S.escaping' +escaping :: Bool -> Sh a -> Sh a +escaping b = lift1 (S.escaping b) + +-- | see 'S.print_stdout' +print_stdout :: Bool -> Sh a -> Sh a +print_stdout b = lift1 (S.print_stdout b) + +-- | see 'S.print_commands +print_commands :: Bool -> Sh a -> Sh a +print_commands b = lift1 (S.print_commands b) + +-- | see 'S.tracing' +tracing :: Bool -> Sh a -> Sh a +tracing b = lift1 (S.tracing b) + +-- | see 'S.errExit' +errExit :: Bool -> Sh a -> Sh a +errExit b = lift1 (S.errExit b) + + +-- | see 'S.run' +run :: FilePath -> [Text] -> Sh Text +run a b = sh0 $ S.run a b + +-- | see 'S.run_' +run_ :: FilePath -> [Text] -> Sh () +run_ a b = sh0 $ S.run_ a b + +-- | see 'S.runFoldLines' +runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a +runFoldLines a cb fp ts = sh0 $ S.runFoldLines a cb fp ts + +-- | see 'S.-|-' +(-|-) :: Sh Text -> Sh b -> Sh b +(-|-) = lift2 (S.-|-) + +-- | see 'S.lastStderr' +lastStderr :: Sh Text +lastStderr = sh0 S.lastStderr + +-- | see 'S.setStdin' +setStdin :: Text -> Sh () +setStdin = sh1 S.setStdin + +-- | see 'S.lastExitCode' +lastExitCode :: Sh Int +lastExitCode = sh0 S.lastExitCode + +-- | see 'S.command' +command :: FilePath -> [Text] -> [Text] -> Sh Text +command = sh3 S.command + +-- | see 'S.command_' +command_ :: FilePath -> [Text] -> [Text] -> Sh () +command_ = sh3 S.command_ + + +-- | see 'S.command1' +command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text +command1 = sh4 S.command1 + +-- | see 'S.command1_' +command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh () +command1_ = sh4 S.command1_ + +-- | see 'S.sshPairs' +sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text +sshPairs = sh2 S.sshPairs + +-- | see 'S.sshPairs_' +sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh () +sshPairs_ = sh2 S.sshPairs_ + +-- | see 'S.setenv' +setenv :: Text -> Text -> Sh () +setenv = sh2 S.setenv + +-- | see 'S.get_env' +get_env :: Text -> Sh (Maybe Text) +get_env = sh1 S.get_env + +-- | see 'S.get_env_text' +get_env_text :: Text -> Sh Text +get_env_text = sh1 S.get_env_text + +-- | see 'S.get_env_def' +get_env_def :: Text -> Text -> Sh Text +get_env_def a d = sh0 $ fmap (fromMaybe d) $ S.get_env a +{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-} + +-- | see 'S.appendToPath' +appendToPath :: FilePath -> Sh () +appendToPath = sh1 S.appendToPath + +-- | see 'S.cd' +cd :: FilePath -> Sh () +cd = sh1 S.cd + +-- | see 'S.chdir' +chdir :: FilePath -> Sh a -> Sh a +chdir p = lift1 (S.chdir p) + +-- | see 'S.pwd' +pwd :: Sh FilePath +pwd = sh0 S.pwd + +----------------------------------------------------------------- +-- Printing + +-- | Echo text to standard (error, when using _err variants) output. The _n +-- variants do not print a final newline. +echo, echo_n_err, echo_err, echo_n :: Text -> Sh () + +echo = sh1 S.echo +echo_n_err = sh1 S.echo_n_err +echo_err = sh1 S.echo_err +echo_n = sh1 S.echo_n + +-- | see 'S.inspect' +inspect :: Show s => s -> Sh () +inspect = sh1 S.inspect + +-- | see 'S.inspect_err' +inspect_err :: Show s => s -> Sh () +inspect_err = sh1 S.inspect_err + +-- | see 'S.tag' +tag :: Sh a -> Text -> Sh a +tag a t = lift1 (flip S.tag t) a + +-- | see 'S.trace' +trace :: Text -> Sh () +trace = sh1 S.trace + +-- | see 'S.show_command' +show_command :: FilePath -> [Text] -> Text +show_command = S.show_command + +------------------------------------------------------------------ +-- Querying filesystem + +-- | see 'S.ls' +ls :: FilePath -> Sh FilePath +ls = sh1s S.ls + +-- | see 'S.lsT' +lsT :: FilePath -> Sh Text +lsT = sh1s S.lsT + +-- | see 'S.test_e' +test_e :: FilePath -> Sh Bool +test_e = sh1 S.test_e + +-- | see 'S.test_f' +test_f :: FilePath -> Sh Bool +test_f = sh1 S.test_f + +-- | see 'S.test_d' +test_d :: FilePath -> Sh Bool +test_d = sh1 S.test_d + +-- | see 'S.test_s' +test_s :: FilePath -> Sh Bool +test_s = sh1 S.test_s + +-- | see 'S.which +which :: FilePath -> Sh (Maybe FilePath) +which = sh1 S.which + +--------------------------------------------------------------------- +-- Filename helpers + +-- | see 'S.absPath' +absPath :: FilePath -> Sh FilePath +absPath = sh1 S.absPath + +-- | see 'S.canonic' +canonic :: FilePath -> Sh FilePath +canonic = sh1 S.canonic + +-- | see 'S.canonicalize' +canonicalize :: FilePath -> Sh FilePath +canonicalize = sh1 S.canonicalize + +-- | see 'S.relPath' +relPath :: FilePath -> Sh FilePath +relPath = sh1 S.relPath + +-- | see 'S.relativeTo' +relativeTo :: FilePath -- ^ anchor path, the prefix + -> FilePath -- ^ make this relative to anchor path + -> Sh FilePath +relativeTo = sh2 S.relativeTo + +------------------------------------------------------------- +-- Manipulating filesystem + +-- | see 'S.mv' +mv :: FilePath -> FilePath -> Sh () +mv = sh2 S.mv + +-- | see 'S.rm' +rm :: FilePath -> Sh () +rm = sh1 S.rm + +-- | see 'S.rm_f' +rm_f :: FilePath -> Sh () +rm_f = sh1 S.rm_f + +-- | see 'S.rm_rf' +rm_rf :: FilePath -> Sh () +rm_rf = sh1 S.rm_rf + +-- | see 'S.cp' +cp :: FilePath -> FilePath -> Sh () +cp = sh2 S.cp + +-- | see 'S.cp_r' +cp_r :: FilePath -> FilePath -> Sh () +cp_r = sh2 S.cp_r + +-- | see 'S.mkdir' +mkdir :: FilePath -> Sh () +mkdir = sh1 S.mkdir + +-- | see 'S.mkdir_p' +mkdir_p :: FilePath -> Sh () +mkdir_p = sh1 S.mkdir_p + +-- | see 'S.mkdirTree' +mkdirTree :: Tree FilePath -> Sh () +mkdirTree = sh1 S.mkdirTree + +-- | see 'S.readFile' +readfile :: FilePath -> Sh Text +readfile = sh1 S.readfile + +-- | see 'S.readBinary' +readBinary :: FilePath -> Sh ByteString +readBinary = sh1 S.readBinary + +-- | see 'S.writeFile' +writefile :: FilePath -> Text -> Sh () +writefile = sh2 S.writefile + +-- | see 'S.touchFile' +touchfile :: FilePath -> Sh () +touchfile = sh1 S.touchfile + +-- | see 'S.appendFile' +appendfile :: FilePath -> Text -> Sh () +appendfile = sh2 S.appendfile + +-- | see 'S.withTmpDir' +withTmpDir :: (FilePath -> Sh a) -> Sh a +withTmpDir f = Sh $ S.withTmpDir (unSh . f) + +----------------------------------------------------------------- +-- find + +-- | see 'S.find' +find :: FilePath -> Sh FilePath +find = sh1s S.find + +-- | see 'S.findWhen' +findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath +findWhen p a = Sh $ S.findWhen (fmap and . unSh . p) a + +-- | see 'S.findFold' +findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a +findFold cons nil a = Sh $ S.findFold cons' nil' a + where nil' = return nil + cons' as dir = unSh $ roll $ mapM (flip cons dir) as + +-- | see 'S.findDirFilter' +findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh FilePath +findDirFilter p a = Sh $ S.findDirFilter (fmap and . unSh . p) a + +-- | see 'S.findDirFilterWhen' +findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter + -> (FilePath -> Sh Bool) -- ^ file filter + -> FilePath -- ^ directory + -> Sh FilePath +findDirFilterWhen dirPred filePred a = + Sh $ S.findDirFilterWhen + (fmap and . unSh . dirPred) + (fmap and . unSh . filePred) + a + + +-- | see 'S.findFoldDirFilterWhen' +findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a +findFoldDirFilter cons nil p a = Sh $ S.findFoldDirFilter cons' nil' p' a + where p' = fmap and . unSh . p + nil' = return nil + cons' as dir = unSh $ roll $ mapM (flip cons dir) as + +----------------------------------------------------------- +-- exiting the program + +-- | see 'S.exit' +exit :: Int -> Sh () +exit = sh1 S.exit + +-- | see 'S.errorExit' +errorExit :: Text -> Sh () +errorExit = sh1 S.errorExit + +-- | see 'S.quietExit' +quietExit :: Int -> Sh () +quietExit = sh1 S.quietExit + +-- | see 'S.terror' +terror :: Text -> Sh a +terror = sh1 S.terror + +------------------------------------------------------------ +-- Utilities + +-- | see 'S.catch_sh' +catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a +catch_sh a f = Sh $ S.catch_sh (unSh a) (unSh . f) + +-- | see 'S.catchany_sh' +catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a +catchany_sh = catch_sh + + +-- | see 'S.finally_sh' +finally_sh :: Sh a -> Sh b -> Sh a +finally_sh = lift2 S.finally_sh + +-- | see 'S.time' +time :: Sh a -> Sh (Double, a) +time = lift1 S.time + +-- | see 'S.ShellyHandler' +data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a) + +-- | see 'S.catches_sh' +catches_sh :: Sh a -> [ShellyHandler a] -> Sh a +catches_sh a hs = Sh $ S.catches_sh (unSh a) (fmap convert hs) + where convert :: ShellyHandler a -> S.ShellyHandler [a] + convert (ShellyHandler f) = S.ShellyHandler (unSh . f) + +------------------------------------------------------------ +-- convert between Text and FilePath + +-- | see 'S.toTextWarn' +toTextWarn :: FilePath -> Sh Text +toTextWarn = sh1 S.toTextWarn + +------------------------------------------------------------- +-- internal functions for writing extension + +get :: Sh State +get = sh0 S.get + +put :: State -> Sh () +put = sh1 S.put + +-------------------------------------------------------- +-- polyvariadic vodoo + +-- | Converter for the variadic argument version of 'run' called 'cmd'. +class ShellArg a where toTextArg :: a -> Text +instance ShellArg Text where toTextArg = id +instance ShellArg FilePath where toTextArg = toTextIgnore + + +-- Voodoo to create the variadic function 'cmd' +class ShellCommand t where + cmdAll :: FilePath -> [Text] -> t + +instance ShellCommand (Sh Text) where + cmdAll fp args = run fp args + +instance (s ~ Text, Show s) => ShellCommand (Sh s) where + cmdAll fp args = run fp args + +-- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature +instance ShellCommand (Sh ()) where + cmdAll fp args = run_ fp args + +instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where + cmdAll fp acc = \x -> cmdAll fp (acc ++ [toTextArg x]) + +-- | see 'S.cmd' +cmd :: (ShellCommand result) => FilePath -> result +cmd fp = cmdAll fp [] diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-} --- import qualified FindSpec --- main :: IO () --- main = FindSpec.main diff --git a/test/sleep.hs b/test/sleep.hs deleted file mode 100644 --- a/test/sleep.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# Language OverloadedStrings #-} -import Shelly - -main :: IO () -main = - shelly $ do - echo "sleeping" - run "sleep" ["5"] - echo "all done"