shelly 1.8.2 → 1.9.0
raw patch · 13 files changed
+237/−297 lines, 13 filesdep +unixdep −system-fileiodep −system-filepathdep ~basedep ~timedep ~transformers
Dependencies added: unix
Dependencies removed: system-fileio, system-filepath
Dependency ranges changed: base, time, transformers
Files
- ChangeLog.md +12/−78
- README.md +1/−2
- shelly.cabal +25/−45
- src/Shelly.hs +78/−66
- src/Shelly/Base.hs +32/−36
- src/Shelly/Directory.hs +14/−2
- src/Shelly/Find.hs +43/−33
- src/Shelly/Lifted.hs +2/−2
- src/Shelly/Pipe.hs +3/−3
- test/src/FindSpec.hs +17/−7
- test/src/RmSpec.hs +4/−3
- test/src/RunSpec.hs +5/−16
- test/src/TestInit.hs +1/−4
ChangeLog.md view
@@ -1,115 +1,49 @@-# 1.8.2--Andreas Abel, 2022-03-24--Version still using the `system-filepath` and `system-fileio` packages,-fixes issue [#189](https://github.com/gregwebs/Shelly.hs/issues/189).--* Builds with GHC 7.4 - 9.2.-* Backport `MonadFail` fixes from 1.9.0.-* Remove `unix` dependency in favor of `unix-compat`.-* Allow `time-1.12`.-* Backport CI on GitHub Action testing on Linux with GHC 7.4 - 9.2, on Windows/macOS with 8.8 - 9.2.- # 1.8.1 -Greg Weber, 2018-05-30-* New function `cp_should_follow_symlinks` to specify whether a copy should follow symlinks.+There is a new function `cp_should_follow_symlinks` to specify whether a copy should follow symlinks. # 1.8.0 -Greg Weber, 2018-05-09-* `cp_r` now uses upper case R: `cp -R`.+* `cp_r` now uses upper case R: `cp -R` # 1.7.2 -Greg Weber, 2018-03-17-* Fix handling of case-insensitive environment variables on Windows.- [#166](https://github.com/yesodweb/Shelly.hs/issues/166)--# 1.7.1--Greg Weber, 2018-03-06-* Support `exceptions-0.9`.+* Support exceptions-0.9 # 1.7.0.1 -Greg Weber, 2018-01-23-* Fix `FindSpec.hs` tests.- Fixes [#150](https://github.com/yesodweb/Shelly.hs/issues/150)- and [#162](https://github.com/yesodweb/Shelly.hs/issues/162).--# 1.7.0--Greg Weber, 2017-12-10-* Quote `ssh` remote commands aggressively with single quotes.- [#160](https://github.com/yesodweb/Shelly.hs/issues/160)--# 1.6.9--Greg Weber, 2017-12-07-* Strongly escape `ssh` commands.-* Add `sshPairsP`: parallel execution of `ssh` commands.+* Fix FindSpec.hs tests. Fixes [#150](https://github.com/yesodweb/Shelly.hs/issues/150), [#162](https://github.com/yesodweb/Shelly.hs/issues/162) # 1.6.8.7 -Sibi Prabakaran, 2017-11-26-* Relax `unix-compat` constraints.+* Relax unix-compat constraints # 1.6.8.6 -Sibi Prabakaran, 2017-11-19 * Fix Build issue [#156](https://github.com/yesodweb/Shelly.hs/issues/156) # 1.6.8.5 -Sibi Prabakaran, 2017-11-12 * Fix Windows build [#155](https://github.com/yesodweb/Shelly.hs/pull/155) -# 1.6.8.4--Greg Weber, 2017-08-07-* Option `followSymlink` for find-command.-* Allow `time-1.7/8`.--# 1.6.8.3--Greg Weber, 2017-03-03-* Support GHC 8.0.2--# 1.6.8.2--Greg Weber, 2017-03-03-* Allow `time-1.6`and `directory-1.3`--# 1.6.8.1--Greg Weber, 2016-10-02-* _changelog missing_- # 1.6.8 -Greg Weber, 2016-06-26-* Added `sshPairsWithOptions` function.+* added sshPairsWithOptions function # 1.6.7 -Greg Weber, 2016-06-24-* Flush `stdout` when using `echo`, not just `echo_n`.-* Fix should be able to silence `stderr` when using `runHandle`.-* Expose `RunFailed`.+* flush stdout when using `echo`, not just `echo_n`+* fix should be able to silence stderr when using `runHandle`+* expose RunFailed # 1.6.6 -Greg Weber, 2016-04-21-* Add `prependToPath` function.+* add prependToPath function # 1.6.5 -Greg Weber, 2015-12-10-* Expose `MonadShControl`.+* expose MonadShControl # 1.6.4.1 -Greg Weber, 2015-12-01-* Add `writeBinary` function.+* add writeBinary function
README.md view
@@ -1,7 +1,6 @@ # Shelly -[](https://github.com/gregwebs/Shelly.hs/actions/workflows/haskell-ci.yml)-[](https://github.com/gregwebs/Shelly.hs/actions/workflows/mac-win-ci.yml)+[](https://travis-ci.org/yesodweb/Shelly.hs) [](https://hackage.haskell.org/package/shelly) [](http://stackage.org/nightly/package/shelly) [](http://stackage.org/lts/package/shelly)
shelly.cabal view
@@ -1,6 +1,6 @@ Name: shelly -Version: 1.8.2+Version: 1.9.0 Synopsis: shell-like (systems) programming in Haskell Description: Shelly provides convenient systems programming in Haskell,@@ -13,37 +13,23 @@ . * maintains its own environment, making it thread-safe. .- * is modern, using Text and system-filepath/system-fileio+ * is modern, using Text filepath/directory . Shelly is originally forked from the Shellish package. . See the shelly-extra package for additional functionality. .- An overview is available in the README: <https://github.com/gregwebs/Shelly.hs/blob/master/README.md>+ An overview is available in the README: <https://github.com/yesodweb/Shelly.hs/blob/master/README.md> -Homepage: https://github.com/gregwebs/Shelly.hs+Homepage: https://github.com/yesodweb/Shelly.hs License: BSD3 License-file: LICENSE Author: Greg Weber, Petr Rockai-Maintainer: Andreas Abel+Maintainer: Greg Weber <greg@gregweber.info> Category: Development Build-type: Simple-Cabal-version: >=1.10--tested-with:- GHC == 9.2.2- GHC == 9.0.2- GHC == 8.10.7- GHC == 8.8.4- GHC == 8.6.5- GHC == 8.4.4- GHC == 8.2.2- GHC == 8.0.2- GHC == 7.10.3- GHC == 7.8.4- GHC == 7.6.3- GHC == 7.4.2+Cabal-version: >=1.8 -- for the sdist of the test suite extra-source-files: test/src/*.hs@@ -62,15 +48,14 @@ hs-source-dirs: src Build-depends:- base >= 4 && < 5, containers >= 0.4.2.0,- time >= 1.3 && < 1.13,+ time >= 1.3 && < 1.10, directory >= 1.3.0.0 && < 1.4.0.0, mtl >= 2, process >= 1.0, unix-compat < 0.6,- system-filepath >= 0.4.7 && < 0.5,- system-fileio < 0.4,+ unix,+ filepath, monad-control >= 0.3.2 && < 1.1, lifted-base, lifted-async,@@ -78,22 +63,24 @@ enclosed-exceptions, text, bytestring, async, transformers, transformers-base -- if impl(ghc < 8.0)- build-depends: fail >= 4.9 && < 4.10+ if impl(ghc >= 7.6.1)+ build-depends:+ base >= 4.6 && < 5+ else+ build-depends:+ base >= 4 && < 5 ghc-options: -Wall if impl(ghc >= 7.6.1) CPP-Options: -DNO_PRELUDE_CATCH - default-language: Haskell2010- default-extensions:+ extensions: CPP source-repository head type: git- location: https://github.com/gregwebs/Shelly.hs+ location: https://github.com/yesodweb/Shelly.hs Flag lifted Description: run the tests against Shelly.Lifted@@ -117,7 +104,6 @@ SshSpec Shelly Shelly.Base- Shelly.Directory Shelly.Find Shelly.Lifted TestInit@@ -128,11 +114,7 @@ -fno-warn-unused-do-bind -fno-warn-type-defaults - default-language: Haskell2010- default-extensions:- CPP- OverloadedStrings- ExtendedDefaultRules+ extensions: OverloadedStrings, ExtendedDefaultRules if flag(lifted) cpp-options: -DLIFTED@@ -146,10 +128,9 @@ directory >= 1.3.0.0 && < 1.4.0.0, process >= 1.1.0, unix-compat < 0.6,- system-filepath >= 0.4.7 && < 0.5,- system-fileio < 0.4,+ unix,+ time >= 1.3 && < 1.10, mtl >= 2,- time >= 1.3 && < 1.13, HUnit >= 1.2, hspec >= 2.0, hspec-contrib,@@ -165,6 +146,9 @@ if impl(ghc < 8.0) build-depends: fail >= 4.9 && < 4.10 + extensions:+ CPP+ Flag build-examples Description: build some example programs Default: False@@ -182,8 +166,7 @@ , shelly , text - default-language: Haskell2010- default-extensions:+ extensions: CPP else buildable: False@@ -198,8 +181,7 @@ , shelly , text - default-language: Haskell2010- default-extensions:+ extensions: CPP else buildable: False@@ -216,5 +198,3 @@ , text else buildable: False-- default-language: Haskell2010
src/Shelly.hs view
@@ -77,7 +77,7 @@ , RunFailed(..) -- * convert between Text and FilePath- , toTextIgnore, toTextWarn, FP.fromText+ , toTextIgnore, toTextWarn, fromText -- * Utility Functions , whenM, unlessM, time, sleep@@ -138,24 +138,20 @@ import Data.Monoid ((<>)) #endif -import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))-import Filesystem hiding (canonicalizePath)-import qualified Filesystem.Path.CurrentOS as FP+import System.FilePath hiding ((</>), (<.>))+import qualified System.FilePath as FP -import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, pathIsSymbolicLink )+import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, pathIsSymbolicLink+ , copyFile, removeFile, doesFileExist, doesDirectoryExist, listDirectory+ , renameFile, renameDirectory, removeDirectoryRecursive, createDirectoryIfMissing+ , getCurrentDirectory )+import System.IO (Handle) 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 CmdArgs a where@@ -183,7 +179,6 @@ -- Useful for a type signature of a function that uses 'cmd' class CmdArg a where toTextArg :: a -> Text instance CmdArg Text where toTextArg = id-instance CmdArg FilePath where toTextArg = toTextIgnore instance CmdArg String where toTextArg = T.pack -- | For the variadic function 'cmd'@@ -229,28 +224,31 @@ cmd :: (ShellCmd result) => FilePath -> result cmd fp = cmdAll fp [] +-- | Convert Text to a FilePath-+fromText :: Text -> FilePath+fromText = T.unpack+ -- | 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+instance ToFilePath Text where toFilePath = T.unpack --- | uses System.FilePath.CurrentOS, but can automatically convert a Text+-- | uses System.FilePath, 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+-- | uses System.FilePath, but can automatically convert a Text (<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath-x <.> y = toFilePath x FP.<.> y+x <.> y = toFilePath x FP.<.> T.unpack y toTextWarn :: FilePath -> Sh Text-toTextWarn efile = case toText efile of- Left f -> encodeError f >> return f- Right f -> return f+toTextWarn efile = do+ when (not $ isValid efile) $ encodeError (T.pack $ makeValid efile)+ return (T.pack $ makeValid efile) where encodeError f = echo ("non-unicode file name: " <> f) @@ -318,7 +316,7 @@ runCommand :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle) runCommand handles st exe args = findExe exe >>= \fullExe -> liftIO $ shellyProcess handles st $- RawCommand (encodeString fullExe) (map T.unpack args)+ RawCommand fullExe (map T.unpack args) where findExe :: FilePath -> Sh FilePath findExe@@ -350,7 +348,7 @@ shellyProcess reusedHandles st cmdSpec = do (createdInH, createdOutH, createdErrorH, pHandle) <- createProcess CreateProcess { cmdspec = cmdSpec- , cwd = Just $ encodeString $ sDirectory st+ , cwd = Just $ sDirectory st , env = Just $ sEnvironment st , std_in = createUnless mInH , std_out = createUnless mOutH@@ -504,24 +502,32 @@ -} pack :: String -> FilePath-pack = decodeString+pack = id -- | 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+-- wraps directory 'System.Directory.renameFile', which may not work across FS boundaries mv :: FilePath -> FilePath -> Sh () mv from' to' = do trace $ "mv " <> toTextIgnore from' <> " " <> toTextIgnore to' from <- absPath from'+ from_dir <- test_d from to <- absPath 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)- )+ let to_loc = if not to_dir then to else to FP.</> (FP.takeFileName from)+ liftIO $ createDirectoryIfMissing True (takeDirectory to_loc)+ if not from_dir + then liftIO $ renameFile from to_loc+ `catchany` (\e -> throwIO $+ ReThrownException e (extraMsg to_loc from)+ )+ else liftIO $ renameDirectory from to_loc+ `catchany` (\e -> throwIO $+ ReThrownException e (extraMsg to_loc from)+ ) where- extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t+ extraMsg :: String -> String -> String+ extraMsg t f = "during copy from: " ++ f ++ " to: " ++ t -- | Get back [Text] instead of [FilePath] lsT :: FilePath -> Sh [Text]@@ -552,13 +558,13 @@ -- | Create a new directory (fails if the directory exists). mkdir :: FilePath -> Sh () mkdir = traceAbsPath ("mkdir " <>) >=>- liftIO . createDirectory False+ liftIO . createDirectoryIfMissing False -- | Create a new directory, including parents (succeeds if the directory -- already exists). mkdir_p :: FilePath -> Sh () mkdir_p = traceAbsPath ("mkdir -p " <>) >=>- liftIO . createTree+ liftIO . createDirectoryIfMissing True -- | Create a new directory tree. You can describe a bunch of directories as -- a tree and this function will create all subdirectories. An example:@@ -589,7 +595,7 @@ isExecutable :: FilePath -> IO Bool-isExecutable f = (executable `fmap` getPermissions (encodeString f)) `catch` (\(_ :: IOError) -> return False)+isExecutable f = (executable `fmap` getPermissions f) `catch` (\(_ :: IOError) -> return False) -- | Get a full path to an executable by looking at the @PATH@ environement -- variable. Windows normally looks in additional places besides the@@ -613,7 +619,7 @@ whichFull fp = do (trace . mappend "which " . toTextIgnore) fp >> whichUntraced where- whichUntraced | absolute fp = checkFile+ whichUntraced | isAbsolute fp = checkFile | dotSlash splitOnDirs = checkFile | length splitOnDirs > 0 = lookupPath >>= leftPathError | otherwise = lookupCache >>= leftPathError@@ -624,9 +630,9 @@ checkFile :: Sh (Either String FilePath) checkFile = do- exists <- liftIO $ isFile fp+ exists <- liftIO $ doesFileExist fp return $ if exists then Right fp else- Left $ "did not find file: " <> encodeString fp+ Left $ "did not find file: " <> fp leftPathError :: Maybe FilePath -> Sh (Either String FilePath) leftPathError Nothing = Left <$> pathLookupError@@ -636,7 +642,7 @@ pathLookupError = do pATH <- get_env_text "PATH" return $- "shelly did not find " `mappend` encodeString fp `mappend`+ "shelly did not find " `mappend` fp `mappend` " in the PATH: " `mappend` T.unpack pATH lookupPath :: Sh (Maybe FilePath)@@ -652,7 +658,7 @@ L.find (S.member fp . snd) pathExecutables - pathDirs = mapM absPath =<< ((map FP.fromText . filter (not . T.null) . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH")+ pathDirs = mapM absPath =<< ((map T.unpack . filter (not . T.null) . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH") cachedPathExecutables :: Sh [(FilePath, S.Set FilePath)] cachedPathExecutables = do@@ -664,7 +670,7 @@ executables <- forM dirs (\dir -> do files <- (liftIO . listDirectory) dir `catch_sh` (\(_ :: IOError) -> return []) exes <- fmap (map snd) $ liftIO $ filterM (isExecutable . fst) $- map (\f -> (f, filename f)) files+ map (\f -> (f, takeFileName f)) files return $ S.fromList exes ) let cachedExecutables = zip dirs executables@@ -689,12 +695,12 @@ test_e :: FilePath -> Sh Bool test_e = absPath >=> \f -> liftIO $ do- file <- isFile f- if file then return True else isDirectory f+ file <- doesFileExist f+ if file then return True else doesDirectoryExist f -- | Does a path point to an existing file? test_f :: FilePath -> Sh Bool-test_f = absPath >=> liftIO . isFile+test_f = absPath >=> liftIO . doesFileExist -- | Test that a file is in the PATH and also executable test_px :: FilePath -> Sh Bool@@ -707,17 +713,17 @@ -- | 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'+-- Uses 'removeDirectoryRecursive' rm_rf :: FilePath -> Sh () rm_rf infp = do f <- traceAbsPath ("rm -rf " <>) infp isDir <- (test_d f) if not isDir then whenM (test_f f) $ rm_f f else- (liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) ->+ (liftIO_ $ removeDirectoryRecursive f) `catch_sh` (\(e :: IOError) -> when (isPermissionError e) $ do- find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (encodeString file) `catchany` \_ -> return ())- liftIO $ removeTree f+ find f >>= mapM_ (\file -> liftIO_ $ fixPermissions file `catchany` \_ -> return ())+ liftIO $ removeDirectoryRecursive f ) where fixPermissions file = do permissions <- liftIO $ getPermissions file@@ -734,7 +740,7 @@ -- Does fail if the file does not exist (use 'rm_f' instead) or is not a file. rm :: FilePath -> Sh () rm = traceAbsPath ("rm " <>) >=>- -- TODO: better error message for removeFile (give filename)+ -- TODO: better error message for removeFile (give takeFileName) liftIO . removeFile -- | Set an environment variable. The environment is maintained in Sh@@ -995,7 +1001,7 @@ shelly' :: MonadIO m => ReadOnlyState -> Sh a -> m a shelly' ros action = do environment <- liftIO getNormalizedEnvironment- dir <- liftIO getWorkingDirectory+ dir <- liftIO getCurrentDirectory let def = State { sCode = 0 , sStdin = Nothing , sStderr = T.empty@@ -1037,7 +1043,7 @@ d <- pwd sf <- shellyFile let logFile = d</>shelly_dir</>sf- (writefile logFile trc >> return ("log of commands saved to: " <> encodeString logFile))+ (writefile logFile trc >> return ("log of commands saved to: " <> logFile)) `catchany_sh` (\_ -> ranCommands) where@@ -1051,7 +1057,7 @@ nextNum :: [FilePath] -> Int nextNum [] = 1- nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . encodeString . filename) $ fs+ nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . takeFileName) $ fs -- from safe package readDef :: Read a => a -> String -> a@@ -1409,11 +1415,16 @@ 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))+ finalTo <- if not toIsDir then do + mkdir to + return to + else do+ -- this takes the name of the from directory + -- because filepath has no builtin function like `dirname`+ let d = to </> (last . splitPath $ takeDirectory (addTrailingPathSeparator from))+ mkdir_p d >> return d+ ls from >>= mapM_ (\item -> do+ cp_r (from FP.</> takeFileName item) (finalTo FP.</> takeFileName item)) -- | Copy a file. The second path could be a directory, in which case the -- original file name is used, in that directory.@@ -1426,14 +1437,15 @@ 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+ let to_loc = if to_dir then to FP.</> takeFileName from else to if shouldFollowSymlinks then copyNormal from to_loc else do- isSymlink <- liftIO $ pathIsSymbolicLink (encodeString from)+ isSymlink <- liftIO $ pathIsSymbolicLink from if not isSymlink then copyNormal from to_loc else do- target <- liftIO $ getSymbolicLinkTarget (encodeString from)- liftIO $ createFileLink target (encodeString to_loc)+ target <- liftIO $ getSymbolicLinkTarget from+ liftIO $ createFileLink target to_loc where- extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t+ extraMsg :: String -> String -> String+ extraMsg t f = "during copy from: " ++ f ++ " to: " ++ t copyNormal from to = liftIO $ copyFile from to `catchany` (\e -> throwIO $ ReThrownException e (extraMsg to from) )@@ -1456,12 +1468,12 @@ writefile :: FilePath -> Text -> Sh () writefile f' bits = do f <- traceAbsPath ("writefile " <>) f'- liftIO (TIO.writeFile (encodeString f) bits)+ liftIO (TIO.writeFile f bits) writeBinary :: FilePath -> ByteString -> Sh () writeBinary f' bytes = do f <- traceAbsPath ("writeBinary " <>) f'- liftIO (BS.writeFile (encodeString f) bytes)+ liftIO (BS.writeFile f bytes) -- | Update a file, creating (a blank file) if it does not exist. touchfile :: FilePath -> Sh ()@@ -1471,7 +1483,7 @@ appendfile :: FilePath -> Text -> Sh () appendfile f' bits = do f <- traceAbsPath ("appendfile " <>) f'- liftIO (TIO.appendFile (encodeString f) bits)+ liftIO (TIO.appendFile f bits) readfile :: FilePath -> Sh Text readfile = traceAbsPath ("readfile " <>) >=> \fp ->@@ -1481,11 +1493,11 @@ -- | wraps ByteSting readFile readBinary :: FilePath -> Sh ByteString readBinary = traceAbsPath ("readBinary " <>)- >=> liftIO . BS.readFile . encodeString+ >=> liftIO . BS.readFile -- | flipped hasExtension for Text hasExt :: Text -> FilePath -> Bool-hasExt = flip hasExtension+hasExt ext fp = T.pack (FP.takeExtension fp) == ext -- | Run a Sh computation and collect timing information. -- The value returned is the amount of _real_ time spent running the computation
src/Shelly/Base.hs view
@@ -8,7 +8,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-}-+{-# LANGUAGE InstanceSigs#-}+-- | 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 ( Sh(..), ShIO, runSh, State(..), ReadOnlyState(..), StdHandle(..),@@ -42,15 +45,14 @@ liftM ) import Control.Monad.Fail (MonadFail)-import qualified Control.Monad.Fail as Fail import Control.Monad.Base import Control.Monad.Trans.Control import Control.Applicative (Applicative, (<$>))-import Filesystem (isDirectory, listDirectory)+import System.Directory( doesDirectoryExist, 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 System.FilePath ( FilePath, isRelative)+import qualified System.FilePath as FP+import qualified System.Directory as FS import Data.IORef (readIORef, modifyIORef, IORef) import Data.Monoid (mappend) import qualified Data.Text as T@@ -70,13 +72,7 @@ newtype Sh a = Sh { unSh :: ReaderT (IORef State) IO a- } deriving (Functor, Applicative, Monad, MonadIO, MonadReader (IORef State), Catch.MonadMask) --, MonadFail)---- Andreas Abel, 2022-03-24--- For reasons unclear to me, GHC 7.10 does not derive the MonadFail instance--- from the instances for IO and ReaderT. Starts working with GHC 8.0.-instance MonadFail Sh where- fail = Sh . ReaderT . const . Fail.fail+ } deriving (Applicative, Monad, MonadFail, MonadIO, MonadReader (IORef State), Functor, Catch.MonadMask) instance MonadBase IO Sh where liftBase = Sh . ReaderT . const@@ -174,12 +170,16 @@ fpCan <- canonic fullFp stripIt relCan fpCan $ return $ Left fpCan where+ stripIt+ :: FilePath+ -> FilePath+ -> Sh (Either FilePath FilePath)+ -> Sh (Either FilePath FilePath) stripIt rel toStrip nada =- case FP.stripPrefix rel toStrip of- Just stripped ->- if stripped == toStrip then nada- else return $ Right stripped- Nothing -> nada+ let stripped = FP.makeRelative rel toStrip+ in if stripped == toStrip + then nada + else return $ Right stripped -- | make the second path relative to the first -- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary@@ -201,9 +201,7 @@ -- | 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+addTrailingSlash = FP.addTrailingPathSeparator -- | makes an absolute path. -- Like 'canonicalize', but on an exception returns 'absPath'@@ -219,7 +217,7 @@ -- | 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+canonicalizePath p = let was_dir = null (FP.takeFileName p) in if not was_dir then FS.canonicalizePath p else addTrailingSlash `fmap` FS.canonicalizePath p @@ -232,8 +230,10 @@ -- An absolute path is returned as is. -- To create a relative path, use 'relPath'. absPath :: FilePath -> Sh FilePath-absPath p | FP.null p = liftIO $ throwIO EmptyFilePathError- | relative p = (FP.</> p) <$> gets sDirectory+absPath p | null p = liftIO $ throwIO EmptyFilePathError+ | isRelative p = do + cwd <- gets sDirectory+ return (cwd FP.</> p) | otherwise = return p -- | deprecated@@ -243,16 +243,16 @@ -- | Does a path point to an existing directory? test_d :: FilePath -> Sh Bool-test_d = absPath >=> liftIO . isDirectory+test_d = absPath >=> liftIO . doesDirectoryExist -- | Does a path point to a symlink? test_s :: FilePath -> Sh Bool test_s = absPath >=> liftIO . \f -> do- stat <- getSymbolicLinkStatus (encodeString f)+ stat <- getSymbolicLinkStatus f return $ isSymbolicLink stat unpack :: FilePath -> String-unpack = encodeString+unpack = id gets :: (State -> a) -> Sh a gets f = f <$> get@@ -284,19 +284,14 @@ 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+ files <- liftIO $ listDirectory fp+ let absolute = map (fp FP.</>) files+ let relativized = map (\p -> FP.joinPath [f, p]) files 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+toTextIgnore = T.pack -- | a print lifted into 'Sh' inspect :: (Show s) => s -> Sh ()@@ -326,3 +321,4 @@ -- @... `catch` \(e :: SomeException) -> ...@). catchany :: IO a -> (SomeException -> IO a) -> IO a catchany = catch+
src/Shelly/Directory.hs view
@@ -2,19 +2,31 @@ module Shelly.Directory where import System.IO.Error (modifyIOError, ioeSetLocation, ioeGetLocation)-import qualified Filesystem.Path.CurrentOS as FP+import qualified System.Directory as FP -import qualified System.PosixCompat as Posix+#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif createFileLink :: String -> String -> IO () createFileLink target link = (`ioeAddLocation` "createFileLink") `modifyIOError` do+#ifdef mingw32_HOST_OS+ Win32.createSymbolicLink False target link+#else Posix.createSymbolicLink target link+#endif getSymbolicLinkTarget :: String -> IO String getSymbolicLinkTarget path = (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do+#ifdef mingw32_HOST_OS+ Win32.readSymbolicLink path+#else Posix.readSymbolicLink path+#endif ioeAddLocation :: IOError -> String -> IOError ioeAddLocation e loc = do
src/Shelly/Find.hs view
@@ -4,17 +4,23 @@ -- 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+ ( 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)-import Filesystem.Path.CurrentOS (encodeString)+import Prelude hiding ( FilePath )+import Shelly.Base+import Control.Monad ( foldM )+import Data.Monoid ( mappend )+import System.PosixCompat.Files ( getSymbolicLinkStatus+ , isSymbolicLink+ )+import System.Directory ( doesDirectoryExist ) -- | List directory recursively (like the POSIX utility "find"). -- listing is relative if the path given is relative.@@ -31,7 +37,8 @@ -- | 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)+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.@@ -41,36 +48,39 @@ -- | 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+ :: (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+ 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+ :: (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)+ files <- ls absDir filt <- dirFilter absDir- if not filt then return startValue+ if not filt+ then return startValue -- use possible relative path, not absolute so that listing will remain relative else do- (rPaths, aPaths) <- lsRelAbs dir + (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 (encodeString absolutePath)- newAcc <- folder acc relativePath- follow <- fmap sFollowSymlink get- if isDir && (follow || not sym)- then findFoldDirFilter folder newAcc - dirFilter relativePath- else return newAcc+ where+ traverse acc (relativePath, absolutePath) = do+ -- optimization: don't use Shelly API since our path is already good+ isDir <- liftIO $ doesDirectoryExist absolutePath+ sym <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus absolutePath+ newAcc <- folder acc relativePath+ follow <- fmap sFollowSymlink get+ if isDir && (follow || not sym)+ then findFoldDirFilter folder newAcc dirFilter relativePath+ else return newAcc
src/Shelly/Lifted.hs view
@@ -80,7 +80,7 @@ , bracket_sh, catchany, catch_sh, handle_sh, handleany_sh, finally_sh, catches_sh, catchany_sh -- * convert between Text and FilePath- , S.toTextIgnore, toTextWarn, FP.fromText+ , S.toTextIgnore, toTextWarn, S.fromText -- * Utility Functions , S.whenM, S.unlessM, time, sleep@@ -105,7 +105,7 @@ import Data.Monoid import System.IO ( Handle ) import Data.Tree ( Tree )-import qualified Filesystem.Path.CurrentOS as FP+import qualified System.FilePath as FP import Control.Exception.Lifted import Control.Exception.Enclosed
src/Shelly/Pipe.hs view
@@ -78,7 +78,7 @@ , catchany_sh -- * convert between Text and FilePath- , toTextIgnore, toTextWarn, fromText+ , toTextIgnore, toTextWarn, S.fromText -- * Utilities. , (<$>), whenM, unlessM, time@@ -102,14 +102,14 @@ import Control.Monad.Trans import Control.Exception hiding (handle) -import Filesystem.Path(FilePath)+import System.FilePath(FilePath) import qualified Shelly as S import Shelly( (</>), (<.>), hasExt , whenM, unlessM, toTextIgnore- , fromText, catchany+ , catchany , FoldCallback) import Data.Maybe(fromMaybe)
test/src/FindSpec.hs view
@@ -5,10 +5,11 @@ import System.Directory (createDirectoryIfMissing) import System.PosixCompat.Files (createSymbolicLink, fileExist) import qualified System.FilePath as SF+import Shelly createSymlinkForTest :: IO () createSymlinkForTest = do- createDirectoryIfMissing False symDir+ createDirectoryIfMissing True symDir fexist <- fileExist (symDir SF.</> "symlinked_dir") if fexist then return ()@@ -49,6 +50,14 @@ "./TestInit.hs", "./TestMain.hs", "./WhichSpec.hs", "./WriteSpec.hs", "./sleep.hs"] + it "lists relative files in folder" $ do+ res <- shelly $ cd "test" >> ls "src"+ sort res @?= ["src/CopySpec.hs", "src/EnvSpec.hs", "src/FailureSpec.hs",+ "src/FindSpec.hs", "src/Help.hs", "src/LiftedSpec.hs", "src/LogWithSpec.hs", "src/MoveSpec.hs",+ "src/ReadFileSpec.hs", "src/RmSpec.hs", "src/RunSpec.hs", "src/SshSpec.hs",+ "src/TestInit.hs", "src/TestMain.hs",+ "src/WhichSpec.hs", "src/WriteSpec.hs", "src/sleep.hs"]+ it "finds relative files" $ do res <- shelly $ cd "test/src" >> find "." sort res @?= ["./CopySpec.hs", "./EnvSpec.hs", "./FailureSpec.hs",@@ -84,7 +93,7 @@ "TestInit.hs", "TestMain.hs", "WhichSpec.hs", "WriteSpec.hs", "sleep.hs"] - unless isWindows $ before createSymlinkForTest $ do+ before createSymlinkForTest $ do it "follow symlinks" $ do res <- shelly $@@ -92,12 +101,12 @@ relPath "test/data" >>= find >>= mapM (relativeTo "test/data") sort res @?= [ "dir"- , "nonascii.txt"- , "symlinked_dir"- , "zshrc" , "dir/symlinked_dir" , "dir/symlinked_dir/hoge_file"+ , "nonascii.txt"+ , "symlinked_dir" , "symlinked_dir/hoge_file"+ , "zshrc" ] it "not follow symlinks" $ do res <-@@ -106,9 +115,10 @@ relPath "test/data" >>= find >>= mapM (relativeTo "test/data") sort res @?= [ "dir"+ , "dir/symlinked_dir" , "nonascii.txt" , "symlinked_dir"- , "zshrc"- , "dir/symlinked_dir" , "symlinked_dir/hoge_file"+ , "zshrc" ]+
test/src/RmSpec.hs view
@@ -1,6 +1,7 @@ module RmSpec (rmSpec) where import TestInit+import Data.Text as T import Help rmSpec :: Spec@@ -56,7 +57,7 @@ it "rm" $ do res <- shelly $ do writefile b "b"- cmd "ln" "-s" b l+ cmd "ln" "-s" (T.pack b) (T.pack l) rm l test_f b assert res@@ -65,7 +66,7 @@ it "rm_f" $ do res <- shelly $ do writefile b "b"- cmd "ln" "-s" b l+ cmd "ln" "-s" (T.pack b) (T.pack l) rm_f l test_f b assert res@@ -75,7 +76,7 @@ res <- shelly $ do mkdir d writefile (d</>b) "b"- cmd "ln" "-s" (d</>b) l+ cmd "ln" "-s" (T.pack $ d</>b) (T.pack l) rm_rf l test_f (d</>b) assert res
test/src/RunSpec.hs view
@@ -18,16 +18,12 @@ it "without escaping" $ do res <- shelly $ escaping False $ run "echo" [ "*" ]- if isWindows- then res @?= "*\n"- else assert $ "README.md" `elem` T.words res+ assert $ "README.md" `elem` T.words res it "with binary handle mode" $ do res <- shelly $ onCommandHandles (initOutputHandles (flip hSetBinaryMode True)) $ run "cat" [ "test/data/nonascii.txt" ]- if isWindows- then res @?= "Selbstverst\228ndlich \252berraschend\r\n"- else res @?= "Selbstverst\228ndlich \252berraschend\n"+ res @?= "Selbstverst\228ndlich \252berraschend\n" -- Bash-related commands describe "bash" $ do@@ -42,9 +38,7 @@ it "with binary handle mode" $ do res <- shelly $ onCommandHandles (initOutputHandles (flip hSetBinaryMode True)) $ bash "cat" [ "test/data/nonascii.txt" ]- if isWindows- then res @?= "Selbstverst\228ndlich \252berraschend\r\n"- else res @?= "Selbstverst\228ndlich \252berraschend\n"+ res @?= "Selbstverst\228ndlich \252berraschend\n" {- This throws spurious errors on some systems it "can detect failing commands in pipes" $ do@@ -57,13 +51,8 @@ it "preserve pipe behaviour" $ do (eCode, res) <- shelly $ escaping False $ errExit False $ do- res <-- if isWindows- then bash "echo" [ "foo", "|", "echo", "bar" ]- else bash "echo" [ "'foo'", "|", "echo", "'bar'" ]+ res <- bash "echo" [ "'foo'", "|", "echo", "'bar'" ] eCode <- lastExitCode return (eCode, res)- if isWindows- then res @?= "bar'\n"- else res @?= "bar\n"+ res @?= "bar\n" eCode @?= 0
test/src/TestInit.hs view
@@ -1,4 +1,4 @@-module TestInit (module Export, isWindows) where+module TestInit (module Export) where import Test.HUnit as Export hiding (path) import Test.Hspec as Export@@ -8,6 +8,3 @@ import Shelly as Export #endif import Test.Hspec.Contrib.HUnit ()-import System.Info(os)-isWindows :: Bool -isWindows = os == "mingw32"