diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ # Shelly -[![Build Status](https://github.com/gregwebs/Shelly.hs/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/gregwebs/Shelly.hs/actions/workflows/haskell-ci.yml) -[![Build Status](https://github.com/gregwebs/Shelly.hs/actions/workflows/mac-win-ci.yml/badge.svg?branch=master)](https://github.com/gregwebs/Shelly.hs/actions/workflows/mac-win-ci.yml) +[![Build Status](https://travis-ci.org/yesodweb/Shelly.hs.svg?branch=master)](https://travis-ci.org/yesodweb/Shelly.hs) [![Hackage](https://img.shields.io/hackage/v/shelly.svg)](https://hackage.haskell.org/package/shelly) [![Stackage Nightly](http://stackage.org/package/shelly/badge/nightly)](http://stackage.org/nightly/package/shelly) [![Stackage LTS](http://stackage.org/package/shelly/badge/lts)](http://stackage.org/lts/package/shelly) diff --git a/shelly.cabal b/shelly.cabal --- a/shelly.cabal +++ b/shelly.cabal @@ -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: + An overview is available in the README: -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 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 diff --git a/src/Shelly.hs b/src/Shelly.hs --- a/src/Shelly.hs +++ b/src/Shelly.hs @@ -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 = dshelly_dirsf - (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 diff --git a/src/Shelly/Base.hs b/src/Shelly/Base.hs --- a/src/Shelly/Base.hs +++ b/src/Shelly/Base.hs @@ -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 + diff --git a/src/Shelly/Directory.hs b/src/Shelly/Directory.hs --- a/src/Shelly/Directory.hs +++ b/src/Shelly/Directory.hs @@ -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 diff --git a/src/Shelly/Find.hs b/src/Shelly/Find.hs --- a/src/Shelly/Find.hs +++ b/src/Shelly/Find.hs @@ -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 diff --git a/src/Shelly/Lifted.hs b/src/Shelly/Lifted.hs --- a/src/Shelly/Lifted.hs +++ b/src/Shelly/Lifted.hs @@ -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 diff --git a/src/Shelly/Pipe.hs b/src/Shelly/Pipe.hs --- a/src/Shelly/Pipe.hs +++ b/src/Shelly/Pipe.hs @@ -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) diff --git a/test/src/FindSpec.hs b/test/src/FindSpec.hs --- a/test/src/FindSpec.hs +++ b/test/src/FindSpec.hs @@ -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" ] + diff --git a/test/src/RmSpec.hs b/test/src/RmSpec.hs --- a/test/src/RmSpec.hs +++ b/test/src/RmSpec.hs @@ -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 (db) "b" - cmd "ln" "-s" (db) l + cmd "ln" "-s" (T.pack $ db) (T.pack l) rm_rf l test_f (db) assert res diff --git a/test/src/RunSpec.hs b/test/src/RunSpec.hs --- a/test/src/RunSpec.hs +++ b/test/src/RunSpec.hs @@ -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 diff --git a/test/src/TestInit.hs b/test/src/TestInit.hs --- a/test/src/TestInit.hs +++ b/test/src/TestInit.hs @@ -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"