shelly 0.9.7.3 → 0.10
raw patch · 3 files changed
+117/−115 lines, 3 filesdep +HUnitdep +hspecdep +hspec-discoverdep −SafeSemaphore
Dependencies added: HUnit, hspec, hspec-discover
Dependencies removed: SafeSemaphore
Files
- Shelly.hs +110/−74
- shelly.cabal +6/−3
- test/main.hs +1/−38
Shelly.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies, IncoherentInstances, GADTs #-}-{-# LANGUAGE CPP #-} -- | 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.@@ -40,27 +40,26 @@ , cd, chdir, pwd -- * Printing- , echo, echo_n, echo_err, echo_n_err, inspect+ , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err , tag, trace, show_command -- * Querying filesystem.- , ls, ls', test_e, test_f, test_d, test_s, which, find+ , ls, ls', test_e, test_f, test_d, test_s, which,+ -- * Finding files+ find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter -- * Filename helpers- , path, absPath, (</>), (<.>)+ , path, absPath, (</>), (<.>), relativeTo, canonic -- * Manipulating filesystem. , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p , readfile, writefile, appendfile, withTmpDir - -- * Running external commands asynchronously.- , jobs, background, getBgResult, BgResult- -- * exiting the program , exit, errorExit, terror -- * Utilities.- , (<$>), (<$$>), grep, whenM, unlessM, canonic+ , (<$>), (<$$>), grep, whenM, unlessM , catchany, catch_sh, ShellyHandler(..), catches_sh, catchany_sh , Timing(..), time , RunFailed(..)@@ -70,6 +69,9 @@ -- * Re-exported for your convenience , liftIO, when, unless, FilePath++ -- * internal functions for writing extension+ , get, put ) where -- TODO:@@ -107,7 +109,6 @@ import Control.Exception hiding (handle) import Control.Monad.Reader import Control.Concurrent-import qualified Control.Concurrent.MSem as Sem import Data.Time.Clock( getCurrentTime, diffUTCTime ) import qualified Data.Text.Lazy.IO as TIO@@ -121,7 +122,8 @@ import Data.Monoid (mappend) import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))-import Filesystem+import Filesystem hiding (canonicalizePath)+import qualified Filesystem import qualified Filesystem.Path.CurrentOS as FP import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )@@ -390,12 +392,15 @@ cd d return r --- | makes an absolute path. Same as canonic.--- TODO: use normalise from system-filepath+-- | makes an absolute path.+-- Like 'canonic', but on an exception returns 'absPath' path :: FilePath -> ShIO FilePath-path = canonic+path fp = do+ absFP <- absPath fp+ liftIO $ canonicalizePath absFP `catchany` \_ -> return absFP --- | makes an absolute path. @path@ will also normalize+-- | makes an absolute path based on the working directory.+-- @path@ will also canonicalize absPath :: FilePath -> ShIO FilePath absPath p | relative p = (FP.</> p) <$> gets sDirectory | otherwise = return p@@ -426,27 +431,97 @@ -- | Get back [Text] instead of [FilePath] ls' :: FilePath -> ShIO [Text]-ls' fp = do- trace $ "ls " `mappend` toTextIgnore fp- efiles <- ls fp- mapM toTextWarn efiles+ls' fp = ls fp >>= mapM toTextWarn -- | List directory contents. Does *not* include \".\" and \"..\", but it does -- include (other) hidden files. ls :: FilePath -> ShIO [FilePath]-ls = path >=> \fp -> (liftIO $ listDirectory fp) `tag` ("ls " `mappend` toTextIgnore fp) +ls fp = (liftIO $ listDirectory fp) `tag` ("ls " `mappend` toTextIgnore fp) +-- | 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+ -> ShIO FilePath+relativeTo relativeFP fp = do+ stripIt relativeFP fp $ do+ isDir <- test_d relativeFP+ let relDir = if not isDir then relativeFP else addTrailingSlash relativeFP+ relAbs <- path relDir+ absFP <- path fp+ stripIt relAbs absFP $ return fp+ where+ stripIt rel toStrip nada = do+ case stripPrefix rel toStrip of+ Just stripped ->+ if stripped == toStrip then nada+ else return stripped+ Nothing -> nada++addTrailingSlash :: FilePath -> FilePath+addTrailingSlash p =+ if FP.null (filename p) then p else+ p FP.</> FP.empty++-- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash+canonicalizePath :: FilePath -> IO FilePath+canonicalizePath p = let was_dir = FP.null (filename p) in+ if not was_dir then Filesystem.canonicalizePath p+ else addTrailingSlash `fmap` Filesystem.canonicalizePath p++ -- | 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 -> ShIO [FilePath]-find dir = do trace ("find " `mappend` toTextIgnore dir)- bits <- ls dir- subDir <- forM bits $ \x -> do- ex <- test_d $ dir FP.</> x- sym <- test_s $ dir FP.</> x- if ex && not sym then find (dir FP.</> x)- else return []- return $ map (dir FP.</>) bits ++ concat subDir+find dir = findFold dir [] (\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 -> (FilePath -> ShIO Bool) -> ShIO [FilePath]+findWhen dir filt = findDirFilterWhen dir (const $ return True) filt++-- | Fold an arbitrary folding function over files froma a 'find'.+-- Like 'findWhen' but use a more general fold rather than a filter.+findFold :: FilePath -> a -> (a -> FilePath -> ShIO a) -> ShIO a+findFold fp = findFoldDirFilter fp (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 -> (FilePath -> ShIO Bool) -> ShIO [FilePath]+findDirFilter dir filt = findDirFilterWhen dir 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 -- ^ directory+ -> (FilePath -> ShIO Bool) -- ^ directory filter+ -> (FilePath -> ShIO Bool) -- ^ file filter+ -> ShIO [FilePath]+findDirFilterWhen dir dirFilt fileFilter = findFoldDirFilter dir dirFilt [] filterIt+ 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 :: FilePath -> (FilePath -> ShIO Bool) -> a -> (a -> FilePath -> ShIO a) -> ShIO a+findFoldDirFilter dir dirFilter startValue folder = do+ trace ("findFold " `mappend` toTextIgnore dir)+ filt <- dirFilter dir+ if filt+ then ls dir >>= foldM traverse startValue+ else return startValue+ where+ traverse acc x = do+ isDir <- test_d x+ sym <- test_s x+ if isDir && not sym+ then findFold x acc folder+ else folder acc x+ -- | Obtain the current (ShIO) working directory. pwd :: ShIO FilePath pwd = gets sDirectory `tag` "pwd"@@ -479,6 +554,13 @@ (trace . LT.pack . show) x liftIO $ print x +-- | a print lifted into ShIO using stderr+inspect_err :: (Show s) => s -> ShIO ()+inspect_err x = do+ let shown = LT.pack $ show x+ trace shown+ echo_err shown+ -- | Create a new directory (fails if the directory exists). mkdir :: FilePath -> ShIO () mkdir = absPath >=> \fp -> do@@ -539,6 +621,7 @@ -- | 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 -> ShIO () rm_rf f = absPath f >>= \f' -> do trace $ "rm -rf " `mappend` toTextIgnore f@@ -609,53 +692,6 @@ -- | Turn on/off printing stdout print_stdout :: Bool -> ShIO a -> ShIO a print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a---- | Create a 'BgJobManager' that has a 'limit' on the max number of background tasks.--- an invocation of jobs is independent of any others, and not tied to the ShIO monad in any way.--- This blocks the execution of the program until all 'background' jobs are finished.-jobs :: Int -> (BgJobManager -> ShIO a) -> ShIO a-jobs limit action = do- unless (limit > 0) $ terror "expected limit to be > 0"- availableJobsSem <- liftIO $ Sem.new limit- res <- action $ BgJobManager availableJobsSem- liftIO $ waitForJobs availableJobsSem- return res- where- waitForJobs sem = do- avail <- Sem.peekAvail sem- if avail == limit then return () else waitForJobs sem---- | The manager tracks the number of jobs. Register your 'background' jobs with it.-newtype BgJobManager = BgJobManager (Sem.MSem Int)---- | Type returned by tasks run asynchronously in the background.-newtype BgResult a = BgResult (MVar a)---- | Returns the promised result from a backgrounded task. Blocks until--- the task completes.-getBgResult :: BgResult a -> ShIO a-getBgResult (BgResult mvar) = liftIO $ takeMVar mvar---- | Run the `ShIO` task asynchronously in the background, returns--- the `BgResult a`, a promise immediately. Run "getBgResult" to wait for the result.--- The background task will inherit the current ShIO context--- The 'BjJobManager' ensures the max jobs limit must be sufficient for the parent and all children.-background :: BgJobManager -> ShIO a -> ShIO (BgResult a)-background (BgJobManager manager) proc = do- state <- get- liftIO $ do- -- take up a spot- -- It is important to do this before forkIO:- -- It ensures that that jobs will block and the program won't exit before our jobs are done- -- On the other hand, a user might not expect 'jobs' to block- Sem.wait manager- mvar <- newEmptyMVar -- future result-- _<- forkIO $ do- result <- shelly $ (put state >> proc)- Sem.signal manager -- open a spot back up- liftIO $ putMVar mvar result- return $ BgResult mvar -- | Turn on/off command echoing.
shelly.cabal view
@@ -1,6 +1,6 @@ Name: shelly -Version: 0.9.7.3+Version: 0.10 Synopsis: shell-like (systems) programming in Haskell Description: Shelly provides a single module for convenient@@ -17,6 +17,8 @@ * is modern. It uses Text and system-filepath/system-fileio . Shelly is originally forked from the Shellish package.+ .+ See the shelly-extra package for additional functionality. Homepage: https://github.com/yesodweb/Shelly.hs@@ -34,7 +36,6 @@ Build-depends: base >= 4 && < 5, time, directory, text, mtl , process >= 1.0- , SafeSemaphore , unix-compat < 0.4 , system-filepath < 0.5 , system-fileio < 0.4@@ -48,10 +49,12 @@ ghc-options: -Wall Build-depends: base >= 4 && < 5, time, directory, text, mtl, process- , SafeSemaphore , unix-compat < 0.4 , system-filepath < 0.5 , system-fileio < 0.4+ , hspec-discover+ , hspec >= 1.1+ , HUnit -- demonstarated that command output in Shellish was not shown until after the command finished -- not necessary anymore
test/main.hs view
@@ -1,38 +1,1 @@-{-# Language OverloadedStrings #-}-{-# Language ExtendedDefaultRules #-}-{-# Language ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}--import Shelly-import Data.Text.Lazy as LT-default (LT.Text)--main :: IO ()-main =- shelly $- -- verbosely $- do- jobs 2 $ \job -> do- _<- background job $ cmd "sleep" "2"- echo "immediate"- _<- background job $ cmd "sleep" "2"- echo "immediate2"- _<- background job $ cmd "sleep" "2"- echo "blocked by background "- - echo "blocked by jobs"-- setStdin "in"- setStdin "override stdin"- run_ "cat" ["-"]-- recho <- cmd "echo" "cmd"- _<-cmd "echo" "bar" "baz"- echo recho-- (res :: Text) <- cmd "pwd"- liftIO $ putStrLn $ show res- inspect res-- inspect =<< (cmd "echo" "compose" :: ShIO Text)- inspect =<< (cmd "pwd")+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}