shelly 0.15.4.1 → 1.0.0.0
raw patch · 11 files changed
+2125/−2099 lines, 11 filesdep −HUnitdep −hspecdep ~basedep ~containersdep ~directoryPVP ok
version bump matches the API change (PVP)
Dependencies removed: HUnit, hspec
Dependency ranges changed: base, containers, directory, mtl, process, time
API changes (from Hackage documentation)
+ Shelly: runHandle :: FilePath -> [Text] -> (Handle -> Sh a) -> Sh a
+ Shelly: runHandles :: FilePath -> [Text] -> (Maybe Handle) -> (Handle -> Handle -> Sh a) -> Sh a
Files
- Shelly.hs +0/−988
- Shelly/Base.hs +0/−246
- Shelly/Find.hs +0/−74
- Shelly/Pipe.hs +0/−741
- shelly.cabal +24/−37
- src/Shelly.hs +1149/−0
- src/Shelly/Base.hs +253/−0
- src/Shelly/Find.hs +74/−0
- src/Shelly/Pipe.hs +625/−0
- test/main.hs +0/−4
- test/sleep.hs +0/−9
− Shelly.hs
@@ -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 = d</>shelly_dir</>sf- (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 *)
− Shelly/Base.hs
@@ -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-
− Shelly/Find.hs
@@ -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
− Shelly/Pipe.hs
@@ -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 []-
shelly.cabal view
@@ -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
+ src/Shelly.hs view
@@ -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 = d</>shelly_dir</>sf+ (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 *)
+ src/Shelly/Base.hs view
@@ -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+
+ src/Shelly/Find.hs view
@@ -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
+ src/Shelly/Pipe.hs view
@@ -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 []
− test/main.hs
@@ -1,4 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}--- import qualified FindSpec--- main :: IO ()--- main = FindSpec.main
− test/sleep.hs
@@ -1,9 +0,0 @@-{-# Language OverloadedStrings #-}-import Shelly--main :: IO ()-main =- shelly $ do- echo "sleeping"- run "sleep" ["5"]- echo "all done"