diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for execpath + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Luke Clifton + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Luke Clifton nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,118 @@ +# 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 supports + + * Automatically defining a function for each executable on your `$PATH` + using template Haskell. + + * Redirction of stdout and stderr + + -- Redirect stdout + λ echo "Hello" &> StdErr + λ echo "Hello" &> Truncate ".tmp_file" + + -- Redirect stderr + λ echo "Hello" &!> Append "/dev/null" + λ echo "Hello" &!> StdOut + + + * Piping stdout or stderr to the input of a chained process + + λ cat "/dev/urandom" |> xxd |> head "-n" 5 + + * Multiple processes sequentially feeding a single process + + λ (echo 1 >> echo 2) |> cat + + * Use of Haskells concurrency primitives. + + λ race (sleep 1) $ curl "http://this_needs_to_timeout_after_1_second" + + λ d <- readTrim $ mktemp "-d" + λ :{ + | System.Directory.withCurrentDirectory d $ do + | mapConcurrently_ (curl "-LOJs") + | [ "https://raw.githubusercontent.com/luke-clifton/shh/master/shell.nix" + | , "https://raw.githubusercontent.com/luke-clifton/shh/master/shh.cabal" + | ] + | ls + | :} + + * Capturing of process output + + λ loggedIn <- nub . words <$> readProc users + λ putStrLn $ "Logged in users: " ++ show loggedIn + + λ mapM_ putStrLn =<< readSplit0 (Shh.Example.find "-maxdepth" 1 "-print0") + + * Capturing infinite output of a process lazily + + λ withRead (cat "/dev/urandom" |> xxd) $ mapM_ putStrLn . take 3 . lines + 00000000: 8fcb ebee 9228 a897 3bfc 1d05 491d aceb .....(..;...I... + 00000010: 47de 3ea3 2788 44ac 9b85 0a0f a458 b949 G.>.'.D......X.I + 00000020: 5308 ddfe 5790 5a5f 39e3 bbb6 b689 2b03 S...W.Z_9.....+. + + * Write strings to stdin of a process. + + λ writeProc cat "Hello\n" + Hello + + λ "Hello" >>> shasum + f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0 - + + λ shasum <<< "Hello" + f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0 - + + * Proper exceptions, when a process exits with a failure code, an exception + is thrown. You can catch these normally. The exception includes the error + code, the command, and all it's arguments. + + λ false "Ha, it died" + *** Exception: Command `false "Ha, it died"` failed [exit 1] + + λ catchCode false + 1 + +## Mnemonics + +Shh has many symbols that might seem intimidating at first, but there +is a simple mnemonic for them. + + | Piping. Looks like a pipe, same as in POSIX shells. + & Redirection, think of the shell `2>&1` + >,< The direction of flow of a command + ! Operate on stderr instead of stdout + +So, for example, + + ls |> cat Pipe the stdout of `ls` into stdin of `cat` + cat <| ls Same as above + ls &> StdErr Redirect stdout of `ls` to wherever stderr is going. + StdErr <& ls Same as above + ls &!> StdOut Redirect stderr of `ls` to wherever stdout is going. + StdOut > echo "Hello" >> sleep 2) |> cat diff --git a/shh.cabal b/shh.cabal new file mode 100644 --- /dev/null +++ b/shh.cabal @@ -0,0 +1,61 @@ +name: shh +version: 0.1.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 + perform many shell-like functions, such as piping + and redirection. +license: BSD3 +license-file: LICENSE +author: Luke Clifton +maintainer: lukec@themk.net +copyright: (c) 2018 Luke Clifton +category: System +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/luke-clifton/shh + +library + exposed-modules: Shh + , Shh.Example + , Shh.Internal + build-depends: base >=4.9 && <4.12 + , async + , deepseq + , directory + , filepath + , mtl + , process + , split + , template-haskell + , unix + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable shh-example + ghc-options: -threaded -with-rtsopts=-N + default-language: Haskell2010 + build-depends: + base >=4.9, + shh + hs-source-dirs: app + main-is: Example.hs + + +test-suite shh-tests + ghc-options: -threaded -with-rtsopts=-N + default-language: Haskell2010 + build-depends: + base >=4.9, + tasty, + tasty-quickcheck, + tasty-hunit, + shh + hs-source-dirs: test + main-is: Test.hs + type: exitcode-stdio-1.0 diff --git a/src/Shh.hs b/src/Shh.hs new file mode 100644 --- /dev/null +++ b/src/Shh.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} +-- | Shh provides a shell-like environment for Haskell. +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. + , exe + , mkProc + , runProc + , Proc() + -- | == Piping and Redirection + , PipeResult(..) + , (<|) + , Stream(..) + , devNull + -- | == Reading @stdout@ + , readProc + , withRead + , trim + , readTrim + , split0 + , readSplit0 + , readLines + , readAuto + -- | == Writing to @stdin@ + , writeProc + , (<<<), (>>>) + , readWriteProc + , mapP + -- | == Exceptions + -- If any exception is allowed to propagate out of a pipeline, all the + -- processes comprising the pipeline will be terminated. This is contrary + -- to how a shell normally works (even with @-o pipefail@!). + , Failure(..) + , ignoreFailure + , catchFailure + , catchCode + -- | == Constructing Arguments + , ExecArg(..) + -- | == Template Haskell helpers + , loadEnv + , loadAnnotatedEnv + , loadExe + , loadExeAs + ) where + +import Shh.Internal diff --git a/src/Shh/Example.hs b/src/Shh/Example.hs new file mode 100644 --- /dev/null +++ b/src/Shh/Example.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Shh.Example where + +import Shh + +$(loadAnnotatedEnv (\s -> s ++ "_")) diff --git a/src/Shh/Internal.hs b/src/Shh/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Shh/Internal.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} + +-- | See documentation for "Shh". +module Shh.Internal where + + +import Control.Concurrent.Async +import Control.DeepSeq (rnf) +import Control.Exception as C +import Control.Monad +import Control.Monad.IO.Class +import Data.Char (isLower, isSpace, isAlphaNum) +import Data.List (nub, dropWhileEnd, intercalate) +import Data.List.Split (endBy, splitOn) +import Data.Maybe (mapMaybe) +import Language.Haskell.TH +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.Environment (getEnv) +import System.Exit (ExitCode(..)) +import System.IO +import System.Posix.Signals +import System.Process + +-- | This function needs to be called in order to use the library succesfully +-- from GHCi. +initInteractive :: IO () +initInteractive = do + hSetBuffering stdin LineBuffering + +-- | When a process exits with a non-zero exit code +-- 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. +data Failure = Failure + { failureProg :: String + , failureArgs :: [String] + , failureCode :: Int + } deriving (Eq, Ord) + +instance Show Failure where + show f = concat $ + [ "Command `" + ] + ++ [intercalate " " (failureProg f : map show (failureArgs f))] + ++ + [ "` failed [exit " + , show (failureCode f) + , "]" + ] + +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`). +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. + -- + -- The result is polymorphic in it's output, and can result in either + -- another `Proc a` or an `IO a` depending on the context in which it is + -- used. + -- + -- >>> echo "Hello" |> wc + -- 1 1 6 + (|>) :: Proc a -> Proc a -> f a + + -- | Similar to `|!>` except that it connects stderr to stdin of the + -- next process in the chain. + -- + -- NB: The next command to be `|>` on will recapture the stdout of + -- 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 + + -- | Redirect stdout of this process to another location + -- + -- > ls &> Append "/dev/null" + (&>) :: Proc a -> Stream -> f a + + -- | Redirect stderr of this process to another location + -- + -- > ls &!> StdOut + (&!>) :: Proc a -> Stream -> f a + +-- | Flipped version of `|>` +(<|) :: PipeResult f => Proc a -> Proc a -> f a +(<|) = flip (|>) + +instance PipeResult IO where + a |> b = runProc $ a |> b + a |!> b = runProc $ a |!> b + a &> s = runProc $ a &> s + a &!> s = runProc $ a &!> s + +-- | Create a pipe, and close both ends on exception. +withPipe :: (Handle -> Handle -> IO a) -> IO a +withPipe k = + bracket + createPipe + (\(r,w) -> hClose r `finally` hClose w) + (\(r,w) -> k r w) + +instance PipeResult Proc where + (Proc a) |> (Proc b) = Proc $ \i o e pl pw -> + withPipe $ \r w -> do + a' <- async $ a i w e (pure ()) (hClose w) + b' <- async $ b r o e (pure ()) (hClose r) + link2 a' b' + (_, br) <- (pl >> waitBoth a' b') `finally` pw + pure br + + (Proc a) |!> (Proc b) = Proc $ \i o e pl pw -> do + withPipe $ \r w -> do + a' <- async $ a i o w (pure ()) (hClose w) + b' <- async $ b r o e (pure ()) (hClose r) + link2 a' b' + (_, br) <- (pl >> waitBoth a' b') `finally` pw + pure br + + 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 + (Proc f) &> (Append path) = Proc $ \i _ e pl pw -> + withBinaryFile 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 + (Proc f) &!> (Append path) = Proc $ \i o _ pl pw -> + withBinaryFile path AppendMode $ \h -> f i o h pl pw + + +-- | 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"@ +devNull :: Stream +devNull = Truncate "/dev/null" + +-- | Type representing a series or pipeline (or both) of shell commands. +newtype Proc a = Proc (Handle -> Handle -> Handle -> IO () -> IO () -> IO a) + deriving Functor + +instance MonadIO Proc where + liftIO a = Proc $ \_ _ _ pl pw -> do + (pl >> a) `finally` pw + +-- | The `Semigroup` instance for `Proc` pipes the stdout of one process +-- into the stdin of the next. However, consider using `|>` instead which +-- behaves when used in an `IO` context. If you use `<>` in an IO monad +-- you will be using the `IO` instance of semigroup which is a sequential +-- execution. `|>` prevents that error. +instance Semigroup (Proc a) where + (<>) = (|>) + +instance (a ~ ()) => Monoid (Proc a) where + mempty = Proc $ \_ _ _ pl pw -> pl `finally` pw + +instance Applicative Proc where + pure a = Proc $ \_ _ _ pw pl -> do + pw `finally` pl + pure a + + f <*> a = do + f' <- f + 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 ()) + let + Proc f' = f ar + f' i o e (pure ()) pw + +-- | Run's a `Proc` in `IO`. This is usually not required, as most +-- 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 ()) + +-- | Create a `Proc` from a command and a list of arguments. +mkProc :: String -> [String] -> Proc () +mkProc cmd args = Proc $ \i o e pl pw -> do + bracket + (createProcess_ cmd (proc cmd args) + { std_in = UseHandle i + , std_out = UseHandle o + , std_err = UseHandle e + , close_fds = True + } + ) + (\(_,_,_,ph) -> terminateProcess ph) + $ \(_,_,_,ph) -> do + pl + (waitProc cmd args ph `onException` terminateProcess ph) `finally` pw + + +-- | Read the stdout of a `Proc` in any `MonadIO` (including other `Proc`s). +-- This is strict, so the whole output is read into a `String`. See `withRead` +-- for a lazy version that can be used for streaming. +readProc :: MonadIO io => Proc a -> io String +readProc (Proc f) = liftIO $ do + (r,w) <- createPipe + (_,o) <- concurrently + (f stdin w stderr (pure ()) (hClose w)) + (do + output <- hGetContents r + C.evaluate $ rnf output + hClose r + pure output + ) + pure o + +-- | Run a process and capture it's output lazily. Once the continuation +-- is completed, the handles are closed, and the process is terminated. +withRead :: MonadIO io => Proc a -> (String -> IO b) -> io b +withRead (Proc f) k = liftIO $ + withPipe $ \r w -> do + withAsync (f stdin w stderr (pure ()) (hClose w)) $ \_ -> + (hGetContents r >>= k) `finally` hClose r + + +-- | Read and write to a `Proc`... +readWriteProc :: MonadIO io => Proc a -> String -> io String +readWriteProc (Proc f) input = liftIO $ do + (ri,wi) <- createPipe + (ro,wo) <- createPipe + (_,o) <- concurrently + (concurrently + (f ri wo stderr (pure ()) (hClose wo `finally` hClose ri)) + (hPutStr wi input `finally` hClose wi) + ) (do + output <- hGetContents ro + C.evaluate $ rnf output + hClose ro + pure output + ) + pure o + +-- | Some as `readWriteProc`. Map a `Proc` over a `String`. +-- +-- >>> mapP shasum "Hello" +-- "f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0 -\n" +mapP :: MonadIO io => Proc a -> String -> io String +mapP = readWriteProc + +-- | Provide the stdin of a `Proc` from a `String` +writeProc :: MonadIO io => Proc a -> String -> io a +writeProc (Proc f) input = liftIO $ do + (r,w) <- createPipe + fst <$> concurrently + (f r stdout stderr (pure ()) (hClose r)) + (hPutStr w input `finally` hClose w) + +-- | Flipped, infix version of `writeProc` +(>>>) :: MonadIO io => String -> Proc a -> io a +(>>>) = flip writeProc + + +-- | Infix version of `writeProc` +(<<<) :: MonadIO io => Proc a -> String -> io a +(<<<) = writeProc + +-- | What 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 () +waitProc cmd arg ph = waitForProcess ph >>= \case + ExitFailure c + | fromIntegral c == negate sigPIPE -> pure () + | otherwise -> throwIO $ Failure cmd arg c + ExitSuccess -> pure () + +-- | Trim leading and tailing whitespace. +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +-- | Allow us to catch `Failure` exceptions in `IO` and `Proc` +class ProcFailure m where + -- | Run a `Proc` action, catching an `Failure` exceptions + -- and returning them. + catchFailure :: Proc a -> m (Either Failure a) + +instance ProcFailure Proc where + catchFailure (Proc f) = Proc $ \i o e pl pw -> do + try $ f i o e pl pw + +instance ProcFailure IO where + catchFailure = runProc . catchFailure + +-- | 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) +-- *** Exception: Command `false` failed [exit 1] +-- +-- >>> (ignoreFailure false) `|>` (sleep 2 >> echo 1) +-- 1 +ignoreFailure :: (Functor m, ProcFailure m) => Proc a -> m () +ignoreFailure = void . catchFailure + +-- | Run an `Proc` action returning the return code if an +-- exception was thrown, and 0 if it wasn't. +catchCode :: (Functor m, ProcFailure m) => Proc a -> m Int +catchCode = fmap getCode . catchFailure + where + getCode (Right _) = 0 + getCode (Left f) = failureCode f + +-- | Like `readProc`, but trim leading and tailing whitespace. +readTrim :: MonadIO io => Proc a -> io String +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] + +instance ExecArg String where + asArg s = [s] + +-- TODO: Determine if `Char` flags should be prepended with a '-' or not. +-- instance ExecArg Char where +-- asArg c = [['-', c]] + +instance ExecArg Int +instance ExecArg Integer +instance ExecArg Word + +-- | A class for building up a command +class ExecArgs a where + toArgs :: [String] -> a + +instance ExecArgs (Proc ()) where + toArgs (cmd:args) = mkProc cmd args + toArgs _ = error "The impossible happened. How did you construct this?" + +instance (ExecArg b, ExecArgs a) => ExecArgs (b -> a) where + toArgs f i = toArgs $ f ++ asArg i + +-- | Commands can be executed directly in IO +instance ExecArgs (IO ()) where + toArgs = runProc . toArgs + +-- | Force a `()` result. +class Unit a +instance {-# OVERLAPPING #-} Unit b => Unit (a -> b) +instance {-# OVERLAPPABLE #-} a ~ () => Unit (m a) + +-- | Get all files in a directory on your `$PATH`. +-- +-- TODO: Check for executability. +pathBins :: IO [FilePath] +pathBins = do + pathsVar <- splitOn ":" <$> getEnv "PATH" + paths <- filterM doesDirectoryExist pathsVar + nub . concat <$> mapM getDirectoryContents paths + +-- | Execute the given command. Further arguments can be passed in. +-- +-- > exe "ls" "-l" +-- +-- See also `loadExe` and `loadEnv`. +exe :: (Unit a, ExecArgs a) => String -> a +exe s = toArgs [s] + +-- | Create a function for the executable named +loadExe :: String -> Q [Dec] +loadExe s = loadExeAs s s + +-- | @$(loadExeAs fnName executable)@ defines a function called @fnName@ +-- which executes the path in @executable@. +loadExeAs :: String -> String -> Q [Dec] +loadExeAs fnName executable = + -- TODO: Can we place haddock markup in TH generated functions. + -- TODO: Can we palce the man page for each function in there xD + -- https://ghc.haskell.org/trac/ghc/ticket/5467 + let + name = mkName $ fnName + impl = valD (varP name) (normalB [| + exe executable + |]) [] + typn = mkName "a" + typ = SigD name (ForallT [PlainTV typn] [AppT (ConT ''Unit) (VarT typn), AppT (ConT ''ExecArgs) (VarT typn)] (VarT typn)) + in do + i <- impl + return $ [typ,i] + +-- | Checks if a String is a valid Haskell identifier. +validIdentifier :: String -> Bool +validIdentifier "" = False +validIdentifier ident = isValidInit (head ident) && all isValidC ident && isNotIdent + where + isValidInit c = isLower c || c `elem` "_" + isValidC c = isAlphaNum c || c `elem` "_'" + isNotIdent = not $ ident `elem` + [ "import", "if", "else", "then", "do", "in", "let", "type" + , "as", "case", "of", "class", "data", "default", "deriving" + , "instance", "forall", "foreign", "hiding", "infix", "infixl" + , "infixr", "mdo", "module", "newtype", "proc", "qualified" + , "rec", "type", "where"] + +-- | Scans your '$PATH' environment variable and creates a function for each +-- executable found. Binaries that would not create valid Haskell identifiers +-- are ignored. +loadEnv :: Q [Dec] +loadEnv = loadAnnotatedEnv id + +-- | Like `loadEnv`, but allows you to modify the function name that would +-- be generated. +loadAnnotatedEnv :: (String -> String) -> Q [Dec] +loadAnnotatedEnv f = do + bins <- runIO pathBins + let pairs = mapMaybe getAnnotation bins + fmap join $ mapM (uncurry loadExeAs) pairs + + where + getAnnotation :: String -> Maybe (String,String) + getAnnotation s + | validIdentifier (f s) = Just (f s, s) + | otherwise = Nothing + +-- | Function that splits '\0' seperated list of strings. +split0 :: String -> [String] +split0 = endBy "\0" + +-- | A convinience function for reading in a @"\\NUL"@ seperated list of +-- strings. This is commonly used when dealing with paths. +-- +-- > readSplit0 $ find "-print0" +readSplit0 :: Proc () -> IO [String] +readSplit0 p = split0 <$> readProc p + +-- | A convinience function for reading the output lines of a `Proc`. +readLines :: Proc () -> IO [String] +readLines p = lines <$> readProc p + +-- | Like `readProc`, but attempts to `Prelude.read` the result. +readAuto :: Read a => Proc () -> IO a +readAuto p = read <$> readProc p diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExtendedDefaultRules #-} +module Main where + +import Shh +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +$(loadEnv) + +main = do + putStrLn "################################################" + putStrLn " These tests require that certain binaries" + putStrLn " exist on your $PATH. If you are getting" + putStrLn " failures, please check that it's not because" + putStrLn " they are missing." + putStrLn "################################################" + defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [unitTests, properties] + +properties :: TestTree +properties = testGroup "Properties" + [ testProperty "trim = trim . trim" $ \l -> trim l == trim (trim l) + ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "Read stdout" $ do + l <- readProc $ echo "test" + l @?= "test\n" + , testCase "Redirect to /dev/null" $ do + l <- readProc $ echo "test" &> devNull + l @?= "" + , testCase "Redirect to file (Truncate)" $ do + t <- trim <$> readProc mktemp + echo "test" &> Truncate t + r <- readProc $ cat t + rm t + "test\n" @?= r + , testCase "Redirect to file (Append)" $ do + t <- readTrim mktemp + echo "test" &> Truncate t + echo "test" &> Append t + r <- readProc $ cat t + rm t + "test\ntest\n" @?= r + , testCase "Long pipe" $ do + r <- readProc $ echo "test" |> shasum |> shasum |> shasum + r @?= "3f18e7bc4021e72e52fc1395ece85d82f912a74a -\n" + , testCase "Pipe stderr" $ do + r <- readProc $ echo "test" &> StdErr |!> cat + r @?= "test\n" + , testCase "Lazy read" $ do + withRead (cat "/dev/urandom" |> xxd) $ \s -> do + take 10 s @?= "00000000: " + , testCase "Multiple outputs" $ do + l <- readProc $ (echo (1 :: Int) >> echo (2 :: Int)) |> cat + l @?= "1\n2\n" + , testCase "Terminate upstream processes" $ do + Left x <- catchFailure (mkProc "false" ["dummy"] |> (sleep 1 >> false "Didn't kill")) + x @?= Shh.Failure "false" ["dummy"] 1 + , testCase "Write to process" $ do + t <- readTrim mktemp + writeProc (cat &> Truncate t) "Hello" + r <- readProc (cat t) + r @?= "Hello" + writeProc (cat &> Truncate t) "Goodbye" + r <- readProc (cat t) + r @?= "Goodbye" + , testCase "mapP" $ do + r <- mapP shasum "test" + r @?= "a94a8fe5ccb19ba61c4c0873d391e987982fbbd3 -\n" + , testCase "ignoreFailure" $ do + r <- readProc $ ignoreFailure false |> echo "Hello" + r @?= "Hello\n" + ]