shell-conduit 4.6.1 → 4.7.0
raw patch · 6 files changed
+198/−150 lines, 6 filesdep +unliftiodep −control-monad-loopdep −monad-controldep −transformers-basedep ~conduitdep ~resourcet
Dependencies added: unliftio
Dependencies removed: control-monad-loop, monad-control, transformers-base
Dependency ranges changed: conduit, resourcet
Files
- CHANGELOG.md +9/−1
- shell-conduit.cabal +9/−8
- src/Data/Conduit/Shell/Process.hs +104/−98
- src/Data/Conduit/Shell/Segments.hs +5/−6
- src/Data/Conduit/Shell/Types.hs +15/−37
- test/Spec.hs +56/−0
CHANGELOG.md view
@@ -1,3 +1,11 @@+# 4.7.0++* Port it for newer conduit and resourcet++# 4.6.2++* Add test for piping feature+ # 4.6.1 * Fix import error in Stackage: https://github.com/fpco/stackage/issues/2355@@ -5,6 +13,6 @@ # 4.6.0 * Add basic tests code-* Accept list as variadic command line arguments+* Accept list as variadic command line arguments. `mkdir "-p" ["folder1", "folder2"]` works now. * TRAVIS CI added
shell-conduit.cabal view
@@ -1,5 +1,5 @@ name: shell-conduit-version: 4.6.1+version: 4.7.0 synopsis: Write shell scripts with Conduit description: Write shell scripts with Conduit. See "Data.Conduit.Shell" for documentation. license: BSD3@@ -27,26 +27,24 @@ build-depends: async >= 2.0.1.5 , base >= 4 && <5 , bytestring- , conduit+ , conduit >= 1.3 , conduit-extra- , control-monad-loop , directory , filepath- , monad-control , monads-tf , process >= 1.2.1.0- , resourcet+ , resourcet >= 1.2.0+ , unliftio , semigroups , split , template-haskell , text , transformers- , transformers-base , unix >= 2.7.0.1 test-suite test type: exitcode-stdio-1.0- ghc-options: -Wall+ ghc-options: -Wall -threaded hs-source-dirs: test/ main-is: Spec.hs @@ -54,7 +52,10 @@ shell-conduit, hspec >= 2.1 && < 3, hspec-expectations,- template-haskell+ template-haskell,+ conduit,+ bytestring,+ conduit-extra source-repository head type: git
src/Data/Conduit/Shell/Process.hs view
@@ -89,7 +89,9 @@ -- | Process handles: @stdin@, @stdout@, @stderr@ data Handles =- Handles Handle Handle Handle+ Handles Handle+ Handle+ Handle -- | Process running exception. data ProcessException@@ -103,19 +105,19 @@ instance Show ProcessException where show ProcessEmpty = "empty process" show (ProcessException cp ec) =- concat ["The "- ,case cmdspec cp of- ShellCommand s -> "shell command " ++ show s- RawCommand f args ->- "raw command: " ++- unwords (f : map show args)- ," returned a failure exit code: "- ,case ec of- ExitFailure i -> show i- _ -> show ec]+ concat+ [ "The "+ , case cmdspec cp of+ ShellCommand s -> "shell command " ++ show s+ RawCommand f args -> "raw command: " ++ unwords (f : map show args)+ , " returned a failure exit code: "+ , case ec of+ ExitFailure i -> show i+ _ -> show ec+ ] -- | Convert a process or a conduit to a segment.-class ToSegment a where+class ToSegment a where type SegmentResult a toSegment :: a -> Segment (SegmentResult a) @@ -123,17 +125,17 @@ type SegmentResult (Segment r) = r toSegment = id -instance (a ~ ByteString,ToChunk b,m ~ IO) => ToSegment (ConduitM a b m r) where- type SegmentResult (ConduitM a b m r) = r- toSegment f =- SegmentConduit (f `fuseUpstream` CL.map toChunk)+instance (a ~ ByteString, ToChunk b, m ~ IO) =>+ ToSegment (ConduitT a b m r) where+ type SegmentResult (ConduitT a b m r) = r+ toSegment f = SegmentConduit (f `fuseUpstream` CL.map toChunk) instance ToSegment CreateProcess where type SegmentResult CreateProcess = () toSegment = liftProcess -- | Used to allow outputting stdout or stderr.-class ToChunk a where+class ToChunk a where toChunk :: a -> Either ByteString ByteString instance ToChunk ByteString where@@ -152,30 +154,37 @@ -- | Run a segment. run :: Segment r -> IO r-run (SegmentConduit c) =- run (SegmentProcess (conduitToProcess c))-run (SegmentProcess p) =- p (Handles stdin stdout stderr)+run (SegmentConduit c) = run (SegmentProcess (conduitToProcess c))+run (SegmentProcess p) = p (Handles stdin stdout stderr) -- | Fuse two segments (either processes or conduits). ($|) :: Segment () -> Segment b -> Segment b x $| y = x `fuseSegment` y+ infixl 0 $| -- | Work on the stream as 'Text' values from UTF-8.-text :: (r ~ (),m ~ IO) => ConduitM Text Text m r -> Segment r-text conduit' = bytes (decodeUtf8 $= conduit' $= encodeUtf8)+text+ :: (r ~ (), m ~ IO)+ => ConduitT Text Text m r -> Segment r+text conduit' = bytes (decodeUtf8 .| conduit' .| encodeUtf8) -- | Lift a conduit into a segment.-bytes :: (a ~ ByteString,m ~ IO) => ConduitM a ByteString m r -> Segment r+bytes+ :: (a ~ ByteString, m ~ IO)+ => ConduitT a ByteString m r -> Segment r bytes f = SegmentConduit (f `fuseUpstream` CL.map toChunk) -- | Lift a conduit into a segment.-conduit :: (a ~ ByteString,m ~ IO) => ConduitM a ByteString m r -> Segment r+conduit+ :: (a ~ ByteString, m ~ IO)+ => ConduitT a ByteString m r -> Segment r conduit f = SegmentConduit (f `fuseUpstream` CL.map toChunk) -- | Lift a conduit into a segment, which can yield stderr.-conduitEither :: (a ~ ByteString,m ~ IO) => ConduitM a (Either ByteString ByteString) m r -> Segment r+conduitEither+ :: (a ~ ByteString, m ~ IO)+ => ConduitT a (Either ByteString ByteString) m r -> Segment r conduitEither f = SegmentConduit (f `fuseUpstream` CL.map toChunk) -- | Lift a process into a segment.@@ -183,98 +192,95 @@ liftProcess cp = SegmentProcess (\(Handles inh outh errh) ->- let config =- cp {std_in = UseHandle inh- ,std_out = UseHandle outh- ,std_err = UseHandle errh- ,close_fds = True}- in do (Nothing,Nothing,Nothing,ph) <- createProcess_ "liftProcess" config- ec <- waitForProcess ph- case ec of- ExitSuccess -> return ()- _ ->- throwIO (ProcessException cp ec))+ let config =+ cp+ { std_in = UseHandle inh+ , std_out = UseHandle outh+ , std_err = UseHandle errh+ , close_fds = True+ }+ in do (Nothing, Nothing, Nothing, ph) <- createProcess_ "liftProcess" config+ ec <- waitForProcess ph+ case ec of+ ExitSuccess -> return ()+ _ -> throwIO (ProcessException cp ec)) -- | Convert a conduit to a process.-conduitToProcess :: ConduitM ByteString (Either ByteString ByteString) IO r+conduitToProcess :: ConduitT ByteString (Either ByteString ByteString) IO r -> (Handles -> IO r) conduitToProcess c (Handles inh outh errh) =- sourceHandle inh $$ c `fuseUpstream`- sinkHandles outh errh+ runConduit $ sourceHandle inh .| c `fuseUpstream` sinkHandles outh errh -- | Sink everything into the two handles.-sinkHandles :: Handle -> Handle -> Consumer (Either ByteString ByteString) IO ()+sinkHandles :: Handle+ -> Handle+ -> ConduitT (Either ByteString ByteString) Void IO () sinkHandles out err =- CL.mapM_ (\ebs ->- case ebs of- Left bs -> S.hPut out bs- Right bs -> S.hPut err bs)+ CL.mapM_+ (\ebs ->+ case ebs of+ Left bs -> S.hPut out bs+ Right bs -> S.hPut err bs) -- | Create a pipe. createHandles :: IO (Handle, Handle) createHandles =- mask_ (do (inFD,outFD) <- createPipe- x <- fdToHandle inFD- y <- fdToHandle outFD- hSetBuffering x NoBuffering- hSetBuffering y NoBuffering- return (x,y))+ mask_+ (do (inFD, outFD) <- createPipe+ x <- fdToHandle inFD+ y <- fdToHandle outFD+ hSetBuffering x NoBuffering+ hSetBuffering y NoBuffering+ return (x, y)) -- | Fuse two processes. fuseProcess :: (Handles -> IO ()) -> (Handles -> IO r) -> (Handles -> IO r)-fuseProcess left right (Handles in1 out2 err) =- do (in2,out1) <- createHandles- runConcurrently- (Concurrently- (left (Handles in1 out1 err) `finally`- hClose out1) *>- Concurrently- (right (Handles in2 out2 err) `finally`- hClose in2))+fuseProcess left right (Handles in1 out2 err) = do+ (in2, out1) <- createHandles+ runConcurrently+ (Concurrently (left (Handles in1 out1 err) `finally` hClose out1) *>+ Concurrently (right (Handles in2 out2 err) `finally` hClose in2)) -- | Fuse two conduits.-fuseConduit :: Monad m- => ConduitM ByteString (Either ByteString ByteString) m ()- -> ConduitM ByteString (Either ByteString ByteString) m r- -> ConduitM ByteString (Either ByteString ByteString) m r-fuseConduit left right = left =$= getZipConduit right'- where right' =- ZipConduit (CL.filter isRight) *>- ZipConduit- (CL.mapMaybe (either (const Nothing) Just) =$=- right)- isRight Right{} = True- isRight Left{} = False+fuseConduit+ :: Monad m+ => ConduitT ByteString (Either ByteString ByteString) m ()+ -> ConduitT ByteString (Either ByteString ByteString) m r+ -> ConduitT ByteString (Either ByteString ByteString) m r+fuseConduit left right = left .| getZipConduit right'+ where+ right' =+ ZipConduit (CL.filter isRight) *>+ ZipConduit (CL.mapMaybe (either (const Nothing) Just) .| right)+ isRight Right {} = True+ isRight Left {} = False -- | Fuse a conduit with a process.-fuseConduitProcess :: ConduitM ByteString (Either ByteString ByteString) IO ()- -> (Handles -> IO r)- -> (Handles -> IO r)-fuseConduitProcess left right (Handles in1 out2 err) =- do (in2,out1) <- createHandles- runConcurrently- (Concurrently- ((sourceHandle in1 $$ left =$- sinkHandles out1 err) `finally`- hClose out1) *>- Concurrently- (right (Handles in2 out2 err) `finally`- hClose in2))+fuseConduitProcess+ :: ConduitT ByteString (Either ByteString ByteString) IO ()+ -> (Handles -> IO r)+ -> (Handles -> IO r)+fuseConduitProcess left right (Handles in1 out2 err) = do+ (in2, out1) <- createHandles+ runConcurrently+ (Concurrently+ ((runConduit $ sourceHandle in1 .| left .| sinkHandles out1 err) `finally`+ hClose out1) *>+ Concurrently (right (Handles in2 out2 err) `finally` hClose in2)) -- | Fuse a process with a conduit.-fuseProcessConduit :: (Handles -> IO ())- -> ConduitM ByteString (Either ByteString ByteString) IO r- -> (Handles -> IO r)-fuseProcessConduit left right (Handles in1 out2 err) =- do (in2,out1) <- createHandles- runConcurrently- (Concurrently- (left (Handles in1 out1 err) `finally`- hClose out1) *>- Concurrently- ((sourceHandle in2 $$ right `fuseUpstream`- sinkHandles out2 err) `finally`- hClose in2))+fuseProcessConduit+ :: (Handles -> IO ())+ -> ConduitT ByteString (Either ByteString ByteString) IO r+ -> (Handles -> IO r)+fuseProcessConduit left right (Handles in1 out2 err) = do+ (in2, out1) <- createHandles+ runConcurrently+ (Concurrently (left (Handles in1 out1 err) `finally` hClose out1) *>+ Concurrently+ ((runConduit $+ sourceHandle in2 .| right `fuseUpstream` sinkHandles out2 err) `finally`+ hClose in2)) -- | Fuse one segment with another. fuseSegment :: Segment () -> Segment r -> Segment r
src/Data/Conduit/Shell/Segments.hs view
@@ -1,22 +1,21 @@ -- | Helpful segment combinators.- module Data.Conduit.Shell.Segments where import qualified Data.ByteString.Char8 as S8-import Data.Conduit+import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB-import Data.Conduit.Shell.Process-import Data.Text (Text)+import Data.Conduit.Shell.Process+import Data.Text (Text) import qualified Data.Text.Encoding as T -- | Extract the 'String' values from a segment. strings :: Segment () -> Segment [String]-strings s = s $| conduit (CB.lines $= CL.map S8.unpack $= CL.consume)+strings s = s $| conduit (CB.lines .| CL.map S8.unpack .| CL.consume) -- | Extract the 'Text' values from a segment. texts :: Segment () -> Segment [Text]-texts s = s $| conduit (CB.lines $= CL.map T.decodeUtf8 $= CL.consume)+texts s = s $| conduit (CB.lines .| CL.map T.decodeUtf8 .| CL.consume) -- | Ignore any output from a segment. ignore :: Segment () -> Segment ()
src/Data/Conduit/Shell/Types.hs view
@@ -11,61 +11,39 @@ {-# LANGUAGE CPP #-} -- | All types.- module Data.Conduit.Shell.Types where import Control.Applicative-import Control.Exception+import UnliftIO.Exception import Control.Monad-import Control.Monad.Base import Control.Monad.IO.Class import Control.Monad.Trans.Class-import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.Conduit import Data.Typeable -- | Shell transformer.-newtype ShellT m a =- ShellT {runShellT :: ResourceT m a}- deriving (Applicative,Monad,Functor,MonadThrow,MonadIO,MonadTrans)--deriving instance (MonadResourceBase m) => MonadBase IO (ShellT m)-deriving instance (MonadResourceBase m) => MonadResource (ShellT m)--#if MIN_VERSION_monad_control(1,0,0)-newtype StMShell m a = StMShell{unStMGeoServer :: StM (ResourceT m) a}-#endif+newtype ShellT m a = ShellT+ { runShellT :: ResourceT m a+ } deriving (Applicative, Monad, Functor, MonadThrow, MonadIO, MonadTrans) --- | Dumb instance.-instance (MonadThrow m,MonadIO m,MonadBaseControl IO m) => MonadBaseControl IO (ShellT m) where-#if MIN_VERSION_monad_control(1,0,0)- type StM (ShellT m) a = StMShell m a-#else- newtype StM (ShellT m) a = StMShell{unStMGeoServer ::- StM (ResourceT m) a}-#endif- liftBaseWith f =- ShellT (liftBaseWith- (\run ->- f (liftM StMShell .- run .- runShellT)))- restoreM = ShellT . restoreM . unStMGeoServer+deriving instance (MonadUnliftIO m) => MonadResource (ShellT m) -- | Intentionally only handles 'ShellException'. Use normal exception -- handling to handle usual exceptions.-instance (MonadBaseControl IO (ShellT m),Applicative m,MonadThrow m) => Alternative (ConduitM i o (ShellT m)) where- empty = monadThrow ShellEmpty- x <|> y =- do r <- tryC x- case r of- Left (_ :: ShellException) -> y- Right rr -> return rr+instance (MonadUnliftIO (ShellT m), Applicative m, MonadThrow m) =>+ Alternative (ConduitT i o (ShellT m)) where+ empty = throwIO ShellEmpty+ x <|> y = do+ r <- tryC x+ case r of+ Left (_ :: ShellException) -> y+ Right rr -> return rr -- | An exception resulting from a shell command. data ShellException = ShellEmpty -- ^ For 'mempty'. | ShellExitFailure !Int -- ^ Process exited with failure.- deriving (Typeable,Show)+ deriving (Typeable, Show)+ instance Exception ShellException
test/Spec.hs view
@@ -1,11 +1,19 @@ {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} import Test.Hspec import Data.Conduit.Shell hiding (ignore) -- https://github.com/fpco/stackage/issues/2355#issue-212177275 import Data.Conduit.Shell.PATH (true, false) import Data.Conduit.Shell.Segments (strings, ignore)+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import qualified Data.ByteString.Char8 as S8 import Control.Applicative+import Data.ByteString+import Data.Char (toUpper)+import Data.Either (isRight, isLeft)+import Control.Exception (try) main :: IO () main =@@ -66,6 +74,27 @@ #else val `shouldBe` ["hello", " haskell"] #endif+ it "list mixed variant - 1" $+ do val <- run $ strings $ echo "-e" ["hello\n", "haskell"]+#ifdef darwin_HOST_OS+ val `shouldBe` ["-e hello", " haskell"]+#else+ val `shouldBe` ["hello", " haskell"]+#endif+ it "list mixed variant - 2" $+ do val <- run $ strings $ echo "-e" ["hello\n", "haskell\n"] "world"+#ifdef darwin_HOST_OS+ val `shouldBe` ["-e hello", " haskell", " world"]+#else+ val `shouldBe` ["hello", " haskell", " world"]+#endif+ it "list mixed variant - 3" $+ do val <- run $ strings $ echo "-e" ["hello\n", "haskell\n"] "world\n" ["planet"]+#ifdef darwin_HOST_OS+ val `shouldBe` ["-e hello", " haskell", " world", " planet"]+#else+ val `shouldBe` ["hello", " haskell", " world", " planet"]+#endif describe "cd" $ do it "cd /" $ do val <-@@ -79,3 +108,30 @@ do ignore $ cd ["/home", undefined] strings pwd val `shouldBe` ["/home"]+ describe "Piping" $+ do it "basic piping" $+ do (val :: [String]) <-+ run $ strings (echo "hello" $| conduit (CL.map (S8.map toUpper)))+ val `shouldBe` ["HELLO"]+ it "piping of commands - example 1" $+ do val <- run $ strings (ls "/" $| grep "etc")+ val `shouldBe` ["etc"]+ it "piping of commands - example 2" $+ do val <- run $ strings (echo "hello" $| tr "[a-z]" "[A-Z]")+ val `shouldBe` ["HELLO"]+ describe "Exception" $+ do it "Basic exception handling - success" $+ do (val :: Either ProcessException () ) <- try $ run (ls "/bin")+ val `shouldSatisfy` isRight+ it "Basic exception handling - failure" $+ do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory")+ val `shouldSatisfy` isLeft+ it "Basic exception handling with <|> - success" $+ do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory" <|> ls "/bin")+ val `shouldSatisfy` isRight+ it "Basic exception handling with <|> - failure" $+ do (val :: Either ProcessException () ) <- try $ run (ls "/non_existent_directory" <|> ls "/non_existent_directory")+ val `shouldSatisfy` isLeft+ it "Basic exception handling with <|> - first success" $+ do (val :: Either ProcessException () ) <- try $ run (ls "/bin" <|> ls "/non_existent_directory")+ val `shouldSatisfy` isRight