packages feed

shh (empty) → 0.1.0.0

raw patch · 10 files changed

+832/−0 lines, 10 filesdep +asyncdep +basedep +deepseqsetup-changed

Dependencies added: async, base, deepseq, directory, filepath, mtl, process, shh, split, tasty, tasty-hunit, tasty-quickcheck, template-haskell, unix

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for execpath++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <!& ls  Same as above++## Usage++Enable Temlpate Haskell and load the environment++    {-# LANGUAGE TemplateHaskell #-}+    $(loadEnv)++You now have all your executables available as simple to read+Haskell functions.++### Usage in GHCi++If you want `^D` to be recognised as a EOF marker (when running commands+that read from stdin) when running in GHCi, you will need to run the+`initInteractive` function. This sets the line buffering appropriately and+ensures the terminal is in canonical mode.++### Script Usage++TODO: Fill this in once on Hackage.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Example.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExtendedDefaultRules #-}++module Main where++import Control.Monad+import Shh+import Data.Monoid+import Data.Char+import Data.List++$(loadEnv)++main :: IO ()+main = (sleep 1 >> echo "Hello" >> sleep 2) |> cat
+ shh.cabal view
@@ -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
+ src/Shh.hs view
@@ -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
+ src/Shh/Example.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}++module Shh.Example where++import Shh++$(loadAnnotatedEnv (\s -> s ++ "_"))
+ src/Shh/Internal.hs view
@@ -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
+ test/Test.hs view
@@ -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"+    ]