shh 0.3.1.3 → 0.4.0.0

raw patch · 7 files changed

+597/−73 lines, 7 filesdep +doctestdep −hashabledep ~basedep ~deepseqdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest

Dependencies removed: hashable

Dependency ranges changed: base, deepseq, directory, split, unix

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• README.md +27/−2
• app/shh-app.hs +33/−8
• shh.cabal +8/−9
• src/Shh.hs +36/−4
• src/Shh/Internal.hs +369/−44
• test/Test.hs +111/−6

@@ -1,5 +1,18 @@ # Revision history for shh +## 0.4.0.0 -- 2019-04-20++* Pre-compile Shell.hs for faster loading of shh shell+* Introduce `nativeProc` interface and related functions (`pureProc`...)+* Allow type-changing `|>` which enables `capture` and+  similar "processes" to replace the less consistent `readProc`+  family of functions.  `s <- readProc $ echo "Hello"` can now+  be written `s <- echo "Hello" |> capture`. This allows capturing+  within the `Proc` monad to manipulate the stream in Haskell.+* Introduce `xargs1` function which can replace some uses of the `xargs`+  utility, and provides a type-checked, and spell-checked interface+  similar to `xargs`.+ ## 0.3.X.X -- 2019-03-10  * Changes how lazy reading works. We no longer terminate the process, we

@@ -3,11 +3,16 @@ [![](https://img.shields.io/hackage/v/shh.svg?colorB=%23999&label=shh)](http://hackage.haskell.org/package/shh) [![](https://img.shields.io/hackage/v/shh-extras.svg?colorB=%23999&label=shh-extras)](http://hackage.haskell.org/package/shh-extras) [![](https://builds.sr.ht/~lukec/shh/nix.yml.svg)](https://builds.sr.ht/~lukec/shh/nix.yml?)-[![](https://travis-ci.org/luke-clifton/shh.svg?branch=master)](https://travis-ci.org/luke-clifton/shh)  Shh is a library to enable convinient shell-like programming in Haskell. It works well in scripts, and from GHCi, allowing you to use GHCi as a shell. +It's primary purpose is in replacing shell scripts. As such, many+functions are provided to mimic the shell environment, and porting shell+scripts to shh should be fairly straightforward. A simple+["cargo culting" port](docs/porting.md) should work in most situations,+and perhaps be even more robust than the original.+ It is also a wrapper tool around launching GHCi as a shell.  It supports@@ -51,6 +56,8 @@   * Capturing of process output +       λ s <- echo "Hello" |> tr "-d" "l" |> capture+        λ loggedIn <- nub . words <$> readProc users        λ putStrLn $ "Logged in users: " ++ show loggedIn @@ -84,6 +91,14 @@        λ catchCode false        1 + * "Native" processes, i.e. Haskell functions that behave like a process.++       λ echo "Hello" |> pureProc (map toUpper) |> tr "-d" "L"+       HEO++ * And much, much more! Look at the documentation on Hackage for a+   comprehensive overview of all the possibilities.+ ## Mnemonics   Shh has many symbols that might seem intimidating at first, but there@@ -162,6 +177,17 @@ it is up to you to make sure that the compiler, and packages you require are available, either globally, or provided by the `wrapper` script. +#### Faster Startup++`shh` precompiles your `Shell.hs` file so that starting up `shh` is very+quick on subsequent launches. Unfortunately, `shh` isn't quite able to detect+this perfectly. If you see GHCi telling you that it is `Compiling Shell`,+and you notice the delay when starting `shh`, try manually forcing a rebuild+by passing in the `--rebuild` argument to `shh`.++This is particularly likely to happen if you upgrade your GHC, or installed+packages, or even `shh` itself.+ #### Nix Wrapper Example  The following snippet could act as a `wrapper` file to set up a suitable@@ -174,4 +200,3 @@ ### Script Usage  TODO: Fill this in once the user experience is better.-    

@@ -1,38 +1,41 @@ {-# LANGUAGE LambdaCase #-} module Main where +import Control.DeepSeq (force)+import Control.Exception+import Control.Monad import Shh import System.IO+import System.IO.Error import System.Environment import System.Exit import System.IO.Temp import System.Directory-import Data.Hashable (hash)-import Data.List.Split (splitOn)+import System.Posix.Process  defaultShell = "\ \{-# LANGUAGE TemplateHaskell #-}\n\ \module Shell where\n\ \import Shh\n\ \$(loadEnv SearchPath)\n\-\ "+\"  defaultInitGhci = "\ \:seti -XNoOverloadedLists\n\ \import Shh\n\-\ "+\"  extraInitGhci = "\ \import Shh.Prompt\n\ \:set prompt-function formatPrompt \"\\n\\ESC[1;32m[%u@%h:%w]λ \\ESC[0m\"\n\ \:set prompt-cont \"| \"\n\-\ "+\"   defaultWrapper = "\ \#! /usr/bin/env sh\n\ \exec \"$@\"\n\-\ "+\"  debug = putStrLn @@ -58,12 +61,20 @@         wrapper :: String         wrapper = shhDir <> "/wrapper" -     debug $ "Shh home is: " <> shhDir      createDirectoryIfMissing False shhDir      withCurrentDirectory shhDir $ do+        case a of+            ["--rebuild"] -> do+                removeFile "Shell.hi"+                removeFile "Shell.o"+            [] -> pure ()+            ["--help"] -> do+                putStrLn "usage: shh [--rebuild]"+                exitSuccess+            _ -> error $ "Unknown arguments: " ++ show a         writeIfMissing "wrapper" defaultWrapper         setPermissions "wrapper" $             setOwnerExecutable True $@@ -88,6 +99,20 @@                     putStrLn "#####################################################################"                 Right _ -> appendFile "init.ghci" extraInitGhci         writeIfMissing "Shell.hs" defaultShell+        writeIfMissing "paths" ""+        pp <- readFile "paths"+        cp <- show <$> pathBins+        pathDiff <- evaluate $ force pp /= cp+        outdated <- catch (do+            shellMod <- getModificationTime "Shell.hs"+            hiMod    <- getModificationTime "Shell.hi"+            pure (shellMod > hiMod)+            ) (\e -> if (isDoesNotExistError e) then pure True else throwIO e)+        when (outdated || pathDiff) $ do+            putStrLn "Rebuilding Shell.hs..."+            writeFile "paths" cp+            -- Use absolute path of Shell.hs so that GHCi doesn't recompile.+            exe wrapper "ghc" "-c" "-dynamic" (shhDir <> "/Shell.hs") -    runProc $ mkProc' True wrapper ["ghci", "-ghci-script", shhDir <> "/init.ghci", shhDir <> "/Shell.hs"]+    executeFile wrapper False ["ghci", "-ghci-script", shhDir <> "/init.ghci", shhDir <> "/Shell.hs"] Nothing 

@@ -1,8 +1,8 @@ name:                shh-version:             0.3.1.3+version:             0.4.0.0 synopsis:            Simple shell scripting from Haskell description:         Provides a shell scripting environment for Haskell. It-                     helps you all external binaries, and allows you to+                     helps you use external binaries, and allows you to                      perform many shell-like functions, such as piping                      and redirection. license:             BSD3@@ -23,7 +23,7 @@   exposed-modules:     Shh                      , Shh.Internal   build-depends:-    base             >= 4.11 && < 4.13,+    base             >= 4.9 && < 4.13,     async            >= 2.2.1 && < 2.3,     deepseq          >= 1.4.3 && < 1.5,     directory        >= 1.3.1 && < 1.4,@@ -43,17 +43,13 @@   default-language: Haskell2010   build-depends:     base >=4.9,-    async,-    hashable,-    hashable,     temporary,+    deepseq,     directory,     shh,-    split+    unix   hs-source-dirs: app   main-is: shh-app.hs-  build-tools:-    ghc  executable shh-example   ghc-options: -threaded -with-rtsopts=-N@@ -71,6 +67,9 @@   default-language: Haskell2010   build-depends:     base >=4.9,+    async,+    directory,+    doctest,     tasty,     tasty-quickcheck,     tasty-hunit,

@@ -4,28 +4,59 @@ module Shh     ( initInteractive     -- | == Constructing a `Proc`-    -- You will rarely have to use these as most of the time these are-    -- created for you by using the `loadEnv` template Haskell function.+    -- | === External Processes+    -- These allow for the construction of @`Proc`@s that call external+    -- processes. You will often use the TemplateHaskell functions below+    -- to create these.     , exe     , mkProc     , mkProc'     , runProc     , Proc()+    -- | === "Native" Processes+    -- You can also create native Haskell @`Proc`@s which behave the same+    -- way, but simply run Haskell functions instead of external processes.+    -- +    -- NB: The functions here that operate on @String@s from @stdin@ read them+    -- lazily, and can be used in a streaming fashion.+    , pureProc+    , writeOutput, writeError+    , prefixLines+    , capture+    , captureTrim+    , captureSplit+    , captureSplit0+    , captureLines+    , readInput+    , readInputSplit+    , readInputSplit0+    , readInputLines+    , readInputP+    , readInputSplitP+    , readInputSplit0P+    , readInputLinesP+    , xargs1     -- | == Piping and Redirection     , PipeResult(..)+    , (<|)     , Stream(..)     , devNull-    -- === Lazy/Streaming reads+    -- | === Lazy/Streaming reads     -- These reads are lazy. The process is run long enough to produce     -- the amount of output that is actually used. It is therefor suitable     -- for use with infinite output streams. The process is terminated     -- as soon the function finishes. Note that the result is forced to     -- normal form to prevent any accidental reading after the process has     -- terminated.+    --+    -- NB: See `readInput` and `pureProc` for more flexible options to those+    -- listed here.+    , withRead     , withReadSplit0     , withReadLines     , withReadWords     -- | === Strict reads+    -- NB: See also `capture`     , readProc     , readTrim     , readSplit0@@ -33,7 +64,8 @@     , readWords     , readAuto     -- | === Writing to @stdin@-    , (<<<), (>>>)+    -- NB: See also `writeOutput` for an `echo`-like option.+    , (<<<), (>>>), writeProc     , readWriteProc     , apply     -- | === String manipulation

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}@@ -13,6 +14,7 @@ -- | See documentation for "Shh". module Shh.Internal where +import Control.Concurrent.MVar import Control.Concurrent.Async import Control.DeepSeq (force,NFData) import Control.Exception as C@@ -23,26 +25,53 @@ import Data.List.Split (endBy, splitOn) import qualified Data.Map as Map import Data.Maybe (isJust)+import Data.Typeable+import GHC.IO.BufferedIO+import GHC.IO.Device as IODevice hiding (read)+import GHC.IO.Encoding+import GHC.IO.Exception (IOErrorType(ResourceVanished))+import GHC.IO.Handle+import GHC.IO.Handle.Internals+import GHC.IO.Handle.Types+import GHC.IO.Handle.Types (Handle(..)) import Language.Haskell.TH import qualified System.Directory as Dir import System.Environment (getEnv, setEnv) import System.Exit (ExitCode(..)) import System.FilePath (takeFileName) import System.IO+import System.IO.Error import System.Posix.Signals import System.Process +-- $setup+-- For doc-tests. Not sure I can use TH in doc tests.+-- >>> import Data.Monoid+-- >>> let cat = exe "cat"+-- >>> let echo = exe "echo"+-- >>> let false = exe "false"+-- >>> let head = exe "head"+-- >>> let md5sum = exe "md5sum"+-- >>> let printf = exe "printf"+-- >>> let sleep = exe "sleep"+-- >>> let true = exe "true"+-- >>> let wc = exe "wc"+-- >>> let xargs = exe "xargs"+-- >>> let yes = exe "yes"+-- >>> let some_command = writeOutput "this is stdout" >> (writeOutput "this is stderr" &> StdErr)+ -- | This function needs to be called in order to use the library successfully--- from GHCi.+-- from GHCi. If you use the @formatPrompt@ function from the @shh-extras@+-- package, this will be automatically called for you. initInteractive :: IO () initInteractive = do     hSetBuffering stdin LineBuffering  -- | When a process exits with a non-zero exit code--- we throw this Failure exception.+-- we throw this @Failure@ exception. -- -- The only exception to this is when a process is terminated--- by SIGPIPE in a pipeline, in which case we ignore it.+-- by @SIGPIPE@ in a pipeline, in which case we ignore it. data Failure = Failure     { failureProg :: String     , failureArgs :: [String]@@ -63,9 +92,8 @@ instance Exception Failure  -- | This class is used to allow most of the operators in Shh to be--- polymorphic in their return value. This makes using them in an `IO`--- context easier (we can avoid having to prepend everything with a--- `runProc`).+-- polymorphic in their return value. This makes using them in an `IO` context+-- easier (we can avoid having to prepend everything with a `runProc`). class PipeResult f where     -- | Use this to send the output of on process into the input of another.     -- This is just like a shells `|` operator.@@ -74,13 +102,16 @@     -- another `Proc a` or an `IO a` depending on the context in which it is     -- used.     --+    -- If any intermediate process throws an exception, the whole pipeline+    -- is canceled.+    --+    -- The result of the last process in the chain is the result returned+    -- by the pipeline. +    --     -- >>> echo "Hello" |> wc     --       1       1       6-    (|>) :: Proc a -> Proc a -> f a--    -- | Flipped version of `|>`-    (<|) :: Proc a -> Proc a -> f a-    (<|) = flip (|>)+    (|>) :: Proc b -> Proc a -> f a+    infixl 1 |>      -- | Similar to `|!>` except that it connects stderr to stdin of the     -- next process in the chain.@@ -89,39 +120,51 @@     -- both preceding processes, because they are both going to the same     -- handle!     --                                            -    -- This is probably not what you want, see the `&>` and `&!>` operators-    -- for redirection.-    (|!>) :: Proc a -> Proc a -> f a+    -- See the `&>` and `&!>` operators for redirection.+    --+    -- >>> echo "Ignored" |!> wc "-c"+    -- Ignored+    -- 0+    (|!>) :: Proc b -> Proc a -> f a+    infixl 1 |!>      -- | Redirect stdout of this process to another location     ---    -- > ls &> Append "/dev/null"+    -- >>> echo "Ignore me" &> Append "/dev/null"     (&>) :: Proc a -> Stream -> f a+    infixl 9 &>      -- | Redirect stderr of this process to another location     ---    -- > ls &!> StdOut+    -- >>> echo "Shh" &!> StdOut+    -- Shh     (&!>) :: Proc a -> Stream -> f a+    infixl 9 &!> -    -- | Provide the stdin of a `Proc` from a `String`-    writeProc :: Proc a -> String -> f a+    -- | Lift a Haskell function into a @`Proc`@. The handles are the @stdin@+    -- @stdout@ and @stderr@ of the resulting @`Proc`@+    nativeProc :: NFData a => (Handle -> Handle -> Handle -> IO a) -> f a -    -- | Run a process and capture it's output lazily. Once the continuation-    -- is completed, the handles are closed. However, the process is run-    -- until it naturally terminates in order to capture the correct exit-    -- code. Many utilities behave correctly with this (e.g. @cat@ will-    -- terminate if you close the handle).-    withRead :: (NFData b) => Proc a -> (String -> IO b) -> f b+-- | Flipped version of `|>` with lower precedence.+--+-- >>> captureTrim <| (echo "Hello" |> wc "-c")+-- "6"+(<|) :: PipeResult f => Proc a -> Proc b -> f a+(<|) = flip (|>)+infixr 1 <|  instance PipeResult IO where     a |> b = runProc $ a |> b     a |!> b = runProc $ a |!> b     a &> s = runProc $ a &> s     a &!> s = runProc $ a &!> s-    writeProc p s = runProc $ writeProc p s-    withRead p k = runProc $ withRead p k+    nativeProc f = runProc $ nativeProc f --- | Create a pipe, and close both ends on exception.+-- | Create a pipe, and close both ends on exception. The first argument+-- is the read end, the second is the write end.+--+-- >>> withPipe $ \r w -> hPutStrLn w "test" >> hClose w >> hGetLine r+-- "test" withPipe :: (Handle -> Handle -> IO a) -> IO a withPipe k =     bracket@@ -160,28 +203,131 @@     (Proc f) &!> (Append path) = Proc $ \i o _ pl pw ->         withBinaryFile path AppendMode $ \h -> f i o h pl pw -    writeProc (Proc f) input = Proc $ \_ o e pl pw -> do-        withPipe $ \r w ->-            fst <$> concurrently-                (f r o e pl (pw `finally` hClose r))-                (hPutStr w input `finally` hClose w)+    nativeProc f = Proc $ \i o e pl pw -> handle handler $ do+        pl+        -- We duplicate these so that you can't accidentally close the+        -- real ones.+        withDuplicates i o e $ \i' o' e' -> do+            (f i' o' e' >>= C.evaluate . force)+                `finally` (hClose i')+                `finally` (hClose o')+                `finally` (hClose e')+                `finally` pw -    withRead (Proc f) k = Proc $ \i _ e pl pw -> do-        withPipe $ \r w -> do-            withAsync (f i w e pl (hClose w `finally` pw)) $ \a -> do-                rr <- (hGetContents r >>= k >>= C.evaluate . force) `finally` hClose r-                _ <- wait a-                pure rr+        where+            -- The resource vanished error only occurs when upstream pipe closes.+            -- This can only happen with the `|>` combinator, which will discard+            -- the result of this `Proc` anyway. If the return value is somehow+            -- inspected, or maybe if the exception is somehow legitimate, we+            -- simply package it up as an exploding return value. `runProc` will+            -- make sure to evaluate all `Proc`'s to WHNF in order to uncover it.+            -- This should never happen. *nervous*+            handler :: IOError -> IO a+            handler e+                | ioeGetErrorType e == ResourceVanished = pure (throw e)+                | otherwise = throwIO e +-- | Simple @`Proc`@ that writes a `String` to it's @stdout@. This behaves+-- very much like the standard @echo@ utility, except that there is no+-- restriction as to what can be in the string argument.+--+-- >>> writeOutput "Hello"+-- Hello+writeOutput :: PipeResult io => String -> io ()+writeOutput s = nativeProc $ \_ o _ -> do+    hPutStr o s++-- | Simple @`Proc`@ that writes a `String` to it's @stderr@.+-- See also @`writeOutput`@.+-- >>> writeError "Hello" &> devNull+-- Hello+writeError :: PipeResult io => String -> io ()+writeError s = nativeProc $ \_ _ e -> do+    hPutStr e s++-- | Simple @`Proc`@ that reads it's input, and can react to it with an IO+-- action. Does not write anything to it's output. See also @`capture`@.+--+-- @`readInput`@ uses lazy IO to read it's stdin, and works with infinite+-- inputs.+--+-- >>> yes |> readInput (pure . unlines . take 3 . lines)+-- "y\ny\ny\n"+readInput :: (NFData a, PipeResult io) => (String -> IO a) -> io a+readInput f = nativeProc $ \i _ _ -> do+    hGetContents i >>= f++-- | Like @`readInput`@, but @`split`@s the string.+--+-- >>> yes |> readInputSplit "\n" (pure . take 3)+-- ["y","y","y"]+readInputSplit :: (NFData a, PipeResult io) => String -> ([String] -> IO a) -> io a+readInputSplit s f = readInput (f . split s)++-- | Like @`readInput`@, but @`split`@s the string on the 0 byte.+--+-- >>> writeOutput "1\0\&2\0" |> readInputSplit0 pure+-- ["1","2"]+readInputSplit0 :: (NFData a, PipeResult io) => ([String] -> IO a) -> io a+readInputSplit0 = readInputSplit "\0"++-- | Like @`readInput`@, but @`split`@s the string on new lines.+--+-- >>> writeOutput "a\nb\n" |> readInputLines pure+-- ["a","b"]+readInputLines :: (NFData a, PipeResult io) => ([String] -> IO a) -> io a+readInputLines = readInputSplit "\n"++-- | Creates a pure @`Proc`@ that simple transforms the @stdin@ and writes+-- it to @stdout@. The input can be infinite.+--+-- >>> yes |> pureProc (take 4) |> capture+-- "y\ny\n"+pureProc :: PipeResult io => (String -> String) -> io ()+pureProc f = nativeProc $ \i o _ -> do+    s <- hGetContents i+    hPutStr o (f s)++-- | Captures the stdout of a process and prefixes all the lines with+-- the given string.+--+-- >>> some_command |> prefixLines "stdout: " |!> prefixLines "stderr: " &> StdErr+-- stdout: this is stdout+-- stderr: this is stderr+prefixLines :: PipeResult io => String -> io ()+prefixLines s = pureProc $ unlines . map (s ++) . lines++-- | Provide the stdin of a `Proc` from a `String`+--+-- Same as @`writeOutput` s |> p@+writeProc :: PipeResult io => Proc a -> String -> io a+writeProc p s = writeOutput s |> p++-- | Run a process and capture it's output lazily. Once the continuation+-- is completed, the handles are closed. However, the process is run+-- until it naturally terminates in order to capture the correct exit+-- code. Most utilities behave correctly with this (e.g. @cat@ will+-- terminate if you close the handle).+--+-- Same as @p |> readInput f@+withRead :: (PipeResult f, NFData b) => Proc a -> (String -> IO b) -> f b+withRead p f = p |> readInput f+ -- | Type used to represent destinations for redirects. @`Truncate` file@ -- is like @> file@ in a shell, and @`Append` file@ is like @>> file@. data Stream = StdOut | StdErr | Truncate FilePath | Append FilePath  -- | Shortcut for @`Truncate` "\/dev\/null"@+-- +-- >>> echo "Hello" &> devNull devNull :: Stream devNull = Truncate "/dev/null"  -- | Type representing a series or pipeline (or both) of shell commands.+--+-- @Proc@'s can communicate to each other via @stdin@, @stdout@ and @stderr@+-- and can communicate to Haskell via their parameterised return type, or by+-- throwing an exception. newtype Proc a = Proc (Handle -> Handle -> Handle -> IO () -> IO () -> IO a)     deriving Functor @@ -210,7 +356,6 @@         a' <- a         pure (f' a')         - instance Monad Proc where     (Proc a) >>= f = Proc $ \i o e pl pw -> do         ar <- a i o e pl (pure ())@@ -222,8 +367,22 @@ -- commands in Shh are polymorphic in their return type, and work -- just fine in `IO` directly. runProc :: Proc a -> IO a-runProc (Proc f) = f stdin stdout stderr (pure ()) (pure ())+runProc = runProc' stdin stdout stderr +-- | Run's a `Proc` in `IO`. Like `runProc`, but you get to choose the handles.+-- This is UNSAFE to expose externally, because there are restrictions on what+-- the Handle can be. Within shh, we never call `runProc'` with invalid handles,+-- so we ignore that corner case (see `hDup`).+runProc' :: Handle -> Handle -> Handle -> Proc a -> IO a+runProc' i o e (Proc f) = do+    r <- f i o e (pure ()) (pure ())+    -- Evaluate to WHNF to uncover any ResourceVanished exceptions+    -- that may be hiding in there from `nativeProc`. These should+    -- not happen under normal circumstances, but we would at least+    -- like to have the exception thrown ASAP if, for whatever reason,+    -- it does happen.+    pure $! r+ -- | Create a `Proc` from a command and a list of arguments. -- The boolean represents whether we should delegate control-c -- or not. Most uses of @`mkProc'`@ in Shh do not delegate control-c.@@ -256,10 +415,44 @@ readProc :: PipeResult io => Proc a -> io String readProc p = withRead p pure +-- | A special `Proc` which captures it's stdin and presents it as a `String`+-- to Haskell.+--+-- >>> printf "Hello" |> md5sum |> capture+-- "8b1a9953c4611296a827abf8c47804d7  -\n"+capture :: PipeResult io => io String+capture = readInput pure++-- | Like @'capture'@, except that it @'trim'@s leading and trailing white+-- space.+--+-- >>> printf "Hello" |> md5sum |> captureTrim+-- "8b1a9953c4611296a827abf8c47804d7  -"+captureTrim :: PipeResult io => io String+captureTrim = readInput (pure . trim)++-- | Like @'capture'@, but splits the input using the provided separator.+--+-- NB: This is strict. If you want a streaming version, use `readInput`+captureSplit :: PipeResult io => String -> io [String]+captureSplit s = readInput (pure . endBy s)++-- | Same as @'captureSplit' "\0"@.+captureSplit0 :: PipeResult io => io [String]+captureSplit0 = captureSplit "\0"++-- | Same as @'captureSplit' "\n"@.+captureLines :: PipeResult io => io [String]+captureLines = captureSplit "\n"+ -- | Apply a transformation function to the string before the IO action. withRead' :: (NFData b, PipeResult io) => (String -> a) -> Proc x -> (a -> IO b) -> io b withRead' f p io = withRead p (io . f) +-- | Like @'withRead'@ except it splits the string with the provided separator.+withReadSplit :: (NFData b, PipeResult io) => String -> Proc a -> ([String] -> IO b) -> io b+withReadSplit = withRead' . split+ -- | Like @'withRead'@ except it splits the string with @'split0'@ first. withReadSplit0 :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b withReadSplit0 = withRead' split0@@ -281,8 +474,8 @@  -- | Some as `readWriteProc`. Apply a `Proc` to a `String`. ----- >>> apply shasum "Hello"--- "f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0  -\n"+-- >> apply md5sum "Hello"+-- "8b1a9953c4611296a827abf8c47804d7  -\n" apply :: MonadIO io => Proc a -> String -> io String apply = readWriteProc @@ -324,10 +517,10 @@ -- | Run a `Proc` action, ignoring any `Failure` exceptions. -- This can be used to prevent a process from interrupting a whole pipeline. ----- >>> false `|>` (sleep 2 >> echo 1)+-- >>> false |> (sleep 2 >> echo 1) -- *** Exception: Command `false` failed [exit 1] ----- >>> (ignoreFailure  false) `|>` (sleep 2 >> echo 1)+-- >>> (ignoreFailure  false) |> (sleep 2 >> echo 1) -- 1 ignoreFailure :: (Functor m, ProcFailure m) => Proc a -> m () ignoreFailure = void . catchFailure@@ -527,6 +720,18 @@         rawExe (f $ takeFileName bin) bin     pure (concat i) +-- | Split a string separated by the provided separator. Trailing separators+-- are ignored, and do not produce an empty string. Compatible with the+-- output of most CLI programs, such as @find -print0@.+--+-- >>> split "\n" "a\nb\n"+-- ["a","b"]+--+-- >>> split "\n" "a\nb"+-- ["a","b"]+split :: String -> String -> [String]+split = endBy+ -- | Function that splits '\0' separated list of strings. Useful in conjunction -- with @find . "-print0"@. split0 :: String -> [String]@@ -570,3 +775,123 @@  instance {-# OVERLAPS #-} (io ~ IO (), path ~ FilePath) => Cd (path -> io) where     cd = cd'++-- | @xargs1 n f@ runs @f@ for each item in the input separated by @n@. Similar+-- to the standard @xargs@ utility, but you get to choose the separator, and it+-- only does one argument per command. Compare the following two lines, which+-- do the same thing.+--+-- >>> printf "a\\0b" |> xargs "--null" "-L1" "echo" |> cat+-- a+-- b+-- >>> printf "a\\0b" |> xargs1 "\0" echo |> cat+-- a+-- b+--+-- One benefit of this method over the standard @xargs@ is that we can run+-- Haskell functions as well.+--+-- >>> yes |> head "-n" 5 |> xargs1 "\n" (const $ pure $ Sum 1)+-- Sum {getSum = 5}+xargs1 :: (NFData a, Monoid a) => String -> (String -> Proc a) -> Proc a+xargs1 n f = readInputSplitP n (fmap mconcat . mapM f)++-- | Simple @`Proc`@ that reads it's input and can react to the output by+-- calling other @`Proc`@'s which can write something to it's stdout.+-- The internal @`Proc`@ is given @/dev/null@ as it's input.+readInputP :: (NFData a, PipeResult io) => (String -> Proc a) -> io a+readInputP f = nativeProc $ \i o e -> do+    s <- hGetContents i+    withNullInput $ \i' ->+        liftIO $ runProc' i' o e (f s)++-- | Like @`readInputP`@, but splits the input.+readInputSplitP :: (NFData a, PipeResult io) => String -> ([String] -> Proc a) -> io a+readInputSplitP s f = readInputP (f . split s)++-- | Like @`readInputP`@, but splits the input on 0 bytes.+readInputSplit0P :: (NFData a, PipeResult io) => ([String] -> Proc a) -> io a+readInputSplit0P = readInputSplitP "\0"++-- | Like @`readInputP`@, but splits the input on new lines.+readInputLinesP :: (NFData a, PipeResult io) => ([String] -> Proc a) -> io a+readInputLinesP = readInputSplitP "\n"++-- | Create a null file handle.+withNullInput :: (Handle -> IO a) -> IO a+withNullInput = withFile "/dev/null" ReadMode++-- | Bracket a @`hDup`@+withDuplicate :: Handle -> (Handle -> IO a) -> IO a+withDuplicate h f = bracket (hDup h) hClose f++-- | Bracket three @`hDup`@s+withDuplicates :: Handle -> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a+withDuplicates a b c f =+    withDuplicate a $ \a' -> withDuplicate b $ \b' -> withDuplicate c $ \c' -> f a' b' c'++-- | Bracket two @`hDup`@s and provide a null input handle.+withDuplicateNullInput :: Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a+withDuplicateNullInput a b f = do+    withNullInput $ \i -> do+        withDuplicate a $ \a' -> withDuplicate b $ \b' -> f i a' b'++-- | Duplicate a @`Handle`@ without trying to flush buffers. Only works on @`FileHandle`@s.+--+-- hDuplicate tries to "flush" read buffers by seeking backwards, which doesn't+-- work for streams/pipes. Since we are simulating a @fork + exec@ in @`nativeProc`@,+-- losing the buffers is actually the expected behaviour. (System.Process doesn't+-- attempt to flush the buffers).+--+-- NB: An alternate solution that we could implement (even for System.Process forks)+-- is to create a fresh pipe and spawn an async task to forward buffered content+-- from the original handle if there is something in the buffer. My concern would+-- be that it might be a performance hit that people aren't expecting.+--+-- Code basically copied from+-- http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.IO.Handle.html#hDuplicate+-- with minor modifications.+hDup :: Handle -> IO Handle+hDup h@(FileHandle path m) = do+    withHandle_' "hDup" h m $ \h_ ->+        dupHandleShh path h Nothing h_ (Just handleFinalizer)+hDup h@(DuplexHandle path r w) = do+    (FileHandle _ write_m) <-+        withHandle_' "hDup" h w $ \h_ ->+            dupHandleShh path h Nothing h_ (Just handleFinalizer)+    (FileHandle _ read_m) <-+        withHandle_' "hDup" h r $ \h_ ->+            dupHandleShh path h (Just write_m) h_  Nothing+    return (DuplexHandle path read_m write_m)++-- | Helper function for duplicating a Handle+dupHandleShh+    :: FilePath+    -> Handle+    -> Maybe (MVar Handle__)+    -> Handle__+    -> Maybe HandleFinalizer+    -> IO Handle+dupHandleShh filepath h other_side h_@Handle__{..} mb_finalizer = do+    case other_side of+        Nothing -> do+            new_dev <- IODevice.dup haDevice+            dupHandleShh_ new_dev filepath other_side h_ mb_finalizer+        Just r  ->+            withHandle_' "dupHandleShh" h r $ \Handle__{haDevice=dev} -> do+                dupHandleShh_ dev filepath other_side h_ mb_finalizer++-- | Helper function for duplicating a Handle+dupHandleShh_+    :: (IODevice dev, BufferedIO dev, Typeable dev) => dev+    -> FilePath+    -> Maybe (MVar Handle__)+    -> Handle__+    -> Maybe HandleFinalizer+    -> IO Handle+dupHandleShh_ new_dev filepath other_side Handle__{..} mb_finalizer = do+    -- XXX wrong!+    mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing+    mkHandle new_dev filepath haType True{-buffered-} mb_codec+        NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }+        mb_finalizer other_side

@@ -2,14 +2,23 @@ {-# LANGUAGE ExtendedDefaultRules #-} module Main where +import System.Directory import Shh+import Test.DocTest import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Control.Exception import Control.Monad+import Data.Char+import Data.Word+import Control.Concurrent.Async+import System.IO -$(load SearchPath ["tr", "echo", "cat", "true", "false", "mktemp", "sleep", "rm"])+load SearchPath+    ["wc", "head", "tr", "echo", "cat", "true", "false", "mktemp", "sleep"+    , "rm", "printf", "xargs", "find"+    ]  main = do     putStrLn "################################################"@@ -18,16 +27,48 @@     putStrLn " failures, please check that it's not because"     putStrLn " they are missing."     putStrLn "################################################"+    doctest ["--fast", "-isrc", "src/Shh/Internal.hs"]     defaultMain tests  tests :: TestTree-tests = testGroup "Tests" [unitTests, properties]+tests = localOption (Timeout 4000000 "4s") $ testGroup "Tests" [unitTests, properties] +bytesToString :: [Word8] -> String+bytesToString = map (chr . fromIntegral)+ properties :: TestTree properties = testGroup "Properties"     [ testProperty "trim = trim . trim" $ \l -> trim l == trim (trim l)     , testProperty "encodeIdentifier = encodeIdentifier . encodeIdentifier"         $ \l -> encodeIdentifier l == encodeIdentifier (encodeIdentifier l)+    , testProperty "writeOutput" $ \s -> ioProperty $ do+        let+            s' = bytesToString s+        k <- writeOutput s' |> capture+        pure $ s' === k+    , testProperty "pureProc id" $ \s -> ioProperty $ do+        let+            s' = bytesToString s+        k <- readProc $ s' >>> pureProc id+        pure $ s' === k+    , testProperty "pureProc (map toUpper)" $ \(ASCIIString s) -> ioProperty $ do+        k <- readProc $ s >>> pureProc (map toUpper)+        pure $ map toUpper s === k+    , testProperty "pureProc . const === writeOutput" $ \s -> ioProperty $ do+        let+            s' = bytesToString s+        a <- writeOutput s' |> capture+        b <- pureProc (const s') |> capture+        pure $ a === b+    , testProperty "writeOutput s |> capture >>= writeOutput |> capture === s"+        $ \(ASCIIString s) -> ioProperty $ do+            r <- writeOutput s |> capture >>= writeOutput |> capture+            pure $ r === s+    , testProperty "pureProc id === readInputP (\\s -> writeOutput s)"+        $ \(ASCIIString s) -> ioProperty $ do+            a <- writeOutput s |> pureProc id |> capture+            b <- writeOutput s |> readInputP (\s -> writeOutput s) |> capture+            pure $ a === b     ]  withTmp :: (FilePath -> IO a) -> IO a@@ -41,6 +82,9 @@     , testCase "Redirect to /dev/null" $ do         l <- readProc $ echo "test" &> devNull         l @?= ""+    , testCase "Redirct stderr" $ do+        l <- echo "test" &> StdErr |!> capture+        l @?= "test\n"     , testCase "Redirect to file (Truncate)" $ withTmp $ \t -> do         echo "test" &> Truncate t         r <- readProc $ cat t@@ -53,12 +97,12 @@     , testCase "Long pipe" $ do         r <- readProc $ echo "test" |> tr "-d" "e" |> tr "-d" "s"         r @?= "tt\n"-    , testCase "Pipe stderr" $ do+    , testCase "Pipe stderr" $ replicateM_ 100 $ do         r <- readProc $ echo "test" &> StdErr |!> cat         r @?= "test\n"-    , testCase "Lazy read" $ do-        withRead (cat "/dev/urandom" |> tr "-C" "-d" "a") $ \s -> do-            take 6 s @?= "aaaaaa"+    , testCase "Lazy read" $ replicateM_ 100 $ do+        withRead (cat "/dev/zero") $ \s -> do+            take 6 s @?= "\0\0\0\0\0\0"     , testCase "Multiple outputs" $ do         l <- readProc $ (echo (1 :: Int) >> echo (2 :: Int)) |> cat         l @?= "1\n2\n"@@ -93,4 +137,65 @@     , testCase "Lazy read checks code" $ replicateM_ 30 $ do         Left r <- catchFailure $ withRead (cat "/dev/urandom" |> false "dummy") $ pure . take 3         r @?= Shh.Failure "false" ["dummy"] 1+    , testCase "Identifier odd chars" $ encodeIdentifier "1@3.-" @?= "_1_3__"+    , testCase "Identifier make lower" $ encodeIdentifier "T.est" @?= "t_est"+    , testCase "pureProc closes input" $ do+        r <- readProc $ cat "/dev/urandom" |> pureProc (const "test")+        r @?= "test"+    , testCase "pureProc closes output" $ do+        r <- readProc $ pureProc (const "test") |> cat+        r @?= "test"+    , testCase "pureProc doesn't close std handles" $ do+        runProc $ pureProc (const "")+        b <- hIsOpen stdin+        b @?= True+        b <- hIsOpen stdout+        b @?= True+        runProc $ pureProc (const "") &> StdErr+        b <- hIsOpen stderr+        b @?= True+    , testCase "pureProc sanity check" $ do+        r <- readProc $ printf "Hello" |> pureProc id |> cat+        r @?= "Hello"+    , testCase "bind nativeProc" $ do+        r <- writeOutput "te" >> writeOutput "st" |> capture+        r @?= "test"+    , testCase "stdin interleave capture" $ do+        r <- writeOutput "te" >> writeError "--" &!> devNull >> writeOutput "st" >> writeError "--" &!> devNull |> capture+        r @?= "test"+    , testCase "stderr interleave capture" $ do+        r <- writeOutput "--" &> devNull >> writeError "te" >> writeOutput "--" &> devNull >> writeError "st" |!> capture+        r @?= "test"+    , testCase "prefixLines" $ do+        r <- printf "Hello\\nWorld" |> prefixLines ":" |> capture+        r @?= ":Hello\n:World\n"+    , testCase "Bind in the middle" $ do+        l <- echo "a" |> prefixLines ":" >> echo "c" |> prefixLines ":" |> capture+        l @?= "::a\n:c\n"+    , testCase "writeOutput mimics printf" $ do+        l <- writeOutput "a\0b\0c" |> capture+        r <- printf "a\\0b\\0c" |> capture+        l @?= r+    , testCase "xargs1 printf" $ do+        a <- printf "a\\0b\\0c" |> xargs "--null" "-L1" "echo" |> capture+        b <- printf "a\\0b\\0c" |> xargs1 "\0" echo |> capture+        a @?= b+    , testCase "xargs1 writeOutput" $ do+        a <- writeOutput "a\0b\0c" |> xargs "--null" "-L1" "echo" |> capture+        b <- writeOutput "a\0b\0c" |> xargs1 "\0" echo |> capture+        a @?= b+    , testCase "fixity |>" $ do+        a <- echo "a" >> echo "b" >> echo "c" |> Main.head "-n" 2 |> capture+        b <- (echo "a" >> echo "b" >> echo "c") |> Main.head "-n" 2 |> capture+        a @?= b+    , testCase "pureProc . const === writeOutput (spam test)" $ replicateM_ 3000 $ do+        let+            s = ""+        a <- writeOutput s |> capture+        b <- pureProc (const s) |> capture+        a @?= b+    , testCase "complex example with intermediate handles (>BUFSIZ)" $ do+        let c = 20000000+        s <- readTrim $ cat "/dev/urandom" |> readInputP (\s -> writeOutput (map toUpper s) |> cat) |> Main.head "-c" c |> wc "-c"+        show c @?= s     ]