shelly 0.10.0.1 → 0.11
raw patch · 5 files changed
+365/−290 lines, 5 files
Files
- Shelly.hs +72/−284
- Shelly/Base.hs +212/−0
- Shelly/Find.hs +71/−0
- shelly.cabal +6/−6
- test/main.hs +4/−0
Shelly.hs view
@@ -44,12 +44,10 @@ , tag, trace, show_command -- * Querying filesystem.- , ls, ls', test_e, test_f, test_d, test_s, which,- -- * Finding files- find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter+ , ls, lsT, test_e, test_f, test_d, test_s, which -- * Filename helpers- , path, absPath, (</>), (<.>), relativeTo, canonic+ , path, (</>), (<.>), canonic, canonicalize, absPath, relativeTo -- * Manipulating filesystem. , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p@@ -60,7 +58,7 @@ -- * Utilities. , (<$>), (<$$>), grep, whenM, unlessM- , catchany, catch_sh, ShellyHandler(..), catches_sh, catchany_sh+ , catchany, catch_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh , Timing(..), time , RunFailed(..) @@ -74,28 +72,11 @@ , get, put ) where --- TODO:--- shebang runner that puts wrappers in and invokes--- perhaps also adds monadloc--- convenience for commands that use record arguments-{-- let oFiles = ("a.o", "b.o")- let ldOutput x = ("-o", x)-- let def = LD { output = error "", verbose = False, inputs = [] }- data LD = LD { output :: FilePath, verbose :: Bool, inputs :: [FilePath] } deriving(Data, Typeable)- instance Runnable LD where- run :: LD -> IO ()-- class Runnable a where- run :: a -> ShIO Text-- let ld = def :: LD- run (ld "foo") { oFiles = [] }- run ld { oFiles = [] }- ld = ..magic..--}-+import Shelly.Base+import Shelly.Find (find)+import Control.Monad ( when, unless )+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Reader (runReaderT, ask) import Prelude hiding ( catch, readFile, FilePath ) import Data.List( isInfixOf ) import Data.Char( isAlphaNum, isSpace )@@ -107,26 +88,23 @@ import System.Environment import Control.Applicative import Control.Exception hiding (handle)-import Control.Monad.Reader import Control.Concurrent import Data.Time.Clock( getCurrentTime, diffUTCTime ) import qualified Data.Text.Lazy.IO as TIO import qualified Data.Text.IO as STIO import System.Process( CmdSpec(..), StdStream(CreatePipe), CreateProcess(..), createProcess, waitForProcess, ProcessHandle )+import System.IO.Error (isPermissionError) import qualified Data.Text.Lazy as LT-import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.Builder as B import qualified Data.Text as T import Data.Monoid (mappend) import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>)) import Filesystem hiding (canonicalizePath)-import qualified Filesystem import qualified Filesystem.Path.CurrentOS as FP -import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink ) import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, findExecutable ) {- GHC won't default to Text with this, even with extensions!@@ -171,13 +149,6 @@ -- note that ShIO () actually doesn't work for its case (_<- cmd) when there is no type signature instance ShellCommand (ShIO ()) where cmdAll fp args = run_ fp args-{-- >> liftIO (throwIO CmdError)-data CmdError = CmdError deriving Typeable-instance Show CmdError where- show (CmdError) = "Sorry! You are running up against some of the magic from using the variadic argument function 'cmd'. Please report this issue so we can fix it."-instance Exception CmdError--} instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where cmdAll fp acc = \x -> cmdAll fp (acc ++ [toTextArg x])@@ -217,11 +188,6 @@ x <.> y = toFilePath x FP.<.> LT.toStrict y --- | silently uses the Right or Left value of "Filesystem.Path.CurrentOS.toText"-toTextIgnore :: FilePath -> Text-toTextIgnore fp = LT.fromStrict $ case toText fp of- Left f -> f- Right f -> f toTextWarn :: FilePath -> ShIO Text toTextWarn efile = fmap lazy $ case toText efile of@@ -259,50 +225,17 @@ go $ foldLine (acc, line) `catchany` \_ -> return acc -data State = State { sCode :: Int- , sStdin :: Maybe Text -- ^ stdin for the command to be run- , sStderr :: Text- , sDirectory :: FilePath- , sPrintStdout :: Bool -- ^ print stdout of command that is executed- , sPrintCommands :: Bool -- ^ print command that is executed- , sRun :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)- , sEnvironment :: [(String, String)]- , sTrace :: B.Builder- }- -- | same as 'trace', but use it combinator style tag :: ShIO a -> Text -> ShIO a tag action msg = do trace msg- result <- action- return result----- | log actions that occur-trace :: Text -> ShIO ()-trace msg = modify $ \st -> st { sTrace = sTrace st `mappend` B.fromLazyText msg `mappend` "\n" }--type ShIO a = ReaderT (IORef State) IO a--get :: ShIO State-get = do- stateVar <- ask - liftIO (readIORef stateVar)+ action put :: State -> ShIO () put newState = do stateVar <- ask liftIO (writeIORef stateVar newState) -modify :: (State -> State) -> ShIO ()-modify f = do- state <- ask - liftIO (modifyIORef state f)---gets :: (State -> a) -> ShIO a-gets f = f <$> get- -- FIXME: find the full path to the exe from PATH runCommand :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle) runCommand exe args = do@@ -342,18 +275,19 @@ run_sudo cmd args = Sudo $ run "/usr/bin/sudo" (cmd:args) -} --- | A helper to catch any exception (same as--- @... `catch` \(e :: SomeException) -> ...@).-catchany :: IO a -> (SomeException -> IO a) -> IO a-catchany = catch- -- | Catch an exception in the ShIO monad. catch_sh :: (Exception e) => ShIO a -> (e -> ShIO a) -> ShIO a catch_sh action handle = do ref <- ask liftIO $ catch (runReaderT action ref) (\e -> runReaderT (handle e) ref) +-- | Catch an exception in the ShIO monad.+finally_sh :: ShIO a -> ShIO b -> ShIO a+finally_sh action handle = do+ ref <- ask+ liftIO $ finally (runReaderT action ref) (runReaderT handle ref) + -- | You need this when using 'catches_sh'. data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> ShIO a) @@ -373,38 +307,22 @@ -- | Change current working directory of ShIO. This does *not* change the -- working directory of the process we are running it. Instead, ShIO keeps--- track of its own workking directory and builds absolute paths internally+-- 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 -> ShIO ()-cd dir = do dir' <- absPath dir- trace $ "cd " `mappend` toTextIgnore dir'- modify $ \st -> st { sDirectory = dir' }+cd = absPath >=> \dir -> do+ trace $ "cd " `mappend` toTextIgnore dir+ modify $ \st -> st { sDirectory = dir } -- | "cd", execute a ShIO action in the new directory and then pop back to the original directory chdir :: FilePath -> ShIO a -> ShIO a chdir dir action = do- d <- pwd+ d <- gets sDirectory cd dir- r <- action `catchany_sh` (\e ->- cd d >> liftIO (throwIO e)- )- cd d- return r---- | makes an absolute path.--- Like 'canonic', but on an exception returns 'absPath'-path :: FilePath -> ShIO FilePath-path fp = do- absFP <- absPath fp- liftIO $ canonicalizePath absFP `catchany` \_ -> return absFP+ action `finally_sh` cd d --- | 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 -- | apply a String IO operations to a Text FilePath {-@@ -416,9 +334,6 @@ asString f = pack . f . unpack -} -unpack :: FilePath -> String-unpack = encodeString- pack :: String -> FilePath pack = decodeString @@ -431,113 +346,13 @@ liftIO $ rename a' b' -- | Get back [Text] instead of [FilePath]-ls' :: FilePath -> ShIO [Text]-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 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 = 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+lsT :: FilePath -> ShIO [Text]+lsT = ls >=> mapM toTextWarn -- | Obtain the current (ShIO) working directory. pwd :: ShIO FilePath pwd = gets sDirectory `tag` "pwd" --- | 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 -> ShIO ()-echo = traceLiftIO TIO.putStrLn-echo_n = traceLiftIO $ (>> hFlush System.IO.stdout) . TIO.putStr-echo_err = traceLiftIO $ TIO.hPutStrLn stderr-echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr--traceLiftIO :: (Text -> IO ()) -> Text -> ShIO ()-traceLiftIO f msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'") >> liftIO (f msg)- exit :: Int -> ShIO () exit 0 = liftIO (exitWith ExitSuccess) `tag` "exit 0" exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " `mappend` LT.pack (show n))@@ -549,24 +364,11 @@ terror :: Text -> ShIO a terror = fail . LT.unpack --- | a print lifted into ShIO-inspect :: (Show s) => s -> ShIO ()-inspect x = do- (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 trace $ "mkdir " `mappend` toTextIgnore fp- liftIO $ createDirectory False fp `catchany` (\e -> throwIO e >> return ())+ liftIO $ createDirectory False fp -- | Create a new directory, including parents (succeeds if the directory -- already exists).@@ -584,11 +386,6 @@ (trace . mappend "which " . toTextIgnore) fp (liftIO . findExecutable . unpack >=> return . fmap pack) fp --- | Obtain a (reasonably) canonic file path to a filesystem object. Based on--- "canonicalizePath" in FileSystem.-canonic :: FilePath -> ShIO FilePath-canonic = absPath >=> liftIO . canonicalizePath- -- | A monadic-conditional version of the "when" guard. whenM :: Monad m => m Bool -> m () -> m () whenM c a = c >>= \res -> when res a@@ -599,55 +396,48 @@ -- | Does a path point to an existing filesystem object? test_e :: FilePath -> ShIO Bool-test_e f = do- fs <- absPath f+test_e = absPath >=> \f -> do liftIO $ do- file <- isFile fs- if file then return True else isDirectory fs+ file <- isFile f+ if file then return True else isDirectory f -- | Does a path point to an existing file? test_f :: FilePath -> ShIO Bool test_f = absPath >=> liftIO . isFile --- | Does a path point to an existing directory?-test_d :: FilePath -> ShIO Bool-test_d = absPath >=> liftIO . isDirectory---- | Does a path point to a symlink?-test_s :: FilePath -> ShIO Bool-test_s = absPath >=> liftIO . \f -> do- stat <- getSymbolicLinkStatus (unpack f)- return $ isSymbolicLink stat- -- | 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+rm_rf = absPath >=> \f -> do trace $ "rm -rf " `mappend` toTextIgnore f- whenM (test_d f) $ do- _<- find f' >>= mapM (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ())- liftIO_ $ removeTree f'- whenM (test_f f) $ rm_f 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 already is not there.+-- | Remove a file. Does not fail if the file does not exist. -- Does fail if the file is not a file. rm_f :: FilePath -> ShIO ()-rm_f f = do+rm_f = absPath >=> \f -> do trace $ "rm -f " `mappend` toTextIgnore f- whenM (test_e f) $ absPath f >>= liftIO . removeFile+ 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 -> ShIO ()-rm f = do+rm = absPath >=> \f -> do trace $ "rm" `mappend` toTextIgnore f- absPath f >>= liftIO . removeFile+ canonic f >>= liftIO . removeFile -- | Set an environment variable. The environment is maintained in ShIO -- internally, and is passed to any external commands to be executed.@@ -660,7 +450,7 @@ -- | 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 -> ShIO ()-appendToPath filepath = do+appendToPath = absPath >=> \filepath -> do tp <- toTextWarn filepath pe <- getenv path_env setenv path_env $ pe `mappend` ":" `mappend` tp@@ -706,11 +496,7 @@ sub a = do oldState <- get modify $ \st -> st { sTrace = B.fromText "" }- r <- a `catchany_sh` (\e -> do- restoreState oldState- liftIO $ throwIO e)- restoreState oldState- return r+ a `finally_sh` (restoreState oldState) where restoreState oldState = do newState <- get@@ -925,27 +711,32 @@ -- | Copy a file, or a directory recursively. cp_r :: FilePath -> FilePath -> ShIO ()-cp_r from to = do- trace $ "cp -r " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to- from_d <- (test_d from)- if not from_d then cp from to else do- let fromName = filename from- let toDir = if filename to == fromName then to else to FP.</> fromName- unlessM (test_d toDir) $ mkdir toDir- ls from >>= mapM_- (\item -> cp_r (from FP.</> filename item) (toDir FP.</> filename item))+cp_r from' to' = do+ fromDir <- absPath from'+ from_d <- (test_d fromDir)+ if not from_d then cp from' to' else do+ to <- absPath to'+ trace $ "cp -r " `mappend` toTextIgnore fromDir `mappend` " " `mappend` toTextIgnore to+ toIsDir <- test_d to+ toDir <- if toIsDir+ then return $ fromDir </> to+ else mkdir to >> return to+ when (fromDir == toDir) $ liftIO $ throwIO $ userError $ LT.unpack $ "cp_r: " `mappend`+ toTextIgnore fromDir `mappend` " and " `mappend` toTextIgnore toDir `mappend` " are identical" + ls fromDir >>= mapM_ (\item -> cp_r (fromDir FP.</> filename item) (toDir 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 -> ShIO ()-cp from to = do- from' <- absPath from- to' <- absPath to- trace $ "cp " `mappend` toTextIgnore from' `mappend` " " `mappend` toTextIgnore to'+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')+ 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@@ -984,22 +775,19 @@ liftIO $ hClose handle -- required on windows rm_f p mkdir p- a <- act p `catchany_sh` \e -> do- rm_rf p >> liftIO (throwIO e)- rm_rf p- return a+ act p `finally_sh` (rm_rf p) -- | Write a Lazy Text to a file. writefile :: FilePath -> Text -> ShIO ()-writefile f bits = absPath f >>= \f' -> do- trace $ "writefile " `mappend` toTextIgnore f'- liftIO (TIO.writeFile (unpack f') bits)+writefile f' bits = absPath f' >>= \f -> do+ trace $ "writefile " `mappend` toTextIgnore f+ liftIO (TIO.writeFile (unpack f) bits) -- | Append a Lazy Text to a file. appendfile :: FilePath -> Text -> ShIO ()-appendfile f bits = absPath f >>= \f' -> do- trace $ "appendfile " `mappend` toTextIgnore f'- liftIO (TIO.appendFile (unpack f') bits)+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.
+ Shelly/Base.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}+-- | prevent circular dependencies+-- needed by multiple exposed modules+module Shelly.Base+ (+ ShIO, State(..), FilePath, Text,+ path, absPath, canonic, canonicalize,+ test_d, test_s,+ unpack, gets, get, modify, trace,+ ls,+ toTextIgnore,+ echo, echo_n, echo_err, echo_n_err, inspect, inspect_err,+ catchany,+ liftIO, (>=>),+ eitherRelativeTo, relativeTo, maybeRelativeTo+ ) where++import Prelude hiding ( FilePath, catch )+import Data.Text.Lazy (Text)+import Filesystem.Path.CurrentOS (FilePath)+import System.Process( ProcessHandle )+import System.IO ( Handle, hFlush, stderr, stdout )++import Control.Monad.Trans ( liftIO )+import Control.Monad ( (>=>) ) +import Filesystem (isDirectory, listDirectory)+import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )+import Filesystem.Path.CurrentOS (encodeString, relative)+import qualified Filesystem.Path.CurrentOS as FP+import qualified Filesystem as FS+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask, ReaderT)+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)++type ShIO a = ReaderT (IORef State) IO a++data State = State { sCode :: Int+ , sStdin :: Maybe Text -- ^ stdin for the command to be run+ , sStderr :: Text+ , sDirectory :: FilePath+ , sPrintStdout :: Bool -- ^ print stdout of command that is executed+ , sPrintCommands :: Bool -- ^ print command that is executed+ , sRun :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)+ , sEnvironment :: [(String, String)]+ , sTrace :: B.Builder+ }++-- | Makes a relative path relative to the current ShIO working directory.+-- An absolute path is returned as is.+-- To create an absolute path, use 'absPath'+path :: FilePath -> ShIO FilePath+path 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+ -> ShIO (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 $ do+ stripIt relativeFP fullFp $ do+ stripIt relDir fp $ do+ stripIt relDir fullFp $ do+ relCan <- canonic relDir+ fpCan <- canonic fullFp+ stripIt relCan fpCan $ return $ Left fpCan+ where+ stripIt rel toStrip nada = do+ 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+ -> ShIO FilePath+relativeTo relativeFP fp =+ fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp++maybeRelativeTo :: FilePath -- ^ anchor path, the prefix+ -> FilePath -- ^ make this relative to anchor path+ -> ShIO (Maybe FilePath)+maybeRelativeTo relativeFP fp = do+ epath <- eitherRelativeTo relativeFP fp+ return $ case epath of+ Right p -> Just p+ Left _ -> Nothing+++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 'path'+canonic :: FilePath -> ShIO 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 -> ShIO 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 'path'.+absPath :: FilePath -> ShIO FilePath+absPath p | relative p = (FP.</> p) <$> gets sDirectory+ | otherwise = return p++-- | Does a path point to an existing directory?+test_d :: FilePath -> ShIO Bool+test_d = absPath >=> liftIO . isDirectory++-- | Does a path point to a symlink?+test_s :: FilePath -> ShIO Bool+test_s = absPath >=> liftIO . \f -> do+ stat <- getSymbolicLinkStatus (unpack f)+ return $ isSymbolicLink stat++unpack :: FilePath -> String+unpack = encodeString++gets :: (State -> a) -> ShIO a+gets f = f <$> get++get :: ShIO State+get = do+ stateVar <- ask + liftIO (readIORef stateVar)++modify :: (State -> State) -> ShIO ()+modify f = do+ state <- ask + liftIO (modifyIORef state f)++-- | internally log what occured.+-- Log will be re-played on failure.+trace :: Text -> ShIO ()+trace msg = 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 -> ShIO [FilePath]+-- it is important to use path and not absPath so that the listing can remain relative+ls f = absPath f >>= \fp -> do+ trace $ "ls " `mappend` toTextIgnore fp+ filt <- if not (relative f) then return (return)+ else do+ wd <- gets sDirectory+ return (relativeTo wd)+ contents <- liftIO $ listDirectory fp+ mapM filt contents++-- | 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 ShIO+inspect :: (Show s) => s -> ShIO ()+inspect x = do+ (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++-- | 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 -> ShIO ()+echo = traceLiftIO TIO.putStrLn+echo_n = traceLiftIO $ (>> hFlush System.IO.stdout) . TIO.putStr+echo_err = traceLiftIO $ TIO.hPutStrLn stderr+echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr++traceLiftIO :: (Text -> IO ()) -> Text -> ShIO ()+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 view
@@ -0,0 +1,71 @@+{-# 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 -> ShIO [FilePath]+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+ absDir <- absPath dir+ trace ("find " `mappend` toTextIgnore absDir)+ filt <- dirFilter absDir+ if filt+ -- use possible relative path, not absolute so that listing will remain relative+ then ls dir >>= foldM traverse startValue+ else return startValue+ where+ traverse acc x = do+ -- optimization: don't use Shelly API since our path is already good+ isDir <- liftIO $ isDirectory x+ sym <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus (unpack x)+ if isDir && not sym+ then findFold x acc folder+ else folder acc x
shelly.cabal view
@@ -1,11 +1,10 @@ Name: shelly -Version: 0.10.0.1+Version: 0.11 Synopsis: shell-like (systems) programming in Haskell -Description: Shelly provides a single module for convenient- systems programming in Haskell, similar in spirit to POSIX- shells. Shelly:+Description: Shelly provides convenient systems programming in Haskell,+ similar in spirit to POSIX shells. Shelly: . * is aimed at convenience and getting things done rather than being a demonstration of elegance.@@ -14,7 +13,7 @@ . * maintains its own environment, making it thread-safe. .- * is modern. It uses Text and system-filepath/system-fileio+ * is modern, using Text and system-filepath/system-fileio . Shelly is originally forked from the Shellish package. .@@ -32,7 +31,8 @@ Library- Exposed-modules: Shelly+ Exposed-modules: Shelly, Shelly.Find+ other-modules: Shelly.Base Build-depends: base >= 4 && < 5, time, directory, text, mtl , process >= 1.0
test/main.hs view
@@ -1,1 +1,5 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-}+{-import qualified CopySpec-}+{-main = CopySpec.main-}+-- import qualified FindSpec+-- main = FindSpec.main