diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,98 @@ +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/src/Turtle.hs b/src/Turtle.hs --- a/src/Turtle.hs +++ b/src/Turtle.hs @@ -70,6 +70,7 @@ , module Turtle.Pattern , module Turtle.Options , module Turtle.Shell + , module Turtle.Line , module Turtle.Prelude , module Control.Applicative , module Control.Monad @@ -92,6 +93,7 @@ import Turtle.Pattern import Turtle.Options import Turtle.Shell +import Turtle.Line import Turtle.Prelude import Control.Applicative ( Applicative(..) @@ -148,7 +150,7 @@ 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 & 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,609 @@ +{-# 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 + + -- * Subprocess management + , proc + , shell + , system + , procs + , shells + , inproc + , inshell + , inprocWithErr + , inshellWithErr + , procStrict + , shellStrict + , procStrictWithErr + , shellStrictWithErr + ) where + +import Control.Applicative +import Control.Concurrent.Async (Async, Concurrently(..)) +import Control.Foldl (FoldM(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Managed (MonadManaged(..)) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Filesystem.Path (FilePath) +import Prelude hiding (FilePath) +import System.Exit (ExitCode(..)) +import System.IO (Handle) +import Turtle.Internal (ignoreSIGPIPE) +import Turtle.Prelude (ProcFailed(..), ShellFailed(..)) +import Turtle.Shell (Shell(..), 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.Text +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 (\(FoldM step begin done) -> do + x0 <- begin + 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 $! x0 ) + 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_ (Async.withAsyncWithUnmask feedIn (\a -> Process.waitForProcess ph <* halt a) ) + handle (Nothing , ph) = do + Process.waitForProcess ph + + Exception.bracket open close' handle ) + +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_ (Async.withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* halt a))) + (Data.ByteString.hGetContents hOut) ) ) + +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_ (Async.withAsyncWithUnmask feedIn (\a -> liftIO (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)) + +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 (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 (sh (do + bytes <- s + liftIO (Data.ByteString.hPut hIn bytes) ) ) + `Exception.finally` close hIn + + a <- using (Managed.managed (Exception.mask_ . Async.withAsyncWithUnmask feedIn)) + inhandle hOut <|> (liftIO (Process.waitForProcess ph *> halt a) *> empty) + +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 (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 (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 (\(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.managed (Exception.mask_ . Async.withAsyncWithUnmask feedIn )) + b <- using (Managed.managed (Exception.mask_ . Async.withAsyncWithUnmask forwardOut)) + c <- using (Managed.managed (Exception.mask_ . Async.withAsyncWithUnmask forwardErr)) + 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 (Process.waitForProcess 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`. This does /not/ throw an 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 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 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)) 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,16 @@ +module Turtle.Internal + ( ignoreSIGPIPE + ) where + +import Control.Exception (handle, throwIO) +import Foreign.C.Error (Errno(..), ePIPE) +import GHC.IO.Exception (IOErrorType(..), IOException(..)) + +ignoreSIGPIPE :: IO () -> IO () +ignoreSIGPIPE = handle (\e -> case e of + IOError + { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + ) 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,99 @@ +{-# 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.String +#if __GLASGOW_HASKELL__ >= 710 +#else +import Data.Monoid +#endif +import Data.Maybe +import Data.Typeable +import Control.Exception + +-- | 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) + +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 -> [Line] +textToLines = +#if __GLASGOW_HASKELL__ >= 708 + coerce Text.lines +#else + map unsafeTextToLine . Text.lines +#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 [] = Just (Line "") + 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: -- @@ -64,6 +67,7 @@ -- * Consume parsers , subcommand + , subcommandGroup , options ) where @@ -82,13 +86,21 @@ import qualified Options.Applicative as Opts import qualified Options.Applicative.Types as Opts import Prelude hiding (FilePath) +import Text.PrettyPrint.ANSI.Leijen (Doc, displayS, renderCompact) -- | 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 {-| The name of a command-line argument @@ -115,7 +127,7 @@ This description will appear in the header of the @--help@ output -} -newtype Description = Description { getDescription :: Text } +newtype Description = Description { getDescription :: Doc } deriving (IsString) {-| A helpful message explaining what a flag does @@ -228,10 +240,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/Prelude.hs b/src/Turtle/Prelude.hs --- a/src/Turtle/Prelude.hs +++ b/src/Turtle/Prelude.hs @@ -111,13 +111,11 @@ , Filesystem.readTextFile , Filesystem.writeTextFile , arguments -#if MIN_VERSION_base(4,7,0) +#if __GLASGOW_HASKELL__ >= 710 , export , unset #endif -#if MIN_VERSION_base(4,6,0) , need -#endif , env , cd , pwd @@ -138,6 +136,8 @@ , touch , time , hostname + , which + , whichAll , sleep , exit , die @@ -153,12 +153,9 @@ , mktempdir , fork , wait + , pushd -- * Shell - , inproc - , inshell - , inprocWithErr - , inshellWithErr , stdin , input , inhandle @@ -174,6 +171,7 @@ , cat , grep , sed + , onFiles , inplace , find , yes @@ -183,6 +181,7 @@ , limit , limitWhile , cache + , parallel -- * Folds , countChars @@ -198,8 +197,14 @@ , system , procs , shells + , inproc + , inshell + , inprocWithErr + , inshellWithErr , procStrict , shellStrict + , procStrictWithErr + , shellStrictWithErr -- * Permissions , Permissions @@ -227,6 +232,26 @@ , 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 + + -- * Headers + , WithHeader(..) + , header + -- * Exceptions , ProcFailed(..) , ShellFailed(..) @@ -235,22 +260,26 @@ import Control.Applicative import Control.Concurrent (threadDelay) import Control.Concurrent.Async - (Async, withAsync, withAsyncWithUnmask, wait, waitSTM, concurrently) + (Async, withAsync, withAsyncWithUnmask, 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, finally, mask_, throwIO) +import Control.Exception (Exception, bracket, bracket_, finally, mask_, throwIO) import Control.Foldl (Fold, FoldM(..), genericLength, handles, list, premap) +import qualified Control.Foldl import qualified Control.Foldl.Text -import Control.Monad (liftM, msum, when, unless) +import Control.Monad (guard, liftM, msum, when, unless, (>=>)) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Managed (MonadManaged(..), managed, runManaged) +import Control.Monad.Managed (MonadManaged(..), managed, 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.Time.Clock.POSIX (POSIXTime) import Data.Traversable import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -263,11 +292,11 @@ import System.Clock (Clock(..), TimeSpec(..), getTime) import System.Environment ( getArgs, -#if MIN_VERSION_base(4,7,0) +#if __GLASGOW_HASKELL__ >= 710 setEnv, unsetEnv, #endif -#if MIN_VERSION_base(4,6,0) +#if __GLASGOW_HASKELL__ >= 708 lookupEnv, #endif getEnvironment ) @@ -277,7 +306,9 @@ import System.IO (Handle, hClose) import qualified System.IO as IO import System.IO.Temp (withTempDirectory, withTempFile) -import System.IO.Error (catchIOError, ioeGetErrorType) +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 @@ -286,16 +317,15 @@ openDirStream, readDirStream, closeDirStream, - touchFile, - getSymbolicLinkStatus, - isDirectory, - isSymbolicLink ) + touchFile ) #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, (%)) +import Turtle.Internal (ignoreSIGPIPE) +import Turtle.Line {-| Run a command using @execvp@, retrieving the exit code @@ -307,7 +337,7 @@ -- ^ Command -> [Text] -- ^ Arguments - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io ExitCode -- ^ Exit code @@ -330,7 +360,7 @@ :: MonadIO io => Text -- ^ Command line - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io ExitCode -- ^ Exit code @@ -359,7 +389,7 @@ -- ^ Command -> [Text] -- ^ Arguments - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io () procs cmd args s = do @@ -382,7 +412,7 @@ :: MonadIO io => Text -- ^ Command line - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io () -- ^ Exit code @@ -403,7 +433,7 @@ -- ^ Command -> [Text] -- ^ Arguments - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io (ExitCode, Text) -- ^ Exit code and stdout @@ -422,12 +452,54 @@ :: MonadIO io => Text -- ^ Command line - -> Shell Text + -> 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 @@ -436,37 +508,45 @@ :: MonadIO io => Process.CreateProcess -- ^ Command - -> Shell Text + -> Shell Line -- ^ 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) + (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 (hClose handle) + unless finalized (ignoreSIGPIPE (hClose handle)) return True ) + let close' (Just hIn, ph) = do + close hIn + Process.terminateProcess ph + close' (Nothing , ph) = do + Process.terminateProcess ph - 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) ) ) ) + let handle (Just hIn, ph) = do + let feedIn :: (forall a. IO a -> IO a) -> IO () + feedIn restore = + restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + mask_ (withAsyncWithUnmask feedIn (\a -> Process.waitForProcess ph <* halt a) ) + handle (Nothing , ph) = do + Process.waitForProcess ph + bracket open close' handle ) + systemStrict :: MonadIO io => Process.CreateProcess -- ^ Command - -> Shell Text + -> Shell Line -- ^ Lines of standard input -> io (ExitCode, Text) -- ^ Exit code and stdout @@ -486,21 +566,55 @@ mvar <- newMVar False let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) + unless finalized (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 (sh (do - txt <- s - liftIO (Text.hPutStrLn hIn txt) ) ) - `finally` close hIn + restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn concurrently - (mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a))) + (mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* halt a))) (Text.hGetContents hOut) ) ) +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 (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 (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + + runConcurrently $ (,,) + <$> Concurrently (mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* 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 @@ -510,9 +624,9 @@ -- ^ Command -> [Text] -- ^ Arguments - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell Text + -> Shell Line -- ^ Lines of standard output inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args)) @@ -526,18 +640,18 @@ inshell :: Text -- ^ Command line - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell Text + -> Shell Line -- ^ Lines of standard output inshell cmd = stream (Process.shell (unpack cmd)) stream :: Process.CreateProcess -- ^ Command - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell Text + -> Shell Line -- ^ Lines of standard output stream p s = do let p' = p @@ -560,21 +674,17 @@ (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 + feedIn restore = restore (outhandle hIn s) `finally` close hIn a <- using (managed (mask_ . withAsyncWithUnmask feedIn)) - inhandle hOut <|> (liftIO (Process.waitForProcess ph *> wait a) *> empty) + inhandle hOut <|> (liftIO (Process.waitForProcess ph *> halt a) *> empty) streamWithErr :: Process.CreateProcess -- ^ Command - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell (Either Text Text) + -> Shell (Either Line Line) -- ^ Lines of standard output streamWithErr p s = do let p' = p @@ -597,24 +707,20 @@ (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 + feedIn restore = restore (outhandle hIn s) `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)))) )) + 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 - txt <- inhandle hErr - liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left txt)))) )) + line <- inhandle hErr + liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) )) `finally` STM.atomically (TQueue.writeTQueue queue Nothing) let drain = Shell (\(FoldM step begin done) -> do x0 <- begin @@ -650,9 +756,9 @@ -- ^ Command -> [Text] -- ^ Arguments - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell (Either Text Text) + -> 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)) @@ -669,36 +775,36 @@ inshellWithErr :: Text -- ^ Command line - -> Shell Text + -> Shell Line -- ^ Lines of standard input - -> Shell (Either Text Text) + -> Shell (Either Line Line) -- ^ 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) +echo :: MonadIO io => Line -> io () +echo line = liftIO (Text.putStrLn (lineToText line)) -- | Print to @stderr@ -err :: MonadIO io => Text -> io () -err txt = liftIO (Text.hPutStrLn IO.stderr txt) +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 Text) +readline :: MonadIO io => io (Maybe Line) readline = liftIO (do eof <- IO.isEOF if eof then return Nothing - else fmap (Just . pack) getLine ) + 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 MIN_VERSION_base(4,7,0) +#if __GLASGOW_HASKELL__ >= 710 -- | Set or modify an environment variable export :: MonadIO io => Text -> Text -> io () export key val = liftIO (setEnv (unpack key) (unpack val)) @@ -708,10 +814,12 @@ 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) +#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 @@ -724,6 +832,21 @@ cd :: MonadIO io => FilePath -> io () cd path = liftIO (Filesystem.setWorkingDirectory 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 Filesystem.getWorkingDirectory @@ -873,20 +996,10 @@ 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 + linkstat <- lstat path + let isLink = PosixCompat.isSymbolicLink linkstat + isDir = PosixCompat.isDirectory linkstat if isLink then rm path else do @@ -895,7 +1008,6 @@ child <- ls path loop child ) <|> rmdir path else rm path -#endif -- | Check if a file exists testfile :: MonadIO io => FilePath -> io Bool @@ -943,7 +1055,7 @@ > 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 nonwritable "foo.txt" -- chmod u-w foo.txt -} chmod :: MonadIO io @@ -1073,6 +1185,30 @@ 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 (Text.split (== ':') paths) + let path' = Filesystem.fromText path cmd + + True <- testfile path' + + let handler :: IOError -> IO Permissions + handler e = + if isPermissionError e || isDoesNotExistError e + then return Directory.emptyPermissions + else throwIO e + + perms <- liftIO (getmod path' `catchIOError` handler) + + guard (Directory.executable perms) + return path' + {-| Sleep for the given duration A numeric literal argument is interpreted as seconds. In other words, @@ -1180,18 +1316,22 @@ 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 Text +stdin :: Shell Line stdin = inhandle IO.stdin -- | Read lines of `Text` from a file -input :: FilePath -> Shell Text +input :: FilePath -> Shell Line input file = do handle <- using (readonly file) inhandle handle -- | Read lines of `Text` from a `Handle` -inhandle :: Handle -> Shell Text +inhandle :: Handle -> Shell Line inhandle handle = Shell (\(FoldM step begin done) -> do x0 <- begin let loop x = do @@ -1200,45 +1340,45 @@ then done x else do txt <- Text.hGetLine handle - x' <- step x txt + x' <- step x (unsafeTextToLine txt) loop $! x' loop $! x0 ) -- | Stream lines of `Text` to standard output -stdout :: MonadIO io => Shell Text -> io () +stdout :: MonadIO io => Shell Line -> io () stdout s = sh (do - txt <- s - liftIO (echo txt) ) + line <- s + liftIO (echo line) ) -- | Stream lines of `Text` to a file -output :: MonadIO io => FilePath -> Shell Text -> io () +output :: MonadIO io => FilePath -> Shell Line -> io () output file s = sh (do handle <- using (writeonly file) - txt <- s - liftIO (Text.hPutStrLn handle txt) ) + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) -- | Stream lines of `Text` to a `Handle` -outhandle :: MonadIO io => Handle -> Shell Text -> io () +outhandle :: MonadIO io => Handle -> Shell Line -> io () outhandle handle s = sh (do - txt <- s - liftIO (Text.hPutStrLn handle txt) ) + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) -- | Stream lines of `Text` to append to a file -append :: MonadIO io => FilePath -> Shell Text -> io () +append :: MonadIO io => FilePath -> Shell Line -> io () append file s = sh (do handle <- using (appendonly file) - txt <- s - liftIO (Text.hPutStrLn handle txt) ) + line <- s + liftIO (Text.hPutStrLn handle (lineToText line)) ) -- | Stream lines of `Text` to standard error -stderr :: MonadIO io => Shell Text -> io () +stderr :: MonadIO io => Shell Line -> io () stderr s = sh (do - txt <- s - liftIO (err txt) ) + line <- s + liftIO (err line) ) -- | Read in a stream's contents strictly -strict :: MonadIO io => Shell Text -> io Text -strict s = liftM Text.unlines (fold s list) +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 @@ -1257,36 +1397,45 @@ cat = msum -- | Keep all lines that match the given `Pattern` -grep :: Pattern a -> Shell Text -> Shell Text +grep :: Pattern a -> Shell Line -> Shell Line grep pattern s = do - txt <- s - _:_ <- return (match pattern txt) - return txt + line <- s + _:_ <- return (match pattern (lineToText line)) + return line {-| 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@. + @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 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)) - txt <- s - txt':_ <- return (match pattern' txt) - return txt' + 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 "" +-- | 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 Filesystem.fromText . f . getRights . fmap Filesystem.toText + where + getRights :: forall a. Shell (Either a Text) -> Shell Text + getRights s = s >>= either (const empty) return + + -- | 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 @@ -1307,7 +1456,7 @@ return path -- | A Stream of @\"y\"@s -yes :: Shell Text +yes :: Shell Line yes = fmap (\_ -> "y") endless -- | Number each element of a `Shell` (starting at 0) @@ -1437,8 +1586,8 @@ 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 + line <- input file + case reads (Text.unpack (lineToText line)) of [(ma, "")] -> return ma _ -> die (format ("cache: Invalid data stored in "%w) file) @@ -1458,6 +1607,18 @@ 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) @@ -1473,7 +1634,18 @@ -- | Get the size of a file or a directory du :: MonadIO io => FilePath -> io Size -du path = liftIO (fmap Size (Filesystem.getSize path)) +du path = liftIO (do + isDir <- testdir path + size <- do + if isDir + then do + let sizes = do + child <- lstree path + True <- testfile child + liftIO (Filesystem.getSize child) + fold sizes Control.Foldl.sum + else Filesystem.getSize path + return (Size size) ) {-| An abstract file size @@ -1493,7 +1665,7 @@ >>> format sz 2309 "2.309 KB" >>> format sz 949203 -"949.203 MB" +"949.203 KB" >>> format sz 1600000000 "1.600 GB" >>> format sz 999999999999999999 @@ -1556,8 +1728,10 @@ 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 +countChars :: Integral n => Fold Line n +countChars = + premap lineToText Control.Foldl.Text.length + + charsPerNewline * countLines charsPerNewline :: Num a => a #ifdef mingw32_HOST_OS @@ -1567,13 +1741,64 @@ #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) +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 Text n +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 . Filesystem.encodeString + +-- | 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 . Filesystem.encodeString + +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' (FoldM step begin done) = k (FoldM 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' = do + x <- begin + return (Pair x Nothing) + + done' (Pair x _) = done x 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 @@ -373,7 +374,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 +383,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 @@ -590,8 +592,8 @@ -- > -- 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 @@ -600,7 +602,7 @@ -- > -- > import Turtle -- > --- > str :: Text +-- > str :: Line -- > str = "Hello!" -- > -- > main :: IO () @@ -638,21 +640,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. -- @@ -672,7 +674,7 @@ -- > -- > import Turtle -- > --- > str :: Text +-- > str :: Line -- > str = 4 -- > -- > main :: IO () @@ -683,16 +685,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 -- @@ -733,7 +735,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 -- @ -- @@ -774,7 +776,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 -- @ -- @@ -928,7 +930,7 @@ -- @ -- Prelude Turtle> view (`liftIO` readline) -- ABC\ --- Just \"ABC\" +-- Just (Line "ABC") -- @ -- -- Another way to say that is: @@ -1112,13 +1114,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,11 +1128,11 @@ -- > 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 @@ -1193,8 +1195,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 +1213,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 +1239,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 @@ -1654,7 +1656,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 +1666,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: 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/turtle.cabal b/turtle.cabal --- a/turtle.cabal +++ b/turtle.cabal @@ -1,5 +1,5 @@ Name: turtle -Version: 1.2.8 +Version: 1.3.0 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -22,7 +22,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 . @@ -40,6 +40,8 @@ then you should also check out the @Shelly@ library which provides similar functionality. Category: System +Extra-Source-Files: + CHANGELOG.md Source-Repository head Type: git Location: https://github.com/Gabriel439/Haskell-Turtle-Library @@ -47,35 +49,42 @@ 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 + base >= 4.6 && < 5 , + ansi-wl-pprint >= 0.6 && < 0.7 , + async >= 2.0.0.0 && < 2.2 , + bytestring >= 0.9.1.8 && < 0.11, + 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.13 && < 0.14, + optional-args >= 1.0 && < 2.0 , + unix-compat >= 0.4 && < 0.5 if os(windows) Build-Depends: Win32 >= 2.2.0.1 && < 2.4 else Build-Depends: unix >= 2.5.1.0 && < 2.8 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 @@ -89,6 +98,16 @@ base >= 4 && < 5 , doctest >= 0.7 && < 0.12 +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 + benchmark bench Type: exitcode-stdio-1.0 HS-Source-Dirs: bench @@ -97,6 +116,9 @@ Default-Language: Haskell2010 Build-Depends: base >= 4 && < 5 , - criterion >= 0.4 && < 2 , text < 1.3, turtle + if impl(ghc < 7.8) + Build-Depends: criterion >= 0.4 && < 1.1.4.0 + else + Build-Depends: criterion >= 0.4 && < 1.2