diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,378 @@ +1.6.2 + +* Build against latest `ansi-wl-pprint` and `optparse-applicative` [[#445]](https://github.com/Gabriella439/turtle/pull/445) / [[#446]](https://github.com/Gabriella439/turtle/pull/446) / [[#447]](https://github.com/Gabriella439/turtle/pull/447) + +1.6.1 + +* BUG FIX: Fix `turtle` to build on Windows +* BUG FIX: `stripPrefix` and `commonPrefix` now correctly handle files with + extensions + * For example, before this fix `stripPrefix "./" "./foo.bar"` would + return `Just "foo/.bar"` + +1.6.0 + +* BREAKING CHANGE: Switch to the `FilePath` type from `base` instead of + `system-filepath` + * This is a breaking change for a couple of reasons: + * The `FilePath` type has changed, so the API is not backwards-compatible + * The thing most likely to break is if you directly imported utilities + from the `system-filepath` or `system-fileio` packages to operate on + `turtle`'s `FilePath`s + * If that happens, you should first check if the `Turtle` module + exports a utility of the same name. If so, then switch to that + * If there is no equivalent substitute from the `Turtle` module then + you will have to change your code to use the closest equivalent + utility from the `filepath` or `directory` package + * If you were previously using any of the `system-filepath` or + `system-fileio` utilities re-exported from the `Turtle` module then + those utilities will not break as they have been replaced with + versions compatible with the `FilePath` type from `base` + * The second thing most likely to break is any code that relies on + typeclasses since because if you defined any instances for the + `FilePath` type exported by `turtle` then those instances will now + overlap with any instances defined for the `String` type + * The conversion utilities (e.g. `toText`, `encodeString`) will still + work, so code that used those conversion utilities should be less + affected by this change + * The behavior of the `collapse` utility is subtly different + * `collapse` no longer interprets `..` in paths + * This new behavior is more correct in the presence of symlinks, so the + change is (hopefully) an improvement to downstream code + * The new API strives to match the old behavior as closely as possible + * … so this should (hopefully) not break too much code in practice + * With the exception of the `collapse` function the new API should be + bug-for-bug compatible with the old API + * Most of the surprising behavior inherited from the old API is around + how `.` and `..` are handled in paths + * `parent ".." == "."` is an example of such surprising behavior + * At some point in the future we may fix bugs in these utilities inherited + from `system-filepath` / `system-fileio`, but no decision either way has + been made, yet + * Some old utilities are marked `DEPRECATED` if their behavior exactly matches + the behavior of an existing utility from the `filepath` or `directory` + package + * These may be eventually removed at some point in the future or they + remain in a deprecated state indefinitely. No decision either way has + been made + * The `Turtle` module also re-exports any utility suggested by a + `DEPRECATED` pragma as a convenience + * Other utilities are not deprecated if the old behavior significantly departs + from any existing utility from the `filepath` or `directory` package + * For example, the behavior of the `filename` utility differs from the + behavior of `System.FilePath.takeFileName` for filenames that begin with a + `.`, so we have to preserve the old behavior to avoid breaking downstream + code + * At some point in the future utilities like these may be deprecated in + favor of their closest analogs in the `filepath` / `directory` packages or + they may be supported indefinitely. No decision either way has been made + * If you want to try to author code that is compatible with both the + pre-1.6 and post-1.6 API: + * If you add any instances to the `FilePath` type, import it qualified + directly from the `system-filepath` package and use it only for instances + * Otherwise, don't import anything else from the `system-filepath` / + `system-fileio` packages if you can help it. Instead, restrict yourself + entirely to the utilities and `FilePath` type exported by the `Turtle` + module + * Use the conversion utilities (e.g. `encodeStrings`, even if they are not + necessary post-1.6) + * If that's still not enough, use `CPP` and good luck! + +1.5.25 + +* Build against latest version of `Win32` package + +1.5.24 + +* Expose `Format` constructor + +1.5.23 + +* Add `fromIO` utility +* Build against GHC 9.0 / 9.2 + +1.5.22 + +* Add new `update` utility +* Improve documentation for `limit` + +1.5.21 + +* Build against `optparse-applicative-0.16.0.0` + +1.5.20 + +* Build against `doctest-0.17` +* Only depend on `semigroups` for GHC < 8.0 + +1.5.19 + +* Add pattern synonyms for `Size` + +1.5.18 + +* Fix space leak + +1.5.17 + +* Add `optionsExt`: Extended version of `options` with header, footer, + porgram-description and version information in `--help` flag +* Add `readlink` + +1.5.16 + +* Add `cptreeL` + +1.5.15 + +* Add `toLines` +* Add `Turtle.Bytes.{fromUTF8,toUTF8}` +* Add `Turtle.Bytes.{compress,decompress}` +* Always expose a `MonadFail` instance, relying on the `fail` package + where needed. Related GHC 8.8 preparedness. + +1.5.14 + +* Fix `cptree` to copy symlinks instead of descending into them + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/344 +* Build against newer versions of `Win32` package + +1.5.13 + +* Fix `chmod` bug + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/337 +* Add `reduce` and re-export `(<&>)` + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/332 + +1.5.12 + +* Increase upper bound on `containers` + +1.5.11 + +* Don't forward broken pipe exceptions when using `inproc` + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/321 +* Increase upper bound on `stm` + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/321 +* Tutorial improvements: + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/322 + +1.5.10 + +* Increase upper bound on `doctest` and `criterion` + +1.5.9 + +* Add `symlink` + +1.5.8 + +* Bug fix: `invert` no longer rejects inputs where a prefix matches the inverted + pattern + * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/297 +* Add lsdepth, findtree, cmin, and cmax +* Increase upper bound on `temporary` and `foldl` + +1.5.7 + +* Increase upper bound on `doctest` + +1.5.6 + +* Increase upper bound on `exceptions` + +1.5.5 + +* Increase upper bound on `criterion` + +1.5.4 + +* Increase upper bound on `exceptions` + +1.5.3 + +* Increase upper bound on `doctest` + +1.5.2 + +* Increase upper bound on `async` + +1.5.1 + +* GHC 8.4 support +* Re-export `encodeString`/`decodeString` +* Update tutorial to use `stack script` +* Increase upper bounds on dependencies + +1.5.0 + +* BREAKING CHANGE: Add `MonadCatch` instance for `Shell` + * This requires a breaking change to the internal implementation of `Shell` + * Most breaking changes can be fixed by replacing the `Shell` constructor + with the newly added `_Shell` utility for ease of migration + * If you don't use the `Shell` constructor then this change likely does not + affect you +* Add `eprintf` + +1.4.5 + +* Add `grepText`, `uniq`, `nub`, `sort` to `Turtle.Prelude` +* Increase upper bound on `unix-compat` + +1.4.4 + +* Fix small mistake in tutorial + +1.4.3 + +* Increase upper bound on `doctest` + +1.4.2 + +* Add `sed{Prefix,Suffix,Entire}` and `inplace{Prefix,Suffix,Entire}` + +1.4.1 + +* Increase upper bound on `doctest` + +1.4.0 + +* BREAKING CHANGE: Remove unnecessary `Maybe` from type of `single` +* BREAKING CHANGE: Consolidate `searchable` and `executable` +* `stream{,WithErr}` now throws an `ExitCode` on failure + +1.3.6 + +* Build against `ghc-8.2` +* Relax upper bound on `optparse-applicative` and `foldl` + +1.3.5 + +* Increase upper bound on `foldl` + +1.3.4 + +* Bug fix: `cptree` now correctly copies files instead of creating directories + of the same name +* Increase upper bound on `criterion` + +1.3.3 + +* Bug fix: Change `textToLines` to behave like `Data.Text.splitOn "\n"` + instead of `Data.Text.unlines` + * This fixes weird behavior around handling empty strings. `splitOn` does + the right thing, but `unlines` does not. For example, this indirectly + fixes a regression in `sed`, which would discard empty lines +* Bug fix: `which`/`whichAll` now behave correctly on Windows +* Add new `cptree`/`single` utilities +* Documentation fixes + +1.3.2 + +* Fix bugs in subprocess management +* Generalize type of `repr` to return any type that implements `IsString` +* Add `optLine`, `argLine`, and `l` utilities to simplify working with `Line`s + +1.3.1 + +* `find` no longer follows symlinks +* Increase upper bound on `directory` + +1.3 + +* BREAKING CHANGE: Several utilities now produce and consume `Line`s instead of + `Text` + * The purpose of this change is to fix a very common source of confusion for + new users about which utilities are line-aware + * Most of the impact on existing code is just changing the types by + replacing `Text` with `Line` in the right places. The change at the + term level should be small (based on the changes to the tutorial examples) +* BREAKING CHANGE: `Description` now wraps a `Doc` instead of `Text` + * In the most common case where users use string literals this has no effect +* New `Turtle.Bytes` module that provides `ByteString` variations on subprocess + runners +* Fix `du` reporting incorrect sizes for directories +* Add `pushd`, `stat`, `lstat`, `which`, `procStrictWithErr`, + `shellStrictWithErr`, `onFiles`, `header`, `subcommandGroup`, and `parallel` +* Backport `need` to GHC 7.6.3 +* Fix missing help text for option parsers +* Fix bugs in subprocess management + +1.2.8 + +* Increase upper bound on `time` and `transformers` +* Fix incorrect lower bound for `base` + +1.2.7 + +* Increase upper bound on `clock` dependency + +1.2.6 + +* Generalize several types to use `MonadManaged` +* Generalize type of `printf` to use `MonadIO` +* Add `system`, and `copymod` +* Fix `rmtree` to more accurately match behavior of `rm -r` + +1.2.5 + +* Add `printf`, `utc`, `procs`, and `shells` + +1.2.4 + +* Generalize type of `d` format specifier to format any `Integral` type +* Add `inprocWithErr`, `inShellWithErr`, `inplace`, and `sz` + +1.2.3 + +* Add `subcommand` and `testpath` +* Use line buffering for `Text`-based subprocesses + +1.2.2 + +* Re-export `with` +* Add `begins`, `ends`, `contains`, `lowerBounded`, `mktempfile`, `nl`, `paste` + `endless`, `lsif`, and `cut` +* Fix subprocess management bugs + +1.2.1 + +* Fix subprocess management bugs + +1.2.0 + +* BREAKING CHANGE: `du` now returns a `Size` instead of an `Integer` +* New `Turtle.Options` module that provides convenient utilities for options + parsing +* Add `hostname`, `outhandle`, `stderr`, `cache`, `countChars`, `countWords`, + and `countLines` +* Fix subprocess management bugs + +1.1.1 + +* Add `bounded`, `upperBounded`, `procStrict`, `shellStrict`, `arguments` +* Add several `Permissions`-related commands +* Generalize several types to `MonadIO` + +1.1.0 + +* BREAKING CHANGE: Remove `Floating`/`Fractional` instances for `Pattern` and + `Shell` +* BREAKING CHANGE: Change behavior of `Num` instance for `Pattern` and `Shell` +* Re-export `(&)` +* Add `asciiCI`, `(.||.)`, `(.&&.)`, `strict` + +1.0.2 + +* Add `fp` format specifier +* Add `chars`/`chars` high-efficiency parsing primitives +* Fix bugs in path handling + +1.0.1 + +* Generalize type of `die` +* Fix doctest + +1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015 Gabriel Gonzalez +Copyright (c) 2017 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, @@ -8,7 +8,7 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors + * Neither the name of Gabriella Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -2,7 +2,7 @@ module Main where import qualified Data.Text as Text -import Criterion.Main +import Test.Tasty.Bench import Turtle boundedNaive :: Int -> Int -> Pattern a -> Pattern [a] diff --git a/src/Turtle.hs b/src/Turtle.hs --- a/src/Turtle.hs +++ b/src/Turtle.hs @@ -47,8 +47,6 @@ -- -- "Control.Monad.Managed.Safe" provides `Managed` resources -- --- "Filesystem.Path.CurrentOS" provides `FilePath`-manipulation utilities --- -- Additionally, you might also want to import the following modules qualified: -- -- * "Options.Applicative" from @optparse-applicative@ for command-line option @@ -61,8 +59,6 @@ -- * "Data.Text" (for `Text`-manipulation utilities) -- -- * "Data.Text.IO" (for reading and writing `Text`) --- --- * "Filesystem.Path.CurrentOS" (for the remaining `FilePath` utilities) module Turtle ( -- * Modules @@ -70,13 +66,15 @@ , module Turtle.Pattern , module Turtle.Options , module Turtle.Shell + , module Turtle.Line , module Turtle.Prelude , module Control.Applicative , module Control.Monad , module Control.Monad.IO.Class , module Data.Monoid , module Control.Monad.Managed - , module Filesystem.Path.CurrentOS + , module System.FilePath + , module Turtle.Internal , Fold(..) , FoldM(..) , Text @@ -86,12 +84,14 @@ , ExitCode(..) , IsString(..) , (&) + , (<&>) ) where import Turtle.Format import Turtle.Pattern import Turtle.Options import Turtle.Shell +import Turtle.Line import Turtle.Prelude import Control.Applicative ( Applicative(..) @@ -117,9 +117,23 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Monoid (Monoid(..), (<>)) import Data.String (IsString(..)) -import Filesystem.Path.CurrentOS +import Control.Monad.Managed (Managed, managed, runManaged, with) +import Control.Foldl (Fold(..), FoldM(..)) +import Data.Text (Text) +import Data.Time (NominalDiffTime, UTCTime) +import System.FilePath ( FilePath - , root + , dropExtension + , hasExtension + , isAbsolute + , isRelative + , () + , (<.>) + ) +import System.IO (Handle) +import System.Exit (ExitCode(..)) +import Turtle.Internal + ( root , directory , parent , filename @@ -127,28 +141,21 @@ , basename , absolute , relative - , () , commonPrefix , stripPrefix , collapse , splitDirectories , extension - , hasExtension - , (<.>) - , dropExtension , splitExtension + , splitExtensions , toText , fromText + , encodeString + , decodeString ) -import Control.Monad.Managed (Managed, managed, runManaged, with) -import Control.Foldl (Fold(..), FoldM(..)) -import Data.Text (Text) -import Data.Time (NominalDiffTime, UTCTime) -import System.IO (Handle) -import System.Exit (ExitCode(..)) import Prelude hiding (FilePath) -#if MIN_VERSION_base(4,8,0) +#if __GLASGOW_HASKELL__ >= 710 import Data.Function ((&)) #else infixl 1 & @@ -158,4 +165,33 @@ -- application operator '$', which allows '&' to be nested in '$'. (&) :: a -> (a -> b) -> b x & f = f x +#endif + +#if __GLASGOW_HASKELL__ >= 821 +import Data.Functor ((<&>)) +#else +-- | Flipped version of '<$>'. +-- +-- @ +-- ('<&>') = 'flip' 'fmap' +-- @ +-- +-- @since 4.11.0.0 +-- +-- ==== __Examples__ +-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right': +-- +-- >>> Just 2 <&> (+1) +-- Just 3 +-- +-- >>> [1,2,3] <&> (+1) +-- [2,3,4] +-- +-- >>> Right 3 <&> (+1) +-- Right 4 +-- +(<&>) :: Functor f => f a -> (a -> b) -> f b +as <&> f = f <$> as + +infixl 1 <&> #endif diff --git a/src/Turtle/Bytes.hs b/src/Turtle/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Turtle/Bytes.hs @@ -0,0 +1,802 @@ +{-# LANGUAGE RankNTypes #-} + +{-| This module provides `ByteString` analogs of several utilities in + "Turtle.Prelude". The main difference is that the chunks of bytes read by + these utilities are not necessarily aligned to line boundaries. +-} + +module Turtle.Bytes ( + -- * Byte operations + stdin + , input + , inhandle + , stdout + , output + , outhandle + , append + , stderr + , strict + , compress + , decompress + , WindowBits(..) + , Zlib.defaultWindowBits + , fromUTF8 + , toUTF8 + + -- * Subprocess management + , proc + , shell + , procs + , shells + , inproc + , inshell + , inprocWithErr + , inshellWithErr + , procStrict + , shellStrict + , procStrictWithErr + , shellStrictWithErr + + , system + , stream + , streamWithErr + , systemStrict + , systemStrictWithErr + ) where + +import Control.Applicative +import Control.Concurrent.Async (Async, Concurrently(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Managed (MonadManaged(..)) +import Data.ByteString (ByteString) +import Data.Monoid +import Data.Streaming.Zlib (Inflate, Popper, PopperRes(..), WindowBits(..)) +import Data.Text (Text) +import Data.Text.Encoding (Decoding(..)) +import System.Exit (ExitCode(..)) +import System.IO (Handle) +import Turtle.Internal (ignoreSIGPIPE) +import Turtle.Prelude (ProcFailed(..), ShellFailed(..)) +import Turtle.Shell (Shell(..), FoldShell(..), fold, sh) + +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.STM as STM +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.STM.TQueue as TQueue +import qualified Control.Exception as Exception +import qualified Control.Foldl +import qualified Control.Monad +import qualified Control.Monad.Managed as Managed +import qualified Data.ByteString +import qualified Data.Streaming.Zlib as Zlib +import qualified Data.Text +import qualified Data.Text.Encoding as Encoding +import qualified Data.Text.Encoding.Error as Encoding.Error +import qualified Foreign +import qualified System.IO +import qualified System.Process as Process +import qualified Turtle.Prelude + +{-| Read chunks of bytes from standard input + + The chunks are not necessarily aligned to line boundaries +-} +stdin :: Shell ByteString +stdin = inhandle System.IO.stdin + +{-| Read chunks of bytes from a file + + The chunks are not necessarily aligned to line boundaries +-} +input :: FilePath -> Shell ByteString +input file = do + handle <- using (Turtle.Prelude.readonly file) + inhandle handle + +{-| Read chunks of bytes from a `Handle` + + The chunks are not necessarily aligned to line boundaries +-} +inhandle :: Handle -> Shell ByteString +inhandle handle = Shell (\(FoldShell step begin done) -> do + let loop x = do + eof <- System.IO.hIsEOF handle + if eof + then done x + else do + bytes <- Data.ByteString.hGetSome handle defaultChunkSize + x' <- step x bytes + loop $! x' + loop $! begin ) + where + -- Copied from `Data.ByteString.Lazy.Internal` + defaultChunkSize :: Int + defaultChunkSize = 32 * 1024 - 2 * Foreign.sizeOf (undefined :: Int) + +{-| Stream chunks of bytes to standard output + + The chunks are not necessarily aligned to line boundaries +-} +stdout :: MonadIO io => Shell ByteString -> io () +stdout s = sh (do + bytes <- s + liftIO (Data.ByteString.hPut System.IO.stdout bytes) ) + +{-| Stream chunks of bytes to a file + + The chunks do not need to be aligned to line boundaries +-} +output :: MonadIO io => FilePath -> Shell ByteString -> io () +output file s = sh (do + handle <- using (Turtle.Prelude.writeonly file) + bytes <- s + liftIO (Data.ByteString.hPut handle bytes) ) + +{-| Stream chunks of bytes to a `Handle` + + The chunks do not need to be aligned to line boundaries +-} +outhandle :: MonadIO io => Handle -> Shell ByteString -> io () +outhandle handle s = sh (do + bytes <- s + liftIO (Data.ByteString.hPut handle bytes) ) + +{-| Append chunks of bytes to append to a file + + The chunks do not need to be aligned to line boundaries +-} +append :: MonadIO io => FilePath -> Shell ByteString -> io () +append file s = sh (do + handle <- using (Turtle.Prelude.appendonly file) + bytes <- s + liftIO (Data.ByteString.hPut handle bytes) ) + +{-| Stream chunks of bytes to standard error + + The chunks do not need to be aligned to line boundaries +-} +stderr :: MonadIO io => Shell ByteString -> io () +stderr s = sh (do + bytes <- s + liftIO (Data.ByteString.hPut System.IO.stderr bytes) ) + +-- | Read in a stream's contents strictly +strict :: MonadIO io => Shell ByteString -> io ByteString +strict s = do + listOfByteStrings <- fold s Control.Foldl.list + return (Data.ByteString.concat listOfByteStrings) + +{-| Run a command using @execvp@, retrieving the exit code + + The command inherits @stdout@ and @stderr@ for the current process +-} +proc + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io ExitCode + -- ^ Exit code +proc cmd args = + system + ( (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args)) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.Inherit + , Process.std_err = Process.Inherit + } ) + +{-| Run a command line using the shell, retrieving the exit code + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stdout@ and @stderr@ for the current process +-} +shell + :: MonadIO io + => Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io ExitCode + -- ^ Exit code +shell cmdline = + system + ( (Process.shell (Data.Text.unpack cmdline)) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.Inherit + , Process.std_err = Process.Inherit + } ) + +{-| This function is identical to `proc` except this throws `ProcFailed` for + non-zero exit codes +-} +procs + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io () +procs cmd args s = do + exitCode <- proc cmd args s + case exitCode of + ExitSuccess -> return () + _ -> liftIO (Exception.throwIO (ProcFailed cmd args exitCode)) + +{-| This function is identical to `shell` except this throws `ShellFailed` for + non-zero exit codes +-} +shells + :: MonadIO io + => Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io () + -- ^ Exit code +shells cmdline s = do + exitCode <- shell cmdline s + case exitCode of + ExitSuccess -> return () + _ -> liftIO (Exception.throwIO (ShellFailed cmdline exitCode)) + +{-| Run a command using @execvp@, retrieving the exit code and stdout as a + non-lazy blob of Text + + The command inherits @stderr@ for the current process +-} +procStrict + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString) + -- ^ Exit code and stdout +procStrict cmd args = + systemStrict (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args)) + +{-| Run a command line using the shell, retrieving the exit code and stdout as a + non-lazy blob of Text + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stderr@ for the current process +-} +shellStrict + :: MonadIO io + => Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString) + -- ^ Exit code and stdout +shellStrict cmdline = systemStrict (Process.shell (Data.Text.unpack cmdline)) + +{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr + as a non-lazy blob of Text +-} +procStrictWithErr + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString, ByteString) + -- ^ (Exit code, stdout, stderr) +procStrictWithErr cmd args = + systemStrictWithErr (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args)) + +{-| Run a command line using the shell, retrieving the exit code, stdout, and + stderr as a non-lazy blob of Text + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input +-} +shellStrictWithErr + :: MonadIO io + => Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString, ByteString) + -- ^ (Exit code, stdout, stderr) +shellStrictWithErr cmdline = + systemStrictWithErr (Process.shell (Data.Text.unpack cmdline)) + +-- | Halt an `Async` thread, re-raising any exceptions it might have thrown +halt :: Async a -> IO () +halt a = do + m <- Async.poll a + case m of + Nothing -> Async.cancel a + Just (Left e) -> Exception.throwIO e + Just (Right _) -> return () + +{-| `system` generalizes `shell` and `proc` by allowing you to supply your own + custom `CreateProcess`. This is for advanced users who feel comfortable + using the lower-level @process@ API +-} +system + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io ExitCode + -- ^ Exit code +system p s = liftIO (do + let open = do + (m, Nothing, Nothing, ph) <- Process.createProcess p + case m of + Just hIn -> System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing) + _ -> return () + return (m, ph) + + -- Prevent double close + mvar <- MVar.newMVar False + let close handle = do + MVar.modifyMVar_ mvar (\finalized -> do + Control.Monad.unless finalized + (ignoreSIGPIPE (System.IO.hClose handle)) + return True ) + let close' (Just hIn, ph) = do + close hIn + Process.terminateProcess ph + close' (Nothing , ph) = do + Process.terminateProcess ph + + let handle (Just hIn, ph) = do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (outhandle hIn s)) + `Exception.finally` close hIn + Exception.mask (\restore -> + Async.withAsync (feedIn restore) (\a -> + restore (Process.waitForProcess ph) <* halt a ) ) + handle (Nothing , ph) = do + Process.waitForProcess ph + + Exception.bracket open close' handle ) + +{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to + supply your own custom `CreateProcess`. This is for advanced users who feel + comfortable using the lower-level @process@ API +-} +systemStrict + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString) + -- ^ Exit code and stdout +systemStrict p s = liftIO (do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.Inherit + } + + let open = do + (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') + System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing) + return (hIn, hOut, ph) + + -- Prevent double close + mvar <- MVar.newMVar False + let close handle = do + MVar.modifyMVar_ mvar (\finalized -> do + Control.Monad.unless finalized + (ignoreSIGPIPE (System.IO.hClose handle)) + return True ) + + Exception.bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (outhandle hIn s)) + `Exception.finally` close hIn + + Async.concurrently + (Exception.mask (\restore -> + Async.withAsync (feedIn restore) (\a -> + restore (Process.waitForProcess ph) <* halt a ) )) + (Data.ByteString.hGetContents hOut) ) ) + +{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and + `procStrictWithErr` by allowing you to supply your own custom + `CreateProcess`. This is for advanced users who feel comfortable using + the lower-level @process@ API +-} +systemStrictWithErr + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> io (ExitCode, ByteString, ByteString) + -- ^ Exit code and stdout +systemStrictWithErr p s = liftIO (do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + let open = do + (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') + System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing) + return (hIn, hOut, hErr, ph) + + -- Prevent double close + mvar <- MVar.newMVar False + let close handle = do + MVar.modifyMVar_ mvar (\finalized -> do + Control.Monad.unless finalized + (ignoreSIGPIPE (System.IO.hClose handle)) + return True ) + + Exception.bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (outhandle hIn s)) + `Exception.finally` close hIn + + runConcurrently $ (,,) + <$> Concurrently (Exception.mask (\restore -> + Async.withAsync (feedIn restore) (\a -> + restore (Process.waitForProcess ph) <* halt a ) )) + <*> Concurrently (Data.ByteString.hGetContents hOut) + <*> Concurrently (Data.ByteString.hGetContents hErr) ) ) + +{-| Run a command using @execvp@, streaming @stdout@ as chunks of `ByteString` + + The command inherits @stderr@ for the current process +-} +inproc + :: Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell ByteString + -- ^ Chunks of bytes read from process output +inproc cmd args = + stream (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args)) + +{-| Run a command line using the shell, streaming @stdout@ as chunks of + `ByteString` + + This command is more powerful than `inproc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stderr@ for the current process +-} +inshell + :: Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell ByteString + -- ^ Chunks of bytes read from process output +inshell cmd = stream (Process.shell (Data.Text.unpack cmd)) + +waitForProcessThrows :: Process.ProcessHandle -> IO () +waitForProcessThrows ph = do + exitCode <- Process.waitForProcess ph + case exitCode of + ExitSuccess -> return () + ExitFailure _ -> Exception.throwIO exitCode + +{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your + own custom `CreateProcess`. This is for advanced users who feel comfortable + using the lower-level @process@ API + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +stream + :: Process.CreateProcess + -- ^ Command + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell ByteString + -- ^ Chunks of bytes read from process output +stream p s = do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.Inherit + } + + let open = do + (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') + System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing) + return (hIn, hOut, ph) + + -- Prevent double close + mvar <- liftIO (MVar.newMVar False) + let close handle = do + MVar.modifyMVar_ mvar (\finalized -> do + Control.Monad.unless finalized (ignoreSIGPIPE (System.IO.hClose handle)) + return True ) + + (hIn, hOut, ph) <- using (Managed.managed (Exception.bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph))) + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (sh (do + bytes <- s + liftIO (Data.ByteString.hPut hIn bytes) ) ) ) + `Exception.finally` close hIn + + a <- using + (Managed.managed (\k -> + Exception.mask (\restore -> + Async.withAsync (feedIn restore) k ) )) + inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty) + +{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing + you to supply your own custom `CreateProcess`. This is for advanced users + who feel comfortable using the lower-level @process@ API + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +streamWithErr + :: Process.CreateProcess + -- ^ Command + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell (Either ByteString ByteString) + -- ^ Chunks of bytes read from process output +streamWithErr p s = do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + let open = do + (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') + System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing) + return (hIn, hOut, hErr, ph) + + -- Prevent double close + mvar <- liftIO (MVar.newMVar False) + let close handle = do + MVar.modifyMVar_ mvar (\finalized -> do + Control.Monad.unless finalized (ignoreSIGPIPE (System.IO.hClose handle)) + return True ) + + (hIn, hOut, hErr, ph) <- using (Managed.managed (Exception.bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph))) + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (sh (do + bytes <- s + liftIO (Data.ByteString.hPut hIn bytes) ) ) ) + `Exception.finally` close hIn + + queue <- liftIO TQueue.newTQueueIO + let forwardOut :: (forall a. IO a -> IO a) -> IO () + forwardOut restore = + restore (sh (do + bytes <- inhandle hOut + liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right bytes)))) )) + `Exception.finally` STM.atomically (TQueue.writeTQueue queue Nothing) + let forwardErr :: (forall a. IO a -> IO a) -> IO () + forwardErr restore = + restore (sh (do + bytes <- inhandle hErr + liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left bytes)))) )) + `Exception.finally` STM.atomically (TQueue.writeTQueue queue Nothing) + let drain = Shell (\(FoldShell step begin done) -> do + let loop x numNothing + | numNothing < 2 = do + m <- STM.atomically (TQueue.readTQueue queue) + case m of + Nothing -> loop x $! numNothing + 1 + Just e -> do + x' <- step x e + loop x' numNothing + | otherwise = return x + x1 <- loop begin (0 :: Int) + done x1 ) + + a <- using + (Managed.managed (\k -> + Exception.mask (\restore -> + Async.withAsync (feedIn restore) k ) )) + b <- using + (Managed.managed (\k -> + Exception.mask (\restore -> + Async.withAsync (forwardOut restore) k ) )) + c <- using + (Managed.managed (\k -> + Exception.mask (\restore -> + Async.withAsync (forwardErr restore) k ) )) + let l `also` r = do + _ <- l <|> (r *> STM.retry) + _ <- r + return () + let waitAll = STM.atomically (Async.waitSTM a `also` (Async.waitSTM b `also` Async.waitSTM c)) + drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty) + +{-| Run a command using the shell, streaming @stdout@ and @stderr@ as chunks of + `ByteString`. Chunks from @stdout@ are wrapped in `Right` and chunks from + @stderr@ are wrapped in `Left`. + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +inprocWithErr + :: Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell (Either ByteString ByteString) + -- ^ Chunks of either output (`Right`) or error (`Left`) +inprocWithErr cmd args = + streamWithErr (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args)) + + +{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as + chunks of `ByteString`. Chunks from @stdout@ are wrapped in `Right` and + chunks from @stderr@ are wrapped in `Left`. + + This command is more powerful than `inprocWithErr`, but highly vulnerable to + code injection if you template the command line with untrusted input + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +inshellWithErr + :: Text + -- ^ Command line + -> Shell ByteString + -- ^ Chunks of bytes written to process input + -> Shell (Either ByteString ByteString) + -- ^ Chunks of either output (`Right`) or error (`Left`) +inshellWithErr cmd = streamWithErr (Process.shell (Data.Text.unpack cmd)) + +-- | Internal utility used by both `compress` and `decompress` +fromPopper :: Popper -> Shell ByteString +fromPopper popper = loop + where + loop = do + result <- liftIO popper + + case result of + PRDone -> + empty + PRNext compressedByteString -> + return compressedByteString <|> loop + PRError exception -> + liftIO (Exception.throwIO exception) + +{-| Compress a stream using @zlib@ + + Note that this can decompress streams that are the concatenation of + multiple compressed streams (just like @gzip@) + +>>> let compressed = select [ "ABC", "DEF" ] & compress 0 defaultWindowBits +>>> compressed & decompress defaultWindowBits & view +"ABCDEF" +>>> (compressed <|> compressed) & decompress defaultWindowBits & view +"ABCDEF" +"ABCDEF" +-} +compress + :: Int + -- ^ Compression level + -> WindowBits + -- ^ + -> Shell ByteString + -- ^ + -> Shell ByteString +compress compressionLevel windowBits bytestrings = do + deflate <- liftIO (Zlib.initDeflate compressionLevel windowBits) + + let loop = do + bytestring <- bytestrings + + popper <- liftIO (Zlib.feedDeflate deflate bytestring) + + fromPopper popper + + let wrapUp = do + let popper = liftIO (Zlib.finishDeflate deflate) + + fromPopper popper + + loop <|> wrapUp + +data DecompressionState = Uninitialized | Decompressing Inflate + +-- | Decompress a stream using @zlib@ (just like the @gzip@ command) +decompress :: WindowBits -> Shell ByteString -> Shell ByteString +decompress windowBits (Shell k) = Shell k' + where + k' (FoldShell step begin done) = k (FoldShell step' begin' done') + where + begin' = (begin, Uninitialized) + + step' (x0, Uninitialized) compressedByteString = do + inflate <- Zlib.initInflate windowBits + + step' (x0, Decompressing inflate) compressedByteString + step' (x0, Decompressing inflate) compressedByteString = do + popper <- Zlib.feedInflate inflate compressedByteString + + let loop x = do + result <- popper + + case result of + PRDone -> do + compressedByteString' <- Zlib.getUnusedInflate inflate + + if Data.ByteString.null compressedByteString' + then return (x, Decompressing inflate) + else do + decompressedByteString <- Zlib.finishInflate inflate + + x' <- step x decompressedByteString + + step' (x', Uninitialized) compressedByteString' + PRNext decompressedByteString -> do + x' <- step x decompressedByteString + + loop x' + PRError exception -> do + Exception.throwIO exception + + loop x0 + + done' (x0, Uninitialized) = do + done x0 + done' (x0, Decompressing inflate) = do + decompressedByteString <- Zlib.finishInflate inflate + + x0' <- step x0 decompressedByteString + + done' (x0', Uninitialized) + +{-| Decode a stream of bytes as UTF8 `Text` + + NOTE: This function will throw a pure exception (i.e. an `error`) if UTF8 + decoding fails (mainly due to limitations in the @text@ package's stream + decoding API) +-} +toUTF8 :: Shell ByteString -> Shell Text +toUTF8 (Shell k) = Shell k' + where + k' (FoldShell step begin done) = + k (FoldShell step' begin' done') + where + begin' = + (mempty, Encoding.streamDecodeUtf8With Encoding.Error.strictDecode, begin) + + step' (prefix, decoder, x) suffix = do + let bytes = prefix <> suffix + + let Some text prefix' decoder' = decoder bytes + + x' <- step x text + + return (prefix', decoder', x') + + done' (_, _, x) = do + done x + +-- | Encode a stream of bytes as UTF8 `Text` +fromUTF8 :: Shell Text -> Shell ByteString +fromUTF8 = fmap Encoding.encodeUtf8 diff --git a/src/Turtle/Format.hs b/src/Turtle/Format.hs --- a/src/Turtle/Format.hs +++ b/src/Turtle/Format.hs @@ -42,10 +42,11 @@ module Turtle.Format ( -- * Format - Format + Format (..) , (%) , format , printf + , eprintf , makeFormat -- * Parameters @@ -58,6 +59,7 @@ , e , g , s + , l , fp , utc @@ -72,11 +74,13 @@ import Data.Text (Text, pack) import Data.Time (UTCTime) import Data.Word -import Filesystem.Path.CurrentOS (FilePath, toText) import Numeric (showEFloat, showFFloat, showGFloat, showHex, showOct) -import Prelude hiding ((.), id, FilePath) +import Prelude hiding ((.), id) +import qualified System.IO as IO +import Turtle.Line (Line) import qualified Data.Text.IO as Text +import qualified Turtle.Line -- | A `Format` string newtype Format a b = Format { (>>-) :: (Text -> a) -> b } @@ -110,6 +114,14 @@ printf :: MonadIO io => Format (io ()) r -> r printf fmt = fmt >>- (liftIO . Text.putStr) +{-| Print a `Format` string to standard err (without a trailing newline) + +>>> eprintf ("Hello, "%s%"!\n") "world" +Hello, world! +-} +eprintf :: MonadIO io => Format (io ()) r -> r +eprintf fmt = fmt >>- (liftIO . Text.hPutStr IO.stderr) + -- | Create your own format specifier makeFormat :: (a -> Text) -> Format r (a -> r) makeFormat k = Format (\return_ -> \a -> return_ (k a)) @@ -194,20 +206,27 @@ s :: Format r (Text -> r) s = makeFormat id --- | `Format` a `Filesystem.Path.CurrentOS.FilePath` into `Text` +{-| `Format` that inserts a `Line` + +>>> format l "ABC" +"ABC" +-} +l :: Format r (Line -> r) +l = makeFormat Turtle.Line.lineToText + +-- | `Format` a `FilePath` into `Text` fp :: Format r (FilePath -> r) -fp = makeFormat (\fpath -> either id id (toText fpath)) +fp = makeFormat pack -- | `Format` a `UTCTime` into `Text` utc :: Format r (UTCTime -> r) utc = w -{-| Convert a `Show`able value to `Text` - - Short-hand for @(format w)@ +{-| Convert a `Show`able value to any type that implements `IsString` (such as + `Text`) >>> repr (1,2) "(1,2)" -} -repr :: Show a => a -> Text -repr = format w +repr :: (Show a, IsString text) => a -> text +repr = fromString . show diff --git a/src/Turtle/Internal.hs b/src/Turtle/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Turtle/Internal.hs @@ -0,0 +1,249 @@ +module Turtle.Internal where + +import Control.Applicative ((<|>)) +import Control.Exception (handle, throwIO) +import Data.Text (Text) +import Foreign.C.Error (Errno(..), ePIPE) +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import System.FilePath (()) + +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified System.FilePath as FilePath + +ignoreSIGPIPE :: IO () -> IO () +ignoreSIGPIPE = handle (\e -> case e of + IOError + { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + ) + +{-| Convert a `FilePath` to human-readable `Text` + + Note that even though the type says `Either` this utility actually always + succeeds and returns a `Right` value. The only reason for the `Either` is + compatibility with the old type from the @system-filepath@ package. +-} +toText :: FilePath -> Either Text Text +toText = Right . Text.pack +{-# DEPRECATED toText "Use Data.Text.pack instead" #-} + +-- | Convert `Text` to a `FilePath` +fromText :: Text -> FilePath +fromText = Text.unpack +{-# DEPRECATED fromText "Use Data.Text.unpack instead" #-} + +-- | Convert a `String` to a `FilePath` +decodeString :: String -> FilePath +decodeString = id +{-# DEPRECATED decodeString "Use id instead" #-} + +-- | Convert a `FilePath` to a `String` +encodeString :: FilePath -> String +encodeString = id +{-# DEPRECATED encodeString "Use id instead" #-} + +-- | Find the greatest common prefix between a list of `FilePath`s +commonPrefix :: [FilePath] -> FilePath +commonPrefix [ ] = mempty +commonPrefix (path : paths) = foldr longestPathPrefix path paths + where + longestPathPrefix left right + | leftComponents == rightComponents = + FilePath.joinPath leftComponents + ++ mconcat (longestPrefix leftExtensions rightExtensions) + | otherwise = + FilePath.joinPath (longestPrefix leftComponents rightComponents) + where + (leftComponents, leftExtensions) = splitExt (splitDirectories left) + + (rightComponents, rightExtensions) = splitExt (splitDirectories right) + +longestPrefix :: Eq a => [a] -> [a] -> [a] +longestPrefix (l : ls) (r : rs) + | l == r = l : longestPrefix ls rs +longestPrefix _ _ = [ ] + +-- | Remove a prefix from a path +stripPrefix :: FilePath -> FilePath -> Maybe FilePath +stripPrefix prefix path = do + componentSuffix <- List.stripPrefix prefixComponents pathComponents + + if null componentSuffix + then do + prefixSuffix <- List.stripPrefix prefixExtensions pathExtensions + + return (mconcat prefixSuffix) + else do + return (FilePath.joinPath componentSuffix ++ mconcat pathExtensions) + where + (prefixComponents, prefixExtensions) = splitExt (splitDirectories prefix) + + (pathComponents, pathExtensions) = splitExt (splitDirectories path) + +-- Internal helper function for `stripPrefix` and `commonPrefix` +splitExt :: [FilePath] -> ([FilePath], [String]) +splitExt [ component ] = ([ base ], map ("." ++) exts) + where + (base, exts) = splitExtensions component +splitExt [ ] = + ([ ], [ ]) +splitExt (component : components) = (component : base, exts) + where + (base, exts) = splitExt components + +-- | Normalise a path +collapse :: FilePath -> FilePath +collapse = FilePath.normalise +{-# DEPRECATED collapse "Use System.FilePath.normalise instead" #-} + +-- | Read in a file as `Text` +readTextFile :: FilePath -> IO Text +readTextFile = Text.IO.readFile +{-# DEPRECATED readTextFile "Use Data.Text.IO.readFile instead" #-} + +-- | Write out a file as `Text` +writeTextFile :: FilePath -> Text -> IO () +writeTextFile = Text.IO.writeFile +{-# DEPRECATED writeTextFile "Use Data.Text.IO.writeFile instead" #-} + +-- | Retrieves the `FilePath`'s root +root :: FilePath -> FilePath +root = fst . FilePath.splitDrive + +-- | Retrieves the `FilePath`'s parent directory +parent :: FilePath -> FilePath +parent path = prefix suffix + where + (drive, rest) = FilePath.splitDrive path + + components = loop (splitDirectories rest) + + prefix = + case components of + "./" : _ -> drive + "../" : _ -> drive + _ | null drive -> "./" + | otherwise -> drive + + suffix = FilePath.joinPath components + + loop [ _ ] = [ ] + loop [ ] = [ ] + loop (c : cs) = c : loop cs + +-- | Retrieves the `FilePath`'s directory +directory :: FilePath -> FilePath +directory path + | prefix == "" && suffix == ".." = + "../" + | otherwise = + trailingSlash (FilePath.takeDirectory prefix) ++ suffix + where + (prefix, suffix) = trailingParent path + where + trailingParent ".." = ("" , "..") + trailingParent [ a, b ] = ([ a, b ], "" ) + trailingParent [ a ] = ([ a ] , "" ) + trailingParent [ ] = ([ ] , "" ) + trailingParent (c : cs) = (c : p, s) + where + ~(p, s) = trailingParent cs + + trailingSlash "" = "/" + trailingSlash "/" = "/" + trailingSlash (c : cs) = c : trailingSlash cs + +-- | Retrieves the `FilePath`'s filename component +filename :: FilePath -> FilePath +filename path + | result == "." || result == ".." = "" + | otherwise = result + where + result = FilePath.takeFileName path + +-- | Retrieve a `FilePath`'s directory name +dirname :: FilePath -> FilePath +dirname path = loop (splitDirectories path) + where + loop [ x, y ] = + case deslash y <|> deslash x of + Just name -> name + Nothing -> "" + loop [ x ] = + case deslash x of + Just name -> name + Nothing -> "" + loop [ ] = + "" + loop (_ : xs) = + loop xs + + deslash "" = Nothing + deslash "/" = Just "" + deslash (c : cs) = fmap (c :) (deslash cs) + +-- | Retrieve a `FilePath`'s basename component +basename :: FilePath -> String +basename path = + case name of + '.' : _ -> name + _ -> + case splitExtensions name of + (base, _) -> base + where + name = filename path + +-- | Test whether a path is absolute +absolute :: FilePath -> Bool +absolute = FilePath.isAbsolute +{-# DEPRECATED absolute "Use System.FilePath.isAbsolute instead" #-} + +-- | Test whether a path is relative +relative :: FilePath -> Bool +relative = FilePath.isRelative +{-# DEPRECATED relative "Use System.FilePath.isRelative instead" #-} + +-- | Split a `FilePath` into its components +splitDirectories :: FilePath -> [FilePath] +splitDirectories path = loop (FilePath.splitPath path) + where + loop [ ] = [ ] + loop [ ".." ] = [ "../" ] + loop [ "." ] = [ "./" ] + loop (c : cs) = c : loop cs + +-- | Get a `FilePath`'s last extension, or `Nothing` if it has no extension +extension :: FilePath -> Maybe String +extension path = + case suffix of + '.' : ext -> Just ext + _ -> Nothing + where + suffix = FilePath.takeExtension path + +-- | Split a `FilePath` on its extension +splitExtension :: FilePath -> (String, Maybe String) +splitExtension path = + case suffix of + '.' : ext -> (prefix, Just ext) + _ -> (prefix, Nothing) + where + (prefix, suffix) = FilePath.splitExtension path + +-- | Split a `FilePath` on its extensions +splitExtensions :: FilePath -> (String, [String]) +splitExtensions path0 = (prefix0, reverse exts0) + where + (prefix0, exts0) = loop path0 + + loop path = case splitExtension path of + (prefix, Just ext) -> + (base, ext : exts) + where + (base, exts) = loop prefix + (base, Nothing) -> + (base, []) diff --git a/src/Turtle/Line.hs b/src/Turtle/Line.hs new file mode 100644 --- /dev/null +++ b/src/Turtle/Line.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Turtle.Line + ( Line + , lineToText + , textToLines + , linesToText + , textToLine + , unsafeTextToLine + , NewlineForbidden(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +#if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce +#endif +import Data.List.NonEmpty (NonEmpty(..)) +import Data.String +#if __GLASGOW_HASKELL__ >= 710 +#else +import Data.Monoid +#endif +import Data.Maybe +import Data.Typeable +import Control.Exception + +import qualified Data.List.NonEmpty + +-- | The `NewlineForbidden` exception is thrown when you construct a `Line` +-- using an overloaded string literal or by calling `fromString` explicitly +-- and the supplied string contains newlines. This is a programming error to +-- do so: if you aren't sure that the input string is newline-free, do not +-- rely on the @`IsString` `Line`@ instance. +-- +-- When debugging, it might be useful to look for implicit invocations of +-- `fromString` for `Line`: +-- +-- > >>> sh (do { line <- "Hello\nWorld"; echo line }) +-- > *** Exception: NewlineForbidden +-- +-- In the above example, `echo` expects its argument to be a `Line`, thus +-- @line :: `Line`@. Since we bind @line@ in `Shell`, the string literal +-- @\"Hello\\nWorld\"@ has type @`Shell` `Line`@. The +-- @`IsString` (`Shell` `Line`)@ instance delegates the construction of a +-- `Line` to the @`IsString` `Line`@ instance, where the exception is thrown. +-- +-- To fix the problem, use `textToLines`: +-- +-- > >>> sh (do { line <- select (textToLines "Hello\nWorld"); echo line }) +-- > Hello +-- > World +data NewlineForbidden = NewlineForbidden + deriving (Show, Typeable) + +instance Exception NewlineForbidden + +-- | A line of text (does not contain newlines). +newtype Line = Line Text + deriving (Eq, Ord, Show, Monoid) + +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup Line where + (<>) = mappend +#endif + +instance IsString Line where + fromString = fromMaybe (throw NewlineForbidden) . textToLine . fromString + +-- | Convert a line to a text value. +lineToText :: Line -> Text +lineToText (Line t) = t + +-- | Split text into lines. The inverse of `linesToText`. +textToLines :: Text -> NonEmpty Line +textToLines = +#if __GLASGOW_HASKELL__ >= 708 + Data.List.NonEmpty.fromList . coerce (Text.splitOn "\n") +#else + Data.List.NonEmpty.fromList . map unsafeTextToLine . Text.splitOn "\n" +#endif + +-- | Merge lines into a single text value. +linesToText :: [Line] -> Text +linesToText = +#if __GLASGOW_HASKELL__ >= 708 + coerce Text.unlines +#else + Text.unlines . map lineToText +#endif + +-- | Try to convert a text value into a line. +-- Precondition (checked): the argument does not contain newlines. +textToLine :: Text -> Maybe Line +textToLine = fromSingleton . textToLines + where + fromSingleton (a :| []) = Just a + fromSingleton _ = Nothing + +-- | Convert a text value into a line. +-- Precondition (unchecked): the argument does not contain newlines. +unsafeTextToLine :: Text -> Line +unsafeTextToLine = Line diff --git a/src/Turtle/Options.hs b/src/Turtle/Options.hs --- a/src/Turtle/Options.hs +++ b/src/Turtle/Options.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Example usage of this module: -- @@ -14,8 +17,8 @@ -- > -- > main = do -- > (name, age) <- options "Greeting script" parser --- > echo (format ("Hello there, "%s) name) --- > echo (format ("You are "%d%" years old") age) +-- > echo (repr (format ("Hello there, "%s) name)) +-- > echo (repr (format ("You are "%d%" years old") age)) -- -- > $ ./options --name John --age 42 -- > Hello there, John @@ -46,6 +49,7 @@ -- * Flag-based option parsers , switch , optText + , optLine , optInt , optInteger , optDouble @@ -55,6 +59,7 @@ -- * Positional argument parsers , argText + , argLine , argInt , argInteger , argDouble @@ -64,7 +69,9 @@ -- * Consume parsers , subcommand + , subcommandGroup , options + , optionsExt ) where @@ -73,23 +80,56 @@ import Data.String (IsString) import Text.Read (readMaybe) import Data.Text (Text) -import qualified Data.Text as Text import Data.Optional import Control.Applicative import Control.Monad.IO.Class -import Filesystem.Path.CurrentOS (FilePath, fromText) import Options.Applicative (Parser) +import Text.PrettyPrint.ANSI.Leijen (Doc, displayS, renderCompact) +import Turtle.Line (Line) + +import qualified Data.Text as Text import qualified Options.Applicative as Opts import qualified Options.Applicative.Types as Opts -import Prelude hiding (FilePath) +import qualified Turtle.Line -- | Parse the given options from the command line options :: MonadIO io => Description -> Parser a -> io a options desc parser = liftIO - $ Opts.execParser + $ Opts.customExecParser (Opts.prefs prefs) $ Opts.info (Opts.helper <*> parser) - (Opts.header (Text.unpack (getDescription desc))) + (Opts.headerDoc (Just (getDescription desc))) + where + prefs :: Opts.PrefsMod +#if MIN_VERSION_optparse_applicative(0,13,0) + prefs = Opts.showHelpOnError <> Opts.showHelpOnEmpty +#else + prefs = Opts.showHelpOnError +#endif +{-| Parse the given options from the command line and add additional information + + Extended version of @options@ with program version header and footer information +-} +optionsExt :: MonadIO io => Header -> Footer -> Description -> Version -> Parser a -> io a +optionsExt header footer desc version parser = liftIO + $ Opts.customExecParser (Opts.prefs prefs) + $ Opts.info (Opts.helper <*> versionOption <*> parser) + (Opts.headerDoc (Just (getHeader header)) <> + Opts.footerDoc (Just (getFooter footer)) <> + Opts.progDescDoc (Just (getDescription desc))) + where + versionOption = + Opts.infoOption + (Text.unpack version) + (Opts.long "version" <> Opts.help "Show version") + prefs :: Opts.PrefsMod +#if MIN_VERSION_optparse_applicative(0,13,0) + prefs = Opts.showHelpOnError <> Opts.showHelpOnEmpty +#else + prefs = Opts.showHelpOnError +#endif + + {-| The name of a command-line argument This is used to infer the long name and metavariable for the command line @@ -115,9 +155,24 @@ This description will appear in the header of the @--help@ output -} -newtype Description = Description { getDescription :: Text } +newtype Description = Description { getDescription :: Doc } deriving (IsString) +{-| Header of the program + + This description will appear in the header of the @--help@ output +-} +newtype Header = Header { getHeader :: Doc } + deriving (IsString) +{-| Footer of the program + + This description will appear in the footer of the @--help@ output +-} +newtype Footer = Fotter { getFooter :: Doc } + deriving (IsString) + +-- | Program Version +type Version = Text {-| A helpful message explaining what a flag does This will appear in the @--help@ output @@ -174,9 +229,13 @@ optText :: ArgName -> ShortName -> Optional HelpMessage -> Parser Text optText = opt Just +-- | Parse a `Line` value as a flag-based option +optLine :: ArgName -> ShortName -> Optional HelpMessage -> Parser Line +optLine = opt Turtle.Line.textToLine + -- | Parse a `FilePath` value as a flag-based option optPath :: ArgName -> ShortName -> Optional HelpMessage -> Parser FilePath -optPath argName short msg = fmap fromText (optText argName short msg) +optPath argName short msg = fmap Text.unpack (optText argName short msg) {- | Build a positional argument parser for any type by providing a `Text`-parsing function @@ -210,16 +269,20 @@ argText :: ArgName -> Optional HelpMessage -> Parser Text argText = arg Just +-- | Parse a `Line` as a positional argument +argLine :: ArgName -> Optional HelpMessage -> Parser Line +argLine = arg Turtle.Line.textToLine + -- | Parse a `FilePath` as a positional argument argPath :: ArgName -> Optional HelpMessage -> Parser FilePath -argPath argName msg = fmap fromText (argText argName msg) +argPath argName msg = fmap Text.unpack (argText argName msg) argParseToReadM :: (Text -> Maybe a) -> Opts.ReadM a argParseToReadM f = do s <- Opts.readerAsk case f (Text.pack s) of Just a -> return a - Nothing -> Opts.readerAbort Opts.ShowHelpText + Nothing -> Opts.readerAbort (Opts.ShowHelpText Nothing) {-| Create a sub-command that parses `CommandName` and then parses the rest of the command-line arguments @@ -228,10 +291,28 @@ -} subcommand :: CommandName -> Description -> Parser a -> Parser a subcommand cmdName desc p = - Opts.subparser (Opts.command name info <> Opts.metavar name) + Opts.hsubparser (Opts.command name info <> Opts.metavar name) where name = Text.unpack (getCommandName cmdName) - info = Opts.info - (Opts.helper <*> p) - (Opts.header (Text.unpack (getDescription desc))) + info = Opts.info p (Opts.progDescDoc (Just (getDescription desc))) + +-- | Create a named group of sub-commands +subcommandGroup :: forall a. Description -> [(CommandName, Description, Parser a)] -> Parser a +subcommandGroup name cmds = + Opts.hsubparser (Opts.commandGroup name' <> foldMap f cmds <> Opts.metavar metavar) + where + f :: (CommandName, Description, Parser a) -> Opts.Mod Opts.CommandFields a + f (cmdName, desc, p) = + Opts.command + (Text.unpack (getCommandName cmdName)) + (Opts.info p (Opts.progDescDoc (Just (getDescription desc)))) + + metavar :: String + metavar = Text.unpack (Text.intercalate " | " (map g cmds)) + where + g :: (CommandName, Description, Parser a) -> Text + g (cmdName, _, _) = getCommandName cmdName + + name' :: String + name' = displayS (renderCompact (getDescription name)) "" diff --git a/src/Turtle/Pattern.hs b/src/Turtle/Pattern.hs --- a/src/Turtle/Pattern.hs +++ b/src/Turtle/Pattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -123,6 +124,11 @@ newtype Pattern a = Pattern { runPattern :: StateT Text [] a } deriving (Functor, Applicative, Monad, Alternative, MonadPlus) +#if __GLASGOW_HASKELL__ >= 804 +instance Monoid a => Semigroup (Pattern a) where + (<>) = mappend +#endif + instance Monoid a => Monoid (Pattern a) where mempty = pure mempty mappend = liftA2 mappend @@ -438,11 +444,15 @@ [] >>> match (invert "A") "B" [()] +>>> match (invert "A") "AA" +[()] -} invert :: Pattern a -> Pattern () -invert p = Pattern (StateT (\str -> case runStateT (runPattern p) str of - [] -> [((), "")] - _ -> [] )) +invert p = Pattern (StateT f) + where + f str = case match p str of + [] -> [((), "")] + _ -> [] {-| Match a `Char`, but return `Text` diff --git a/src/Turtle/Prelude.hs b/src/Turtle/Prelude.hs --- a/src/Turtle/Prelude.hs +++ b/src/Turtle/Prelude.hs @@ -3,1577 +3,2342 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} - --- | This module provides a large suite of utilities that resemble Unix --- utilities. --- --- Many of these commands are just existing Haskell commands renamed to match --- their Unix counterparts: --- --- >>> :set -XOverloadedStrings --- >>> cd "/tmp" --- >>> pwd --- FilePath "/tmp" --- --- Some commands are `Shell`s that emit streams of values. `view` prints all --- values in a `Shell` stream: --- --- >>> view (ls "/usr") --- FilePath "/usr/lib" --- FilePath "/usr/src" --- FilePath "/usr/sbin" --- FilePath "/usr/include" --- FilePath "/usr/share" --- FilePath "/usr/games" --- FilePath "/usr/local" --- FilePath "/usr/bin" --- >>> view (find (suffix "Browser.py") "/usr/lib") --- FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py" --- FilePath "/usr/lib/python3.4/idlelib/RemoteObjectBrowser.py" --- FilePath "/usr/lib/python3.4/idlelib/PathBrowser.py" --- FilePath "/usr/lib/python3.4/idlelib/ObjectBrowser.py" --- --- Use `fold` to reduce the output of a `Shell` stream: --- --- >>> import qualified Control.Foldl as Fold --- >>> fold (ls "/usr") Fold.length --- 8 --- >>> fold (find (suffix "Browser.py") "/usr/lib") Fold.head --- Just (FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py") --- --- Create files using `output`: --- --- >>> output "foo.txt" ("123" <|> "456" <|> "ABC") --- >>> realpath "foo.txt" --- FilePath "/tmp/foo.txt" --- --- Read in files using `input`: --- --- >>> stdout (input "foo.txt") --- 123 --- 456 --- ABC --- --- Format strings in a type safe way using `format`: --- --- >>> dir <- pwd --- >>> format ("I am in the "%fp%" directory") dir --- "I am in the /tmp directory" --- --- Commands like `grep`, `sed` and `find` accept arbitrary `Pattern`s --- --- >>> stdout (grep ("123" <|> "ABC") (input "foo.txt")) --- 123 --- ABC --- >>> let exclaim = fmap (<> "!") (plus digit) --- >>> stdout (sed exclaim (input "foo.txt")) --- 123! --- 456! --- ABC --- --- Note that `grep` and `find` differ from their Unix counterparts by requiring --- that the `Pattern` matches the entire line or file name by default. However, --- you can optionally match the prefix, suffix, or interior of a line: --- --- >>> stdout (grep (has "2") (input "foo.txt")) --- 123 --- >>> stdout (grep (prefix "1") (input "foo.txt")) --- 123 --- >>> stdout (grep (suffix "3") (input "foo.txt")) --- 123 --- --- You can also build up more sophisticated `Shell` programs using `sh` in --- conjunction with @do@ notation: --- --- >{-# LANGUAGE OverloadedStrings #-} --- > --- >import Turtle --- > --- >main = sh example --- > --- >example = do --- > -- Read in file names from "files1.txt" and "files2.txt" --- > file <- fmap fromText (input "files1.txt" <|> input "files2.txt") --- > --- > -- Stream each file to standard output only if the file exists --- > True <- liftIO (testfile file) --- > line <- input file --- > liftIO (echo line) --- --- See "Turtle.Tutorial" for an extended tutorial explaining how to use this --- library in greater detail. - -module Turtle.Prelude ( - -- * IO - echo - , err - , readline - , Filesystem.readTextFile - , Filesystem.writeTextFile - , arguments -#if MIN_VERSION_base(4,7,0) - , export - , unset -#endif -#if MIN_VERSION_base(4,6,0) - , need -#endif - , env - , cd - , pwd - , home - , realpath - , mv - , mkdir - , mktree - , cp - , rm - , rmdir - , rmtree - , testfile - , testdir - , testpath - , date - , datefile - , touch - , time - , hostname - , sleep - , exit - , die - , (.&&.) - , (.||.) - - -- * Managed - , readonly - , writeonly - , appendonly - , mktemp - , mktempfile - , mktempdir - , fork - , wait - - -- * Shell - , inproc - , inshell - , inprocWithErr - , inshellWithErr - , stdin - , input - , inhandle - , stdout - , output - , outhandle - , append - , stderr - , strict - , ls - , lsif - , lstree - , cat - , grep - , sed - , inplace - , find - , yes - , nl - , paste - , endless - , limit - , limitWhile - , cache - - -- * Folds - , countChars - , countWords - , countLines - - -- * Text - , cut - - -- * Subprocess management - , proc - , shell - , system - , procs - , shells - , procStrict - , shellStrict - - -- * Permissions - , Permissions - , chmod - , getmod - , setmod - , copymod - , readable, nonreadable - , writable, nonwritable - , executable, nonexecutable - , searchable, nonsearchable - , ooo,roo,owo,oox,oos,rwo,rox,ros,owx,rwx,rws - - -- * File size - , du - , Size - , sz - , bytes - , kilobytes - , megabytes - , gigabytes - , terabytes - , kibibytes - , mebibytes - , gibibytes - , tebibytes - - -- * Exceptions - , ProcFailed(..) - , ShellFailed(..) - ) where - -import Control.Applicative -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async - (Async, withAsync, withAsyncWithUnmask, wait, waitSTM, concurrently) -import Control.Concurrent.MVar (newMVar, modifyMVar_) -import qualified Control.Concurrent.STM as STM -import qualified Control.Concurrent.STM.TQueue as TQueue -import Control.Exception (Exception, bracket, finally, mask_, throwIO) -import Control.Foldl (Fold, FoldM(..), genericLength, handles, list, premap) -import qualified Control.Foldl.Text -import Control.Monad (liftM, msum, when, unless) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Managed (MonadManaged(..), managed, runManaged) -#ifdef mingw32_HOST_OS -import Data.Bits ((.&.)) -#endif -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Text (Text, pack, unpack) -import Data.Time (NominalDiffTime, UTCTime, getCurrentTime) -import Data.Traversable -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Typeable (Typeable) -import qualified Filesystem -import Filesystem.Path.CurrentOS (FilePath, ()) -import qualified Filesystem.Path.CurrentOS as Filesystem -import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) -import Network.HostName (getHostName) -import System.Clock (Clock(..), TimeSpec(..), getTime) -import System.Environment ( - getArgs, -#if MIN_VERSION_base(4,7,0) - setEnv, - unsetEnv, -#endif -#if MIN_VERSION_base(4,6,0) - lookupEnv, -#endif - getEnvironment ) -import System.Directory (Permissions) -import qualified System.Directory as Directory -import System.Exit (ExitCode(..), exitWith) -import System.IO (Handle, hClose) -import qualified System.IO as IO -import System.IO.Temp (withTempDirectory, withTempFile) -import System.IO.Error (catchIOError, ioeGetErrorType) -import qualified System.Process as Process -#ifdef mingw32_HOST_OS -import qualified System.Win32 as Win32 -#else -import System.Posix ( - openDirStream, - readDirStream, - closeDirStream, - touchFile, - getSymbolicLinkStatus, - isDirectory, - isSymbolicLink ) -#endif -import Prelude hiding (FilePath) - -import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy) -import Turtle.Shell -import Turtle.Format (Format, format, makeFormat, d, w, (%)) - -{-| Run a command using @execvp@, retrieving the exit code - - The command inherits @stdout@ and @stderr@ for the current process --} -proc - :: MonadIO io - => Text - -- ^ Command - -> [Text] - -- ^ Arguments - -> Shell Text - -- ^ Lines of standard input - -> io ExitCode - -- ^ Exit code -proc cmd args = - system - ( (Process.proc (unpack cmd) (map unpack args)) - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.Inherit - , Process.std_err = Process.Inherit - } ) - -{-| Run a command line using the shell, retrieving the exit code - - This command is more powerful than `proc`, but highly vulnerable to code - injection if you template the command line with untrusted input - - The command inherits @stdout@ and @stderr@ for the current process --} -shell - :: MonadIO io - => Text - -- ^ Command line - -> Shell Text - -- ^ Lines of standard input - -> io ExitCode - -- ^ Exit code -shell cmdLine = - system - ( (Process.shell (unpack cmdLine)) - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.Inherit - , Process.std_err = Process.Inherit - } ) - -data ProcFailed = ProcFailed - { procCommand :: Text - , procArguments :: [Text] - , procExitCode :: ExitCode - } deriving (Show, Typeable) - -instance Exception ProcFailed - -{-| This function is identical to `proc` except this throws `ProcFailed` for - non-zero exit codes --} -procs - :: MonadIO io - => Text - -- ^ Command - -> [Text] - -- ^ Arguments - -> Shell Text - -- ^ Lines of standard input - -> io () -procs cmd args s = do - exitCode <- proc cmd args s - case exitCode of - ExitSuccess -> return () - _ -> liftIO (throwIO (ProcFailed cmd args exitCode)) - -data ShellFailed = ShellFailed - { shellCommandLine :: Text - , shellExitCode :: ExitCode - } deriving (Show, Typeable) - -instance Exception ShellFailed - -{-| This function is identical to `shell` except this throws `ShellFailed` for - non-zero exit codes --} -shells - :: MonadIO io - => Text - -- ^ Command line - -> Shell Text - -- ^ Lines of standard input - -> io () - -- ^ Exit code -shells cmdline s = do - exitCode <- shell cmdline s - case exitCode of - ExitSuccess -> return () - _ -> liftIO (throwIO (ShellFailed cmdline exitCode)) - -{-| Run a command using @execvp@, retrieving the exit code and stdout as a - non-lazy blob of Text - - The command inherits @stderr@ for the current process --} -procStrict - :: MonadIO io - => Text - -- ^ Command - -> [Text] - -- ^ Arguments - -> Shell Text - -- ^ Lines of standard input - -> io (ExitCode, Text) - -- ^ Exit code and stdout -procStrict cmd args = - systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args)) - -{-| Run a command line using the shell, retrieving the exit code and stdout as a - non-lazy blob of Text - - This command is more powerful than `proc`, but highly vulnerable to code - injection if you template the command line with untrusted input - - The command inherits @stderr@ for the current process --} -shellStrict - :: MonadIO io - => Text - -- ^ Command line - -> Shell Text - -- ^ Lines of standard input - -> io (ExitCode, Text) - -- ^ Exit code and stdout -shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine)) - -{-| `system` generalizes `shell` and `proc` by allowing you to supply your own - custom `CreateProcess`. This is for advanced users who feel comfortable - using the lower-level @process@ API --} -system - :: MonadIO io - => Process.CreateProcess - -- ^ Command - -> Shell Text - -- ^ Lines of standard input - -> io ExitCode - -- ^ Exit code -system p s = liftIO (do - let open = do - (Just hIn, Nothing, Nothing, ph) <- Process.createProcess p - IO.hSetBuffering hIn IO.LineBuffering - return (hIn, ph) - - -- Prevent double close - mvar <- newMVar False - let close handle = do - modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) - return True ) - - bracket open (\(hIn, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, ph) -> do - let feedIn :: (forall a. IO a -> IO a) -> IO () - feedIn restore = - restore (sh (do - txt <- s - liftIO (Text.hPutStrLn hIn txt) ) ) - `finally` close hIn - mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a) ) ) ) - -systemStrict - :: MonadIO io - => Process.CreateProcess - -- ^ Command - -> Shell Text - -- ^ Lines of standard input - -> io (ExitCode, Text) - -- ^ Exit code and stdout -systemStrict p s = liftIO (do - let p' = p - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.Inherit - } - - let open = do - (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') - IO.hSetBuffering hIn IO.LineBuffering - return (hIn, hOut, ph) - - -- Prevent double close - mvar <- newMVar False - let close handle = do - modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) - return True ) - - bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do - let feedIn :: (forall a. IO a -> IO a) -> IO () - feedIn restore = - restore (sh (do - txt <- s - liftIO (Text.hPutStrLn hIn txt) ) ) - `finally` close hIn - - concurrently - (mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a))) - (Text.hGetContents hOut) ) ) - -{-| Run a command using @execvp@, streaming @stdout@ as lines of `Text` - - The command inherits @stderr@ for the current process --} -inproc - :: Text - -- ^ Command - -> [Text] - -- ^ Arguments - -> Shell Text - -- ^ Lines of standard input - -> Shell Text - -- ^ Lines of standard output -inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args)) - -{-| Run a command line using the shell, streaming @stdout@ as lines of `Text` - - This command is more powerful than `inproc`, but highly vulnerable to code - injection if you template the command line with untrusted input - - The command inherits @stderr@ for the current process --} -inshell - :: Text - -- ^ Command line - -> Shell Text - -- ^ Lines of standard input - -> Shell Text - -- ^ Lines of standard output -inshell cmd = stream (Process.shell (unpack cmd)) - -stream - :: Process.CreateProcess - -- ^ Command - -> Shell Text - -- ^ Lines of standard input - -> Shell Text - -- ^ Lines of standard output -stream p s = do - let p' = p - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.Inherit - } - - let open = do - (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') - IO.hSetBuffering hIn IO.LineBuffering - return (hIn, hOut, ph) - - -- Prevent double close - mvar <- liftIO (newMVar False) - let close handle = do - modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) - return True ) - - (hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph))) - let feedIn :: (forall a. IO a -> IO a) -> IO () - feedIn restore = - restore (sh (do - txt <- s - liftIO (Text.hPutStrLn hIn txt) ) ) - `finally` close hIn - - a <- using (managed (mask_ . withAsyncWithUnmask feedIn)) - inhandle hOut <|> (liftIO (Process.waitForProcess ph *> wait a) *> empty) - -streamWithErr - :: Process.CreateProcess - -- ^ Command - -> Shell Text - -- ^ Lines of standard input - -> Shell (Either Text Text) - -- ^ Lines of standard output -streamWithErr p s = do - let p' = p - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.CreatePipe - } - - let open = do - (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') - IO.hSetBuffering hIn IO.LineBuffering - return (hIn, hOut, hErr, ph) - - -- Prevent double close - mvar <- liftIO (newMVar False) - let close handle = do - modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) - return True ) - - (hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph))) - let feedIn :: (forall a. IO a -> IO a) -> IO () - feedIn restore = - restore (sh (do - txt <- s - liftIO (Text.hPutStrLn hIn txt) ) ) - `finally` close hIn - - queue <- liftIO TQueue.newTQueueIO - let forwardOut :: (forall a. IO a -> IO a) -> IO () - forwardOut restore = - restore (sh (do - txt <- inhandle hOut - liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right txt)))) )) - `finally` STM.atomically (TQueue.writeTQueue queue Nothing) - let forwardErr :: (forall a. IO a -> IO a) -> IO () - forwardErr restore = - restore (sh (do - txt <- inhandle hErr - liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left txt)))) )) - `finally` STM.atomically (TQueue.writeTQueue queue Nothing) - let drain = Shell (\(FoldM step begin done) -> do - x0 <- begin - let loop x numNothing - | numNothing < 2 = do - m <- STM.atomically (TQueue.readTQueue queue) - case m of - Nothing -> loop x $! numNothing + 1 - Just e -> do - x' <- step x e - loop x' numNothing - | otherwise = return x - x1 <- loop x0 (0 :: Int) - done x1 ) - - a <- using (managed (mask_ . withAsyncWithUnmask feedIn )) - b <- using (managed (mask_ . withAsyncWithUnmask forwardOut)) - c <- using (managed (mask_ . withAsyncWithUnmask forwardErr)) - let l `also` r = do - _ <- l <|> (r *> STM.retry) - _ <- r - return () - let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c)) - drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty) - -{-| Run a command using the shell, streaming @stdout@ and @stderr@ as lines of - `Text`. Lines from @stdout@ are wrapped in `Right` and lines from @stderr@ - are wrapped in `Left`. This does /not/ throw an exception if the command - returns a non-zero exit code --} -inprocWithErr - :: Text - -- ^ Command - -> [Text] - -- ^ Arguments - -> Shell Text - -- ^ Lines of standard input - -> Shell (Either Text Text) - -- ^ Lines of either standard output (`Right`) or standard error (`Left`) -inprocWithErr cmd args = - streamWithErr (Process.proc (unpack cmd) (map unpack args)) - - -{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as lines - of `Text`. Lines from @stdout@ are wrapped in `Right` and lines from - @stderr@ are wrapped in `Left`. This does /not/ throw an exception if the - command returns a non-zero exit code - - This command is more powerful than `inprocWithErr`, but highly vulnerable to - code injection if you template the command line with untrusted input --} -inshellWithErr - :: Text - -- ^ Command line - -> Shell Text - -- ^ Lines of standard input - -> Shell (Either Text Text) - -- ^ Lines of either standard output (`Right`) or standard error (`Left`) -inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd)) - --- | Print to @stdout@ -echo :: MonadIO io => Text -> io () -echo txt = liftIO (Text.putStrLn txt) - --- | Print to @stderr@ -err :: MonadIO io => Text -> io () -err txt = liftIO (Text.hPutStrLn IO.stderr txt) - -{-| Read in a line from @stdin@ - - Returns `Nothing` if at end of input --} -readline :: MonadIO io => io (Maybe Text) -readline = liftIO (do - eof <- IO.isEOF - if eof - then return Nothing - else fmap (Just . pack) getLine ) - --- | Get command line arguments in a list -arguments :: MonadIO io => io [Text] -arguments = liftIO (fmap (map pack) getArgs) - -#if MIN_VERSION_base(4,7,0) --- | Set or modify an environment variable -export :: MonadIO io => Text -> Text -> io () -export key val = liftIO (setEnv (unpack key) (unpack val)) - --- | Delete an environment variable -unset :: MonadIO io => Text -> io () -unset key = liftIO (unsetEnv (unpack key)) -#endif - -#if MIN_VERSION_base(4,6,0) --- | Look up an environment variable -need :: MonadIO io => Text -> io (Maybe Text) -need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key))) -#endif - --- | Retrieve all environment variables -env :: MonadIO io => io [(Text, Text)] -env = liftIO (fmap (fmap toTexts) getEnvironment) - where - toTexts (key, val) = (pack key, pack val) - --- | Change the current directory -cd :: MonadIO io => FilePath -> io () -cd path = liftIO (Filesystem.setWorkingDirectory path) - --- | Get the current directory -pwd :: MonadIO io => io FilePath -pwd = liftIO Filesystem.getWorkingDirectory - --- | Get the home directory -home :: MonadIO io => io FilePath -home = liftIO Filesystem.getHomeDirectory - --- | Canonicalize a path -realpath :: MonadIO io => FilePath -> io FilePath -realpath path = liftIO (Filesystem.canonicalizePath path) - -#ifdef mingw32_HOST_OS -fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag -fILE_ATTRIBUTE_REPARSE_POINT = 1024 - -reparsePoint :: Win32.FileAttributeOrFlag -> Bool -reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0 -#endif - -{-| Stream all immediate children of the given directory, excluding @\".\"@ and - @\"..\"@ --} -ls :: FilePath -> Shell FilePath -ls path = Shell (\(FoldM step begin done) -> do - x0 <- begin - let path' = Filesystem.encodeString path - canRead <- fmap - Directory.readable - (Directory.getPermissions (deslash path')) -#ifdef mingw32_HOST_OS - reparse <- fmap reparsePoint (Win32.getFileAttributes path') - if (canRead && not reparse) - then bracket - (Win32.findFirstFile (Filesystem.encodeString (path "*"))) - (\(h, _) -> Win32.findClose h) - (\(h, fdat) -> do - let loop x = do - file' <- Win32.getFindDataFileName fdat - let file = Filesystem.decodeString file' - x' <- if (file' /= "." && file' /= "..") - then step x (path file) - else return x - more <- Win32.findNextFile h fdat - if more then loop $! x' else done x' - loop $! x0 ) - else done x0 ) -#else - if canRead - then bracket (openDirStream path') closeDirStream (\dirp -> do - let loop x = do - file' <- readDirStream dirp - case file' of - "" -> done x - _ -> do - let file = Filesystem.decodeString file' - x' <- if (file' /= "." && file' /= "..") - then step x (path file) - else return x - loop $! x' - loop $! x0 ) - else done x0 ) -#endif - -{-| This is used to remove the trailing slash from a path, because - `getPermissions` will fail if a path ends with a trailing slash --} -deslash :: String -> String -deslash [] = [] -deslash (c0:cs0) = c0:go cs0 - where - go [] = [] - go ['\\'] = [] - go (c:cs) = c:go cs - --- | Stream all recursive descendents of the given directory -lstree :: FilePath -> Shell FilePath -lstree path = do - child <- ls path - isDir <- testdir child - if isDir - then return child <|> lstree child - else return child - -{-| Stream all recursive descendents of the given directory - - This skips any directories that fail the supplied predicate - -> lstree = lsif (\_ -> return True) --} -lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath -lsif predicate path = do - child <- ls path - isDir <- testdir child - if isDir - then do - continue <- liftIO (predicate child) - if continue - then return child <|> lsif predicate child - else return child - else return child - -{-| Move a file or directory - - Works if the two paths are on the same filesystem. - If not, @mv@ will still work when dealing with a regular file, - but the operation will not be atomic --} -mv :: MonadIO io => FilePath -> FilePath -> io () -mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath) - (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV - then do - Filesystem.copyFile oldPath newPath - Filesystem.removeFile oldPath - else ioError ioe) - -{-| Create a directory - - Fails if the directory is present --} -mkdir :: MonadIO io => FilePath -> io () -mkdir path = liftIO (Filesystem.createDirectory False path) - -{-| Create a directory tree (equivalent to @mkdir -p@) - - Does not fail if the directory is present --} -mktree :: MonadIO io => FilePath -> io () -mktree path = liftIO (Filesystem.createTree path) - --- | Copy a file -cp :: MonadIO io => FilePath -> FilePath -> io () -cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath) - --- | Remove a file -rm :: MonadIO io => FilePath -> io () -rm path = liftIO (Filesystem.removeFile path) - --- | Remove a directory -rmdir :: MonadIO io => FilePath -> io () -rmdir path = liftIO (Filesystem.removeDirectory path) - -{-| Remove a directory tree (equivalent to @rm -r@) - - Use at your own risk --} -rmtree :: MonadIO io => FilePath -> io () -rmtree path0 = liftIO (sh (loop path0)) - where -#ifdef mingw32_HOST_OS - loop path = do - isDir <- testdir path - if isDir - then (do - child <- ls path - loop child ) <|> rmdir path - else rm path -#else - loop path = do - let path' = Filesystem.encodeString path - stat <- liftIO $ getSymbolicLinkStatus path' - let isLink = isSymbolicLink stat - isDir = isDirectory stat - if isLink - then rm path - else do - if isDir - then (do - child <- ls path - loop child ) <|> rmdir path - else rm path -#endif - --- | Check if a file exists -testfile :: MonadIO io => FilePath -> io Bool -testfile path = liftIO (Filesystem.isFile path) - --- | Check if a directory exists -testdir :: MonadIO io => FilePath -> io Bool -testdir path = liftIO (Filesystem.isDirectory path) - --- | Check if a path exists -testpath :: MonadIO io => FilePath -> io Bool -testpath path = do - exists <- testfile path - if exists - then return exists - else testdir path - -{-| Touch a file, updating the access and modification times to the current time - - Creates an empty file if it does not exist --} -touch :: MonadIO io => FilePath -> io () -touch file = do - exists <- testfile file - liftIO (if exists -#ifdef mingw32_HOST_OS - then do - handle <- Win32.createFile - (Filesystem.encodeString file) - Win32.gENERIC_WRITE - Win32.fILE_SHARE_NONE - Nothing - Win32.oPEN_EXISTING - Win32.fILE_ATTRIBUTE_NORMAL - Nothing - (creationTime, _, _) <- Win32.getFileTime handle - systemTime <- Win32.getSystemTimeAsFileTime - Win32.setFileTime handle creationTime systemTime systemTime -#else - then touchFile (Filesystem.encodeString file) -#endif - else output file empty ) - -{-| Update a file or directory's user permissions - -> chmod rwo "foo.txt" -- chmod u=rw foo.txt -> chmod executable "foo.txt" -- chmod u+x foo.txt -> chmod nonwritable "foo.txt" -- chmod u-x foo.txt --} -chmod - :: MonadIO io - => (Permissions -> Permissions) - -- ^ Permissions update function - -> FilePath - -- ^ Path - -> io Permissions - -- ^ Updated permissions -chmod modifyPermissions path = liftIO (do - let path' = deslash (Filesystem.encodeString path) - permissions <- Directory.getPermissions path' - let permissions' = modifyPermissions permissions - changed = permissions /= permissions' - when changed (Directory.setPermissions path' permissions') - return permissions' ) - --- | Get a file or directory's user permissions -getmod :: MonadIO io => FilePath -> io Permissions -getmod path = liftIO (do - let path' = deslash (Filesystem.encodeString path) - Directory.getPermissions path' ) - --- | Set a file or directory's user permissions -setmod :: MonadIO io => Permissions -> FilePath -> io () -setmod permissions path = liftIO (do - let path' = deslash (Filesystem.encodeString path) - Directory.setPermissions path' permissions ) - --- | Copy a file or directory's permissions (analogous to @chmod --reference@) -copymod :: MonadIO io => FilePath -> FilePath -> io () -copymod sourcePath targetPath = liftIO (do - let sourcePath' = deslash (Filesystem.encodeString sourcePath) - targetPath' = deslash (Filesystem.encodeString targetPath) - Directory.copyPermissions sourcePath' targetPath' ) - --- | @+r@ -readable :: Permissions -> Permissions -readable = Directory.setOwnerReadable True - --- | @-r@ -nonreadable :: Permissions -> Permissions -nonreadable = Directory.setOwnerReadable False - --- | @+w@ -writable :: Permissions -> Permissions -writable = Directory.setOwnerWritable True - --- | @-w@ -nonwritable :: Permissions -> Permissions -nonwritable = Directory.setOwnerWritable False - --- | @+x@ -executable :: Permissions -> Permissions -executable = Directory.setOwnerExecutable True - --- | @-x@ -nonexecutable :: Permissions -> Permissions -nonexecutable = Directory.setOwnerExecutable False - --- | @+s@ -searchable :: Permissions -> Permissions -searchable = Directory.setOwnerSearchable True - --- | @-s@ -nonsearchable :: Permissions -> Permissions -nonsearchable = Directory.setOwnerSearchable False - --- | @-r -w -x@ -ooo :: Permissions -> Permissions -ooo = const Directory.emptyPermissions - --- | @+r -w -x@ -roo :: Permissions -> Permissions -roo = readable . ooo - --- | @-r +w -x@ -owo :: Permissions -> Permissions -owo = writable . ooo - --- | @-r -w +x@ -oox :: Permissions -> Permissions -oox = executable . ooo - --- | @-r -w +s@ -oos :: Permissions -> Permissions -oos = searchable . ooo - --- | @+r +w -x@ -rwo :: Permissions -> Permissions -rwo = readable . writable . ooo - --- | @+r -w +x@ -rox :: Permissions -> Permissions -rox = readable . executable . ooo - --- | @+r -w +s@ -ros :: Permissions -> Permissions -ros = readable . searchable . ooo - --- | @-r +w +x@ -owx :: Permissions -> Permissions -owx = writable . executable . ooo - --- | @+r +w +x@ -rwx :: Permissions -> Permissions -rwx = readable . writable . executable . ooo - --- | @+r +w +s@ -rws :: Permissions -> Permissions -rws = readable . writable . searchable . ooo - -{-| Time how long a command takes in monotonic wall clock time - - Returns the duration alongside the return value --} -time :: MonadIO io => io a -> io (a, NominalDiffTime) -time io = do - TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic) - a <- io - TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic) - let t = fromIntegral ( seconds2 - seconds1) - + fromIntegral (nanoseconds2 - nanoseconds1) / 10^(9::Int) - return (a, fromRational t) - --- | Get the system's host name -hostname :: MonadIO io => io Text -hostname = liftIO (fmap Text.pack getHostName) - -{-| Sleep for the given duration - - A numeric literal argument is interpreted as seconds. In other words, - @(sleep 2.0)@ will sleep for two seconds. --} -sleep :: MonadIO io => NominalDiffTime -> io () -sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int)))) - -{-| Exit with the given exit code - - An exit code of @0@ indicates success --} -exit :: MonadIO io => ExitCode -> io a -exit code = liftIO (exitWith code) - --- | Throw an exception using the provided `Text` message -die :: MonadIO io => Text -> io a -die txt = liftIO (throwIO (userError (unpack txt))) - -infixr 2 .||. -infixr 3 .&&. - -{-| Analogous to `&&` in Bash - - Runs the second command only if the first one returns `ExitSuccess` --} -(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode -cmd1 .&&. cmd2 = do - r <- cmd1 - case r of - ExitSuccess -> cmd2 - _ -> return r - -{-| Analogous to `||` in Bash - - Run the second command only if the first one returns `ExitFailure` --} -(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode -cmd1 .||. cmd2 = do - r <- cmd1 - case r of - ExitFailure _ -> cmd2 - _ -> return r - -{-| Create a temporary directory underneath the given directory - - Deletes the temporary directory when done --} -mktempdir - :: MonadManaged managed - => FilePath - -- ^ Parent directory - -> Text - -- ^ Directory name template - -> managed FilePath -mktempdir parent prefix = using (do - let parent' = Filesystem.encodeString parent - let prefix' = unpack prefix - dir' <- managed (withTempDirectory parent' prefix') - return (Filesystem.decodeString dir')) - -{-| Create a temporary file underneath the given directory - - Deletes the temporary file when done - - Note that this provides the `Handle` of the file in order to avoid a - potential race condition from the file being moved or deleted before you - have a chance to open the file. The `mktempfile` function provides a - simpler API if you don't need to worry about that possibility. --} -mktemp - :: MonadManaged managed - => FilePath - -- ^ Parent directory - -> Text - -- ^ File name template - -> managed (FilePath, Handle) -mktemp parent prefix = using (do - let parent' = Filesystem.encodeString parent - let prefix' = unpack prefix - (file', handle) <- managed (\k -> - withTempFile parent' prefix' (\file' handle -> k (file', handle)) ) - return (Filesystem.decodeString file', handle) ) - -{-| Create a temporary file underneath the given directory - - Deletes the temporary file when done --} -mktempfile - :: MonadManaged managed - => FilePath - -- ^ Parent directory - -> Text - -- ^ File name template - -> managed FilePath -mktempfile parent prefix = using (do - let parent' = Filesystem.encodeString parent - let prefix' = unpack prefix - (file', handle) <- managed (\k -> - withTempFile parent' prefix' (\file' handle -> k (file', handle)) ) - liftIO (hClose handle) - return (Filesystem.decodeString file') ) - --- | Fork a thread, acquiring an `Async` value -fork :: MonadManaged managed => IO a -> managed (Async a) -fork io = using (managed (withAsync io)) - --- | Read lines of `Text` from standard input -stdin :: Shell Text -stdin = inhandle IO.stdin - --- | Read lines of `Text` from a file -input :: FilePath -> Shell Text -input file = do - handle <- using (readonly file) - inhandle handle - --- | Read lines of `Text` from a `Handle` -inhandle :: Handle -> Shell Text -inhandle handle = Shell (\(FoldM step begin done) -> do - x0 <- begin - let loop x = do - eof <- IO.hIsEOF handle - if eof - then done x - else do - txt <- Text.hGetLine handle - x' <- step x txt - loop $! x' - loop $! x0 ) - --- | Stream lines of `Text` to standard output -stdout :: MonadIO io => Shell Text -> io () -stdout s = sh (do - txt <- s - liftIO (echo txt) ) - --- | Stream lines of `Text` to a file -output :: MonadIO io => FilePath -> Shell Text -> io () -output file s = sh (do - handle <- using (writeonly file) - txt <- s - liftIO (Text.hPutStrLn handle txt) ) - --- | Stream lines of `Text` to a `Handle` -outhandle :: MonadIO io => Handle -> Shell Text -> io () -outhandle handle s = sh (do - txt <- s - liftIO (Text.hPutStrLn handle txt) ) - --- | Stream lines of `Text` to append to a file -append :: MonadIO io => FilePath -> Shell Text -> io () -append file s = sh (do - handle <- using (appendonly file) - txt <- s - liftIO (Text.hPutStrLn handle txt) ) - --- | Stream lines of `Text` to standard error -stderr :: MonadIO io => Shell Text -> io () -stderr s = sh (do - txt <- s - liftIO (err txt) ) - --- | Read in a stream's contents strictly -strict :: MonadIO io => Shell Text -> io Text -strict s = liftM Text.unlines (fold s list) - --- | Acquire a `Managed` read-only `Handle` from a `FilePath` -readonly :: MonadManaged managed => FilePath -> managed Handle -readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode)) - --- | Acquire a `Managed` write-only `Handle` from a `FilePath` -writeonly :: MonadManaged managed => FilePath -> managed Handle -writeonly file = using (managed (Filesystem.withTextFile file IO.WriteMode)) - --- | Acquire a `Managed` append-only `Handle` from a `FilePath` -appendonly :: MonadManaged managed => FilePath -> managed Handle -appendonly file = using (managed (Filesystem.withTextFile file IO.AppendMode)) - --- | Combine the output of multiple `Shell`s, in order -cat :: [Shell a] -> Shell a -cat = msum - --- | Keep all lines that match the given `Pattern` -grep :: Pattern a -> Shell Text -> Shell Text -grep pattern s = do - txt <- s - _:_ <- return (match pattern txt) - return txt - -{-| Replace all occurrences of a `Pattern` with its `Text` result - - `sed` performs substitution on a line-by-line basis, meaning that - substitutions may not span multiple lines. Additionally, substitutions may - occur multiple times within the same line, like the behavior of - @s/.../.../g@. - - Warning: Do not use a `Pattern` that matches the empty string, since it will - match an infinite number of times. `sed` tries to detect such `Pattern`s - and `die` with an error message if they occur, but this detection is - necessarily incomplete. --} -sed :: Pattern Text -> Shell Text -> Shell Text -sed pattern s = do - when (matchesEmpty pattern) (die message) - let pattern' = fmap Text.concat - (many (pattern <|> fmap Text.singleton anyChar)) - txt <- s - txt':_ <- return (match pattern' txt) - return txt' - where - message = "sed: the given pattern matches the empty string" - matchesEmpty = not . null . flip match "" - --- | Like `sed`, but operates in place on a `FilePath` (analogous to @sed -i@) -inplace :: MonadIO io => Pattern Text -> FilePath -> io () -inplace pattern file = liftIO (runManaged (do - here <- pwd - (tmpfile, handle) <- mktemp here "turtle" - outhandle handle (sed pattern (input file)) - liftIO (hClose handle) - copymod file tmpfile - mv tmpfile file )) - - --- | Search a directory recursively for all files matching the given `Pattern` -find :: Pattern a -> FilePath -> Shell FilePath -find pattern dir = do - path <- lstree dir - Right txt <- return (Filesystem.toText path) - _:_ <- return (match pattern txt) - return path - --- | A Stream of @\"y\"@s -yes :: Shell Text -yes = fmap (\_ -> "y") endless - --- | Number each element of a `Shell` (starting at 0) -nl :: Num n => Shell a -> Shell (n, a) -nl s = Shell _foldIO' - where - _foldIO' (FoldM step begin done) = _foldIO s (FoldM step' begin' done') - where - step' (x, n) a = do - x' <- step x (n, a) - let n' = n + 1 - n' `seq` return (x', n') - begin' = do - x0 <- begin - return (x0, 0) - done' (x, _) = done x - -data ZipState a b = Empty | HasA a | HasAB a b | Done - -{-| Merge two `Shell`s together, element-wise - - If one `Shell` is longer than the other, the excess elements are - truncated --} -paste :: Shell a -> Shell b -> Shell (a, b) -paste sA sB = Shell _foldIOAB - where - _foldIOAB (FoldM stepAB beginAB doneAB) = do - x0 <- beginAB - - tvar <- STM.atomically (STM.newTVar Empty) - - let begin = return () - - let stepA () a = STM.atomically (do - x <- STM.readTVar tvar - case x of - Empty -> STM.writeTVar tvar (HasA a) - Done -> return () - _ -> STM.retry ) - let doneA () = STM.atomically (do - x <- STM.readTVar tvar - case x of - Empty -> STM.writeTVar tvar Done - Done -> return () - _ -> STM.retry ) - let foldA = FoldM stepA begin doneA - - let stepB () b = STM.atomically (do - x <- STM.readTVar tvar - case x of - HasA a -> STM.writeTVar tvar (HasAB a b) - Done -> return () - _ -> STM.retry ) - let doneB () = STM.atomically (do - x <- STM.readTVar tvar - case x of - HasA _ -> STM.writeTVar tvar Done - Done -> return () - _ -> STM.retry ) - let foldB = FoldM stepB begin doneB - - withAsync (foldIO sA foldA) (\asyncA -> do - withAsync (foldIO sB foldB) (\asyncB -> do - let loop x = do - y <- STM.atomically (do - z <- STM.readTVar tvar - case z of - HasAB a b -> do - STM.writeTVar tvar Empty - return (Just (a, b)) - Done -> return Nothing - _ -> STM.retry ) - case y of - Nothing -> return x - Just ab -> do - x' <- stepAB x ab - loop $! x' - x' <- loop $! x0 - wait asyncA - wait asyncB - doneAB x' ) ) - --- | A `Shell` that endlessly emits @()@ -endless :: Shell () -endless = Shell (\(FoldM step begin _) -> do - x0 <- begin - let loop x = do - x' <- step x () - loop $! x' - loop $! x0 ) - --- | Limit a `Shell` to a fixed number of values -limit :: Int -> Shell a -> Shell a -limit n s = Shell (\(FoldM step begin done) -> do - ref <- newIORef 0 -- I feel so dirty - let step' x a = do - n' <- readIORef ref - writeIORef ref (n' + 1) - if n' < n then step x a else return x - foldIO s (FoldM step' begin done) ) - -{-| Limit a `Shell` to values that satisfy the predicate - - This terminates the stream on the first value that does not satisfy the - predicate --} -limitWhile :: (a -> Bool) -> Shell a -> Shell a -limitWhile predicate s = Shell (\(FoldM step begin done) -> do - ref <- newIORef True - let step' x a = do - b <- readIORef ref - let b' = b && predicate a - writeIORef ref b' - if b' then step x a else return x - foldIO s (FoldM step' begin done) ) - -{-| Cache a `Shell`'s output so that repeated runs of the script will reuse the - result of previous runs. You must supply a `FilePath` where the cached - result will be stored. - - The stored result is only reused if the `Shell` successfully ran to - completion without any exceptions. Note: on some platforms Ctrl-C will - flush standard input and signal end of file before killing the program, - which may trick the program into \"successfully\" completing. --} -cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a -cache file s = do - let cached = do - txt <- input file - case reads (Text.unpack txt) of - [(ma, "")] -> return ma - _ -> - die (format ("cache: Invalid data stored in "%w) file) - exists <- testfile file - mas <- fold (if exists then cached else empty) list - case [ () | Nothing <- mas ] of - _:_ -> select [ a | Just a <- mas ] - _ -> do - handle <- using (writeonly file) - let justs = do - a <- s - liftIO (Text.hPutStrLn handle (Text.pack (show (Just a)))) - return a - let nothing = do - let n = Nothing :: Maybe () - liftIO (Text.hPutStrLn handle (Text.pack (show n))) - empty - justs <|> nothing - --- | Split a line into chunks delimited by the given `Pattern` -cut :: Pattern a -> Text -> [Text] -cut pattern txt = head (match (selfless chars `sepBy` pattern) txt) --- This `head` should be safe ... in theory - --- | Get the current time -date :: MonadIO io => io UTCTime -date = liftIO getCurrentTime - --- | Get the time a file was last modified -datefile :: MonadIO io => FilePath -> io UTCTime -datefile path = liftIO (Filesystem.getModified path) - --- | Get the size of a file or a directory -du :: MonadIO io => FilePath -> io Size -du path = liftIO (fmap Size (Filesystem.getSize path)) - -{-| An abstract file size - - Specify the units you want by using an accessor like `kilobytes` - - The `Num` instance for `Size` interprets numeric literals as bytes --} -newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num) - -instance Show Size where - show = show . _bytes - -{-| `Format` a `Size` using a human readable representation - ->>> format sz 42 -"42 B" ->>> format sz 2309 -"2.309 KB" ->>> format sz 949203 -"949.203 MB" ->>> format sz 1600000000 -"1.600 GB" ->>> format sz 999999999999999999 -"999999.999 TB" --} -sz :: Format r (Size -> r) -sz = makeFormat (\(Size numBytes) -> - let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000 - (numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000 - (numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000 - (numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000 - in if numKilobytes <= 0 - then format (d%" B" ) remainingBytes - else if numMegabytes == 0 - then format (d%"."%d%" KB") remainingKilobytes remainingBytes - else if numGigabytes == 0 - then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes - else if numTerabytes == 0 - then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes - else format (d%"."%d%" TB") numTerabytes remainingGigabytes ) - --- | Extract a size in bytes -bytes :: Integral n => Size -> n -bytes = fromInteger . _bytes - --- | @1 kilobyte = 1000 bytes@ -kilobytes :: Integral n => Size -> n -kilobytes = (`div` 1000) . bytes - --- | @1 megabyte = 1000 kilobytes@ -megabytes :: Integral n => Size -> n -megabytes = (`div` 1000) . kilobytes - --- | @1 gigabyte = 1000 megabytes@ -gigabytes :: Integral n => Size -> n -gigabytes = (`div` 1000) . megabytes - --- | @1 terabyte = 1000 gigabytes@ -terabytes :: Integral n => Size -> n -terabytes = (`div` 1000) . gigabytes - --- | @1 kibibyte = 1024 bytes@ -kibibytes :: Integral n => Size -> n -kibibytes = (`div` 1024) . bytes - --- | @1 mebibyte = 1024 kibibytes@ -mebibytes :: Integral n => Size -> n -mebibytes = (`div` 1024) . kibibytes - --- | @1 gibibyte = 1024 mebibytes@ -gibibytes :: Integral n => Size -> n -gibibytes = (`div` 1024) . mebibytes - --- | @1 tebibyte = 1024 gibibytes@ -tebibytes :: Integral n => Size -> n -tebibytes = (`div` 1024) . gibibytes - -{-| Count the number of characters in the stream (like @wc -c@) - - This uses the convention that the elements of the stream are implicitly - ended by newlines that are one character wide --} -countChars :: Integral n => Fold Text n -countChars = Control.Foldl.Text.length + charsPerNewline * countLines - -charsPerNewline :: Num a => a -#ifdef mingw32_HOST_OS -charsPerNewline = 2 -#else -charsPerNewline = 1 -#endif - --- | Count the number of words in the stream (like @wc -w@) -countWords :: Integral n => Fold Text n -countWords = premap Text.words (handles traverse genericLength) - -{-| Count the number of lines in the stream (like @wc -l@) - - This uses the convention that each element of the stream represents one - line --} -countLines :: Integral n => Fold Text n -countLines = genericLength +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module provides a large suite of utilities that resemble Unix +-- utilities. +-- +-- Many of these commands are just existing Haskell commands renamed to match +-- their Unix counterparts: +-- +-- >>> :set -XOverloadedStrings +-- >>> cd "/tmp" +-- >>> pwd +-- FilePath "/tmp" +-- +-- Some commands are `Shell`s that emit streams of values. `view` prints all +-- values in a `Shell` stream: +-- +-- >>> view (ls "/usr") +-- FilePath "/usr/lib" +-- FilePath "/usr/src" +-- FilePath "/usr/sbin" +-- FilePath "/usr/include" +-- FilePath "/usr/share" +-- FilePath "/usr/games" +-- FilePath "/usr/local" +-- FilePath "/usr/bin" +-- >>> view (find (suffix "Browser.py") "/usr/lib") +-- FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py" +-- FilePath "/usr/lib/python3.4/idlelib/RemoteObjectBrowser.py" +-- FilePath "/usr/lib/python3.4/idlelib/PathBrowser.py" +-- FilePath "/usr/lib/python3.4/idlelib/ObjectBrowser.py" +-- +-- Use `fold` to reduce the output of a `Shell` stream: +-- +-- >>> import qualified Control.Foldl as Fold +-- >>> fold (ls "/usr") Fold.length +-- 8 +-- >>> fold (find (suffix "Browser.py") "/usr/lib") Fold.head +-- Just (FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py") +-- +-- Create files using `output`: +-- +-- >>> output "foo.txt" ("123" <|> "456" <|> "ABC") +-- >>> realpath "foo.txt" +-- FilePath "/tmp/foo.txt" +-- +-- Read in files using `input`: +-- +-- >>> stdout (input "foo.txt") +-- 123 +-- 456 +-- ABC +-- +-- Format strings in a type safe way using `format`: +-- +-- >>> dir <- pwd +-- >>> format ("I am in the "%fp%" directory") dir +-- "I am in the /tmp directory" +-- +-- Commands like `grep`, `sed` and `find` accept arbitrary `Pattern`s +-- +-- >>> stdout (grep ("123" <|> "ABC") (input "foo.txt")) +-- 123 +-- ABC +-- >>> let exclaim = fmap (<> "!") (plus digit) +-- >>> stdout (sed exclaim (input "foo.txt")) +-- 123! +-- 456! +-- ABC +-- +-- Note that `grep` and `find` differ from their Unix counterparts by requiring +-- that the `Pattern` matches the entire line or file name by default. However, +-- you can optionally match the prefix, suffix, or interior of a line: +-- +-- >>> stdout (grep (has "2") (input "foo.txt")) +-- 123 +-- >>> stdout (grep (prefix "1") (input "foo.txt")) +-- 123 +-- >>> stdout (grep (suffix "3") (input "foo.txt")) +-- 123 +-- +-- You can also build up more sophisticated `Shell` programs using `sh` in +-- conjunction with @do@ notation: +-- +-- >{-# LANGUAGE OverloadedStrings #-} +-- > +-- >import Turtle +-- > +-- >main = sh example +-- > +-- >example = do +-- > -- Read in file names from "files1.txt" and "files2.txt" +-- > file <- fmap fromText (input "files1.txt" <|> input "files2.txt") +-- > +-- > -- Stream each file to standard output only if the file exists +-- > True <- liftIO (testfile file) +-- > line <- input file +-- > liftIO (echo line) +-- +-- See "Turtle.Tutorial" for an extended tutorial explaining how to use this +-- library in greater detail. + +module Turtle.Prelude ( + -- * IO + echo + , err + , readline + , Internal.readTextFile + , Internal.writeTextFile + , arguments +#if __GLASGOW_HASKELL__ >= 710 + , export + , unset +#endif + , need + , env + , cd + , pwd + , home + , readlink + , realpath + , mv + , mkdir + , mktree + , cp + , cptree + , cptreeL +#if !defined(mingw32_HOST_OS) + , symlink +#endif + , isNotSymbolicLink + , rm + , rmdir + , rmtree + , testfile + , testdir + , testpath + , date + , datefile + , touch + , time + , hostname + , which + , whichAll + , sleep + , exit + , die + , (.&&.) + , (.||.) + + -- * Managed + , readonly + , writeonly + , appendonly + , mktemp + , mktempfile + , mktempdir + , fork + , wait + , pushd + + -- * Shell + , stdin + , input + , inhandle + , stdout + , output + , outhandle + , append + , stderr + , strict + , ls + , lsif + , lstree + , lsdepth + , cat + , grep + , grepText + , sed + , sedPrefix + , sedSuffix + , sedEntire + , onFiles + , inplace + , inplacePrefix + , inplaceSuffix + , inplaceEntire + , update + , find + , findtree + , yes + , nl + , paste + , endless + , limit + , limitWhile + , cache + , parallel + , single + , uniq + , uniqOn + , uniqBy + , nub + , nubOn + , sort + , sortOn + , sortBy + , toLines + + -- * Folds + , countChars + , countWords + , countLines + + -- * Text + , cut + + -- * Subprocess management + , proc + , shell + , procs + , shells + , inproc + , inshell + , inprocWithErr + , inshellWithErr + , procStrict + , shellStrict + , procStrictWithErr + , shellStrictWithErr + + , system + , stream + , streamWithErr + , systemStrict + , systemStrictWithErr + + -- * Permissions + , Permissions(..) + , chmod + , getmod + , setmod + , copymod + , readable, nonreadable + , writable, nonwritable + , executable, nonexecutable + , ooo,roo,owo,oox,rwo,rox,owx,rwx + + -- * File size + , du + , Size(B, KB, MB, GB, TB, KiB, MiB, GiB, TiB) + , sz + , bytes + , kilobytes + , megabytes + , gigabytes + , terabytes + , kibibytes + , mebibytes + , gibibytes + , tebibytes + + -- * File status + , PosixCompat.FileStatus + , stat + , lstat + , fileSize + , accessTime + , modificationTime + , statusChangeTime + , PosixCompat.isBlockDevice + , PosixCompat.isCharacterDevice + , PosixCompat.isNamedPipe + , PosixCompat.isRegularFile + , PosixCompat.isDirectory + , PosixCompat.isSymbolicLink + , PosixCompat.isSocket + , cmin + , cmax + + -- * Headers + , WithHeader(..) + , header + + -- * Exceptions + , ProcFailed(..) + , ShellFailed(..) + ) where + +import Control.Applicative +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async + (Async, withAsync, waitSTM, concurrently, + Concurrently(..)) +import qualified Control.Concurrent.Async +import Control.Concurrent.MVar (newMVar, modifyMVar_) +import qualified Control.Concurrent.STM as STM +import qualified Control.Concurrent.STM.TQueue as TQueue +import Control.Exception (Exception, bracket, bracket_, finally, mask, throwIO) +import Control.Foldl (Fold(..), genericLength, handles, list, premap) +import qualified Control.Foldl +import qualified Control.Foldl.Text +import Control.Monad (foldM, guard, liftM, msum, when, unless, (>=>), mfilter) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Managed (MonadManaged(..), managed, managed_, runManaged) +#ifdef mingw32_HOST_OS +import Data.Bits ((.&.)) +#endif +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import Data.Ord (comparing) +import qualified Data.Set as Set +import Data.Text (Text, pack, unpack) +import Data.Time (NominalDiffTime, UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import Data.Traversable +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Typeable (Typeable) +import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) +import Network.HostName (getHostName) +import System.Clock (Clock(..), TimeSpec(..), getTime) +import System.Environment ( + getArgs, +#if __GLASGOW_HASKELL__ >= 710 + setEnv, + unsetEnv, +#endif +#if __GLASGOW_HASKELL__ >= 708 + lookupEnv, +#endif + getEnvironment ) +import qualified System.Directory as Directory +import System.FilePath (()) +import qualified System.FilePath as FilePath +import System.Exit (ExitCode(..), exitWith) +import System.IO (Handle, hClose) +import qualified System.IO as IO +import System.IO.Temp (withTempDirectory, withTempFile) +import System.IO.Error + (catchIOError, ioeGetErrorType, isPermissionError, isDoesNotExistError) +import qualified System.PosixCompat as PosixCompat +import qualified System.Process as Process +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import System.Posix ( + openDirStream, + readDirStream, + closeDirStream, + touchFile ) +import System.Posix.Files (createSymbolicLink) +#endif +import Prelude hiding (lines) + +import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy) +import Turtle.Shell +import Turtle.Format (Format, format, makeFormat, d, w, (%), fp) +import qualified Turtle.Internal as Internal +import Turtle.Line + +{-| Run a command using @execvp@, retrieving the exit code + + The command inherits @stdout@ and @stderr@ for the current process +-} +proc + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> io ExitCode + -- ^ Exit code +proc cmd args = + system + ( (Process.proc (unpack cmd) (map unpack args)) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.Inherit + , Process.std_err = Process.Inherit + } ) + +{-| Run a command line using the shell, retrieving the exit code + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stdout@ and @stderr@ for the current process +-} +shell + :: MonadIO io + => Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> io ExitCode + -- ^ Exit code +shell cmdLine = + system + ( (Process.shell (unpack cmdLine)) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.Inherit + , Process.std_err = Process.Inherit + } ) + +data ProcFailed = ProcFailed + { procCommand :: Text + , procArguments :: [Text] + , procExitCode :: ExitCode + } deriving (Show, Typeable) + +instance Exception ProcFailed + +{-| This function is identical to `proc` except this throws `ProcFailed` for + non-zero exit codes +-} +procs + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> io () +procs cmd args s = do + exitCode <- proc cmd args s + case exitCode of + ExitSuccess -> return () + _ -> liftIO (throwIO (ProcFailed cmd args exitCode)) + +data ShellFailed = ShellFailed + { shellCommandLine :: Text + , shellExitCode :: ExitCode + } deriving (Show, Typeable) + +instance Exception ShellFailed + +{-| This function is identical to `shell` except this throws `ShellFailed` for + non-zero exit codes +-} +shells + :: MonadIO io + => Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> io () + -- ^ Exit code +shells cmdline s = do + exitCode <- shell cmdline s + case exitCode of + ExitSuccess -> return () + _ -> liftIO (throwIO (ShellFailed cmdline exitCode)) + +{-| Run a command using @execvp@, retrieving the exit code and stdout as a + non-lazy blob of Text + + The command inherits @stderr@ for the current process +-} +procStrict + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text) + -- ^ Exit code and stdout +procStrict cmd args = + systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args)) + +{-| Run a command line using the shell, retrieving the exit code and stdout as a + non-lazy blob of Text + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stderr@ for the current process +-} +shellStrict + :: MonadIO io + => Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text) + -- ^ Exit code and stdout +shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine)) + +{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr + as a non-lazy blob of Text +-} +procStrictWithErr + :: MonadIO io + => Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text, Text) + -- ^ (Exit code, stdout, stderr) +procStrictWithErr cmd args = + systemStrictWithErr (Process.proc (Text.unpack cmd) (map Text.unpack args)) + +{-| Run a command line using the shell, retrieving the exit code, stdout, and + stderr as a non-lazy blob of Text + + This command is more powerful than `proc`, but highly vulnerable to code + injection if you template the command line with untrusted input +-} +shellStrictWithErr + :: MonadIO io + => Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text, Text) + -- ^ (Exit code, stdout, stderr) +shellStrictWithErr cmdLine = + systemStrictWithErr (Process.shell (Text.unpack cmdLine)) + +-- | Halt an `Async` thread, re-raising any exceptions it might have thrown +halt :: Async a -> IO () +halt a = do + m <- Control.Concurrent.Async.poll a + case m of + Nothing -> Control.Concurrent.Async.cancel a + Just (Left e) -> throwIO e + Just (Right _) -> return () + +{-| `system` generalizes `shell` and `proc` by allowing you to supply your own + custom `CreateProcess`. This is for advanced users who feel comfortable + using the lower-level @process@ API +-} +system + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell Line + -- ^ Lines of standard input + -> io ExitCode + -- ^ Exit code +system p s = liftIO (do + let open = do + (m, Nothing, Nothing, ph) <- Process.createProcess p + case m of + Just hIn -> IO.hSetBuffering hIn IO.LineBuffering + _ -> return () + return (m, ph) + + -- Prevent double close + mvar <- newMVar False + let close handle = do + modifyMVar_ mvar (\finalized -> do + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) + return True ) + let close' (Just hIn, ph) = do + close hIn + Process.terminateProcess ph + close' (Nothing , ph) = do + Process.terminateProcess ph + + let handle (Just hIn, ph) = do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + mask (\restore -> + withAsync (feedIn restore) (\a -> + restore (Process.waitForProcess ph) `finally` halt a) ) + handle (Nothing , ph) = do + Process.waitForProcess ph + + bracket open close' handle ) + + +{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to + supply your own custom `CreateProcess`. This is for advanced users who feel + comfortable using the lower-level @process@ API +-} +systemStrict + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text) + -- ^ Exit code and stdout +systemStrict p s = liftIO (do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.Inherit + } + + let open = do + (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') + IO.hSetBuffering hIn IO.LineBuffering + return (hIn, hOut, ph) + + -- Prevent double close + mvar <- newMVar False + let close handle = do + modifyMVar_ mvar (\finalized -> do + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) + return True ) + + bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + + concurrently + (mask (\restore -> + withAsync (feedIn restore) (\a -> + restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) )) + (Text.hGetContents hOut) ) ) + +{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and + `procStrictWithErr` by allowing you to supply your own custom + `CreateProcess`. This is for advanced users who feel comfortable using + the lower-level @process@ API +-} +systemStrictWithErr + :: MonadIO io + => Process.CreateProcess + -- ^ Command + -> Shell Line + -- ^ Lines of standard input + -> io (ExitCode, Text, Text) + -- ^ Exit code and stdout +systemStrictWithErr p s = liftIO (do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + let open = do + (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') + IO.hSetBuffering hIn IO.LineBuffering + return (hIn, hOut, hErr, ph) + + -- Prevent double close + mvar <- newMVar False + let close handle = do + modifyMVar_ mvar (\finalized -> do + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) + return True ) + + bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + + runConcurrently $ (,,) + <$> Concurrently (mask (\restore -> + withAsync (feedIn restore) (\a -> + restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) )) + <*> Concurrently (Text.hGetContents hOut) + <*> Concurrently (Text.hGetContents hErr) ) ) + +{-| Run a command using @execvp@, streaming @stdout@ as lines of `Text` + + The command inherits @stderr@ for the current process +-} +inproc + :: Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> Shell Line + -- ^ Lines of standard output +inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args)) + +{-| Run a command line using the shell, streaming @stdout@ as lines of `Text` + + This command is more powerful than `inproc`, but highly vulnerable to code + injection if you template the command line with untrusted input + + The command inherits @stderr@ for the current process + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +inshell + :: Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> Shell Line + -- ^ Lines of standard output +inshell cmd = stream (Process.shell (unpack cmd)) + +waitForProcessThrows :: Process.ProcessHandle -> IO () +waitForProcessThrows ph = do + exitCode <- Process.waitForProcess ph + case exitCode of + ExitSuccess -> return () + ExitFailure _ -> Control.Exception.throwIO exitCode + +{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your + own custom `CreateProcess`. This is for advanced users who feel comfortable + using the lower-level @process@ API + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +stream + :: Process.CreateProcess + -- ^ Command + -> Shell Line + -- ^ Lines of standard input + -> Shell Line + -- ^ Lines of standard output +stream p s = do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.Inherit + } + + let open = do + (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') + IO.hSetBuffering hIn IO.LineBuffering + return (hIn, hOut, ph) + + -- Prevent double close + mvar <- liftIO (newMVar False) + let close handle = do + modifyMVar_ mvar (\finalized -> do + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) + return True ) + + (hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph))) + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + + a <- using + (managed (\k -> + mask (\restore -> withAsync (feedIn restore) (restore . k)))) + inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty) + +{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing + you to supply your own custom `CreateProcess`. This is for advanced users + who feel comfortable using the lower-level @process@ API + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +streamWithErr + :: Process.CreateProcess + -- ^ Command + -> Shell Line + -- ^ Lines of standard input + -> Shell (Either Line Line) + -- ^ Lines of standard output +streamWithErr p s = do + let p' = p + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + let open = do + (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') + IO.hSetBuffering hIn IO.LineBuffering + return (hIn, hOut, hErr, ph) + + -- Prevent double close + mvar <- liftIO (newMVar False) + let close handle = do + modifyMVar_ mvar (\finalized -> do + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) + return True ) + + (hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph))) + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + + queue <- liftIO TQueue.newTQueueIO + let forwardOut :: (forall a. IO a -> IO a) -> IO () + forwardOut restore = + restore (sh (do + line <- inhandle hOut + liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right line)))) )) + `finally` STM.atomically (TQueue.writeTQueue queue Nothing) + let forwardErr :: (forall a. IO a -> IO a) -> IO () + forwardErr restore = + restore (sh (do + line <- inhandle hErr + liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) )) + `finally` STM.atomically (TQueue.writeTQueue queue Nothing) + let drain = Shell (\(FoldShell step begin done) -> do + let loop x numNothing + | numNothing < 2 = do + m <- STM.atomically (TQueue.readTQueue queue) + case m of + Nothing -> loop x $! numNothing + 1 + Just e -> do + x' <- step x e + loop x' numNothing + | otherwise = return x + x1 <- loop begin (0 :: Int) + done x1 ) + + a <- using + (managed (\k -> + mask (\restore -> withAsync (feedIn restore) (restore . k)) )) + b <- using + (managed (\k -> + mask (\restore -> withAsync (forwardOut restore) (restore . k)) )) + c <- using + (managed (\k -> + mask (\restore -> withAsync (forwardErr restore) (restore . k)) )) + let l `also` r = do + _ <- l <|> (r *> STM.retry) + _ <- r + return () + let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c)) + drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty) + +{-| Run a command using the shell, streaming @stdout@ and @stderr@ as lines of + `Text`. Lines from @stdout@ are wrapped in `Right` and lines from @stderr@ + are wrapped in `Left`. + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +inprocWithErr + :: Text + -- ^ Command + -> [Text] + -- ^ Arguments + -> Shell Line + -- ^ Lines of standard input + -> Shell (Either Line Line) + -- ^ Lines of either standard output (`Right`) or standard error (`Left`) +inprocWithErr cmd args = + streamWithErr (Process.proc (unpack cmd) (map unpack args)) + +{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as lines + of `Text`. Lines from @stdout@ are wrapped in `Right` and lines from + @stderr@ are wrapped in `Left`. + + This command is more powerful than `inprocWithErr`, but highly vulnerable to + code injection if you template the command line with untrusted input + + Throws an `ExitCode` exception if the command returns a non-zero exit code +-} +inshellWithErr + :: Text + -- ^ Command line + -> Shell Line + -- ^ Lines of standard input + -> Shell (Either Line Line) + -- ^ Lines of either standard output (`Right`) or standard error (`Left`) +inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd)) + +{-| Print exactly one line to @stdout@ + + To print more than one line see `Turtle.Format.printf`, which also supports + formatted output +-} +echo :: MonadIO io => Line -> io () +echo line = liftIO (Text.putStrLn (lineToText line)) + +-- | Print exactly one line to @stderr@ +err :: MonadIO io => Line -> io () +err line = liftIO (Text.hPutStrLn IO.stderr (lineToText line)) + +{-| Read in a line from @stdin@ + + Returns `Nothing` if at end of input +-} +readline :: MonadIO io => io (Maybe Line) +readline = liftIO (do + eof <- IO.isEOF + if eof + then return Nothing + else fmap (Just . unsafeTextToLine . pack) getLine ) + +-- | Get command line arguments in a list +arguments :: MonadIO io => io [Text] +arguments = liftIO (fmap (map pack) getArgs) + +#if __GLASGOW_HASKELL__ >= 710 +{-| Set or modify an environment variable + + Note: This will change the current environment for all of your program's + threads since this modifies the global state of the process +-} +export :: MonadIO io => Text -> Text -> io () +export key val = liftIO (setEnv (unpack key) (unpack val)) + +-- | Delete an environment variable +unset :: MonadIO io => Text -> io () +unset key = liftIO (unsetEnv (unpack key)) +#endif + +-- | Look up an environment variable +need :: MonadIO io => Text -> io (Maybe Text) +#if __GLASGOW_HASKELL__ >= 708 +need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key))) +#else +need key = liftM (lookup key) env +#endif + +-- | Retrieve all environment variables +env :: MonadIO io => io [(Text, Text)] +env = liftIO (fmap (fmap toTexts) getEnvironment) + where + toTexts (key, val) = (pack key, pack val) + +{-| Change the current directory + + Note: This will change the current directory for all of your program's + threads since this modifies the global state of the process +-} +cd :: MonadIO io => FilePath -> io () +cd path = liftIO (Directory.setCurrentDirectory path) + +{-| Change the current directory. Once the current 'Shell' is done, it returns +back to the original directory. + +>>> :set -XOverloadedStrings +>>> cd "/" +>>> view (pushd "/tmp" >> pwd) +FilePath "/tmp" +>>> pwd +FilePath "/" +-} +pushd :: MonadManaged managed => FilePath -> managed () +pushd path = do + cwd <- pwd + using (managed_ (bracket_ (cd path) (cd cwd))) + +-- | Get the current directory +pwd :: MonadIO io => io FilePath +pwd = liftIO Directory.getCurrentDirectory + +-- | Get the home directory +home :: MonadIO io => io FilePath +home = liftIO Directory.getHomeDirectory + +-- | Get the path pointed to by a symlink +readlink :: MonadIO io => FilePath -> io FilePath +readlink path = liftIO (Directory.getSymbolicLinkTarget path) + +-- | Canonicalize a path +realpath :: MonadIO io => FilePath -> io FilePath +realpath path = liftIO (Directory.canonicalizePath path) + +#ifdef mingw32_HOST_OS +fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag +fILE_ATTRIBUTE_REPARSE_POINT = 1024 + +reparsePoint :: Win32.FileAttributeOrFlag -> Bool +reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0 +#endif + +{-| Stream all immediate children of the given directory, excluding @\".\"@ and + @\"..\"@ +-} +ls :: FilePath -> Shell FilePath +ls path = Shell (\(FoldShell step begin done) -> do + let path' = path + canRead <- fmap + Directory.readable + (Directory.getPermissions (deslash path')) +#ifdef mingw32_HOST_OS + reparse <- fmap reparsePoint (Win32.getFileAttributes path') + if (canRead && not reparse) + then bracket + (Win32.findFirstFile (path "*")) + (\(h, _) -> Win32.findClose h) + (\(h, fdat) -> do + let loop x = do + file <- Win32.getFindDataFileName fdat + x' <- if (file /= "." && file /= "..") + then step x (path file) + else return x + more <- Win32.findNextFile h fdat + if more then loop $! x' else done x' + loop $! begin ) + else done begin ) +#else + if canRead + then bracket (openDirStream path') closeDirStream (\dirp -> do + let loop x = do + file <- readDirStream dirp + case file of + "" -> done x + _ -> do + x' <- if (file /= "." && file /= "..") + then step x (path file) + else return x + loop $! x' + loop $! begin ) + else done begin ) +#endif + +{-| This is used to remove the trailing slash from a path, because + `getPermissions` will fail if a path ends with a trailing slash +-} +deslash :: String -> String +deslash [] = [] +deslash (c0:cs0) = c0:go cs0 + where + go [] = [] + go ['\\'] = [] + go (c:cs) = c:go cs + +-- | Stream all recursive descendents of the given directory +lstree :: FilePath -> Shell FilePath +lstree path = do + child <- ls path + isDir <- testdir child + if isDir + then return child <|> lstree child + else return child + + +{- | Stream the recursive descendents of a given directory + between a given minimum and maximum depth +-} +lsdepth :: Int -> Int -> FilePath -> Shell FilePath +lsdepth mn mx path = + lsdepthHelper 1 mn mx path + where + lsdepthHelper :: Int -> Int -> Int -> FilePath -> Shell FilePath + lsdepthHelper depth l u p = + if depth > u + then empty + else do + child <- ls p + isDir <- testdir child + if isDir + then if depth >= l + then return child <|> lsdepthHelper (depth + 1) l u child + else lsdepthHelper (depth + 1) l u child + else if depth >= l + then return child + else empty + +{-| Stream all recursive descendents of the given directory + + This skips any directories that fail the supplied predicate + +> lstree = lsif (\_ -> return True) +-} +lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath +lsif predicate path = do + child <- ls path + isDir <- testdir child + if isDir + then do + continue <- liftIO (predicate child) + if continue + then return child <|> lsif predicate child + else return child + else return child + +{-| Move a file or directory + + Works if the two paths are on the same filesystem. + If not, @mv@ will still work when dealing with a regular file, + but the operation will not be atomic +-} +mv :: MonadIO io => FilePath -> FilePath -> io () +mv oldPath newPath = liftIO $ catchIOError (Directory.renameFile oldPath newPath) + (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV + then do + Directory.copyFile oldPath newPath + Directory.removeFile oldPath + else ioError ioe) + +{-| Create a directory + + Fails if the directory is present +-} +mkdir :: MonadIO io => FilePath -> io () +mkdir path = liftIO (Directory.createDirectory path) + +{-| Create a directory tree (equivalent to @mkdir -p@) + + Does not fail if the directory is present +-} +mktree :: MonadIO io => FilePath -> io () +mktree path = liftIO (Directory.createDirectoryIfMissing True path) + +-- | Copy a file +cp :: MonadIO io => FilePath -> FilePath -> io () +cp oldPath newPath = liftIO (Directory.copyFile oldPath newPath) + +#if !defined(mingw32_HOST_OS) +-- | Create a symlink from one @FilePath@ to another +symlink :: MonadIO io => FilePath -> FilePath -> io () +symlink a b = liftIO $ createSymbolicLink (fp2fp a) (fp2fp b) + where + fp2fp = unpack . format fp + +#endif + +{-| Returns `True` if the given `FilePath` is not a symbolic link + + This comes in handy in conjunction with `lsif`: + + > lsif isNotSymbolicLink +-} +isNotSymbolicLink :: MonadIO io => FilePath -> io Bool +isNotSymbolicLink = fmap (not . PosixCompat.isSymbolicLink) . lstat + +-- | Copy a directory tree and preserve symbolic links +cptree :: MonadIO io => FilePath -> FilePath -> io () +cptree oldTree newTree = sh (do + oldPath <- lsif isNotSymbolicLink oldTree + + -- The `system-filepath` library treats a path like "/tmp" as a file and not + -- a directory and fails to strip it as a prefix from `/tmp/foo`. Adding + -- `( "")` to the end of the path makes clear that the path is a + -- directory + Just suffix <- return (Internal.stripPrefix (oldTree <> [ FilePath.pathSeparator ]) oldPath) + + let newPath = newTree suffix + + isFile <- testfile oldPath + + fileStatus <- lstat oldPath + + if PosixCompat.isSymbolicLink fileStatus + then do + oldTarget <- liftIO (PosixCompat.readSymbolicLink oldPath) + + mktree (FilePath.takeDirectory newPath) + + liftIO (PosixCompat.createSymbolicLink oldTarget newPath) + else if isFile + then do + mktree (FilePath.takeDirectory newPath) + + cp oldPath newPath + else do + mktree newPath ) + +-- | Copy a directory tree and dereference symbolic links +cptreeL :: MonadIO io => FilePath -> FilePath -> io () +cptreeL oldTree newTree = sh (do + oldPath <- lstree oldTree + Just suffix <- return (Internal.stripPrefix (oldTree ++ "/") oldPath) + let newPath = newTree suffix + isFile <- testfile oldPath + if isFile + then mktree (FilePath.takeDirectory newPath) >> cp oldPath newPath + else mktree newPath ) + + +-- | Remove a file +rm :: MonadIO io => FilePath -> io () +rm path = liftIO (Directory.removeFile path) + +-- | Remove a directory +rmdir :: MonadIO io => FilePath -> io () +rmdir path = liftIO (Directory.removeDirectory path) + +{-| Remove a directory tree (equivalent to @rm -r@) + + Use at your own risk +-} +rmtree :: MonadIO io => FilePath -> io () +rmtree path0 = liftIO (sh (loop path0)) + where + loop path = do + linkstat <- lstat path + let isLink = PosixCompat.isSymbolicLink linkstat + isDir = PosixCompat.isDirectory linkstat + if isLink + then rm path + else do + if isDir + then (do + child <- ls path + loop child ) <|> rmdir path + else rm path + +-- | Check if a file exists +testfile :: MonadIO io => FilePath -> io Bool +testfile path = liftIO (Directory.doesFileExist path) + +-- | Check if a directory exists +testdir :: MonadIO io => FilePath -> io Bool +testdir path = liftIO (Directory.doesDirectoryExist path) + +-- | Check if a path exists +testpath :: MonadIO io => FilePath -> io Bool +testpath path = do + exists <- testfile path + if exists + then return exists + else testdir path + +{-| Touch a file, updating the access and modification times to the current time + + Creates an empty file if it does not exist +-} +touch :: MonadIO io => FilePath -> io () +touch file = do + exists <- testfile file + liftIO (if exists +#ifdef mingw32_HOST_OS + then do + handle <- Win32.createFile + file + Win32.gENERIC_WRITE + Win32.fILE_SHARE_NONE + Nothing + Win32.oPEN_EXISTING + Win32.fILE_ATTRIBUTE_NORMAL + Nothing + (creationTime, _, _) <- Win32.getFileTime handle + systemTime <- Win32.getSystemTimeAsFileTime + Win32.setFileTime handle (Just creationTime) (Just systemTime) (Just systemTime) +#else + then touchFile file +#endif + else output file empty ) + +{-| This type is the same as @"System.Directory".`Directory.Permissions`@ + type except combining the `Directory.executable` and + `Directory.searchable` fields into a single `executable` field for + consistency with the Unix @chmod@. This simplification is still entirely + consistent with the behavior of "System.Directory", which treats the two + fields as interchangeable. +-} +data Permissions = Permissions + { _readable :: Bool + , _writable :: Bool + , _executable :: Bool + } deriving (Eq, Read, Ord, Show) + +{-| Under the hood, "System.Directory" does not distinguish between + `Directory.executable` and `Directory.searchable`. They both + translate to the same `System.Posix.ownerExecuteMode` permission. That + means that we can always safely just set the `Directory.executable` + field and safely leave the `Directory.searchable` field as `False` + because the two fields are combined with (`||`) to determine whether to set + the executable bit. +-} +toSystemDirectoryPermissions :: Permissions -> Directory.Permissions +toSystemDirectoryPermissions p = + ( Directory.setOwnerReadable (_readable p) + . Directory.setOwnerWritable (_writable p) + . Directory.setOwnerExecutable (_executable p) + ) Directory.emptyPermissions + +fromSystemDirectoryPermissions :: Directory.Permissions -> Permissions +fromSystemDirectoryPermissions p = Permissions + { _readable = Directory.readable p + , _writable = Directory.writable p + , _executable = + Directory.executable p || Directory.searchable p + } + +{-| Update a file or directory's user permissions + +> chmod rwo "foo.txt" -- chmod u=rw foo.txt +> chmod executable "foo.txt" -- chmod u+x foo.txt +> chmod nonwritable "foo.txt" -- chmod u-w foo.txt + + The meaning of each permission is: + + * `readable` (@+r@ for short): For files, determines whether you can read + from that file (such as with `input`). For directories, determines + whether or not you can list the directory contents (such as with `ls`). + Note: if a directory is not readable then `ls` will stream an empty list + of contents + + * `writable` (@+w@ for short): For files, determines whether you can write + to that file (such as with `output`). For directories, determines whether + you can create a new file underneath that directory. + + * `executable` (@+x@ for short): For files, determines whether or not that + file is executable (such as with `proc`). For directories, determines + whether or not you can read or execute files underneath that directory + (such as with `input` or `proc`) +-} +chmod + :: MonadIO io + => (Permissions -> Permissions) + -- ^ Permissions update function + -> FilePath + -- ^ Path + -> io Permissions + -- ^ Updated permissions +chmod modifyPermissions path = liftIO (do + let path' = deslash path + permissions <- Directory.getPermissions path' + let permissions' = fromSystemDirectoryPermissions permissions + let permissions'' = modifyPermissions permissions' + changed = permissions' /= permissions'' + let permissions''' = toSystemDirectoryPermissions permissions'' + when changed (Directory.setPermissions path' permissions''') + return permissions'' ) + +-- | Get a file or directory's user permissions +getmod :: MonadIO io => FilePath -> io Permissions +getmod path = liftIO (do + let path' = deslash path + permissions <- Directory.getPermissions path' + return (fromSystemDirectoryPermissions permissions)) + +-- | Set a file or directory's user permissions +setmod :: MonadIO io => Permissions -> FilePath -> io () +setmod permissions path = liftIO (do + let path' = deslash path + Directory.setPermissions path' (toSystemDirectoryPermissions permissions) ) + +-- | Copy a file or directory's permissions (analogous to @chmod --reference@) +copymod :: MonadIO io => FilePath -> FilePath -> io () +copymod sourcePath targetPath = liftIO (do + let sourcePath' = deslash sourcePath + targetPath' = deslash targetPath + Directory.copyPermissions sourcePath' targetPath' ) + +-- | @+r@ +readable :: Permissions -> Permissions +readable p = p { _readable = True } + +-- | @-r@ +nonreadable :: Permissions -> Permissions +nonreadable p = p { _readable = False } + +-- | @+w@ +writable :: Permissions -> Permissions +writable p = p { _writable = True } + +-- | @-w@ +nonwritable :: Permissions -> Permissions +nonwritable p = p { _writable = False } + +-- | @+x@ +executable :: Permissions -> Permissions +executable p = p { _executable = True } + +-- | @-x@ +nonexecutable :: Permissions -> Permissions +nonexecutable p = p { _executable = False } + +-- | @-r -w -x@ +ooo :: Permissions -> Permissions +ooo _ = Permissions + { _readable = False + , _writable = False + , _executable = False + } + +-- | @+r -w -x@ +roo :: Permissions -> Permissions +roo = readable . ooo + +-- | @-r +w -x@ +owo :: Permissions -> Permissions +owo = writable . ooo + +-- | @-r -w +x@ +oox :: Permissions -> Permissions +oox = executable . ooo + +-- | @+r +w -x@ +rwo :: Permissions -> Permissions +rwo = readable . writable . ooo + +-- | @+r -w +x@ +rox :: Permissions -> Permissions +rox = readable . executable . ooo + +-- | @-r +w +x@ +owx :: Permissions -> Permissions +owx = writable . executable . ooo + +-- | @+r +w +x@ +rwx :: Permissions -> Permissions +rwx = readable . writable . executable . ooo + +{-| Time how long a command takes in monotonic wall clock time + + Returns the duration alongside the return value +-} +time :: MonadIO io => io a -> io (a, NominalDiffTime) +time io = do + TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic) + a <- io + TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic) + let t = fromIntegral ( seconds2 - seconds1) + + fromIntegral (nanoseconds2 - nanoseconds1) / 10^(9::Int) + return (a, fromRational t) + +-- | Get the system's host name +hostname :: MonadIO io => io Text +hostname = liftIO (fmap Text.pack getHostName) + +-- | Show the full path of an executable file +which :: MonadIO io => FilePath -> io (Maybe FilePath) +which cmd = fold (whichAll cmd) Control.Foldl.head + +-- | Show all matching executables in PATH, not just the first +whichAll :: FilePath -> Shell FilePath +whichAll cmd = do + Just paths <- need "PATH" + path <- select (fmap Text.unpack (Text.splitOn ":" paths)) + let path' = path cmd + + True <- testfile path' + + let handler :: IOError -> IO Bool + handler e = + if isPermissionError e || isDoesNotExistError e + then return False + else throwIO e + + let getIsExecutable = fmap _executable (getmod path') + isExecutable <- liftIO (getIsExecutable `catchIOError` handler) + + guard isExecutable + return path' + +{-| Sleep for the given duration + + A numeric literal argument is interpreted as seconds. In other words, + @(sleep 2.0)@ will sleep for two seconds. +-} +sleep :: MonadIO io => NominalDiffTime -> io () +sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int)))) + +{-| Exit with the given exit code + + An exit code of @0@ indicates success +-} +exit :: MonadIO io => ExitCode -> io a +exit code = liftIO (exitWith code) + +-- | Throw an exception using the provided `Text` message +die :: MonadIO io => Text -> io a +die txt = liftIO (throwIO (userError (unpack txt))) + +infixr 2 .||. +infixr 3 .&&. + +{-| Analogous to `&&` in Bash + + Runs the second command only if the first one returns `ExitSuccess` +-} +(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode +cmd1 .&&. cmd2 = do + r <- cmd1 + case r of + ExitSuccess -> cmd2 + _ -> return r + +{-| Analogous to `||` in Bash + + Run the second command only if the first one returns `ExitFailure` +-} +(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode +cmd1 .||. cmd2 = do + r <- cmd1 + case r of + ExitFailure _ -> cmd2 + _ -> return r + +{-| Create a temporary directory underneath the given directory + + Deletes the temporary directory when done +-} +mktempdir + :: MonadManaged managed + => FilePath + -- ^ Parent directory + -> Text + -- ^ Directory name template + -> managed FilePath +mktempdir parent prefix = using (do + let prefix' = unpack prefix + managed (withTempDirectory parent prefix')) + +{-| Create a temporary file underneath the given directory + + Deletes the temporary file when done + + Note that this provides the `Handle` of the file in order to avoid a + potential race condition from the file being moved or deleted before you + have a chance to open the file. The `mktempfile` function provides a + simpler API if you don't need to worry about that possibility. +-} +mktemp + :: MonadManaged managed + => FilePath + -- ^ Parent directory + -> Text + -- ^ File name template + -> managed (FilePath, Handle) +mktemp parent prefix = using (do + let prefix' = unpack prefix + (file', handle) <- managed (\k -> + withTempFile parent prefix' (\file' handle -> k (file', handle)) ) + return (file', handle) ) + +{-| Create a temporary file underneath the given directory + + Deletes the temporary file when done +-} +mktempfile + :: MonadManaged managed + => FilePath + -- ^ Parent directory + -> Text + -- ^ File name template + -> managed FilePath +mktempfile parent prefix = using (do + let prefix' = unpack prefix + (file', handle) <- managed (\k -> + withTempFile parent prefix' (\file' handle -> k (file', handle)) ) + liftIO (hClose handle) + return file' ) + +-- | Fork a thread, acquiring an `Async` value +fork :: MonadManaged managed => IO a -> managed (Async a) +fork io = using (managed (withAsync io)) + +-- | Wait for an `Async` action to complete +wait :: MonadIO io => Async a -> io a +wait a = liftIO (Control.Concurrent.Async.wait a) + +-- | Read lines of `Text` from standard input +stdin :: Shell Line +stdin = inhandle IO.stdin + +-- | Read lines of `Text` from a file +input :: FilePath -> Shell Line +input file = do + handle <- using (readonly file) + inhandle handle + +-- | Read lines of `Text` from a `Handle` +inhandle :: Handle -> Shell Line +inhandle handle = Shell (\(FoldShell step begin done) -> do + let loop x = do + eof <- IO.hIsEOF handle + if eof + then done x + else do + txt <- Text.hGetLine handle + x' <- step x (unsafeTextToLine txt) + loop $! x' + loop $! begin ) + +-- | Stream lines of `Text` to standard output +stdout :: MonadIO io => Shell Line -> io () +stdout s = sh (do + line <- s + liftIO (echo line) ) + +-- | Stream lines of `Text` to a file +output :: MonadIO io => FilePath -> Shell Line -> io () +output file s = sh (do + handle <- using (writeonly file) + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) + +-- | Stream lines of `Text` to a `Handle` +outhandle :: MonadIO io => Handle -> Shell Line -> io () +outhandle handle s = sh (do + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) + +-- | Stream lines of `Text` to append to a file +append :: MonadIO io => FilePath -> Shell Line -> io () +append file s = sh (do + handle <- using (appendonly file) + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) + +-- | Stream lines of `Text` to standard error +stderr :: MonadIO io => Shell Line -> io () +stderr s = sh (do + line <- s + liftIO (err line) ) + +-- | Read in a stream's contents strictly +strict :: MonadIO io => Shell Line -> io Text +strict s = liftM linesToText (fold s list) + +-- | Acquire a `Managed` read-only `Handle` from a `FilePath` +readonly :: MonadManaged managed => FilePath -> managed Handle +readonly file = using (managed (IO.withFile file IO.ReadMode)) + +-- | Acquire a `Managed` write-only `Handle` from a `FilePath` +writeonly :: MonadManaged managed => FilePath -> managed Handle +writeonly file = using (managed (IO.withFile file IO.WriteMode)) + +-- | Acquire a `Managed` append-only `Handle` from a `FilePath` +appendonly :: MonadManaged managed => FilePath -> managed Handle +appendonly file = using (managed (IO.withFile file IO.AppendMode)) + +-- | Combine the output of multiple `Shell`s, in order +cat :: [Shell a] -> Shell a +cat = msum + +grepWith :: (b -> Text) -> Pattern a -> Shell b -> Shell b +grepWith f pattern' = mfilter (not . null . match pattern' . f) + +-- | Keep all lines that match the given `Pattern` +grep :: Pattern a -> Shell Line -> Shell Line +grep = grepWith lineToText + +-- | Keep every `Text` element that matches the given `Pattern` +grepText :: Pattern a -> Shell Text -> Shell Text +grepText = grepWith id + +{-| Replace all occurrences of a `Pattern` with its `Text` result + + `sed` performs substitution on a line-by-line basis, meaning that + substitutions may not span multiple lines. Additionally, substitutions may + occur multiple times within the same line, like the behavior of + @s\/...\/...\/g@. + + Warning: Do not use a `Pattern` that matches the empty string, since it will + match an infinite number of times. `sed` tries to detect such `Pattern`s + and `die` with an error message if they occur, but this detection is + necessarily incomplete. +-} +sed :: Pattern Text -> Shell Line -> Shell Line +sed pattern' s = do + when (matchesEmpty pattern') (die message) + let pattern'' = fmap Text.concat + (many (pattern' <|> fmap Text.singleton anyChar)) + line <- s + txt':_ <- return (match pattern'' (lineToText line)) + select (textToLines txt') + where + message = "sed: the given pattern matches the empty string" + matchesEmpty = not . null . flip match "" + +{-| Like `sed`, but the provided substitution must match the beginning of the + line +-} +sedPrefix :: Pattern Text -> Shell Line -> Shell Line +sedPrefix pattern' s = do + line <- s + txt':_ <- return (match ((pattern' <> chars) <|> chars) (lineToText line)) + select (textToLines txt') + +-- | Like `sed`, but the provided substitution must match the end of the line +sedSuffix :: Pattern Text -> Shell Line -> Shell Line +sedSuffix pattern' s = do + line <- s + txt':_ <- return (match ((chars <> pattern') <|> chars) (lineToText line)) + select (textToLines txt') + +-- | Like `sed`, but the provided substitution must match the entire line +sedEntire :: Pattern Text -> Shell Line -> Shell Line +sedEntire pattern' s = do + line <- s + txt':_ <- return (match (pattern' <|> chars)(lineToText line)) + select (textToLines txt') + +-- | Make a `Shell Text -> Shell Text` function work on `FilePath`s instead. +-- | Ignores any paths which cannot be decoded as valid `Text`. +onFiles :: (Shell Text -> Shell Text) -> Shell FilePath -> Shell FilePath +onFiles f = fmap Text.unpack . f . fmap Text.pack + +-- | Like `sed`, but operates in place on a `FilePath` (analogous to @sed -i@) +inplace :: MonadIO io => Pattern Text -> FilePath -> io () +inplace = update . sed + +-- | Like `sedPrefix`, but operates in place on a `FilePath` +inplacePrefix :: MonadIO io => Pattern Text -> FilePath -> io () +inplacePrefix = update . sedPrefix + +-- | Like `sedSuffix`, but operates in place on a `FilePath` +inplaceSuffix :: MonadIO io => Pattern Text -> FilePath -> io () +inplaceSuffix = update . sedSuffix + +-- | Like `sedEntire`, but operates in place on a `FilePath` +inplaceEntire :: MonadIO io => Pattern Text -> FilePath -> io () +inplaceEntire = update . sedEntire + +{-| Update a file in place using a `Shell` transformation + + For example, this is used to implement the @inplace*@ family of utilities +-} +update :: MonadIO io => (Shell Line -> Shell Line) -> FilePath -> io () +update f file = liftIO (runManaged (do + here <- pwd + + (tmpfile, handle) <- mktemp here "turtle" + + outhandle handle (f (input file)) + + liftIO (hClose handle) + + copymod file tmpfile + + mv tmpfile file )) + +-- | Search a directory recursively for all files matching the given `Pattern` +find :: Pattern a -> FilePath -> Shell FilePath +find pattern' dir = do + path <- lsif isNotSymlink dir + + let txt = Text.pack path + + _:_ <- return (match pattern' txt) + + return path + where + isNotSymlink :: FilePath -> IO Bool + isNotSymlink file = do + file_stat <- lstat file + return (not (PosixCompat.isSymbolicLink file_stat)) + +-- | Filter a shell of FilePaths according to a given pattern +findtree :: Pattern a -> Shell FilePath -> Shell FilePath +findtree pat files = do + path <- files + + let txt = Text.pack path + + _:_ <- return (match pat txt) + + return path + +{- | Check if a file was last modified after a given + timestamp +-} +cmin :: MonadIO io => UTCTime -> FilePath -> io Bool +cmin t file = do + status <- lstat file + return (adapt status) + where + adapt x = posixSecondsToUTCTime (modificationTime x) > t + +{- | Check if a file was last modified before a given + timestamp +-} +cmax :: MonadIO io => UTCTime -> FilePath -> io Bool +cmax t file = do + status <- lstat file + return (adapt status) + where + adapt x = posixSecondsToUTCTime (modificationTime x) < t + +-- | A Stream of @\"y\"@s +yes :: Shell Line +yes = fmap (\_ -> "y") endless + +-- | Number each element of a `Shell` (starting at 0) +nl :: Num n => Shell a -> Shell (n, a) +nl s = Shell _foldShell' + where + _foldShell' (FoldShell step begin done) = _foldShell s (FoldShell step' begin' done') + where + step' (x, n) a = do + x' <- step x (n, a) + let n' = n + 1 + n' `seq` return (x', n') + begin' = (begin, 0) + done' (x, _) = done x + +data ZipState a b = Empty | HasA a | HasAB a b | Done + +{-| Merge two `Shell`s together, element-wise + + If one `Shell` is longer than the other, the excess elements are + truncated +-} +paste :: Shell a -> Shell b -> Shell (a, b) +paste sA sB = Shell _foldShellAB + where + _foldShellAB (FoldShell stepAB beginAB doneAB) = do + tvar <- STM.atomically (STM.newTVar Empty) + + let begin = () + + let stepA () a = STM.atomically (do + x <- STM.readTVar tvar + case x of + Empty -> STM.writeTVar tvar (HasA a) + Done -> return () + _ -> STM.retry ) + let doneA () = STM.atomically (do + x <- STM.readTVar tvar + case x of + Empty -> STM.writeTVar tvar Done + Done -> return () + _ -> STM.retry ) + let foldA = FoldShell stepA begin doneA + + let stepB () b = STM.atomically (do + x <- STM.readTVar tvar + case x of + HasA a -> STM.writeTVar tvar (HasAB a b) + Done -> return () + _ -> STM.retry ) + let doneB () = STM.atomically (do + x <- STM.readTVar tvar + case x of + HasA _ -> STM.writeTVar tvar Done + Done -> return () + _ -> STM.retry ) + let foldB = FoldShell stepB begin doneB + + withAsync (_foldShell sA foldA) (\asyncA -> do + withAsync (_foldShell sB foldB) (\asyncB -> do + let loop x = do + y <- STM.atomically (do + z <- STM.readTVar tvar + case z of + HasAB a b -> do + STM.writeTVar tvar Empty + return (Just (a, b)) + Done -> return Nothing + _ -> STM.retry ) + case y of + Nothing -> return x + Just ab -> do + x' <- stepAB x ab + loop $! x' + x' <- loop $! beginAB + wait asyncA + wait asyncB + doneAB x' ) ) + +-- | A `Shell` that endlessly emits @()@ +endless :: Shell () +endless = Shell (\(FoldShell step begin _) -> do + let loop x = do + x' <- step x () + loop $! x' + loop $! begin ) + +{-| Limit a `Shell` to a fixed number of values + + NOTE: This is not lazy and will still consume the entire input stream. + There is no way to implement a lazy version of this utility. +-} +limit :: Int -> Shell a -> Shell a +limit n s = Shell (\(FoldShell step begin done) -> do + ref <- newIORef 0 -- I feel so dirty + let step' x a = do + n' <- readIORef ref + writeIORef ref (n' + 1) + if n' < n then step x a else return x + _foldShell s (FoldShell step' begin done) ) + +{-| Limit a `Shell` to values that satisfy the predicate + + This terminates the stream on the first value that does not satisfy the + predicate +-} +limitWhile :: (a -> Bool) -> Shell a -> Shell a +limitWhile predicate s = Shell (\(FoldShell step begin done) -> do + ref <- newIORef True + let step' x a = do + b <- readIORef ref + let b' = b && predicate a + writeIORef ref b' + if b' then step x a else return x + _foldShell s (FoldShell step' begin done) ) + +{-| Cache a `Shell`'s output so that repeated runs of the script will reuse the + result of previous runs. You must supply a `FilePath` where the cached + result will be stored. + + The stored result is only reused if the `Shell` successfully ran to + completion without any exceptions. Note: on some platforms Ctrl-C will + flush standard input and signal end of file before killing the program, + which may trick the program into \"successfully\" completing. +-} +cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a +cache file s = do + let cached = do + line <- input file + case reads (Text.unpack (lineToText line)) of + [(ma, "")] -> return ma + _ -> + die (format ("cache: Invalid data stored in "%w) file) + exists <- testfile file + mas <- fold (if exists then cached else empty) list + case [ () | Nothing <- mas ] of + _:_ -> select [ a | Just a <- mas ] + _ -> do + handle <- using (writeonly file) + let justs = do + a <- s + liftIO (Text.hPutStrLn handle (Text.pack (show (Just a)))) + return a + let nothing = do + let n = Nothing :: Maybe () + liftIO (Text.hPutStrLn handle (Text.pack (show n))) + empty + justs <|> nothing + +{-| Run a list of IO actions in parallel using fork and wait. + + +>>> view (parallel [(sleep 3) >> date, date, date]) +2016-12-01 17:22:10.83296 UTC +2016-12-01 17:22:07.829876 UTC +2016-12-01 17:22:07.829963 UTC + +-} +parallel :: [IO a] -> Shell a +parallel = traverse fork >=> select >=> wait + +-- | Split a line into chunks delimited by the given `Pattern` +cut :: Pattern a -> Text -> [Text] +cut pattern' txt = head (match (selfless chars `sepBy` pattern') txt) +-- This `head` should be safe ... in theory + +-- | Get the current time +date :: MonadIO io => io UTCTime +date = liftIO getCurrentTime + +-- | Get the time a file was last modified +datefile :: MonadIO io => FilePath -> io UTCTime +datefile path = liftIO (Directory.getModificationTime path) + +-- | Get the size of a file or a directory +du :: MonadIO io => FilePath -> io Size +du path = liftIO (do + isDir <- testdir path + size <- do + if isDir + then do + let sizes = do + child <- lstree path + True <- testfile child + liftIO (Directory.getFileSize child) + fold sizes Control.Foldl.sum + else Directory.getFileSize path + return (Size size) ) + +{-| An abstract file size + + Specify the units you want by using an accessor like `kilobytes` + + The `Num` instance for `Size` interprets numeric literals as bytes +-} +newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num) + +instance Show Size where + show = show . _bytes + +{-| `Format` a `Size` using a human readable representation + +>>> format sz 42 +"42 B" +>>> format sz 2309 +"2.309 KB" +>>> format sz 949203 +"949.203 KB" +>>> format sz 1600000000 +"1.600 GB" +>>> format sz 999999999999999999 +"999999.999 TB" +-} +sz :: Format r (Size -> r) +sz = makeFormat (\(Size numBytes) -> + let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000 + (numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000 + (numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000 + (numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000 + in if numKilobytes <= 0 + then format (d%" B" ) remainingBytes + else if numMegabytes == 0 + then format (d%"."%d%" KB") remainingKilobytes remainingBytes + else if numGigabytes == 0 + then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes + else if numTerabytes == 0 + then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes + else format (d%"."%d%" TB") numTerabytes remainingGigabytes ) + +{-| Construct a 'Size' from an integer in bytes + +>>> format sz (B 42) +"42 B" +-} +pattern B :: Integral n => n -> Size +pattern B { bytes } <- (fromInteger . _bytes -> bytes) + where + B = fromIntegral +{-# COMPLETE B #-} + +{-| Construct a 'Size' from an integer in kilobytes + +>>> format sz (KB 42) +"42.0 KB" +>>> let B n = KB 1 in n +1000 +-} +pattern KB :: Integral n => n -> Size +pattern KB { kilobytes } <- (\(B x) -> x `div` 1000 -> kilobytes) + where + KB = B . (* 1000) +{-# COMPLETE KB #-} + +{-| Construct a 'Size' from an integer in megabytes + +>>> format sz (MB 42) +"42.0 MB" +>>> let KB n = MB 1 in n +1000 +-} +pattern MB :: Integral n => n -> Size +pattern MB { megabytes } <- (\(KB x) -> x `div` 1000 -> megabytes) + where + MB = KB . (* 1000) +{-# COMPLETE MB #-} + +{-| Construct a 'Size' from an integer in gigabytes + +>>> format sz (GB 42) +"42.0 GB" +>>> let MB n = GB 1 in n +1000 +-} +pattern GB :: Integral n => n -> Size +pattern GB { gigabytes } <- (\(MB x) -> x `div` 1000 -> gigabytes) + where + GB = MB . (* 1000) +{-# COMPLETE GB #-} + +{-| Construct a 'Size' from an integer in terabytes + +>>> format sz (TB 42) +"42.0 TB" +>>> let GB n = TB 1 in n +1000 +-} +pattern TB :: Integral n => n -> Size +pattern TB { terabytes } <- (\(GB x) -> x `div` 1000 -> terabytes) + where + TB = GB . (* 1000) +{-# COMPLETE TB #-} + +{-| Construct a 'Size' from an integer in kibibytes + +>>> format sz (KiB 42) +"43.8 KB" +>>> let B n = KiB 1 in n +1024 +-} +pattern KiB :: Integral n => n -> Size +pattern KiB { kibibytes } <- (\(B x) -> x `div` 1024 -> kibibytes) + where + KiB = B . (* 1024) +{-# COMPLETE KiB #-} + +{-| Construct a 'Size' from an integer in mebibytes + +>>> format sz (MiB 42) +"44.40 MB" +>>> let KiB n = MiB 1 in n +1024 +-} +pattern MiB :: Integral n => n -> Size +pattern MiB { mebibytes } <- (\(KiB x) -> x `div` 1024 -> mebibytes) + where + MiB = KiB . (* 1024) +{-# COMPLETE MiB #-} + +{-| Construct a 'Size' from an integer in gibibytes + +>>> format sz (GiB 42) +"45.97 GB" +>>> let MiB n = GiB 1 in n +1024 +-} +pattern GiB :: Integral n => n -> Size +pattern GiB { gibibytes } <- (\(MiB x) -> x `div` 1024 -> gibibytes) + where + GiB = MiB . (* 1024) +{-# COMPLETE GiB #-} + +{-| Construct a 'Size' from an integer in tebibytes + +>>> format sz (TiB 42) +"46.179 TB" +>>> let GiB n = TiB 1 in n +1024 +-} +pattern TiB :: Integral n => n -> Size +pattern TiB { tebibytes } <- (\(GiB x) -> x `div` 1024 -> tebibytes) + where + TiB = GiB . (* 1024) +{-# COMPLETE TiB #-} + +-- | Extract a size in bytes +bytes :: Integral n => Size -> n + +-- | @1 kilobyte = 1000 bytes@ +kilobytes :: Integral n => Size -> n + +-- | @1 megabyte = 1000 kilobytes@ +megabytes :: Integral n => Size -> n + +-- | @1 gigabyte = 1000 megabytes@ +gigabytes :: Integral n => Size -> n + +-- | @1 terabyte = 1000 gigabytes@ +terabytes :: Integral n => Size -> n + +-- | @1 kibibyte = 1024 bytes@ +kibibytes :: Integral n => Size -> n + +-- | @1 mebibyte = 1024 kibibytes@ +mebibytes :: Integral n => Size -> n + +-- | @1 gibibyte = 1024 mebibytes@ +gibibytes :: Integral n => Size -> n + +-- | @1 tebibyte = 1024 gibibytes@ +tebibytes :: Integral n => Size -> n + +{-| Count the number of characters in the stream (like @wc -c@) + + This uses the convention that the elements of the stream are implicitly + ended by newlines that are one character wide +-} +countChars :: Integral n => Fold Line n +countChars = + premap lineToText Control.Foldl.Text.length + + charsPerNewline * countLines + +charsPerNewline :: Num a => a +#ifdef mingw32_HOST_OS +charsPerNewline = 2 +#else +charsPerNewline = 1 +#endif + +-- | Count the number of words in the stream (like @wc -w@) +countWords :: Integral n => Fold Line n +countWords = premap (Text.words . lineToText) (handles traverse genericLength) + +{-| Count the number of lines in the stream (like @wc -l@) + + This uses the convention that each element of the stream represents one + line +-} +countLines :: Integral n => Fold Line n +countLines = genericLength + +-- | Get the status of a file +stat :: MonadIO io => FilePath -> io PosixCompat.FileStatus +stat = liftIO . PosixCompat.getFileStatus + +-- | Size of the file in bytes. Does not follow symlinks +fileSize :: PosixCompat.FileStatus -> Size +fileSize = fromIntegral . PosixCompat.fileSize + +-- | Time of last access +accessTime :: PosixCompat.FileStatus -> POSIXTime +accessTime = realToFrac . PosixCompat.accessTime + +-- | Time of last modification +modificationTime :: PosixCompat.FileStatus -> POSIXTime +modificationTime = realToFrac . PosixCompat.modificationTime + +-- | Time of last status change (i.e. owner, group, link count, mode, etc.) +statusChangeTime :: PosixCompat.FileStatus -> POSIXTime +statusChangeTime = realToFrac . PosixCompat.statusChangeTime + +-- | Get the status of a file, but don't follow symbolic links +lstat :: MonadIO io => FilePath -> io PosixCompat.FileStatus +lstat = liftIO . PosixCompat.getSymbolicLinkStatus + +data WithHeader a + = Header a + -- ^ The first line with the header + | Row a a + -- ^ Every other line: 1st element is header, 2nd element is original row + deriving (Show) + +data Pair a b = Pair !a !b + +header :: Shell a -> Shell (WithHeader a) +header (Shell k) = Shell k' + where + k' (FoldShell step begin done) = k (FoldShell step' begin' done') + where + step' (Pair x Nothing ) a = do + x' <- step x (Header a) + return (Pair x' (Just a)) + step' (Pair x (Just a)) b = do + x' <- step x (Row a b) + return (Pair x' (Just a)) + + begin' = Pair begin Nothing + + done' (Pair x _) = done x + +-- | Returns the result of a 'Shell' that outputs a single line. +-- Note that if no lines / more than 1 line is produced by the Shell, this function will `die` with an error message. +-- +-- > main = do +-- > directory <- single (inshell "pwd" empty) +-- > print directory +single :: MonadIO io => Shell a -> io a +single s = do + as <- fold s Control.Foldl.list + case as of + [a] -> return a + _ -> do + let msg = format ("single: expected 1 line of input but there were "%d%" lines of input") (length as) + die msg + +-- | Filter adjacent duplicate elements: +-- +-- >>> view (uniq (select [1,1,2,1,3])) +-- 1 +-- 2 +-- 1 +-- 3 +uniq :: Eq a => Shell a -> Shell a +uniq = uniqOn id + +-- | Filter adjacent duplicates determined after applying the function to the element: +-- +-- >>> view (uniqOn fst (select [(1,'a'),(1,'b'),(2,'c'),(1,'d'),(3,'e')])) +-- (1,'a') +-- (2,'c') +-- (1,'d') +-- (3,'e') +uniqOn :: Eq b => (a -> b) -> Shell a -> Shell a +uniqOn f = uniqBy (\a a' -> f a == f a') + +-- | Filter adjacent duplicate elements determined via the given function: +-- +-- >>> view (uniqBy (==) (select [1,1,2,1,3])) +-- 1 +-- 2 +-- 1 +-- 3 +uniqBy :: (a -> a -> Bool) -> Shell a -> Shell a +uniqBy cmp s = Shell $ \(FoldShell step begin done) -> do + let step' (x, Just a') a | cmp a a' = return (x, Just a) + step' (x, _) a = (, Just a) <$> step x a + begin' = (begin, Nothing) + done' (x, _) = done x + foldShell s (FoldShell step' begin' done') + +-- | Return a new `Shell` that discards duplicates from the input `Shell`: +-- +-- >>> view (nub (select [1, 1, 2, 3, 3, 4, 3])) +-- 1 +-- 2 +-- 3 +-- 4 +nub :: Ord a => Shell a -> Shell a +nub = nubOn id + +-- | Return a new `Shell` that discards duplicates determined via the given function from the input `Shell`: +-- +-- >>> view (nubOn id (select [1, 1, 2, 3, 3, 4, 3])) +-- 1 +-- 2 +-- 3 +-- 4 +nubOn :: Ord b => (a -> b) -> Shell a -> Shell a +nubOn f s = Shell $ \(FoldShell step begin done) -> do + let step' (x, bs) a | Set.member (f a) bs = return (x, bs) + | otherwise = (, Set.insert (f a) bs) <$> step x a + begin' = (begin, Set.empty) + done' (x, _) = done x + foldShell s (FoldShell step' begin' done') + +-- | Return a list of the sorted elements of the given `Shell`, keeping duplicates: +-- +-- >>> sort (select [1,4,2,3,3,7]) +-- [1,2,3,3,4,7] +sort :: (Functor io, MonadIO io, Ord a) => Shell a -> io [a] +sort = sortOn id + +-- | Return a list of the elements of the given `Shell`, sorted after applying the given function and keeping duplicates: +-- +-- >>> sortOn id (select [1,4,2,3,3,7]) +-- [1,2,3,3,4,7] +sortOn :: (Functor io, MonadIO io, Ord b) => (a -> b) -> Shell a -> io [a] +sortOn f = sortBy (comparing f) + +-- | Return a list of the elements of the given `Shell`, sorted by the given function and keeping duplicates: +-- +-- >>> sortBy (comparing fst) (select [(1,'a'),(4,'b'),(2,'c'),(3,'d'),(3,'e'),(7,'f')]) +-- [(1,'a'),(2,'c'),(3,'d'),(3,'e'),(4,'b'),(7,'f')] +sortBy :: (Functor io, MonadIO io) => (a -> a -> Ordering) -> Shell a -> io [a] +sortBy f s = List.sortBy f <$> fold s list + +{-| Group an arbitrary stream of `Text` into newline-delimited `Line`s + +>>> stdout (toLines ("ABC" <|> "DEF" <|> "GHI") +ABCDEFGHI +>>> stdout (toLines empty) -- Note that this always emits at least 1 `Line` + +>>> stdout (toLines ("ABC\nDEF" <|> "" <|> "GHI\nJKL")) +ABC +DEFGHI +JKL +-} +toLines :: Shell Text -> Shell Line +toLines (Shell k) = Shell k' + where + k' (FoldShell step begin done) = + k (FoldShell step' begin' done') + where + step' (Pair x prefix) text = do + let suffix :| lines = Turtle.Line.textToLines text + + let line = prefix <> suffix + + let lines' = line :| lines + + x' <- foldM step x (NonEmpty.init lines') + + let prefix' = NonEmpty.last lines' + + return (Pair x' prefix') + + begin' = (Pair begin "") + + done' (Pair x prefix) = do + x' <- step x prefix + done x' diff --git a/src/Turtle/Shell.hs b/src/Turtle/Shell.hs --- a/src/Turtle/Shell.hs +++ b/src/Turtle/Shell.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-| You can think of `Shell` as @[]@ + `IO` + `Managed`. In fact, you can embed @@ -47,9 +50,8 @@ `Shell` you build must satisfy this law: > -- For every shell `s`: -> _foldIO s (FoldM step begin done) = do -> x <- begin -> x' <- _foldIO s (FoldM step (return x) return) +> _foldShell s (FoldShell step begin done) = do +> x' <- _foldShell s (FoldShell step begin return) > done x' ... which is a fancy way of saying that your `Shell` must call @\'begin\'@ @@ -59,8 +61,13 @@ module Turtle.Shell ( -- * Shell Shell(..) + , FoldShell(..) + , _foldIO + , _Shell , foldIO + , foldShell , fold + , reduce , sh , view @@ -68,29 +75,87 @@ , select , liftIO , using + , fromIO ) where import Control.Applicative import Control.Monad (MonadPlus(..), ap) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Managed (MonadManaged(..), with) +import qualified Control.Monad.Fail as Fail import Control.Foldl (Fold(..), FoldM(..)) import qualified Control.Foldl as Foldl +import Data.Foldable (Foldable) +import qualified Data.Foldable import Data.Monoid import Data.String (IsString(..)) import Prelude -- Fix redundant import warnings +{-| This is similar to @`Control.Foldl.FoldM` `IO`@ except that the @begin@ + field is pure + + This small difference is necessary to implement a well-behaved `MonadCatch` + instance for `Shell` +-} +data FoldShell a b = forall x . FoldShell (x -> a -> IO x) x (x -> IO b) + -- | A @(Shell a)@ is a protected stream of @a@'s with side effects -newtype Shell a = Shell { _foldIO :: forall r . FoldM IO a r -> IO r } +newtype Shell a = Shell { _foldShell:: forall r . FoldShell a r -> IO r } +data Maybe' a = Just' !a | Nothing' + +translate :: FoldM IO a b -> FoldShell a b +translate (FoldM step begin done) = FoldShell step' Nothing' done' + where + step' Nothing' a = do + x <- begin + x' <- step x a + return $! Just' x' + step' (Just' x) a = do + x' <- step x a + return $! Just' x' + + done' Nothing' = do + x <- begin + done x + done' (Just' x) = do + done x + -- | Use a @`FoldM` `IO`@ to reduce the stream of @a@'s produced by a `Shell` foldIO :: MonadIO io => Shell a -> FoldM IO a r -> io r foldIO s f = liftIO (_foldIO s f) +{-| Provided for backwards compatibility with versions of @turtle-1.4.*@ and + older +-} +_foldIO :: Shell a -> FoldM IO a r -> IO r +_foldIO s foldM = _foldShell s (translate foldM) + +-- | Provided for ease of migration from versions of @turtle-1.4.*@ and older +_Shell :: (forall r . FoldM IO a r -> IO r) -> Shell a +_Shell f = Shell (f . adapt) + where + adapt (FoldShell step begin done) = FoldM step (return begin) done + +-- | Use a `FoldShell` to reduce the stream of @a@'s produced by a `Shell` +foldShell :: MonadIO io => Shell a -> FoldShell a b -> io b +foldShell s f = liftIO (_foldShell s f) + -- | Use a `Fold` to reduce the stream of @a@'s produced by a `Shell` fold :: MonadIO io => Shell a -> Fold a b -> io b fold s f = foldIO s (Foldl.generalize f) +-- | Flipped version of 'fold'. Useful for reducing a stream of data +-- +-- ==== __Example__ +-- Sum a `Shell` of numbers: +-- +-- >>> select [1, 2, 3] & reduce Fold.sum +-- 6 +reduce :: MonadIO io => Fold a b -> Shell a -> io b +reduce = flip fold + -- | Run a `Shell` to completion, discarding any unused values sh :: MonadIO io => Shell a -> io () sh s = fold s (pure ()) @@ -102,34 +167,33 @@ liftIO (print x) ) instance Functor Shell where - fmap f s = Shell (\(FoldM step begin done) -> + fmap f s = Shell (\(FoldShell step begin done) -> let step' x a = step x (f a) - in _foldIO s (FoldM step' begin done) ) + in _foldShell s (FoldShell step' begin done) ) instance Applicative Shell where pure = return (<*>) = ap instance Monad Shell where - return a = Shell (\(FoldM step begin done) -> do - x <- begin - x' <- step x a - done x' ) + return a = Shell (\(FoldShell step begin done) -> do + x <- step begin a + done x ) - m >>= f = Shell (\(FoldM step0 begin0 done0) -> do - let step1 x a = _foldIO (f a) (FoldM step0 (return x) return) - _foldIO m (FoldM step1 begin0 done0) ) + m >>= f = Shell (\(FoldShell step0 begin0 done0) -> do + let step1 x a = _foldShell (f a) (FoldShell step0 x return) + _foldShell m (FoldShell step1 begin0 done0) ) - fail _ = mzero +#if!(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif instance Alternative Shell where - empty = Shell (\(FoldM _ begin done) -> do - x <- begin - done x ) + empty = Shell (\(FoldShell _ begin done) -> done begin) - s1 <|> s2 = Shell (\(FoldM step begin done) -> do - x <- _foldIO s1 (FoldM step begin return) - _foldIO s2 (FoldM step (return x) done) ) + s1 <|> s2 = Shell (\(FoldShell step begin done) -> do + x <- _foldShell s1 (FoldShell step begin return) + _foldShell s2 (FoldShell step x done) ) instance MonadPlus Shell where mzero = empty @@ -137,18 +201,30 @@ mplus = (<|>) instance MonadIO Shell where - liftIO io = Shell (\(FoldM step begin done) -> do - x <- begin - a <- io - x' <- step x a - done x' ) + liftIO io = Shell (\(FoldShell step begin done) -> do + a <- io + x <- step begin a + done x ) instance MonadManaged Shell where - using resource = Shell (\(FoldM step begin done) -> do - x <- begin - x' <- with resource (step x) - done x' ) + using resource = Shell (\(FoldShell step begin done) -> do + x <- with resource (step begin) + done x ) +instance MonadThrow Shell where + throwM e = Shell (\_ -> throwM e) + +instance MonadCatch Shell where + m `catch` k = Shell (\f-> _foldShell m f `catch` (\e -> _foldShell (k e) f)) + +instance Fail.MonadFail Shell where + fail _ = mzero + +#if __GLASGOW_HASKELL__ >= 804 +instance Monoid a => Semigroup (Shell a) where + (<>) = mappend +#endif + instance Monoid a => Monoid (Shell a) where mempty = pure mempty mappend = liftA2 mappend @@ -164,10 +240,26 @@ fromString str = pure (fromString str) -- | Convert a list to a `Shell` that emits each element of the list -select :: [a] -> Shell a -select as = Shell (\(FoldM step begin done) -> do - x0 <- begin +select :: Foldable f => f a -> Shell a +select as = Shell (\(FoldShell step begin done) -> do let step' a k x = do x' <- step x a k $! x' - foldr step' done as $! x0 ) + Data.Foldable.foldr step' done as $! begin ) + +-- | Convert an `IO` action that returns a `Maybe` into a `Shell` +fromIO :: IO (Maybe a) -> Shell a +fromIO io = + Shell + (\(FoldShell step begin done) -> do + let loop x = do + m <- io + case m of + Just a -> do + x' <- step x a + loop x' + Nothing -> do + done x + + loop begin + ) diff --git a/src/Turtle/Tutorial.hs b/src/Turtle/Tutorial.hs --- a/src/Turtle/Tutorial.hs +++ b/src/Turtle/Tutorial.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoCPP #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-| Use @turtle@ if you want to write light-weight and maintainable shell @@ -46,7 +47,7 @@ can install a Haskell compiler if one is not already present. If you are curious about how these two lines work, they are described here: - + If you want to make a Windows script independently executable outside of a Git Bash environment, you can either (A) compile the script into an @@ -115,6 +116,9 @@ -- * Conclusion -- $conclusion + -- * Nix scripts + -- $nix + -- * FAQ -- $faq ) where @@ -128,7 +132,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -193,7 +197,7 @@ -- difference: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -210,7 +214,7 @@ -- program this way instead: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -226,7 +230,7 @@ -- permits definitions. If you were to insert a statement at the top-level: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -243,7 +247,7 @@ -- command: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -269,7 +273,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- import Turtle -- @@ -297,7 +301,7 @@ -- within a larger subroutine: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > import Turtle -- @@ -359,7 +363,7 @@ -- following script to find out what happens if we choose `echo` instead: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > import Turtle -- > @@ -373,7 +377,7 @@ -- > $ ./example.hs -- > -- > example.hs:8:10: --- > Couldn't match expected type `Text' with actual type `UTCTime' +-- > Couldn't match expected type `Line' with actual type `UTCTime' -- > In the first argument of `echo', namely `time' -- > In a stmt of a 'do' block: echo time -- > In the expression: @@ -382,13 +386,14 @@ -- > echo time } -- -- The error points to the last line of our program: @(example.hs:8:10)@ means --- line 8, column 10 of our program. If you study the error message closely --- you'll see that the `echo` function expects a `Text` value, but we passed it --- @\'time\'@, which was a `UTCTime` value. Although the error is at the end of --- our script, Haskell catches this error before even running the script. When --- we \"interpret\" a Haskell script the Haskell compiler actually compiles the --- script without any optimizations to generate a temporary executable and then --- runs the executable, much like Perl does for Perl scripts. +-- line 8, column 10 of our program. If you study the error message closely +-- you'll see that the `echo` function expects a `Line` value (a piece of text +-- without newlines), but we passed it @\'time\'@, which was a `UTCTime` value. +-- Although the error is at the end of our script, Haskell catches this error +-- before even running the script. When we \"interpret\" a Haskell script the +-- Haskell compiler actually compiles the script without any optimizations to +-- generate a temporary executable and then runs the executable, much like Perl +-- does for Perl scripts. -- -- You might wonder: \"where are the types?\" None of the above programs had -- any type signatures or type annotations, yet the compiler still detected type @@ -446,14 +451,21 @@ -- -- @ -- Prelude Turtle> :type echo --- echo :: `Text` -> `IO` () +-- echo :: `Line` -> `IO` () -- @ -- -- The above type says that `echo` is a function whose argument is a value of --- type `Text` and whose result is a subroutine (`IO`) with an empty return +-- type `Line` and whose result is a subroutine (`IO`) with an empty return -- value (denoted @\'()\'@). -- --- Now we can understand the type error: `echo` expects a `Text` argument but +-- `Line` is a wrapper around `Text` and represents a `Text` value with no +-- internal newlines: +-- +-- @ +-- newtype `Line` = `Line` `Text` +-- @ +-- +-- Now we can understand the type error: `echo` expects a `Line` argument but -- `datefile` returns a `UTCTime`, which is not the same thing. Unlike Bash, -- not everything is `Text` in Haskell and the compiler will not cast or coerce -- types for you. @@ -472,16 +484,18 @@ -- `print`. -- -- This library provides a helper function that lets you convert any type that --- implements `Show` into a `Text` value: +-- implements `Show` into any other type that implements `IsString`: -- -- @ -- \-\- This behaves like Python's \`repr\` function --- `repr` :: `Show` a => a -> `Text` +-- `repr` :: (`Show` a, `IsString` b) => a -> b -- @ -- -- You could therefore implement `print` in terms of `echo` and `repr`: -- -- > print x = echo (repr x) +-- +-- ... which works because `Line` implements `IsString` -- $shell -- @@ -490,7 +504,7 @@ -- @turtle@: -- -- @ --- $ stack ghci +-- \$ stack ghci -- Prelude> :set -XOverloadedStrings -- Prelude> import Turtle -- Prelude Turtle> `cd` \"/tmp\" @@ -556,7 +570,7 @@ -- Let's illustrate this by adding types to our original script: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > import Turtle -- > @@ -590,17 +604,17 @@ -- > -- v v -- > main :: IO () -- --- Not every top-level value has to be a subroutine, though. For example, you --- can define unadorned `Text` values at the top-level, as we saw previously: +-- Not every top-level value has to be a subroutine, though. For example, you +-- can define unadorned `Line` values at the top-level, as we saw previously: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Turtle -- > --- > str :: Text +-- > str :: Line -- > str = "Hello!" -- > -- > main :: IO () @@ -614,7 +628,7 @@ -- Let's test this out by providing an incorrect type for @\'str\'@: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -638,21 +652,21 @@ -- > In an equation for `str': str = "Hello, world!" -- > -- > example.hs:11:13: --- > Couldn't match expected type `Text' with actual type `Int' +-- > Couldn't match expected type `Line' with actual type `Int' -- > In the first argument of `echo', namely `str' -- > In the expression: echo str -- > In an equation for `main': main = echo str -- -- The first error message relates to the @OverloadedStrings@ extensions. When -- we enable @OverloadedStrings@ the compiler overloads string literals, --- interpreting them as any type that implements the `IsString` interface. The +-- interpreting them as any type that implements the `IsString` interface. The -- error message says that `Int` does not implement the `IsString` interface so -- the compiler cannot interpret a string literal as an `Int`. On the other --- hand the `Text` and `Turtle.FilePath` types do implement `IsString`, which --- is why we can interpret string literals as `Text` or `Turtle.FilePath` --- values. +-- hand the `Text`, `Line` and `Turtle.FilePath` types do implement `IsString`, +-- which is why we can interpret string literals as `Text`, `Line` or +-- `Turtle.FilePath` values. -- --- The second error message says that `echo` expects a `Text` value, but we +-- The second error message says that `echo` expects a `Line` value, but we -- declared @str@ to be an `Int`, so the compiler aborts compilation, requiring -- us to either fix or delete our type signature. -- @@ -666,13 +680,13 @@ -- a string: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Turtle -- > --- > str :: Text +-- > str :: Line -- > str = 4 -- > -- > main :: IO () @@ -683,16 +697,16 @@ -- > $ ./example.hs -- > -- > example.hs:8:7: --- > No instance for (Num Text) +-- > No instance for (Num Line) -- > arising from the literal `4' --- > Possible fix: add an instance declaration for (Num Text) +-- > Possible fix: add an instance declaration for (Num Line) -- > In the expression: 4 -- > In an equation for `str': str = 4 -- -- Haskell also automatically overloads numeric literals, too. The compiler -- interprets integer literals as any type that implements the `Num` interface. --- The `Text` type does not implement the `Num` interface, so we cannot --- interpret integer literals as `Text` strings. +-- The `Line` type does not implement the `Num` interface, so we cannot +-- interpret integer literals as `Line` strings. -- $system -- @@ -702,7 +716,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -733,7 +747,7 @@ -- @ -- `shell` -- :: Text -- Command line --- -> Shell Text -- Standard input (as lines of \`Text\`) +-- -> Shell Line -- Standard input (as lines of \`Text\`) -- -> IO `ExitCode` -- Exit code of the shell command -- @ -- @@ -747,7 +761,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -774,7 +788,7 @@ -- `proc` -- :: Text -- Program -- -> [Text] -- Arguments --- -> Shell Text -- Standard input (as lines of \`Text\`) +-- -> Shell Line -- Standard input (as lines of \`Text\`) -- -> IO ExitCode -- Exit code of the shell command -- @ -- @@ -868,9 +882,9 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv" --- > FilePath "/tmp/tracker-gabriel" +-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2" --- > FilePath "/tmp/orbit-gabriel" +-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix -- @@ -928,7 +942,7 @@ -- @ -- Prelude Turtle> view (`liftIO` readline) -- ABC\ --- Just \"ABC\" +-- Just (Line "ABC") -- @ -- -- Another way to say that is: @@ -977,9 +991,9 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv" --- > FilePath "/tmp/tracker-gabriel" +-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2" --- > FilePath "/tmp/orbit-gabriel" +-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix" -- > FilePath "/usr/lib" @@ -1020,7 +1034,7 @@ -- We can use `select` to implement loops within a `Shell`: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -1042,6 +1056,34 @@ -- > (2,3) -- > (2,4) -- +-- This is because `Shell` behaves like a list comprehension, running each +-- following command once for each element in the stream. This implies that +-- an `Shell` stream that produces 0 elements will short-circuit and prevent +-- subsequent commands from being run. +-- +-- > -- This stream emits 0 elements but still has side effects +-- > inner :: Shell a +-- > inner = do +-- > x <- select [1, 2] +-- > y <- select [3, 4] +-- > liftIO (print (x, y)) +-- > empty +-- > +-- > outer :: Shell () +-- > outer = do +-- > inner +-- > liftIO (echo "This step will never run") +-- +-- If you want to run a `Shell` stream just for its side effects, wrap the +-- `Shell` with `sh`. This ensures that you don't alter the surrounding +-- `Shell`'s control flow by unintentionally running subsequent commands zero +-- times or multiple times: +-- +-- > outer :: Shell () +-- > outer = do +-- > sh inner +-- > liftIO (echo "Now this step will exactly once") +-- -- This uses the `sh` utility instead of `view`. The only difference is that -- `sh` doesn't print any values (since `print` is doing that already): -- @@ -1067,11 +1109,41 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv" --- > FilePath "/tmp/tracker-gabriel" +-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2" --- > FilePath "/tmp/orbit-gabriel" +-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix" +-- +-- You can filter streams using @"Control.Monad".`Control.Monad.mfilter`@, like +-- this: +-- +-- >>> view (select [1..10]) +-- 1 +-- 2 +-- 3 +-- 4 +-- 5 +-- 6 +-- 7 +-- 8 +-- 9 +-- 10 +-- >>> view (mfilter even (select [1..10])) +-- 2 +-- 4 +-- 6 +-- 8 +-- 10 +-- +-- This works because `Control.Monad.mfilter`'s implementation is equivalent to: +-- +-- > mfilter predicate stream = do +-- > element <- stream +-- > if predicate element then return element else empty +-- +-- In other words, `Control.Monad.mfilter` loops over each @element@ of the +-- @stream@ and only `return`s the element if the @predicate@ is `True` -- $folds -- @@ -1092,8 +1164,8 @@ -- @ -- Prelude Turtle Fold> `fold` (ls \"\/tmp\") Fold.list -- [FilePath \"\/tmp\/.X11-unix\",FilePath \"\/tmp\/.X0-lock\",FilePath \"\/tmp\/pulse-PKd --- htXMmr18n\",FilePath \"\/tmp\/pulse-xHYcZ3zmN3Fv\",FilePath \"\/tmp\/tracker-gabriel --- \",FilePath \"\/tmp\/pulse-PYi1hSlWgNj2\",FilePath \"\/tmp\/orbit-gabriel\",FilePath +-- htXMmr18n\",FilePath \"\/tmp\/pulse-xHYcZ3zmN3Fv\",FilePath \"\/tmp\/tracker-gabriella +-- \",FilePath \"\/tmp\/pulse-PYi1hSlWgNj2\",FilePath \"\/tmp\/orbit-gabriella\",FilePath -- \"\/tmp\/ssh-vREYGbWGpiCa\",FilePath \"\/tmp\/.ICE-unix\"] -- @ -- @@ -1112,13 +1184,13 @@ -- For example, you can write to standard output using the `stdout` utility: -- -- @ --- `stdout` :: Shell Text -> IO () +-- `stdout` :: Shell Line -> IO () -- `stdout` s = sh (do -- txt <- s -- liftIO (echo txt) ) -- @ -- --- `stdout` outputs each `Text` value on its own line: +-- `stdout` outputs each `Line` value on its own line: -- -- > Prelude Turtle> stdout "Line 1" -- > Line 1 @@ -1126,18 +1198,18 @@ -- > Line 1 -- > Line 2 -- --- Another useful stream is `stdin`, which emits one line of `Text` per line of +-- Another useful stream is `stdin`, which emits one `Line` value per line of -- standard input: -- -- @ --- `stdin` :: Shell Text +-- `stdin` :: Shell Line -- @ -- -- Let's combine `stdin` and `stdout` to forward all input from standard input -- to standard output: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -1182,9 +1254,9 @@ -- > .X0-lock -- > pulse-PKdhtXMmr18n -- > pulse-xHYcZ3zmN3Fv --- > tracker-gabriel +-- > tracker-gabriella -- > pulse-PYi1hSlWgNj2 --- > orbit-gabriel +-- > orbit-gabriella -- > ssh-vREYGbWGpiCa -- > .ICE-unix -- @@ -1193,8 +1265,8 @@ -- @ -- `inshell` -- :: Text -- Command line --- -> Shell Text -- Standard input to feed to program --- -> Shell Text -- Standard output produced by program +-- -> Shell Line -- Standard input to feed to program +-- -> Shell Line -- Standard output produced by program -- @ -- -- This means you can use `inshell` to embed arbitrary external utilities as @@ -1211,8 +1283,8 @@ -- `inproc` -- :: Text -- Program -- -> [Text] -- Arguments --- -> Shell Text -- Standard input to feed to program --- -> Shell Text -- Standard output produced by program +-- -> Shell Line -- Standard input to feed to program +-- -> Shell Line -- Standard output produced by program -- @ -- -- Using `inproc`, you would write: @@ -1237,7 +1309,7 @@ -- Let's look at the type of `grep`: -- -- @ --- `grep` :: Pattern a -> Shell Text -> Shell Text +-- `grep` :: Pattern a -> Shell Line -> Shell Line -- @ -- -- The first argument of `grep` is actually a `Pattern`, which implements @@ -1378,7 +1450,7 @@ -- a `Shell`: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1404,7 +1476,7 @@ -- file and directory are still cleaned up correctly: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1421,10 +1493,10 @@ -- $monadio -- --- If you are sick of having type `liftIO` everywhere, you can omit it. This --- is because all subroutines in @turtle@ are overloaded using the `MonadIO` --- type class, like our original `pwd` command where we first encountered the --- the `MonadIO` type: +-- If you are sick of having to type `liftIO` everywhere, you can omit it. +-- This is because all subroutines in @turtle@ are overloaded using the +-- `MonadIO` type class, like our original `pwd` command where we first +-- encountered the the `MonadIO` type: -- -- @ -- Prelude Turtle> :type pwd @@ -1468,7 +1540,7 @@ -- to: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1495,7 +1567,7 @@ -- positional arguments for the source and destination file, you can write: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- cp.hs -- > @@ -1509,7 +1581,7 @@ -- > <*> argPath "dest" "The destination file" -- > -- > main = do --- > (src, dest) <- options "A simple `cp` script" parser +-- > (src, dest) <- options "A simple `cp` utility" parser -- > cp src dest -- -- If you run the script without any arguments, you will get an auto-generated @@ -1560,7 +1632,7 @@ -- -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1609,7 +1681,7 @@ -- as short-hands for the flags: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1654,7 +1726,7 @@ -- > -- > parser :: Parser Command -- > parser --- > = fmap IncreaseVolume +-- > = fmap IncreaseVolume -- > (subcommand "up" "Turn the volume up" -- > (argInt "amount" "How much to increase the volume") ) -- > <|> fmap DecreaseVolume @@ -1664,8 +1736,8 @@ -- > main = do -- > x <- options "Volume adjuster" parser -- > case x of --- > IncreaseVolume n -> echo (format ("Increasing the volume by "%d) n) --- > DecreaseVolume n -> echo (format ("Decreasing the volume by "%d) n) +-- > IncreaseVolume n -> printf ("Increasing the volume by "%d%"\n") n +-- > DecreaseVolume n -> printf ("Decreasing the volume by "%d%"\n") n -- -- This will provide `--help` output at both the top level and for each -- subcommand: @@ -1721,12 +1793,37 @@ -- If you have more questions or need help learning the library, ask a question -- on Stack Overflow under the @haskell-turtle@ tag. For bugs or feature -- requests, create an issue on Github at --- +-- -- -- This library provides an extended suite of Unix-like utilities, but would -- still benefit from adding more utilities for better parity with the Unix -- ecosystem. Pull requests to add new utilities are highly welcome! +-- $nix +-- +-- You can also turn `turtle` scripts into runnable scripts using Nix, like +-- this: +-- +-- > #! /usr/bin/env nix-shell +-- > #! nix-shell -i runghc --packages "ghc.withPackages (x: [ x.turtle ])" +-- > +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Turtle +-- > +-- > main = echo "Hello, world!" +-- +-- ... or create an auto-reloading script like this: +-- +-- > #! /usr/bin/env nix-shell +-- > #! nix-shell -i "ghcid -T main" --packages ghcid "ghc.withPackages (x: [ x.turtle ])" +-- > +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Turtle +-- > +-- > main = echo "Hello, world!" + -- $faq -- -- These are the most frequently asked questions from new users: @@ -1777,3 +1874,11 @@ -- /Answer:/ Use `runManaged`, `sh`, or (`<|>`) (all resources acquired in the -- left stream will close before beginning the right stream). Alternatively, -- use `with` to acquire a resource for a limited scope. +-- +-- /Question:/ How do I use @turtle@ to run another shell as a subprocess? +-- +-- /Answer:/ Use `Turtle.system` in conjunction with the `process` library, +-- like this: +-- +-- > Turtle.system (System.Process.proc "/bin/sh" []) empty + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,4 +3,8 @@ import Test.DocTest main :: IO () -main = doctest ["src/Turtle/Pattern.hs", "src/Turtle/Format.hs"] +main = doctest + [ "src/Turtle/Pattern.hs" + , "src/Turtle/Format.hs" + , "src/Turtle/Line.hs" + ] diff --git a/test/RegressionBrokenPipe.hs b/test/RegressionBrokenPipe.hs new file mode 100644 --- /dev/null +++ b/test/RegressionBrokenPipe.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad +import System.Timeout +import Turtle +import qualified Turtle.Bytes as Bytes + +main :: IO () +main = do + echo "proc (text)" + void $ timeout duration $ forever $ proc "true" [] message + echo "procStrict (text)" + void $ timeout duration $ forever $ procStrict "true" [] message + echo "procStrictWithErr (text)" + void $ timeout duration $ forever $ procStrictWithErr "true" [] message + echo "proc (bytes)" + void $ timeout duration $ forever $ Bytes.proc "true" [] message + echo "procStrict (bytes)" + void $ timeout duration $ forever $ Bytes.procStrict "true" [] message + echo "procStrictWithErr (bytes)" + void $ timeout duration $ forever $ Bytes.procStrictWithErr "true" [] message + where + message :: IsString s => s + message = "foobarbaz" + duration = 3 * 10^ (6 :: Int) diff --git a/test/RegressionMaskingException.hs b/test/RegressionMaskingException.hs new file mode 100644 --- /dev/null +++ b/test/RegressionMaskingException.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Turtle + +-- This test fails by hanging +main :: IO () +main = runManaged (do + _ <- fork (shells "while true; do sleep 1; done" empty) + sleep 1 + return () ) diff --git a/test/cptree.hs b/test/cptree.hs new file mode 100644 --- /dev/null +++ b/test/cptree.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Turtle +import System.IO.Temp (withSystemTempDirectory) +import qualified Control.Monad.Fail as Fail +import Control.Monad (unless) + +check :: String -> Bool-> IO () +check errorMessage successs = unless successs $ Fail.fail errorMessage + +main :: IO () +main = withSystemTempDirectory "tempDir" (runTest . fromString) + +runTest :: Turtle.FilePath -> IO () +runTest tempDir = do + let srcDirectory = tempDir "src" + + mktree $ srcDirectory "directory" + touch $ srcDirectory "directory" "file" + + let destDirectory = tempDir "dest" + + cptree srcDirectory destDirectory + + testdir (destDirectory "directory") >>= check "cptree did not preserve directory" + testfile (destDirectory "directory" "file") >>= check "cptree did not preserve directory" diff --git a/test/system-filepath.hs b/test/system-filepath.hs new file mode 100644 --- /dev/null +++ b/test/system-filepath.hs @@ -0,0 +1,226 @@ +{-# Language CPP #-} +{-# Options_GHC -Wno-deprecations #-} + +module Main (main) where + +import Test.Tasty +import Test.Tasty.HUnit +import Turtle + +main :: IO () +main = defaultMain $ testGroup "system-filepath tests" + [ test_Root + , test_Directory + , test_Parent + , test_CommonPrefix + , test_StripPrefix + , test_Collapse + , test_Filename + , test_Dirname + , test_Basename + , test_Absolute + , test_Relative + , test_SplitDirectories + , test_SplitExtension + ] + +test_Root :: TestTree +test_Root = testCase "root" $ do + "" @=? root "" +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + "c:\\" @=? root "c:\\" + "c:\\" @=? root "c:\\foo" +#else + "/" @=? root "/" + "/" @=? root "/foo" +#endif + "" @=? root "foo" + +test_Directory :: TestTree +test_Directory = testCase "directory" $ do + "./" @=? directory "" + "/" @=? directory "/" + "/foo/" @=? directory "/foo/bar" + "/foo/bar/" @=? directory "/foo/bar/" + "./" @=? directory "." + "../" @=? directory ".." + "../" @=? directory "../foo" + "../foo/" @=? directory "../foo/" + "./" @=? directory "foo" + "foo/" @=? directory "foo/bar" + +test_Parent :: TestTree +test_Parent = testCase "parent" $ do + -- The behavior in the presence of `.` / `..` is messed up, but that's how + -- the old system-filepath package worked, so we're preserving that for + -- backwards compatibility (for now) + "./" @=? parent "" + "./" @=? parent "." + "./" @=? parent ".." + "/" @=? parent "/.." + "/" @=? parent "/." + "./" @=? parent "./." + "./" @=? parent "./.." + "../" @=? parent "../.." + "../" @=? parent "../." + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + "c:\\" @=? parent "c:\\" +#else + "/" @=? parent "/" +#endif + "./" @=? parent "foo" + "./" @=? parent "./foo" + "./foo/" @=? parent "foo/bar" + "./foo/" @=? parent "foo/bar/" + "./foo/" @=? parent "./foo/bar" + "/" @=? parent "/foo" + "/foo/" @=? parent "/foo/bar" + +test_Filename :: TestTree +test_Filename = testCase "filename" $ do + "" @=? filename "" + "" @=? filename "." + "" @=? filename ".." + "" @=? filename "/" + "" @=? filename "/foo/" + "bar" @=? filename "/foo/bar" + "bar.txt" @=? filename "/foo/bar.txt" + +test_Dirname :: TestTree +test_Dirname = testCase "dirname" $ do + "" @=? dirname "" + "" @=? dirname "/" + "" @=? dirname "foo" + ".." @=? dirname ".." + "foo" @=? dirname "foo/bar" + "bar" @=? dirname "foo/bar/" + "bar" @=? dirname "foo/bar/baz.txt" + + -- the directory name will be re-parsed to a file name. + let dirnameExts q = snd (splitExtensions (dirname q)) + ["d"] @=? dirnameExts "foo.d/bar" + +test_Basename :: TestTree +test_Basename = testCase "basename" $ do + "" @=? basename ".." + "" @=? basename "/" + "" @=? basename "." + ".txt" @=? basename ".txt" + "foo" @=? basename "foo.txt" + "bar" @=? basename "foo/bar.txt" + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + "bar" @=? basename "c:\\foo\\bar" + "bar" @=? basename "c:\\foo\\bar.txt" +#else + "bar" @=? basename "/foo/bar" + "bar" @=? basename "/foo/bar.txt" +#endif + +test_Absolute :: TestTree +test_Absolute = testCase "absolute" $ do + let myAssert q = assertBool ("absolute " ++ show q) $ absolute q + let myAssert' q = assertBool ("not $ absolute " ++ show q) $ not $ absolute q + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + myAssert "c:\\" + myAssert "c:\\foo\\bar" + myAssert' "" + myAssert' "foo\\bar" + myAssert' "\\foo\\bar" +#else + myAssert "/" + myAssert "/foo/bar" + myAssert' "" + myAssert' "foo/bar" +#endif + + +test_Relative :: TestTree +test_Relative = testCase "relative" $ do + let myAssert q = assertBool ("relative " ++ show q) $ relative q + let myAssert' q = assertBool ("not $ relative " ++ show q) $ not $ relative q + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + myAssert' "c:\\" + myAssert' "c:\\foo\\bar" + myAssert "" + myAssert "foo\\bar" +#else + myAssert' "/" + myAssert' "/foo/bar" + myAssert "" + myAssert "foo/bar" +#endif + +test_CommonPrefix :: TestTree +test_CommonPrefix = testCase "commonPrefix" $ do + "" @=? commonPrefix [] + "./" @=? commonPrefix [".", "."] + "" @=? commonPrefix [".", ".."] + "foo/" @=? commonPrefix ["foo/bar", "foo/baz"] + "foo/a.b" @=? commonPrefix ["foo/a.b.c", "foo/a.b.d"] + "" @=? commonPrefix ["foo/", "bar/"] + +test_StripPrefix :: TestTree +test_StripPrefix = testCase "stripPrefix" $ do + Just "" @=? stripPrefix "" "" + Just "/" @=? stripPrefix "" "/" + Just "" @=? stripPrefix "/" "/" + Just "foo" @=? stripPrefix "/" "/foo" + Just "foo" @=? stripPrefix "./" "./foo" + Just "foo.ext" @=? stripPrefix "./" "./foo.ext" + Just "foo/bar" @=? stripPrefix "/" "/foo/bar" + Just "bar" @=? stripPrefix "/foo/" "/foo/bar" + Just "bar/baz" @=? stripPrefix "/foo/" "/foo/bar/baz" + Just ".txt" @=? stripPrefix "/foo/bar" "/foo/bar.txt" + Just ".gz" @=? stripPrefix "/foo/bar.txt" "/foo/bar.txt.gz" + + -- Test ignoring non-matching prefixes + Nothing @=? stripPrefix "/foo" "/foo/bar" + Nothing @=? stripPrefix "/foo/bar/baz" "/foo" + Nothing @=? stripPrefix "/foo/baz/" "/foo/bar/qux" + Nothing @=? stripPrefix "/foo/bar/baz" "/foo/bar/qux" + +test_Collapse :: TestTree +test_Collapse = testCase "collapse" $ do + -- This behavior differs from the old `system-filepath` package, but this + -- behavior is more correct in the presence of symlinks +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + "foo\\..\\bar" @=? collapse "foo/../bar" + "foo\\bar" @=? collapse "foo/bar" + "foo\\bar" @=? collapse "foo/./bar" +#else + "foo/../bar" @=? collapse "foo/../bar" + "foo/bar" @=? collapse "foo/bar" + "foo/bar" @=? collapse "foo/./bar" +#endif + +test_SplitDirectories :: TestTree +test_SplitDirectories = testCase "splitDirectories" $ do + [] @=? splitDirectories "" + ["./"] @=? splitDirectories "." + ["../"] @=? splitDirectories ".." + ["foo/", "../"] @=? splitDirectories "foo/.." + ["foo/", "./"] @=? splitDirectories "foo/." + ["/"] @=? splitDirectories "/" + ["/", "a"] @=? splitDirectories "/a" + ["/", "ab/", "cd"] @=? splitDirectories "/ab/cd" + ["/", "ab/", "cd/"] @=? splitDirectories "/ab/cd/" + ["ab/", "cd"] @=? splitDirectories "ab/cd" + ["ab/", "cd/"] @=? splitDirectories "ab/cd/" + ["ab/", "cd.txt"] @=? splitDirectories "ab/cd.txt" + ["ab/", "cd/", ".txt"] @=? splitDirectories "ab/cd/.txt" + ["ab/", "./", "cd"] @=? splitDirectories "ab/./cd" + +test_SplitExtension :: TestTree +test_SplitExtension = testCase "splitExtension" $ do + ("", Nothing) @=? splitExtension "" + ("foo", Nothing) @=? splitExtension "foo" + ("foo", Just "") @=? splitExtension "foo." + ("foo", Just "a") @=? splitExtension "foo.a" + ("foo.a/", Nothing) @=? splitExtension "foo.a/" + ("foo.a/bar", Nothing) @=? splitExtension "foo.a/bar" + ("foo.a/bar", Just "b") @=? splitExtension "foo.a/bar.b" + ("foo.a/bar.b", Just "c") @=? splitExtension "foo.a/bar.b.c" diff --git a/turtle.cabal b/turtle.cabal --- a/turtle.cabal +++ b/turtle.cabal @@ -1,14 +1,13 @@ Name: turtle -Version: 1.2.8 +Version: 1.6.2 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE -Copyright: 2015 Gabriel Gonzalez -Author: Gabriel Gonzalez -Maintainer: Gabriel439@gmail.com -Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 -Bug-Reports: https://github.com/Gabriel439/Haskell-Turtle-Library/issues +Copyright: 2015 Gabriella Gonzalez +Author: Gabriella Gonzalez +Maintainer: GenuineGabriella@gmail.com +Bug-Reports: https://github.com/Gabriella439/turtle/issues Synopsis: Shell programming, Haskell-style Description: @turtle@ is a reimplementation of the Unix command line environment in Haskell so that you can use Haskell as both a shell and a scripting @@ -22,7 +21,7 @@ . * Portability: Works on Windows, OS X, and Linux . - * Exception safety: Safely acquire and release resources + * Exception safety: Safely acquire and release resources . * Streaming: Transform or fold command output in constant space . @@ -30,7 +29,7 @@ . * Formatting: Type-safe @printf@-style text formatting . - * Modern: Supports @text@ and @system-filepath@ + * Modern: Supports @text@ . Read "Turtle.Tutorial" for a detailed tutorial or "Turtle.Prelude" for a quick-start guide @@ -40,42 +39,82 @@ then you should also check out the @Shelly@ library which provides similar functionality. Category: System + +Tested-With: + GHC == 9.6.1 + GHC == 9.4.4 + GHC == 9.2.7 + 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 + +Extra-Source-Files: + CHANGELOG.md + Source-Repository head Type: git - Location: https://github.com/Gabriel439/Haskell-Turtle-Library + Location: https://github.com/Gabriella439/turtle +Flag new-deps + Description: Use new versions of ansi-wl-pprint and optparse-applicative + Manual: False + Default: True + Library HS-Source-Dirs: src Build-Depends: - base >= 4.6 && < 5 , - async >= 2.0.0.0 && < 2.2, - clock >= 0.4.1.2 && < 0.8, - directory >= 1.0.7 && < 1.3, - foldl >= 1.1 && < 1.3, - hostname < 1.1, - managed >= 1.0.3 && < 1.1, - process >= 1.0.1.1 && < 1.5, - system-filepath >= 0.3.1 && < 0.5, - system-fileio >= 0.2.1 && < 0.4, - stm < 2.5, - temporary < 1.3, - text < 1.3, - time < 1.7, - transformers >= 0.2.0.0 && < 0.6, - optparse-applicative >= 0.11 && < 0.13, - optional-args >= 1.0 && < 2.0 + -- 2021-09-07: Turtle.Prelude uses GHC-8.0 features, so base >= 4.9 + base >= 4.9 && < 5 , + async >= 2.0.0.0 && < 2.3 , + bytestring >= 0.9.1.8 && < 0.12, + clock >= 0.4.1.2 && < 0.9 , + containers >= 0.5.0.0 && < 0.7 , + directory >= 1.3.1.0 && < 1.4 , + exceptions >= 0.4 && < 0.11, + filepath >= 1.4.1.2 && < 1.5 , + foldl >= 1.1 && < 1.5 , + hostname < 1.1 , + managed >= 1.0.3 && < 1.1 , + process >= 1.0.1.1 && < 1.7 , + stm < 2.6 , + streaming-commons < 0.3 , + temporary < 1.4 , + text >= 1.0.0 && < 2.1 , + time < 1.13, + transformers >= 0.2.0.0 && < 0.7 , + optional-args >= 1.0 && < 2.0 , + unix-compat >= 0.4 && < 0.8 if os(windows) - Build-Depends: Win32 >= 2.2.0.1 && < 2.4 + Build-Depends: Win32 >= 2.12 else - Build-Depends: unix >= 2.5.1.0 && < 2.8 + Build-Depends: unix >= 2.5.1.0 && < 2.9 + + -- A possible Cabal issue makes it try an old version of ansi-wl-pprint + -- even though a newer would work. + -- See discussion in https://github.com/Gabriella439/turtle/pull/446 + if flag(new-deps) + Build-Depends: ansi-wl-pprint >= 1.0 && < 1.1 , + optparse-applicative >= 0.18 && < 0.19 + else + Build-Depends: ansi-wl-pprint >= 0.6 && < 1.0 , + optparse-applicative >= 0.16 && < 0.18 + Exposed-Modules: Turtle, + Turtle.Bytes, Turtle.Format, Turtle.Pattern, Turtle.Shell, Turtle.Options, + Turtle.Line, Turtle.Prelude, Turtle.Tutorial + Other-Modules: + Turtle.Internal GHC-Options: -Wall Default-Language: Haskell2010 @@ -87,8 +126,53 @@ Default-Language: Haskell2010 Build-Depends: base >= 4 && < 5 , - doctest >= 0.7 && < 0.12 + doctest >= 0.7 +test-suite regression-broken-pipe + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: RegressionBrokenPipe.hs + GHC-Options: -Wall -threaded + Default-Language: Haskell2010 + Build-Depends: + base >= 4 && < 5, + turtle + +test-suite regression-masking-exception + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: RegressionMaskingException.hs + GHC-Options: -Wall -threaded + Default-Language: Haskell2010 + Build-Depends: + base >= 4 && < 5, + turtle + +test-suite cptree + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: cptree.hs + GHC-Options: -Wall -threaded + Default-Language: Haskell2010 + Build-Depends: + base >= 4 && < 5, + temporary, + filepath >= 0.4, + turtle + +test-suite system-filepath-tests + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: system-filepath.hs + GHC-Options: -Wall -threaded + Default-Language: Haskell2010 + Build-Depends: + base, + filepath, + tasty >=1.4 && <1.5, + tasty-hunit >=0.10 && <0.11, + turtle + benchmark bench Type: exitcode-stdio-1.0 HS-Source-Dirs: bench @@ -96,7 +180,7 @@ GHC-Options: -O2 -Wall -threaded Default-Language: Haskell2010 Build-Depends: - base >= 4 && < 5 , - criterion >= 0.4 && < 2 , - text < 1.3, + base >= 4 && < 5 , + tasty-bench >= 0.3.1 , + text < 1.3, turtle