diff --git a/Shelly.hs b/Shelly.hs --- a/Shelly.hs +++ b/Shelly.hs @@ -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. diff --git a/Shelly/Base.hs b/Shelly/Base.hs new file mode 100644 --- /dev/null +++ b/Shelly/Base.hs @@ -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 + diff --git a/Shelly/Find.hs b/Shelly/Find.hs new file mode 100644 --- /dev/null +++ b/Shelly/Find.hs @@ -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 diff --git a/shelly.cabal b/shelly.cabal --- a/shelly.cabal +++ b/shelly.cabal @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,1 +1,5 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --nested #-} +{-import qualified CopySpec-} +{-main = CopySpec.main-} +-- import qualified FindSpec +-- main = FindSpec.main