diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Revision history for shh +## 0.6.0.0 -- 2019-06-26 + +This change doesn't remove any functions or majorly change any semantics, +but it will break everything. We now use ByteString instead of String as +the basis for interaction with the OS. This has the potential to improve +performance, but most importantly, helps with correctness. + +* Switch to a ByteString interface, in the process fixing up a bunch of + unicode issues. +* Encode String type arguments as utf8. + ## 0.5.0.0 -- 2019-05-23 * Change how identifiers are encoded to avoid clashes in all scenarios diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -199,4 +199,63 @@ ### Script Usage -TODO: Fill this in once the user experience is better. +#### Nix + +Nixpkgs provides a `writeHaskellBin` function which is very convenient for +writing quick scripts for your Nix setup. + +```nix +writers.writeHaskellBin "example" {libraries = [haskellPackages.shh];} '' + {-# LANGUAGE TemplateHaskell #-} + import Shh + + -- Load binaries from Nix packages. The dependencies will be captured + -- in the closure. + loadFromBins ["${git}", "${coreutils}", "${curl}"] + + main :: IO () + main = do + cat "/a/file" + cp "/a/file" "/b/file" +'' +``` + +## Alternatives + +There are quite a few players in the "shell programming for Haskell" field. + +This table attempts to summarise some of the differences. + + * `Pipe Style` refers to how processes are joined together, "native" means + that the mechanisms provided by the OS are used, while "via haskell" means + that the data is read into the Haskell process, and then written into the + subprocess. + * `Via Shell` refers to whether subprocesses are launched directly or via + a shell (which can provide a "native" piping solution at the cost of + composability) + * `Run in IO` refers to whether commands need to be prefixed with `run` or + similar functions to actually execute them. + * `TH Helper` refers to whether the use of TH to generate Haskell functions + based on commands found at compile time is encouraged in the main library. + * `Monadic Subshell` refers to the ability to join multiple processes together + and feed them all from the same input and to the same output. + `echo a | (cat; echo b) | wc -l` should report that 2 lines appeared. + + +| Library | Pipe Style | Via Shell | Run in IO | Threadsafe `cd` | TH Helper | Monadic Subshell | Redirect `stderr` | +|---------|-------------|-----------|-----------|-----------------|-----------|------------------|-------------------| +| Shh | Native | No | Yes | No | Yes | Yes | Yes | +| Shelly | Via Haskell | Yes | No | Yes | No | No | Yes | +| Turtle | Via Haskell | Optional | No | ? | No | No (Alternative) | Yes | +| shell-conduit | Via Haskell | Optional | No | ? | Yes | Yes | No? | + + +### Errors + +| Library | Exception on non-zero | Contains arguments | Contains `stderr` | Terminates pipeline | +|---------|-----------------------|--------------------|-------------------|---------------------| +| Shh | Yes | Yes | No | Yes | +| Shelly | Yes | Yes | Yes | Yes | +| Turtle | Sometimes | No | No | ? | +| shell-conduit | Yes | Yes | No | No | + diff --git a/app/Example.hs b/app/Example.hs --- a/app/Example.hs +++ b/app/Example.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} module Main where diff --git a/app/shh-app.hs b/app/shh-app.hs --- a/app/shh-app.hs +++ b/app/shh-app.hs @@ -4,6 +4,7 @@ import Control.DeepSeq (force) import Control.Exception import Control.Monad +import Data.ByteString.Lazy.Char8 (ByteString,pack) import Shh import System.IO import System.IO.Error @@ -82,14 +83,14 @@ setOwnerWritable True $ emptyPermissions doIfMissing "init.ghci" $ do - catchFailure (exe wrapper "ghc-pkg" "latest" "shh") >>= \case + catchFailure (exe (pack wrapper) "ghc-pkg" "latest" "shh") >>= \case Left _ -> do putStrLn "Please make the shh and shh-extras packages available in the shh" putStrLn "environment (install it globally or modify the wrapper, see docs)." putStrLn "Aborting" exitFailure Right _ -> writeFile "init.ghci" defaultInitGhci - catchFailure (exe wrapper "ghc-pkg" "latest" "shh-extras") >>= \case + catchFailure (exe (pack wrapper) "ghc-pkg" "latest" "shh-extras") >>= \case Left _ -> do putStrLn "## WARNING ##########################################################" putStrLn "# You do not have the shh-extras library installed, and so we are" @@ -112,7 +113,7 @@ 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") + exe (pack wrapper) "ghc" "-c" "-dynamic" (shhDir <> "/Shell.hs") executeFile wrapper False ["ghci", "-ghci-script", shhDir <> "/init.ghci", shhDir <> "/Shell.hs"] Nothing diff --git a/shh.cabal b/shh.cabal --- a/shh.cabal +++ b/shh.cabal @@ -1,5 +1,5 @@ name: shh -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Simple shell scripting from Haskell description: Provides a shell scripting environment for Haskell. It helps you use external binaries, and allows you to @@ -25,6 +25,7 @@ build-depends: base >= 4.9 && < 4.13, async >= 2.2.1 && < 2.3, + bytestring, deepseq >= 1.4.3 && < 1.5, directory >= 1.3.1 && < 1.4, filepath >= 1.4.2 && < 1.5, @@ -33,7 +34,8 @@ split >= 0.2.3 && < 0.3, template-haskell >= 2.13.0 && < 2.15, containers >= 0.5.11 && < 0.7, - unix >= 2.7.2 && < 2.8 + unix >= 2.7.2 && < 2.8, + utf8-string hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -44,6 +46,7 @@ build-depends: base >=4.9, temporary, + bytestring, deepseq, directory, shh, @@ -68,12 +71,14 @@ build-depends: base >=4.9, async, + bytestring, directory, doctest, tasty, tasty-quickcheck, tasty-hunit, - shh + shh, + utf8-string hs-source-dirs: test main-is: Test.hs type: exitcode-stdio-1.0 diff --git a/src/Shh/Internal.hs b/src/Shh/Internal.hs --- a/src/Shh/Internal.hs +++ b/src/Shh/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} @@ -14,12 +15,19 @@ -- | See documentation for "Shh". module Shh.Internal where +import Prelude hiding (lines, unlines) + import Control.Concurrent.MVar import Control.Concurrent.Async import Control.DeepSeq (force,NFData) import Control.Exception as C import Control.Monad import Control.Monad.IO.Class +import Data.ByteString.Lazy (ByteString, hGetContents) +import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy.Builder.ASCII +import Data.ByteString.Lazy.UTF8 (toString, fromString, lines) +import qualified Data.ByteString.Lazy.Char8 as BC8 import Data.Char (isLower, isSpace, isAlphaNum, ord) import Data.List (dropWhileEnd, intercalate) import Data.List.Split (endBy, splitOn) @@ -30,7 +38,7 @@ 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 hiding (hGetContents) import GHC.IO.Handle.Internals import GHC.IO.Handle.Types import GHC.IO.Handle.Types (Handle(..)) @@ -39,7 +47,7 @@ import System.Environment (getEnv, setEnv) import System.Exit (ExitCode(..)) import System.FilePath (takeFileName, ()) -import System.IO +import System.IO (IOMode(..), withFile, withBinaryFile, stderr, stdout, stdin) import System.IO.Error import System.Posix.Signals import System.Process @@ -47,6 +55,7 @@ -- $setup -- For doc-tests. Not sure I can use TH in doc tests. +-- >>> :seti -XOverloadedStrings -- >>> import Data.Monoid -- >>> let cat = exe "cat" -- >>> let echo = exe "echo" @@ -74,8 +83,8 @@ -- The only exception to this is when a process is terminated -- by @SIGPIPE@ in a pipeline, in which case we ignore it. data Failure = Failure - { failureProg :: String - , failureArgs :: [String] + { failureProg :: ByteString + , failureArgs :: [ByteString] , failureCode :: Int } deriving (Eq, Ord) @@ -83,7 +92,7 @@ show f = concat $ [ "Command `" ] - ++ [intercalate " " (failureProg f : map show (failureArgs f))] + ++ [intercalate " " (BC8.unpack (failureProg f) : map show (failureArgs f))] ++ [ "` failed [exit " , show (failureCode f) @@ -99,7 +108,7 @@ -- | Use this to send the output of on process into the input of another. -- This is just like a shells `|` operator. -- - -- The result is polymorphic in it's output, and can result in either + -- The result is polymorphic in its output, and can result in either -- another `Proc a` or an `IO a` depending on the context in which it is -- used. -- @@ -164,7 +173,7 @@ -- | 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 +-- >>> withPipe $ \r w -> hPutStr w "test" >> hClose w >> hGetLine r -- "test" withPipe :: (Handle -> Handle -> IO a) -> IO a withPipe k = @@ -193,16 +202,16 @@ p &> StdOut = p (Proc f) &> StdErr = Proc $ \i _ e pl pw -> f i e e pl pw (Proc f) &> (Truncate path) = Proc $ \i _ e pl pw -> - withBinaryFile path WriteMode $ \h -> f i h e pl pw + withBinaryFile (BC8.unpack path) WriteMode $ \h -> f i h e pl pw (Proc f) &> (Append path) = Proc $ \i _ e pl pw -> - withBinaryFile path AppendMode $ \h -> f i h e pl pw + withBinaryFile (BC8.unpack path) AppendMode $ \h -> f i h e pl pw p &!> StdErr = p (Proc f) &!> StdOut = Proc $ \i o _ pl pw -> f i o o pl pw (Proc f) &!> (Truncate path) = Proc $ \i o _ pl pw -> - withBinaryFile path WriteMode $ \h -> f i o h pl pw + withBinaryFile (BC8.unpack path) WriteMode $ \h -> f i o h pl pw (Proc f) &!> (Append path) = Proc $ \i o _ pl pw -> - withBinaryFile path AppendMode $ \h -> f i o h pl pw + withBinaryFile (BC8.unpack path) AppendMode $ \h -> f i o h pl pw nativeProc f = Proc $ \i o e pl pw -> handle handler $ do pl @@ -228,66 +237,77 @@ | 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. +-- | Simple @`Proc`@ that writes its argument to its @stdout@. This behaves +-- very much like the standard @printf@ utility, except that there is no +-- restriction as to what can be in the argument. -- +-- NB: @String@ arguments are encoded as UTF8, while @ByteString@ is passed +-- through. Be aware if you are using @OverloadedStrings@ that you will get +-- wrong results if using unicode in your string literal and it inferes +-- anything other than @String@. +-- -- >>> writeOutput "Hello" -- Hello -writeOutput :: PipeResult io => String -> io () +writeOutput :: (ExecArg a, PipeResult io) => a -> io () writeOutput s = nativeProc $ \_ o _ -> do - hPutStr o s + mapM_ (BS.hPutStr o) (asArg s) --- | Simple @`Proc`@ that writes a `String` to it's @stderr@. +-- | Simple @`Proc`@ that writes its argument to its @stderr@. -- See also @`writeOutput`@. +-- -- >>> writeError "Hello" &> devNull -- Hello -writeError :: PipeResult io => String -> io () +writeError :: (ExecArg a, PipeResult io) => a -> io () writeError s = nativeProc $ \_ _ e -> do - hPutStr e s + mapM_ (BS.hPutStr e) (asArg 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`@. +-- | Simple @`Proc`@ that reads its input, and can react to it with an IO +-- action. Does not write anything to its output. See also @`capture`@. -- --- @`readInput`@ uses lazy IO to read it's stdin, and works with infinite +-- @`readInput`@ uses lazy IO to read its 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 :: (NFData a, PipeResult io) => (ByteString -> IO a) -> io a readInput f = nativeProc $ \i _ _ -> do hGetContents i >>= f +-- | Join a list of @ByteString@s with newline characters, terminating it +-- with a newline. +unlines :: [ByteString] -> ByteString +unlines = toLazyByteString . mconcat . map (\l -> lazyByteString l <> char7 '\n') + -- | 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 :: (NFData a, PipeResult io) => ByteString -> ([ByteString] -> 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 :: (NFData a, PipeResult io) => ([ByteString] -> 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 :: (NFData a, PipeResult io) => ([ByteString] -> 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 +-- >>> yes |> pureProc (BS.take 4) |> capture -- "y\ny\n" -pureProc :: PipeResult io => (String -> String) -> io () +pureProc :: PipeResult io => (ByteString -> ByteString) -> io () pureProc f = nativeProc $ \i o _ -> do s <- hGetContents i - hPutStr o (f s) + BS.hPutStr o (f s) -- | Captures the stdout of a process and prefixes all the lines with -- the given string. @@ -295,28 +315,29 @@ -- >>> 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 +prefixLines :: PipeResult io => ByteString -> io () +prefixLines s = pureProc $ \inp -> toLazyByteString $ + mconcat $ map (\l -> lazyByteString s <> lazyByteString l <> char7 '\n') (lines inp) --- | Provide the stdin of a `Proc` from a `String` +-- | Provide the stdin of a `Proc` from a `ByteString` -- -- Same as @`writeOutput` s |> p@ -writeProc :: PipeResult io => Proc a -> String -> io a +writeProc :: PipeResult io => Proc a -> ByteString -> io a writeProc p s = writeOutput s |> p --- | Run a process and capture it's output lazily. Once the continuation +-- | Run a process and capture its 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 :: (PipeResult f, NFData b) => Proc a -> (ByteString -> 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 +data Stream = StdOut | StdErr | Truncate ByteString | Append ByteString -- | Shortcut for @`Truncate` "\/dev\/null"@ -- @@ -387,10 +408,13 @@ -- | 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. -mkProc' :: Bool -> String -> [String] -> Proc () +mkProc' :: Bool -> ByteString -> [ByteString] -> Proc () mkProc' delegate cmd args = Proc $ \i o e pl pw -> do + let + cmd' = BC8.unpack cmd + args' = BC8.unpack <$> args bracket - (createProcess_ cmd (proc cmd args) + (createProcess_ cmd' (proc cmd' args') { std_in = UseHandle i , std_out = UseHandle o , std_err = UseHandle e @@ -405,23 +429,23 @@ -- | Create a `Proc` from a command and a list of arguments. Does not delegate -- control-c handling. -mkProc :: String -> [String] -> Proc () +mkProc :: ByteString -> [ByteString] -> Proc () mkProc = mkProc' False -- | Read the stdout of a `Proc`. This captures stdout, so further piping will -- not see anything on the input. -- --- This is strict, so the whole output is read into a `String`. See `withRead` +-- This is strict, so the whole output is read into a `ByteString`. See `withRead` -- for a lazy version that can be used for streaming. -readProc :: PipeResult io => Proc a -> io String +readProc :: PipeResult io => Proc a -> io ByteString readProc p = withRead p pure --- | A special `Proc` which captures it's stdin and presents it as a `String` +-- | A special `Proc` which captures its stdin and presents it as a `ByteString` -- to Haskell. -- -- >>> printf "Hello" |> md5sum |> capture -- "8b1a9953c4611296a827abf8c47804d7 -\n" -capture :: PipeResult io => io String +capture :: PipeResult io => io ByteString capture = readInput pure -- | Like @'capture'@, except that it @'trim'@s leading and trailing white @@ -429,69 +453,69 @@ -- -- >>> printf "Hello" |> md5sum |> captureTrim -- "8b1a9953c4611296a827abf8c47804d7 -" -captureTrim :: PipeResult io => io String +captureTrim :: PipeResult io => io ByteString 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) +captureSplit :: PipeResult io => ByteString -> io [ByteString] +captureSplit s = readInput (pure . fmap fromString . endBy (toString s) . toString) -- | Same as @'captureSplit' "\0"@. -captureSplit0 :: PipeResult io => io [String] +captureSplit0 :: PipeResult io => io [ByteString] captureSplit0 = captureSplit "\0" -- | Same as @'captureSplit' "\n"@. -captureLines :: PipeResult io => io [String] +captureLines :: PipeResult io => io [ByteString] 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' :: (NFData b, PipeResult io) => (ByteString -> 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 :: (NFData b, PipeResult io) => ByteString -> Proc a -> ([ByteString] -> 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 :: (NFData b, PipeResult io) => Proc a -> ([ByteString] -> IO b) -> io b withReadSplit0 = withRead' split0 -- | Like @'withRead'@ except it splits the string with @'lines'@ first. -- -- NB: Please consider using @'withReadSplit0'@ where you can. -withReadLines :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b +withReadLines :: (NFData b, PipeResult io) => Proc a -> ([ByteString] -> IO b) -> io b withReadLines = withRead' lines -- | Like @'withRead'@ except it splits the string with @'words'@ first. -withReadWords :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b -withReadWords = withRead' words +withReadWords :: (NFData b, PipeResult io) => Proc a -> ([ByteString] -> IO b) -> io b +withReadWords = withRead' (map fromString . words . toString) -- | Read and write to a `Proc`. Same as -- @readProc proc <<< input@ -readWriteProc :: MonadIO io => Proc a -> String -> io String +readWriteProc :: MonadIO io => Proc a -> ByteString -> io ByteString readWriteProc p input = liftIO $ readProc p <<< input --- | Some as `readWriteProc`. Apply a `Proc` to a `String`. +-- | Some as `readWriteProc`. Apply a `Proc` to a `ByteString`. -- -- >> apply md5sum "Hello" -- "8b1a9953c4611296a827abf8c47804d7 -\n" -apply :: MonadIO io => Proc a -> String -> io String +apply :: MonadIO io => Proc a -> ByteString -> io ByteString apply = readWriteProc -- | Flipped, infix version of `writeProc` -(>>>) :: PipeResult io => String -> Proc a -> io a +(>>>) :: PipeResult io => ByteString -> Proc a -> io a (>>>) = flip writeProc -- | Infix version of `writeProc` -(<<<) :: PipeResult io => Proc a -> String -> io a +(<<<) :: PipeResult io => Proc a -> ByteString -> io a (<<<) = writeProc -- | Wait on a given `ProcessHandle`, and throw an exception of --- type `Failure` if it's exit code is non-zero (ignoring SIGPIPE) -waitProc :: String -> [String] -> ProcessHandle -> IO () +-- type `Failure` if its exit code is non-zero (ignoring SIGPIPE) +waitProc :: ByteString -> [ByteString] -> ProcessHandle -> IO () waitProc cmd arg ph = waitForProcess ph >>= \case ExitFailure c | fromIntegral c == negate sigPIPE -> pure () @@ -499,8 +523,8 @@ ExitSuccess -> pure () -- | Trim leading and tailing whitespace. -trim :: String -> String -trim = dropWhileEnd isSpace . dropWhile isSpace +trim :: ByteString -> ByteString +trim = fromString . dropWhileEnd isSpace . dropWhile isSpace . toString -- | Allow us to catch `Failure` exceptions in `IO` and `Proc` class ProcFailure m where @@ -535,36 +559,41 @@ getCode (Left f) = failureCode f -- | Like `readProc`, but trim leading and tailing whitespace. -readTrim :: (Functor io, PipeResult io) => Proc a -> io String +readTrim :: (Functor io, PipeResult io) => Proc a -> io ByteString readTrim = fmap trim . readProc -- | A class for things that can be converted to arguments on the command -- line. The default implementation is to use `show`. class ExecArg a where - asArg :: a -> [String] - default asArg :: Show a => a -> [String] - asArg a = [show a] + asArg :: a -> [ByteString] + default asArg :: Show a => a -> [ByteString] + asArg a = [fromString $ show a] -- God, I hate that String is [Char]... - asArgFromList :: [a] -> [String] - default asArgFromList :: Show a => [a] -> [String] + asArgFromList :: [a] -> [ByteString] + default asArgFromList :: Show a => [a] -> [ByteString] asArgFromList = concatMap asArg +-- | The @Char@ and @String@ instances encodes as UTF8 instance ExecArg Char where - asArg s = [[s]] - asArgFromList s = [s] + asArg s = [fromString [s]] + asArgFromList s = [fromString s] +-- | The @[Char]@/@String@ instance encodes as UTF8 instance ExecArg a => ExecArg [a] where asArg = asArgFromList asArgFromList = concatMap asArg +instance ExecArg ByteString where + asArg s = [s] + instance ExecArg Int instance ExecArg Integer instance ExecArg Word -- | A class for building up a command class ExecArgs a where - toArgs :: [String] -> a + toArgs :: [ByteString] -> a instance ExecArgs (Proc ()) where toArgs (cmd:args) = mkProc cmd args @@ -617,8 +646,8 @@ -- > exe "ls" "-l" -- -- See also `loadExe` and `loadEnv`. -exe :: (Unit a, ExecArgs a) => String -> a -exe s = toArgs [s] +exe :: (Unit a, ExecArgs a, ExecArg str) => str -> a +exe s = toArgs (asArg s) -- | Create a function for the executable named loadExe :: ExecReference -> String -> Q [Dec] @@ -670,6 +699,18 @@ -- Justification for changing @-@ to @_@ is that @-@ appears far more commonly -- in executable names than @_@ does, and so we give it the more ergonomic -- encoding. +-- +-- >>> encodeIdentifier "nix-shell" +-- "nix_shell" +-- +-- >>> encodeIdentifier "R" +-- "_R" +-- +-- >>> encodeIdentifier "x86_64-unknown-linux-gnu-gcc" +-- "x86'_64_unknown_linux_gnu_gcc" +-- +-- >>> encodeIdentifier "release.sh" +-- "release''sh" encodeIdentifier :: String -> String encodeIdentifier ident = let @@ -712,11 +753,11 @@ -- and creating a function @missingExecutables@ to do a runtime check for their -- availability. Uses the @'encodeIdentifier'@ function to create function -- names. -load :: ExecReference -> [String] -> Q [Dec] +load :: ExecReference -> [FilePath] -> Q [Dec] load ref = loadAnnotated ref encodeIdentifier -- | Same as `load`, but allows you to modify the function names. -loadAnnotated :: ExecReference -> (String -> String) -> [String] -> Q [Dec] +loadAnnotated :: ExecReference -> (String -> String) -> [FilePath] -> Q [Dec] loadAnnotated ref f bins = do let pairs = zip (map f bins) bins ds <- fmap join $ mapM (uncurry (loadExeAs ref)) pairs @@ -746,8 +787,8 @@ -- -- >>> split "\n" "a\nb" -- ["a","b"] -split :: String -> String -> [String] -split = endBy +split :: ByteString -> ByteString -> [ByteString] +split s str = fmap fromString $ endBy (toString s) (toString str) -- | Load executables from the given directories loadFromDirs :: [FilePath] -> Q [Dec] @@ -756,7 +797,6 @@ -- | Load executables from the given directories appended with @"/bin"@. -- -- Useful for use with Nix. --- loadFromBins :: [FilePath] -> Q [Dec] loadFromBins = loadFromDirs . fmap ( "bin") @@ -771,29 +811,29 @@ -- | Function that splits '\0' separated list of strings. Useful in conjunction -- with @find . "-print0"@. -split0 :: String -> [String] -split0 = endBy "\0" +split0 :: ByteString -> [ByteString] +split0 = split "\0" -- | A convenience function for reading in a @"\\NUL"@ separated list of -- strings. This is commonly used when dealing with paths. -- -- > readSplit0 $ find "-print0" -readSplit0 :: Proc () -> IO [String] +readSplit0 :: Proc () -> IO [ByteString] readSplit0 p = withReadSplit0 p pure -- | A convenience function for reading the output lines of a `Proc`. -- -- Note: Please consider using @'readSplit0'@ instead if you can. -readLines :: Proc () -> IO [String] +readLines :: Proc () -> IO [ByteString] readLines p = withReadLines p pure -- | Read output into a list of words -readWords :: Proc () -> IO [String] +readWords :: Proc () -> IO [ByteString] readWords p = withReadWords p pure -- | Like `readProc`, but attempts to `Prelude.read` the result. readAuto :: Read a => Proc () -> IO a -readAuto p = read <$> readProc p +readAuto p = read . toString <$> readProc p -- | Mimics the shell builtin "cd". cd' :: FilePath -> IO () @@ -804,7 +844,10 @@ -- | Helper class for variable number of arguments to @cd@ builtin. class Cd a where - -- | Mimics the shell builtin "cd" + -- | Mimics the shell builtin "cd". Be careful using this function + -- in a program, as it doesn't play well with multiple threads. Best + -- to just use it in an interactive shell or for very simple + -- transliterations of shell scripts. cd :: a instance (io ~ IO ()) => Cd io where @@ -830,28 +873,28 @@ -- -- >>> 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 :: (NFData a, Monoid a) => ByteString -> (ByteString -> 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 +-- | Simple @`Proc`@ that reads its input and can react to the output by +-- calling other @`Proc`@'s which can write something to its stdout. +-- The internal @`Proc`@ is given @/dev/null@ as its input. +readInputP :: (NFData a, PipeResult io) => (ByteString -> 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 :: (NFData a, PipeResult io) => ByteString -> ([ByteString] -> 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 :: (NFData a, PipeResult io) => ([ByteString] -> 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 :: (NFData a, PipeResult io) => ([ByteString] -> Proc a) -> io a readInputLinesP = readInputSplitP "\n" -- | Create a null file handle. diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,9 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} module Main where import System.Directory import Shh +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy.UTF8 (toString, fromString) +import qualified Data.ByteString.Lazy.Char8 as C8 import Test.DocTest import Test.Tasty import Test.Tasty.HUnit @@ -16,7 +21,7 @@ import System.IO load SearchPath - ["wc", "head", "tr", "echo", "cat", "true", "false", "mktemp", "sleep" + [ "wc", "head", "tr", "echo", "cat", "true", "false", "mktemp", "sleep" , "rm", "printf", "xargs", "find" ] @@ -33,9 +38,13 @@ tests :: TestTree tests = localOption (Timeout 4000000 "4s") $ testGroup "Tests" [unitTests, properties] -bytesToString :: [Word8] -> String -bytesToString = map (chr . fromIntegral) +bytesToString :: [Word8] -> ByteString +bytesToString = BS.pack +instance Arbitrary ByteString where + arbitrary = bytesToString <$> arbitrary + shrink = fmap BS.pack . shrink . BS.unpack + properties :: TestTree properties = testGroup "Properties" [ testProperty "trim = trim . trim" $ \l -> trim l == trim (trim l) @@ -51,9 +60,9 @@ 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 (map toUpper)" $ \s -> ioProperty $ do + k <- readProc $ s >>> pureProc (C8.map toUpper) + pure $ C8.map toUpper s === k , testProperty "pureProc . const === writeOutput" $ \s -> ioProperty $ do let s' = bytesToString s @@ -61,17 +70,23 @@ b <- pureProc (const s') |> capture pure $ a === b , testProperty "writeOutput s |> capture >>= writeOutput |> capture === s" - $ \(ASCIIString s) -> ioProperty $ do + $ \s -> ioProperty $ do r <- writeOutput s |> capture >>= writeOutput |> capture pure $ r === s , testProperty "pureProc id === readInputP (\\s -> writeOutput s)" - $ \(ASCIIString s) -> ioProperty $ do + $ \s -> ioProperty $ do a <- writeOutput s |> pureProc id |> capture b <- writeOutput s |> readInputP (\s -> writeOutput s) |> capture pure $ a === b + , testProperty "string round trip" $ \s -> ioProperty $ do + r <- writeOutput (s :: String) |> capture + pure $ s == toString r + , testProperty "bytestring round trip" $ \s -> ioProperty $ do + r <- writeOutput (s :: ByteString) |> capture + pure $ s == r ] -withTmp :: (FilePath -> IO a) -> IO a +withTmp :: (ByteString -> IO a) -> IO a withTmp = bracket (readTrim mktemp) rm unitTests :: TestTree @@ -102,7 +117,7 @@ r @?= "test\n" , testCase "Lazy read" $ replicateM_ 100 $ do withRead (cat "/dev/zero") $ \s -> do - take 6 s @?= "\0\0\0\0\0\0" + BS.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" @@ -135,7 +150,7 @@ Left r <- catchFailure $ readProc $ echo "test" |> true |> false "dummy" r @?= Shh.Failure "false" ["dummy"] 1 , testCase "Lazy read checks code" $ replicateM_ 30 $ do - Left r <- catchFailure $ withRead (cat "/dev/urandom" |> false "dummy") $ pure . take 3 + Left r <- catchFailure $ withRead (cat "/dev/urandom" |> false "dummy") $ pure . BS.take 3 r @?= Shh.Failure "false" ["dummy"] 1 , testCase "Identifier odd chars" $ encodeIdentifier "1@3.-" @?= "_1'40'3''_" , testCase "Identifier make lower" $ encodeIdentifier "T.est" @?= "_T''est" @@ -196,6 +211,12 @@ 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 + s <- readTrim $ cat "/dev/urandom" |> readInputP (\s -> writeOutput (C8.map toUpper s) |> cat) |> Main.head "-c" c |> wc "-c" + show c @?= toString s + , testCase "subshells" $ do + s <- readProc $ echo "ac" |> (cat >> echo "bc") |> tr "-d" "c" + s @?= "a\nb\n" + , testCase "unicode" $ do + s <- writeOutput "üか" |> cat |> capture + toString s @?= "üか" ]