├── .ghci ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── TODO.org ├── examples ├── Clone.hs ├── Failure.hs ├── Piping.hs ├── Sequence.hs └── Streaming.hs ├── shell-conduit.cabal ├── src └── Data │ └── Conduit │ ├── Shell.hs │ └── Shell │ ├── PATH.hs │ ├── Process.hs │ ├── Segments.hs │ ├── TH.hs │ ├── Types.hs │ └── Variadic.hs ├── stack.yaml └── test └── Spec.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *~ 4 | dist/ 5 | cabal-dev/ 6 | .hsenv 7 | TAGS 8 | tags 9 | *.tag 10 | .stack-work 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | 14 | matrix: 15 | include: 16 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 17 | compiler: ": #GHC 8.0.2" 18 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 19 | - env: BUILD=cabal GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 20 | compiler: ": #GHC 8.2.1" 21 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 22 | - env: BUILD=cabal GHCVER=8.4.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 23 | compiler: ": #GHC 8.4.1" 24 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 25 | 26 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 27 | compiler: ": #GHC HEAD" 28 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 29 | 30 | - env: BUILD=stack ARGS="--resolver nightly" 31 | compiler: ": #stack nightly" 32 | addons: {apt: {packages: [libgmp-dev]}} 33 | 34 | # Build on OS X in addition to Linux 35 | - env: BUILD=stack ARGS="" 36 | compiler: ": #stack default osx" 37 | os: osx 38 | 39 | - env: BUILD=stack ARGS="--resolver nightly" 40 | compiler: ": #stack nightly osx" 41 | os: osx 42 | 43 | allow_failures: 44 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 45 | - env: BUILD=stack ARGS="--resolver nightly" 46 | # uncomment this after stack version > 1.6.5 is released 47 | - env: BUILD=stack ARGS="" 48 | 49 | before_install: 50 | # Using compiler above sets CC to an invalid value, so unset it 51 | - unset CC 52 | 53 | # We want to always allow newer versions of packages when building on GHC HEAD 54 | - CABALARGS="" 55 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 56 | 57 | # Download and unpack the stack executable 58 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 59 | - mkdir -p ~/.local/bin 60 | - | 61 | if [ `uname` = "Darwin" ] 62 | then 63 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 64 | else 65 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 66 | fi 67 | # Use the more reliable S3 mirror of Hackage 68 | mkdir -p $HOME/.cabal 69 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 70 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 71 | if [ "$CABALVER" != "1.16" ] 72 | then 73 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 74 | fi 75 | install: 76 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 77 | - if [ -f configure.ac ]; then autoreconf -i; fi 78 | - | 79 | set -ex 80 | case "$BUILD" in 81 | stack) 82 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 83 | ;; 84 | cabal) 85 | cabal --version 86 | travis_retry cabal update 87 | # Get the list of packages from the stack.yaml file 88 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 89 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 90 | ;; 91 | esac 92 | set +ex 93 | script: 94 | - | 95 | set -ex 96 | case "$BUILD" in 97 | stack) 98 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 99 | ;; 100 | cabal) 101 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 102 | ORIGDIR=$(pwd) 103 | for dir in $PACKAGES 104 | do 105 | cd $dir 106 | cabal sdist 107 | PKGVER=$(cabal info . | awk '{print $2;exit}') 108 | SRC_TGZ=$PKGVER.tar.gz 109 | cd dist 110 | tar zxfv "$SRC_TGZ" 111 | cd "$PKGVER" 112 | cabal configure --enable-tests 113 | cabal build 114 | cd $ORIGDIR 115 | done 116 | ;; 117 | esac 118 | set +ex 119 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 5.0.0 2 | 3 | * Generalize from IO to MonadUnliftIO m => m. See [PR 17](https://github.com/psibi/shell-conduit/pull/17) 4 | * More detter exclusion of disallowed names. 5 | 6 | # 4.7.0 7 | 8 | * Port it for newer conduit and resourcet 9 | 10 | # 4.6.2 11 | 12 | * Add test for piping feature 13 | 14 | # 4.6.1 15 | 16 | * Fix import error in Stackage: https://github.com/fpco/stackage/issues/2355 17 | 18 | # 4.6.0 19 | 20 | * Add basic tests code 21 | * Accept list as variadic command line arguments. 22 | `mkdir "-p" ["folder1", "folder2"]` works now. 23 | * TRAVIS CI added 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, shell-conduit 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of shell-conduit nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | shell-conduit [![Hackage](https://img.shields.io/hackage/v/shell-conduit.svg?style=flat)](https://hackage.haskell.org/package/shell-conduit) [![Build Status](https://travis-ci.org/psibi/shell-conduit.svg?branch=master)](https://travis-ci.org/psibi/shell-conduit) 2 | ===== 3 | 4 | Write shell scripts with Conduit. Still in the experimental phase. 5 | 6 | [Haddock API documentation](https://www.stackage.org/package/shell-conduit). 7 | 8 | ### Examples 9 | 10 | ##### Cloning and initializing a repo 11 | 12 | ``` haskell 13 | import Control.Monad.IO.Class 14 | import Data.Conduit.Shell 15 | import System.Directory 16 | 17 | main = 18 | run (do exists <- liftIO (doesDirectoryExist "fpco") 19 | if exists 20 | then rm "fpco/.hsenvs" "-rf" 21 | else git "clone" "git@github.com:fpco/fpco.git" 22 | liftIO (setCurrentDirectory "fpco") 23 | shell "./dev-scripts/update-repo.sh" 24 | shell "./dev-scripts/build-all.sh" 25 | alertDone) 26 | ``` 27 | 28 | ##### Piping 29 | 30 | Piping of processes and normal conduits is possible: 31 | 32 | ``` haskell 33 | λ> run (ls $| grep ".*" $| shell "cat" $| conduit (CL.map (S8.map toUpper))) 34 | DIST 35 | EXAMPLES 36 | LICENSE 37 | README.MD 38 | SETUP.HS 39 | SHELL-CONDUIT.CABAL 40 | SRC 41 | TAGS 42 | TODO.ORG 43 | ``` 44 | 45 | ##### Running actions in sequence and piping 46 | 47 | Results are outputted to stdout unless piped into other processes: 48 | 49 | ``` haskell 50 | λ> run (do shell "echo sup"; shell "echo hi") 51 | sup 52 | hi 53 | λ> run (do shell "echo sup" $| sed "s/u/a/"; shell "echo hi") 54 | sap 55 | hi 56 | ``` 57 | 58 | ##### Streaming 59 | 60 | Live streaming between pipes like in normal shell scripting is 61 | possible: 62 | 63 | ``` haskell 64 | λ> run (do tail' "/tmp/example.txt" "-f" $| grep "--line-buffered" "Hello") 65 | Hello, world! 66 | Oh, hello! 67 | ``` 68 | 69 | (Remember that `grep` needs `--line-buffered` if it is to output things 70 | line-by-line). 71 | 72 | ##### Handling exit failures 73 | 74 | Process errors can be ignored by using the Alternative instance. 75 | 76 | ``` haskell 77 | import Control.Applicative 78 | import Control.Monad.Fix 79 | import Data.Conduit.Shell 80 | 81 | main = 82 | run (do ls 83 | echo "Restarting server ... ?" 84 | killall name "-q" <|> return () 85 | fix (\loop -> 86 | do echo "Waiting for it to terminate ..." 87 | sleep "1" 88 | (ps "-C" name >> loop) <|> return ()) 89 | shell "dist/build/ircbrowse/ircbrowse ircbrowse.conf") 90 | where name = "ircbrowse" 91 | ``` 92 | 93 | ##### Running custom things 94 | 95 | You can run processes directly: 96 | 97 | ``` haskell 98 | λ> run (proc "ls" []) 99 | dist LICENSE Setup.hs src TODO.org 100 | examples README.md shell-conduit.cabal TAGS 101 | ``` 102 | 103 | Or shell commands: 104 | 105 | ``` haskell 106 | λ> run (shell "ls") 107 | dist LICENSE Setup.hs src TODO.org 108 | examples README.md shell-conduit.cabal TAGS 109 | ``` 110 | 111 | Or conduits: 112 | 113 | ``` haskell 114 | λ> run (cat $| conduit (awaitForever yield)) 115 | hello 116 | hello 117 | Interrupted. 118 | ``` 119 | 120 | ##### Keyboard configuration 121 | 122 | ``` haskell 123 | import Data.Conduit.Shell 124 | main = 125 | run (do xmodmap ".xmodmap" 126 | xset "r" "rate" "150" "50") 127 | ``` 128 | 129 | ### How it works 130 | 131 | All executable names in the `PATH` at compile-time are brought into 132 | scope as runnable process conduits e.g. `ls` or `grep`. 133 | 134 | All processes are bound as variadic process calling functions, like this: 135 | 136 | ``` haskell 137 | rmdir :: ProcessType r => r 138 | ls :: ProcessType r => r 139 | ``` 140 | 141 | But ultimately the types end up being: 142 | 143 | ``` haskell 144 | rmdir "foo" :: Segment r 145 | ls :: Segment r 146 | ls "." :: Segment r 147 | ``` 148 | 149 | Etc. 150 | 151 | Run all shell scripts with 152 | 153 | ``` haskell 154 | run :: Segment r -> IO r 155 | ``` 156 | 157 | The `Segment` type has a handy `Alternative` instance. 158 | 159 | ### String types 160 | 161 | If using `OverloadedStrings` so that you can use `Text` for arguments, 162 | then also enable `ExtendedDefaultRules`, otherwise you'll get 163 | ambiguous type errors. 164 | 165 | ``` haskell 166 | {-# LANGUAGE ExtendedDefaultRules #-} 167 | ``` 168 | 169 | But this isn't necessary if you don't need to use `Text` yet. Strings 170 | literals will be interpreted as `String`. Though you can pass a value 171 | of type `Text` or any instance of `CmdArg` without needing conversions. 172 | 173 | ### Other modules 174 | 175 | You might want to import the regular Conduit modules qualified, too: 176 | 177 | ``` haskell 178 | import qualified Data.Conduit.List as CL 179 | ``` 180 | 181 | Which contains handy functions for working on streams in a 182 | list-like way. See the rest of the handy modules for Conduit in 183 | [conduit-extra](http://hackage.haskell.org/package/conduit-extra). 184 | 185 | Also of interest is 186 | [csv-conduit](http://hackage.haskell.org/package/csv-conduit), 187 | [html-conduit](http://hackage.haskell.org/package/html-conduit), and 188 | [http-conduit](http://hackage.haskell.org/package/http-conduit). 189 | 190 | Finally, see the Conduit category on Hackage for other useful 191 | libraries: 192 | 193 | All of these general purpose Conduits can be used in shell 194 | scripting. 195 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | * TODO Add explicit echo'ing of commands being run 2 | A la set +x in Bash. 3 | * BLOCKED Error handling. How to catch exceptions in Conduit? 4 | 5 | E.g. the following does not work: 6 | 7 | #+BEGIN_SRC haskell 8 | fix (\loop -> 9 | do e <- tryC (CL.sourceList [] $= ps ["-C","ircbrowse"] $$ discardChunks) 10 | case e of 11 | Left ExitFailure{} -> loop 12 | Right{} -> void (echo ["Waiting..."]) 13 | _ -> return ()) 14 | #+END_SRC 15 | 16 | It yields: 17 | 18 | #+BEGIN_SRC haskell 19 | λ> main 20 | *** Exception: ExitFailure 1 21 | #+END_SRC 22 | -------------------------------------------------------------------------------- /examples/Clone.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.IO.Class 2 | import Data.Conduit.Shell 3 | import System.Directory 4 | 5 | main = 6 | run (do exists <- liftIO (doesDirectoryExist "fpco") 7 | if exists 8 | then rm "fpco/.hsenvs" "-rf" 9 | else git "clone" "git@github.com:fpco/fpco.git" 10 | liftIO (setCurrentDirectory "fpco") 11 | shell "./dev-scripts/update-repo.sh" 12 | shell "./dev-scripts/build-all.sh" 13 | alertDone) 14 | -------------------------------------------------------------------------------- /examples/Failure.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Control.Monad.Fix 3 | import Data.Conduit.Binary 4 | import Data.Conduit.Shell 5 | 6 | main = 7 | run (do ls 8 | echo "Restarting server ... ?" 9 | killall name "-q" <|> return () 10 | fix (\loop -> 11 | do echo "Waiting for it to terminate ..." 12 | sleep "1" 13 | (ps "-C" name >> loop) <|> return ()) 14 | shell "dist/build/ircbrowse/ircbrowse ircbrowse.conf") 15 | where name = "ircbrowse" 16 | -------------------------------------------------------------------------------- /examples/Piping.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.ByteString.Char8 as S8 2 | import Data.Char 3 | import Data.Conduit 4 | import qualified Data.Conduit.List as CL 5 | import Data.Conduit.Shell 6 | 7 | main = run (ls $| grep "Key" $| shell "cat" $| conduit (CL.map (S8.map toUpper))) 8 | -------------------------------------------------------------------------------- /examples/Sequence.hs: -------------------------------------------------------------------------------- 1 | import Data.Conduit.Shell 2 | 3 | main = do run (do shell "echo sup"; shell "echo hi") 4 | run (do shell "echo sup" $| sed "s/u/a/"; shell "echo hi") 5 | -------------------------------------------------------------------------------- /examples/Streaming.hs: -------------------------------------------------------------------------------- 1 | import Data.Conduit.Shell 2 | 3 | main = run (do tail' "/tmp/example.txt" "-f" $| grep "--line-buffered" "Hello") 4 | -------------------------------------------------------------------------------- /shell-conduit.cabal: -------------------------------------------------------------------------------- 1 | name: shell-conduit 2 | version: 5.0.0 3 | synopsis: Write shell scripts with Conduit 4 | description: Write shell scripts with Conduit. See "Data.Conduit.Shell" for documentation. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Chris Done 8 | maintainer: Sibi Prabakaran 9 | copyright: 2014-2017 Chris Done 10 | category: Conduit, Scripting 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | homepage: https://github.com/psibi/shell-conduit 14 | extra-source-files: CHANGELOG.md README.md 15 | bug-reports: https://github.com/psibi/shell-conduit/issues 16 | 17 | library 18 | hs-source-dirs: src/ 19 | ghc-options: -Wall -O2 20 | exposed-modules: Data.Conduit.Shell 21 | Data.Conduit.Shell.PATH 22 | Data.Conduit.Shell.TH 23 | Data.Conduit.Shell.Process 24 | Data.Conduit.Shell.Types 25 | Data.Conduit.Shell.Segments 26 | Data.Conduit.Shell.Variadic 27 | build-depends: async >= 2.0.1.5 28 | , base >= 4 && <5 29 | , bytestring 30 | , conduit >= 1.3 31 | , conduit-extra 32 | , directory 33 | , filepath 34 | , monads-tf 35 | , process >= 1.2.1.0 36 | , resourcet >= 1.2.0 37 | , unliftio 38 | , semigroups 39 | , split 40 | , template-haskell 41 | , text 42 | , transformers 43 | , unix >= 2.7.0.1 44 | default-language: Haskell2010 45 | 46 | test-suite test 47 | type: exitcode-stdio-1.0 48 | ghc-options: -Wall -threaded 49 | hs-source-dirs: test/ 50 | main-is: Spec.hs 51 | 52 | build-depends: base >= 4.5 && < 5, 53 | shell-conduit, 54 | hspec >= 2.1 && < 3, 55 | hspec-expectations, 56 | template-haskell, 57 | conduit, 58 | bytestring, 59 | conduit-extra 60 | default-language: Haskell2010 61 | 62 | source-repository head 63 | type: git 64 | location: http://github.com/psibi/shell-conduit 65 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | -- | Shell scripting with Conduit 4 | -- 5 | -- This module consists only of re-exports, including a few thousand 6 | -- top-level names based on @PATH@. If you don't want that, you can 7 | -- cherry-pick specific modules to import from the library. 8 | -- 9 | -- See "Data.Conduit.Shell.PATH" for all binaries. But you should be 10 | -- able to use whatever executables are in your @PATH@ when the library 11 | -- is compiled. 12 | -- 13 | -- == Examples 14 | -- 15 | -- The monad instance of Conduit will simply pass along all stdout 16 | -- results: 17 | -- 18 | -- Piping with Conduit's normal pipe will predictably pipe things 19 | -- together, as in Bash: 20 | -- 21 | -- >>> run (do shell "echo Hello" $| sed "s/l/a/"; echo "OK!") 22 | -- Healo 23 | -- OK! 24 | -- 25 | -- Streaming pipes (aka lazy pipes) is also possible: 26 | -- 27 | -- >>> run (tail' "/tmp/foo.txt" "-f" $| grep "--line-buffered" "Hello") 28 | -- Hello, world! 29 | -- Oh, hello! 30 | -- 31 | -- (Remember that @grep@ needs @--line-buffered@ if it is to output 32 | -- things line-by-line). 33 | -- 34 | -- Run custom processes via the @proc@ function: 35 | -- 36 | -- >>> run (proc "ls" []) 37 | -- dist LICENSE README.md Setup.hs shell-conduit.cabal src TAGS TODO.org 38 | -- 39 | -- Run shell commands via the @shell@ function: 40 | -- 41 | -- >>> run (shell "ls") 42 | -- dist LICENSE README.md Setup.hs shell-conduit.cabal src TAGS TODO.org 43 | -- 44 | -- Run conduits via the @conduit@ function: 45 | -- 46 | -- >>> run (cat "/tmp/foo.txt" $| conduit (do Just x <- await; yield x)) 47 | -- Hello! 48 | -- 49 | -- == How it works 50 | -- 51 | -- All executable names in the @PATH@ at compile-time are brought into 52 | -- scope as runnable process conduits e.g. @ls@ or @grep@. 53 | -- 54 | -- 55 | -- All processes are bound as variadic process calling functions, like this: 56 | -- 57 | -- @ 58 | -- rmdir :: ProcessType r => r 59 | -- ls :: ProcessType r => r 60 | -- @ 61 | -- 62 | -- But ultimately the types end up being: 63 | -- 64 | -- @ 65 | -- rmdir "foo" :: Segment () 66 | -- ls :: Segment () 67 | -- ls "." :: Segment () 68 | -- @ 69 | -- 70 | -- Etc. 71 | -- 72 | -- Run all shell scripts with 'run': 73 | -- 74 | -- @ 75 | -- run :: Segment r -> IO r 76 | -- @ 77 | -- 78 | -- == String types 79 | -- 80 | -- If using @OverloadedStrings@ so that you can use 'Text' for arguments, 81 | -- then also enable @ExtendedDefaultRules@, otherwise you'll get 82 | -- ambiguous type errors. 83 | -- 84 | -- @ 85 | -- {-# LANGUAGE ExtendedDefaultRules #-} 86 | -- @ 87 | -- 88 | -- But this isn't necessary if you don't need to use 'Text' yet. Strings 89 | -- literals will be interpreted as 'String'. Though you can pass a value 90 | -- of type 'Text' or any instance of 'CmdArg' without needing conversions. 91 | -- 92 | 93 | module Data.Conduit.Shell 94 | (-- * Running scripts 95 | run 96 | -- * Making segments 97 | ,shell 98 | ,proc 99 | ,conduit 100 | ,text 101 | ,bytes 102 | -- * Composition of segments 103 | ,($|) 104 | ,Segment 105 | ,ProcessException(..) 106 | -- * Re-exports 107 | -- $exports 108 | ,module Data.Conduit.Shell.PATH 109 | ,module Data.Conduit.Shell.Types 110 | ,module Data.Conduit.Shell.Variadic 111 | ,module Data.Conduit) 112 | where 113 | 114 | import Data.Conduit 115 | import Data.Conduit.Shell.PATH hiding (strings) 116 | import Data.Conduit.Shell.Process 117 | import Data.Conduit.Shell.Types 118 | import Data.Conduit.Shell.Variadic 119 | 120 | -- $exports 121 | -- 122 | -- The following modules are exported for scripting 123 | -- convenience. "Data.Conduit" and "Data.Conduit.Filesystem" are 124 | -- re-exported from other libraries because they are typical uses. If 125 | -- you want a stream of the contents of a directory, recursively, 126 | -- 'sourceDirectoryDeep' is handy. A program like @find@ is strict, 127 | -- whereas a Conduit can stop processing whenever you wish. 128 | -- 129 | -- You might want to import the regular Conduit modules qualified, too: 130 | -- 131 | -- @ 132 | -- import qualified Data.Conduit.List as CL 133 | -- @ 134 | -- 135 | -- Which contains handy functions for working on streams in a 136 | -- list-like way. See the rest of the handy modules for Conduit in 137 | -- conduit-extra: 138 | -- 139 | -- Also of interest is csv-conduit: 140 | -- And html-conduit: 141 | -- And http-conduit: 142 | -- 143 | -- Finally, see the Conduit category on Hackage for other useful libraries: 144 | -- 145 | -- All of these general purpose Conduits can be used in shell 146 | -- scripting. 147 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/PATH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# OPTIONS_GHC 5 | -fno-warn-missing-signatures -fno-warn-unused-imports #-} 6 | 7 | -- | All binaries in PATH. 8 | module Data.Conduit.Shell.PATH where 9 | 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import Data.Conduit.Shell.Process 13 | import Data.Conduit.Shell.TH 14 | import Data.Conduit.Shell.Variadic 15 | import Data.List 16 | import qualified Data.Text as T (unpack) 17 | import Prelude 18 | import System.Directory 19 | 20 | -- | Helpful CD command. 21 | cd 22 | :: (MonadIO m, CmdArg arg) 23 | => arg -> m () 24 | cd fp = 25 | case (toTextArg fp) of 26 | [] -> return () 27 | (path:_) -> liftIO $ setCurrentDirectory (T.unpack path) 28 | 29 | $(generateBinaries) 30 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | -- | Reading from the process. 9 | 10 | module Data.Conduit.Shell.Process 11 | (-- * Running scripts 12 | run 13 | -- * Conduit types 14 | ,text 15 | ,bytes 16 | -- * General conduits 17 | ,conduit 18 | ,conduitEither 19 | -- * Running processes 20 | ,Data.Conduit.Shell.Process.shell 21 | ,Data.Conduit.Shell.Process.proc 22 | ,($|) 23 | ,Segment 24 | ,ProcessException(..) 25 | ,ToChunk(..) 26 | ,tryS 27 | ) 28 | where 29 | 30 | import Control.Applicative 31 | import Control.Concurrent.Async 32 | import Control.Exception 33 | import Control.Monad 34 | import Control.Monad.IO.Class 35 | import Data.ByteString (ByteString) 36 | import qualified Data.ByteString as S 37 | import Data.Conduit 38 | import Data.Conduit.Binary 39 | import qualified Data.Conduit.List as CL 40 | import Conduit (MonadThrow) 41 | import Data.Conduit.Text (encodeUtf8, decodeUtf8) 42 | import Data.Text (Text) 43 | import Data.Typeable 44 | import System.Exit 45 | import System.IO 46 | import System.Posix.IO (createPipe, fdToHandle) 47 | import System.Process hiding (createPipe) 48 | import UnliftIO (MonadUnliftIO, unliftIO, askUnliftIO) 49 | 50 | -- | A pipeable segment. Either a conduit or a process. 51 | data Segment m r 52 | = SegmentConduit (ConduitM ByteString (Either ByteString ByteString) m r) 53 | | SegmentProcess (Handles -> m r) 54 | 55 | instance MonadIO m => Monad (Segment m) where 56 | return = SegmentConduit . return 57 | SegmentConduit c >>= f = 58 | SegmentProcess (conduitToProcess c) >>= 59 | f 60 | SegmentProcess f >>= g = 61 | SegmentProcess 62 | (\handles -> 63 | do x <- f handles 64 | case g x of 65 | SegmentConduit c -> 66 | conduitToProcess c handles 67 | SegmentProcess p -> p handles) 68 | 69 | instance MonadIO m => Functor (Segment m) where 70 | fmap = liftM 71 | 72 | instance MonadIO m => Applicative (Segment m) where 73 | (<*>) = ap; pure = return 74 | 75 | instance MonadUnliftIO m => Alternative (Segment m) where 76 | this <|> that = 77 | do ex <- tryS this 78 | case ex of 79 | Right x -> pure x 80 | Left (_ :: ProcessException) -> that 81 | empty = throw ProcessEmpty 82 | 83 | -- | Try something in a segment. 84 | tryS :: (Exception e, MonadUnliftIO m) => Segment m r -> Segment m (Either e r) 85 | tryS s = 86 | case s of 87 | SegmentConduit c -> SegmentConduit (tryC c) 88 | SegmentProcess f -> SegmentProcess $ (\h -> do 89 | u <- askUnliftIO 90 | liftIO $ try $ unliftIO u (f h)) 91 | 92 | instance MonadIO m => MonadIO (Segment m) where 93 | liftIO x = SegmentProcess (const $ liftIO x) 94 | 95 | -- | Process handles: @stdin@, @stdout@, @stderr@ 96 | data Handles = 97 | Handles Handle 98 | Handle 99 | Handle 100 | 101 | -- | Process running exception. 102 | data ProcessException 103 | = ProcessException CreateProcess 104 | ExitCode 105 | | ProcessEmpty 106 | deriving (Typeable) 107 | 108 | instance Exception ProcessException 109 | 110 | instance Show ProcessException where 111 | show ProcessEmpty = "empty process" 112 | show (ProcessException cp ec) = 113 | concat 114 | [ "The " 115 | , case cmdspec cp of 116 | ShellCommand s -> "shell command " ++ show s 117 | RawCommand f args -> "raw command: " ++ unwords (f : map show args) 118 | , " returned a failure exit code: " 119 | , case ec of 120 | ExitFailure i -> show i 121 | _ -> show ec 122 | ] 123 | 124 | -- | Convert a process or a conduit to a segment. 125 | class ToSegment m a where 126 | type SegmentResult m a 127 | toSegment :: a -> Segment m (SegmentResult m a) 128 | 129 | instance ToSegment m (Segment m r) where 130 | type SegmentResult m (Segment m r) = r 131 | toSegment = id 132 | 133 | instance (a ~ ByteString, ToChunk b, Monad m) => 134 | ToSegment m (ConduitT a b m r) where 135 | type SegmentResult m (ConduitT a b m r) = r 136 | toSegment f = SegmentConduit (f `fuseUpstream` CL.map toChunk) 137 | 138 | instance MonadIO m => ToSegment m CreateProcess where 139 | type SegmentResult m CreateProcess = () 140 | toSegment = liftProcess 141 | 142 | -- | Used to allow outputting stdout or stderr. 143 | class ToChunk a where 144 | toChunk :: a -> Either ByteString ByteString 145 | 146 | instance ToChunk ByteString where 147 | toChunk = Left 148 | 149 | instance ToChunk (Either ByteString ByteString) where 150 | toChunk = id 151 | 152 | -- | Run a shell command. 153 | shell :: MonadIO m => String -> Segment m () 154 | shell = liftProcess . System.Process.shell 155 | 156 | -- | Run a process command. 157 | proc :: MonadIO m => String -> [String] -> Segment m () 158 | proc name args = liftProcess (System.Process.proc name args) 159 | 160 | -- | Run a segment. 161 | run :: MonadIO m => Segment m r -> m r 162 | run (SegmentConduit c) = run (SegmentProcess (conduitToProcess c)) 163 | run (SegmentProcess p) = p (Handles stdin stdout stderr) 164 | 165 | -- | Fuse two segments (either processes or conduits). 166 | ($|) :: MonadUnliftIO m => Segment m () -> Segment m b -> Segment m b 167 | x $| y = x `fuseSegment` y 168 | 169 | infixl 0 $| 170 | 171 | -- | Work on the stream as 'Text' values from UTF-8. 172 | text 173 | :: (r ~ (), MonadThrow m) 174 | => ConduitT Text Text m r -> Segment m r 175 | text conduit' = bytes (decodeUtf8 .| conduit' .| encodeUtf8) 176 | 177 | -- | Lift a conduit into a segment. 178 | bytes 179 | :: (a ~ ByteString, Monad m) 180 | => ConduitT a ByteString m r -> Segment m r 181 | bytes f = SegmentConduit (f `fuseUpstream` CL.map toChunk) 182 | 183 | -- | Lift a conduit into a segment. 184 | conduit 185 | :: (a ~ ByteString, Monad m) 186 | => ConduitT a ByteString m r -> Segment m r 187 | conduit f = SegmentConduit (f `fuseUpstream` CL.map toChunk) 188 | 189 | -- | Lift a conduit into a segment, which can yield stderr. 190 | conduitEither 191 | :: (a ~ ByteString, Monad m) 192 | => ConduitT a (Either ByteString ByteString) m r -> Segment m r 193 | conduitEither f = SegmentConduit (f `fuseUpstream` CL.map toChunk) 194 | 195 | -- | Lift a process into a segment. 196 | liftProcess :: MonadIO m => CreateProcess -> Segment m () 197 | liftProcess cp = 198 | SegmentProcess 199 | (\(Handles inh outh errh) -> 200 | let config = 201 | cp 202 | { std_in = UseHandle inh 203 | , std_out = UseHandle outh 204 | , std_err = UseHandle errh 205 | , close_fds = True 206 | } 207 | in 208 | liftIO $ do 209 | (Nothing, Nothing, Nothing, ph) <- createProcess_ "liftProcess" config 210 | ec <- waitForProcess ph 211 | case ec of 212 | ExitSuccess -> return () 213 | _ -> throwIO (ProcessException cp ec)) 214 | 215 | -- | Convert a conduit to a process. 216 | conduitToProcess :: MonadIO m => ConduitT ByteString (Either ByteString ByteString) m r 217 | -> (Handles -> m r) 218 | conduitToProcess c (Handles inh outh errh) = 219 | runConduit $ sourceHandle inh .| c `fuseUpstream` sinkHandles outh errh 220 | 221 | -- | Sink everything into the two handles. 222 | sinkHandles :: 223 | MonadIO m 224 | => Handle 225 | -> Handle 226 | -> ConduitT (Either ByteString ByteString) Void m () 227 | sinkHandles out err = 228 | CL.mapM_ 229 | (\ebs -> 230 | liftIO $ case ebs of 231 | Left bs -> S.hPut out bs 232 | Right bs -> S.hPut err bs) 233 | 234 | -- | Create a pipe. 235 | createHandles :: IO (Handle, Handle) 236 | createHandles = 237 | mask_ 238 | (do (inFD, outFD) <- createPipe 239 | x <- fdToHandle inFD 240 | y <- fdToHandle outFD 241 | hSetBuffering x NoBuffering 242 | hSetBuffering y NoBuffering 243 | return (x, y)) 244 | 245 | -- | Fuse two processes. 246 | fuseProcess :: MonadUnliftIO m => (Handles -> m ()) -> (Handles -> m r) -> (Handles -> m r) 247 | fuseProcess left right (Handles in1 out2 err) = do 248 | u <- askUnliftIO 249 | (in2, out1) <- liftIO createHandles 250 | liftIO $ runConcurrently 251 | (Concurrently ((unliftIO u $ left (Handles in1 out1 err)) `finally` hClose out1) *> 252 | Concurrently ((unliftIO u $ right (Handles in2 out2 err)) `finally` hClose in2)) 253 | 254 | -- | Fuse two conduits. 255 | fuseConduit 256 | :: Monad m 257 | => ConduitT ByteString (Either ByteString ByteString) m () 258 | -> ConduitT ByteString (Either ByteString ByteString) m r 259 | -> ConduitT ByteString (Either ByteString ByteString) m r 260 | fuseConduit left right = left .| getZipConduit right' 261 | where 262 | right' = 263 | ZipConduit (CL.filter isRight) *> 264 | ZipConduit (CL.mapMaybe (either (const Nothing) Just) .| right) 265 | isRight Right {} = True 266 | isRight Left {} = False 267 | 268 | -- | Fuse a conduit with a process. 269 | fuseConduitProcess 270 | :: MonadUnliftIO m 271 | => ConduitT ByteString (Either ByteString ByteString) m () 272 | -> (Handles -> m r) 273 | -> (Handles -> m r) 274 | fuseConduitProcess left right (Handles in1 out2 err) = do 275 | u <- askUnliftIO 276 | (in2, out1) <- liftIO createHandles 277 | liftIO $ runConcurrently 278 | (Concurrently 279 | ((unliftIO u $ runConduit $ sourceHandle in1 .| left .| sinkHandles out1 err) `finally` 280 | hClose out1) *> 281 | Concurrently ((unliftIO u $ right (Handles in2 out2 err)) `finally` hClose in2)) 282 | 283 | -- | Fuse a process with a conduit. 284 | fuseProcessConduit 285 | :: MonadUnliftIO m 286 | => (Handles -> m ()) 287 | -> ConduitT ByteString (Either ByteString ByteString) m r 288 | -> (Handles -> m r) 289 | fuseProcessConduit left right (Handles in1 out2 err) = do 290 | u <- askUnliftIO 291 | (in2, out1) <- liftIO createHandles 292 | liftIO $ runConcurrently 293 | (Concurrently ((unliftIO u $ left (Handles in1 out1 err)) `finally` hClose out1) *> 294 | Concurrently 295 | ((unliftIO u $ runConduit $ 296 | sourceHandle in2 .| right `fuseUpstream` sinkHandles out2 err) `finally` 297 | hClose in2)) 298 | 299 | -- | Fuse one segment with another. 300 | fuseSegment :: MonadUnliftIO m => Segment m () -> Segment m r -> Segment m r 301 | SegmentConduit x `fuseSegment` SegmentConduit y = 302 | SegmentConduit (fuseConduit x y) 303 | SegmentConduit x `fuseSegment` SegmentProcess y = 304 | SegmentProcess (fuseConduitProcess x y) 305 | SegmentProcess x `fuseSegment` SegmentConduit y = 306 | SegmentProcess (fuseProcessConduit x y) 307 | SegmentProcess x `fuseSegment` SegmentProcess y = 308 | SegmentProcess (fuseProcess x y) 309 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/Segments.hs: -------------------------------------------------------------------------------- 1 | -- | Helpful segment combinators. 2 | module Data.Conduit.Shell.Segments where 3 | 4 | import Control.Monad (void) 5 | import qualified Data.ByteString.Char8 as S8 6 | import Data.Conduit 7 | import qualified Data.Conduit.List as CL 8 | import qualified Data.Conduit.Binary as CB 9 | import Data.Conduit.Shell.Process 10 | import Data.Text (Text) 11 | import qualified Data.Text.Encoding as T 12 | import UnliftIO (MonadUnliftIO) 13 | 14 | 15 | -- | Extract the 'String' values from a segment. 16 | strings :: MonadUnliftIO m => Segment m () -> Segment m [String] 17 | strings s = s $| conduit (CB.lines .| CL.map S8.unpack .| CL.consume) 18 | 19 | -- | Extract the 'Text' values from a segment. 20 | texts :: MonadUnliftIO m => Segment m () -> Segment m [Text] 21 | texts s = s $| conduit (CB.lines .| CL.map T.decodeUtf8 .| CL.consume) 22 | 23 | -- | Ignore any output from a segment. 24 | ignore :: MonadUnliftIO m => Segment m () -> Segment m () 25 | ignore s = void (s $| conduit CL.consume) 26 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | -- | Generate top-level names for binaries. 5 | 6 | module Data.Conduit.Shell.TH 7 | (generateBinaries) 8 | where 9 | 10 | import Data.Conduit.Shell.Variadic 11 | 12 | import Control.Arrow 13 | import Control.Monad 14 | import Data.Char 15 | import Data.Function 16 | import Data.List 17 | import Data.List.Split 18 | import Language.Haskell.TH 19 | import System.Directory 20 | import System.Environment 21 | import System.FilePath 22 | 23 | -- | Generate top-level names for all binaries in PATH. 24 | generateBinaries :: Q [Dec] 25 | generateBinaries = 26 | do bins <- runIO getAllBinaries 27 | mapM (\(name,bin) -> 28 | do uniqueName <- getUniqueName name 29 | return (FunD uniqueName 30 | [Clause [] 31 | (NormalB (AppE (VarE 'variadicProcess) 32 | (LitE (StringL bin)))) 33 | []])) 34 | (nubBy (on (==) fst) 35 | (filter (not . null . fst) 36 | (map (normalize &&& id) bins))) 37 | where normalize = uncapitalize . go 38 | where go (c:cs) 39 | | c == '-' || c == '_' = 40 | case go cs of 41 | (z:zs) -> toUpper z : zs 42 | [] -> [] 43 | | not (elem (toLower c) allowed) = go cs 44 | | otherwise = c : go cs 45 | go [] = [] 46 | uncapitalize (c:cs) 47 | | isDigit c = '_' : c : cs 48 | | otherwise = toLower c : cs 49 | uncapitalize [] = [] 50 | allowed = 51 | ['a' .. 'z'] ++ 52 | ['0' .. '9'] 53 | 54 | -- | Get a version of the given name available to be bound. 55 | getUniqueName :: String -> Q Name 56 | getUniqueName candidate = 57 | do inScope <- recover (return False) 58 | (do void (reify (mkName candidate)) 59 | return True) 60 | if inScope || candidate `elem` disallowedNames 61 | then getUniqueName (candidate ++ "'") 62 | else return (mkName candidate) 63 | where 64 | disallowedNames = [ 65 | "class", 66 | "data", 67 | "do", 68 | "import", 69 | "type" 70 | ] 71 | 72 | -- | Get a list of all binaries in PATH. 73 | getAllBinaries :: IO [FilePath] 74 | getAllBinaries = 75 | do path <- getEnv "PATH" 76 | fmap concat 77 | (forM (splitOn ":" path) 78 | (\dir -> 79 | do exists <- doesDirectoryExist dir 80 | if exists 81 | then do contents <- getDirectoryContents dir 82 | filterM (\file -> 83 | do exists' <- doesFileExist (dir file) 84 | if exists' 85 | then do perms <- getPermissions (dir file) 86 | return (executable perms) 87 | else return False) 88 | contents 89 | else return [])) 90 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE CPP #-} 12 | 13 | -- | All types. 14 | module Data.Conduit.Shell.Types where 15 | 16 | import Control.Applicative 17 | import UnliftIO.Exception 18 | import Control.Monad 19 | import Control.Monad.IO.Class 20 | import Control.Monad.Trans.Class 21 | import Control.Monad.Trans.Resource 22 | import Data.Conduit 23 | import Data.Typeable 24 | 25 | -- | Shell transformer. 26 | newtype ShellT m a = ShellT 27 | { runShellT :: ResourceT m a 28 | } deriving (Applicative, Monad, Functor, MonadThrow, MonadIO, MonadTrans) 29 | 30 | deriving instance (MonadUnliftIO m) => MonadResource (ShellT m) 31 | 32 | -- | Intentionally only handles 'ShellException'. Use normal exception 33 | -- handling to handle usual exceptions. 34 | instance (MonadUnliftIO (ShellT m), Applicative m, MonadThrow m) => 35 | Alternative (ConduitT i o (ShellT m)) where 36 | empty = throwIO ShellEmpty 37 | x <|> y = do 38 | r <- tryC x 39 | case r of 40 | Left (_ :: ShellException) -> y 41 | Right rr -> return rr 42 | 43 | -- | An exception resulting from a shell command. 44 | data ShellException 45 | = ShellEmpty -- ^ For 'mempty'. 46 | | ShellExitFailure !Int -- ^ Process exited with failure. 47 | deriving (Typeable, Show) 48 | 49 | instance Exception ShellException 50 | -------------------------------------------------------------------------------- /src/Data/Conduit/Shell/Variadic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- | Variadic process calling. 5 | module Data.Conduit.Shell.Variadic 6 | ( ProcessType(..) 7 | , variadicProcess 8 | , CmdArg(..) 9 | ) where 10 | 11 | import qualified Data.ByteString as SB 12 | import qualified Data.ByteString.Lazy as LB 13 | import Data.Conduit.Shell.Process 14 | import qualified Data.Text as ST 15 | import qualified Data.Text.Encoding as ST 16 | import qualified Data.Text.Lazy as LT 17 | import qualified Data.Text.Lazy.Encoding as LT 18 | import Control.Applicative (pure) 19 | import Control.Monad.IO.Class (MonadIO) 20 | 21 | -- | A variadic process maker. 22 | variadicProcess 23 | :: (ProcessType r) 24 | => String -> r 25 | variadicProcess name = spr name [] 26 | 27 | -- | Make the final conduit. 28 | makeProcessLauncher :: MonadIO m => String -> [ST.Text] -> Segment m () 29 | makeProcessLauncher name args = proc name (map ST.unpack args) 30 | 31 | -- | Process return type. 32 | class ProcessType t where 33 | spr :: String -> [ST.Text] -> t 34 | 35 | instance (r ~ (), MonadIO m) => 36 | ProcessType (Segment m r) where 37 | spr name args = makeProcessLauncher name args 38 | 39 | -- | Accept strings as arguments. 40 | instance (ProcessType r, CmdArg a) => 41 | ProcessType (a -> r) where 42 | spr name args = \a -> spr name (args ++ toTextArg a) 43 | 44 | -- | Command line argument. 45 | class CmdArg a where 46 | toTextArg :: a -> [ST.Text] 47 | 48 | instance CmdArg ST.Text where 49 | toTextArg = pure . id 50 | 51 | instance CmdArg LT.Text where 52 | toTextArg = pure . LT.toStrict 53 | 54 | instance CmdArg SB.ByteString where 55 | toTextArg = pure . ST.decodeUtf8 56 | 57 | instance CmdArg LB.ByteString where 58 | toTextArg = pure . LT.toStrict . LT.decodeUtf8 59 | 60 | instance CmdArg String where 61 | toTextArg = pure . ST.pack 62 | 63 | instance CmdArg [String] where 64 | toTextArg = map ST.pack 65 | 66 | instance CmdArg [ST.Text] where 67 | toTextArg = map id 68 | 69 | instance CmdArg [LT.Text] where 70 | toTextArg = map LT.toStrict 71 | 72 | instance CmdArg [SB.ByteString] where 73 | toTextArg = map ST.decodeUtf8 74 | 75 | instance CmdArg [LB.ByteString] where 76 | toTextArg = map (LT.toStrict . LT.decodeUtf8) 77 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | 3 | packages: 4 | - '.' 5 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | import Test.Hspec 6 | import Data.Conduit.Shell hiding (ignore) -- https://github.com/fpco/stackage/issues/2355#issue-212177275 7 | import Data.Conduit.Shell.PATH (true, false) 8 | import Data.Conduit.Shell.Segments (strings, ignore) 9 | import qualified Data.Conduit.List as CL 10 | import qualified Data.Conduit.Binary as CB 11 | import qualified Data.ByteString.Char8 as S8 12 | import Control.Applicative 13 | import Data.ByteString 14 | import Data.Char (toUpper) 15 | import Data.Either (isRight, isLeft) 16 | import Control.Exception (try) 17 | 18 | main :: IO () 19 | main = 20 | hspec $ 21 | do describe "SHELL path functions" $ 22 | do it "false" $ 23 | do val <- run $ strings (false <|> echo "failed") 24 | val `shouldBe` ["failed"] 25 | it "true" $ 26 | do val <- run $ strings (true <|> echo "passed") 27 | val `shouldBe` [] 28 | describe "ls" $ 29 | do it "home directory check" $ 30 | do val <- run $ strings (ls "/") 31 | val `shouldContain` ["home"] 32 | it "long option" $ 33 | do val <- run $ strings (ls "-a" ["/"]) 34 | val `shouldContain` ["home"] 35 | describe "multiple string usage" $ 36 | do it "make two directory" $ 37 | do val <- 38 | run $ 39 | do ignore $ mkdir "-p" "mtest1" "mtest2" "mtest3" 40 | strings $ ls "." 41 | run $ rmdir ["mtest1", "mtest2", "mtest3"] 42 | val `shouldContain` ["mtest1", "mtest2", "mtest3"] 43 | describe "list usage in variadic" $ 44 | do it "two directory" $ 45 | do val <- 46 | run $ 47 | do ignore $ mkdir "-p" ["test1", "test2"] 48 | strings $ ls "." 49 | run $ rmdir ["test1", "test2"] 50 | val `shouldContain` ["test1", "test2"] 51 | describe "shell calls" $ 52 | do it "shell ls" $ 53 | do val <- run $ do strings $ shell "ls /" 54 | val `shouldContain` ["home"] 55 | describe "ordering of arguments" $ 56 | do it "echo -e" $ 57 | do val <- run $ do strings $ echo "-e" "hello\n" "haskell" 58 | #ifdef darwin_HOST_OS 59 | val `shouldBe` ["-e hello", " haskell"] 60 | #else 61 | val `shouldBe` ["hello", " haskell"] 62 | #endif 63 | it "mixed variant" $ 64 | do val <- run $ strings $ echo "-e" ["hello\n", "haskell"] 65 | #ifdef darwin_HOST_OS 66 | val `shouldBe` ["-e hello", " haskell"] 67 | #else 68 | val `shouldBe` ["hello", " haskell"] 69 | #endif 70 | it "list variant" $ 71 | do val <- run $ strings $ echo ["-e", "hello\n", "haskell"] 72 | #ifdef darwin_HOST_OS 73 | val `shouldBe` ["-e hello", " haskell"] 74 | #else 75 | val `shouldBe` ["hello", " haskell"] 76 | #endif 77 | it "list mixed variant - 1" $ 78 | do val <- run $ strings $ echo "-e" ["hello\n", "haskell"] 79 | #ifdef darwin_HOST_OS 80 | val `shouldBe` ["-e hello", " haskell"] 81 | #else 82 | val `shouldBe` ["hello", " haskell"] 83 | #endif 84 | it "list mixed variant - 2" $ 85 | do val <- run $ strings $ echo "-e" ["hello\n", "haskell\n"] "world" 86 | #ifdef darwin_HOST_OS 87 | val `shouldBe` ["-e hello", " haskell", " world"] 88 | #else 89 | val `shouldBe` ["hello", " haskell", " world"] 90 | #endif 91 | it "list mixed variant - 3" $ 92 | do val <- run $ strings $ echo "-e" ["hello\n", "haskell\n"] "world\n" ["planet"] 93 | #ifdef darwin_HOST_OS 94 | val `shouldBe` ["-e hello", " haskell", " world", " planet"] 95 | #else 96 | val `shouldBe` ["hello", " haskell", " world", " planet"] 97 | #endif 98 | describe "cd" $ 99 | do it "cd /" $ 100 | do val <- 101 | run $ 102 | do ignore $ cd "/" 103 | strings pwd 104 | val `shouldBe` ["/"] 105 | it "cd /home" $ 106 | do val <- 107 | run $ 108 | do ignore $ cd ["/home", undefined] 109 | strings pwd 110 | val `shouldBe` ["/home"] 111 | describe "Piping" $ 112 | do it "basic piping" $ 113 | do (val :: [String]) <- 114 | run $ strings (echo "hello" $| conduit (CL.map (S8.map toUpper))) 115 | val `shouldBe` ["HELLO"] 116 | it "piping of commands - example 1" $ 117 | do val <- run $ strings (ls "/" $| grep "etc") 118 | val `shouldBe` ["etc"] 119 | it "piping of commands - example 2" $ 120 | do val <- run $ strings (echo "hello" $| tr "[a-z]" "[A-Z]") 121 | val `shouldBe` ["HELLO"] 122 | describe "Exception" $ 123 | do it "Basic exception handling - success" $ 124 | do (val :: Either ProcessException () ) <- try $ run (ls "/bin") 125 | val `shouldSatisfy` isRight 126 | it "Basic exception handling - failure" $ 127 | do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory") 128 | val `shouldSatisfy` isLeft 129 | it "Basic exception handling with <|> - success" $ 130 | do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory" <|> ls "/bin") 131 | val `shouldSatisfy` isRight 132 | it "Basic exception handling with <|> - failure" $ 133 | do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory" <|> ls "/non_existent_directory") 134 | val `shouldSatisfy` isLeft 135 | it "Basic exception handling with <|> - first success" $ 136 | do (val :: Either ProcessException () ) <- try $ run (ls "/bin" <|> ls "/non_existent_directory") 137 | val `shouldSatisfy` isRight 138 | --------------------------------------------------------------------------------