coquina (empty) → 0.1.0.0
raw patch · 9 files changed
+589/−0 lines, 9 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, containers, coquina, deepseq, directory, exceptions, filepath, hspec, lens, monad-logger, mtl, process, stm, temporary, text, transformers, which
Files
- CHANGELOG.md +9/−0
- LICENSE +12/−0
- README.lhs +25/−0
- README.md +25/−0
- Setup.hs +2/−0
- coquina.cabal +80/−0
- src/Coquina.hs +331/−0
- src/Coquina/Internal.hs +38/−0
- test/unit-tests.hs +67/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Revision history for coquina++## 0.1.0.0++* First version. A few simple functions for running shell commands and+ retrieving their output.+* Uses Text instead of String for stdout and stderr. This allows us to properly+ handle processes which print non-Latin1 characters. UTF-8 encoding is+ assumed.
+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2015, Obsidian Systems LLC+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.lhs view
@@ -0,0 +1,25 @@+# coquina+[](https://haskell.org) [](https://hackage.haskell.org/package/coquina) [](https://matrix.hackage.haskell.org/#/package/coquina) [](https://github.com/obsidiansystems/coquina/actions) [](https://github.com/obsidiansystems/coquina/blob/master/LICENSE)++> *coquina*+> /kōˈkēnə/+> 1. a soft limestone of broken shells, used in road-making in the Caribbean and Florida.+> 2. an easy-to-use library for running shell commands from haskell.++```haskell+import Control.Monad+import Coquina+import System.Process (shell, proc)+import qualified Data.Text as T++main :: IO ()+main = do+ (exitCode, out, err) <- execShell $ do+ (contents, ()) <- readStdout $ run $ shell "ls"+ mapM_ (run . proc "file" . (:[])) $ take 10 $ lines $ T.unpack contents+ putStrLn $ unlines+ [ "Exit code: " ++ show exitCode+ , "stdout: " ++ T.unpack out+ , "stderr: " ++ T.unpack err+ ]+```
+ README.md view
@@ -0,0 +1,25 @@+# coquina+[](https://haskell.org) [](https://hackage.haskell.org/package/coquina) [](https://matrix.hackage.haskell.org/#/package/coquina) [](https://github.com/obsidiansystems/coquina/actions) [](https://github.com/obsidiansystems/coquina/blob/master/LICENSE)++> *coquina*+> /kōˈkēnə/+> 1. a soft limestone of broken shells, used in road-making in the Caribbean and Florida.+> 2. an easy-to-use library for running shell commands from haskell.++```haskell+import Control.Monad+import Coquina+import System.Process (shell, proc)+import qualified Data.Text as T++main :: IO ()+main = do+ (exitCode, out, err) <- execShell $ do+ (contents, ()) <- readStdout $ run $ shell "ls"+ mapM_ (run . proc "file" . (:[])) $ take 10 $ lines $ T.unpack contents+ putStrLn $ unlines+ [ "Exit code: " ++ show exitCode+ , "stdout: " ++ T.unpack out+ , "stderr: " ++ T.unpack err+ ]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ coquina.cabal view
@@ -0,0 +1,80 @@+cabal-version: >=1.10+name: coquina+version: 0.1.0.0+synopsis: Yet another shell monad.+description: A simple monad for shelling out from Haskell programs.+bug-reports: https://github.com/obsidiansystems/coquina/issues+license: BSD3+license-file: LICENSE+author: Obsidian Systems LLC+maintainer: maintainer@obsidian.systems+copyright: 2020 Obsidian Systems LLC+category: shell+build-type: Simple+extra-source-files:+ CHANGELOG.md+ LICENSE+ README.md++library+ hs-source-dirs: src+ build-depends:+ async >=2.2.2 && <2.3+ , base >=4.12.0 && <4.15+ , bytestring >=0.10.8 && <0.11+ , containers >=0.6.0 && <0.7+ , deepseq >=1.4.4 && <1.5+ , directory >=1.3.3 && <1.4+ , exceptions >=0.10.3 && <0.11+ , filepath >=1.4.2 && <1.5+ , monad-logger >=0.3 && <0.4+ , mtl >=2.2.2 && <2.3+ , process >=1.6.5 && <1.7+ , stm >=2.5.0 && <2.6+ , temporary >=1.3 && <1.4+ , text >=1.2.3 && <1.3+ , transformers >=0.5 && <0.6++ exposed-modules:+ Coquina+ Coquina.Internal++ ghc-options: -Wall+ default-language: Haskell2010++executable readme+ main-is: README.lhs+ build-depends:+ base+ , coquina+ , process+ , text++ default-language: Haskell2010+ ghc-options: -pgmL markdown-unlit+ build-tool-depends: markdown-unlit:markdown-unlit -any++test-suite unit-tests+ type: exitcode-stdio-1.0+ main-is: unit-tests.hs+ hs-source-dirs: test+ ghc-options: -Wall -rtsopts+ build-depends:+ async+ , base+ , coquina+ , exceptions+ , hspec+ , lens+ , mtl+ , process+ , stm+ , temporary+ , text+ , which >= 0.2++ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/obsidiansystems/coquina.git
+ src/Coquina.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+ Description:+ A monad for running shell commands in Haskell and combining their output.++Coquina provides a convenient interface for running shell commands in Haskell.+The core functionality of Coquina is the ability to run a sequence of 'Shell'+operations, inspect the output of each operation, combine their results (i.e.,+their exit codes, stdout, and stderr), and stop execution if one of them fails.+See the readme for an example.+-}+module Coquina+ (+ -- * The Shell Monad+ MonadShell(..)+ , tellStdout+ , tellStderr+ , readStdout+ , readStderr+ , Shell(..)+ , runShell+ , execShell+ , hoistShell+ -- * Constructing Shell actions+ , run+ , shellCreateProcess+ , shellCreateProcessWith+ , shellCreateProcessWithEnv+ , runCreateProcess+ , runCreateProcessWithEnv+ , shellCreateProcessWithStdOut+ -- * Running in a temporary directory+ , inTempDirectory+ -- * Streamable Shell processes+ , StreamingProcess(..)+ , shellStreamableProcess+ , shellStreamableProcessBuffered+ -- * Miscellaneous+ , logCommand+ , showCommand+ ) where++import Coquina.Internal (readAndDecodeCreateProcess, withForkWait)++import qualified Control.Concurrent.Async as Async+import Control.DeepSeq (rnf)+import Control.Exception (evaluate)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, finally)+import Control.Monad.Except (MonadError, ExceptT, throwError, runExceptT)+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Except (mapExceptT)+import Control.Monad.Writer+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T (pack)+import qualified Data.Text.Encoding as T (decodeUtf8)+import qualified Data.Text.IO as T (putStrLn)+import GHC.Generics (Generic)+import GHC.IO.Handle (BufferMode(..), Handle, hClose, hIsOpen, hIsReadable, hSetBuffering)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.IO.Temp (withSystemTempDirectory)+import System.Process++instance MonadLogger m => MonadLogger (Shell m) where++-- | A class that supports reading and writing stdout and stderr+class Monad m => MonadShell m where+ tellOutput :: (Text, Text) -> m ()+ readOutput :: m a -> m ((Text, Text), a)++-- | Write to stdout+tellStdout :: MonadShell m => Text -> m ()+tellStdout s = tellOutput (s, mempty)++-- | Write to stderr+tellStderr :: MonadShell m => Text -> m ()+tellStderr s = tellOutput (mempty, s)++-- | Read the stdout of a command+readStdout :: MonadShell m => m a -> m (Text, a)+readStdout f = do+ ((out, _), a) <- readOutput f+ return (out, a)++-- | Read the stderr of a command+readStderr :: MonadShell m => m a -> m (Text, a)+readStderr f = do+ ((_, err), a) <- readOutput f+ return (err, a)++-- | An action that supports running commands, reading their output, and emitting output+newtype Shell m a = Shell { unShell :: ExceptT Int (WriterT (Text, Text) m) a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadError Int, MonadThrow, MonadCatch, MonadMask)++instance MonadTrans Shell where+ lift = Shell . lift . lift++instance Monad m => MonadShell (Shell m) where+ tellOutput = Shell . tell+ readOutput f = Shell $ do+ (a, out) <- listen $ unShell f+ return (out, a)++instance MonadWriter w m => MonadWriter w (Shell m) where+ tell = lift . tell+ -- NB: If the Shell action fails, the listen fails as well+ listen x = do+ ((out, err, r), w) <- lift $ listen $ runShell x+ tellOutput (out, err)+ case r of+ Left ec -> throwError ec+ Right v -> return (v, w)+ pass a = do+ (out, err, e) <- lift $ pass $+ runShell a >>= \case+ (out, err, Left ec) -> return ((out, err, Left ec), id)+ (out, err, Right (x, f)) -> return ((out, err, Right x), f)+ tellOutput (out, err)+ case e of+ Left ec -> throwError ec+ Right v -> return v++-- | Run a shell action, producing stdout, stderr, and a result.+runShell :: Monad m => Shell m a -> m (Text, Text, Either Int a)+runShell (Shell s) = do+ (e, (out, err)) <- runWriterT $ runExceptT s+ return (out, err, e)++-- | Run a shell action, producing an exit code, stdout, and stderr+execShell :: Monad m => Shell m a -> m (ExitCode, Text, Text)+execShell s = do+ (out, err, r) <- runShell s+ case r of+ Left ec -> return (ExitFailure ec, out, err)+ Right _ -> return (ExitSuccess, out, err)++-- | Hoist a shell action into another monad+hoistShell :: (forall x. m x -> n x) -> Shell m a -> Shell n a+hoistShell f s = Shell $ mapExceptT (mapWriterT f) $ unShell s++-- | Run a 'CreateProcess' in a 'Shell'+shellCreateProcess :: MonadIO m => CreateProcess -> Shell m ()+shellCreateProcess = shellCreateProcessWithEnv mempty++-- | Run a 'CreateProcess' in a 'Shell'+run :: MonadIO m => CreateProcess -> Shell m ()+run = shellCreateProcess++-- | Represents a process that is running and whose incremental output can+-- be retrieved before it completes. The '_streamingProcess_waitForProcess'+-- finalizer can be called to get the exit status of the process and to get+-- the final output.+data StreamingProcess m = StreamingProcess+ { _streamingProcess_waitForProcess :: !(Shell m ExitCode)+ , _streamingProcess_terminateProcess :: !(Shell m ())+ , _streamingProcess_getProcessExitCode :: !(Shell m (Maybe ExitCode))+ } deriving Generic++-- | A process whose output can be inspected while it is still running.+shellStreamableProcess+ :: (MonadIO m, MonadMask m)+ => (ByteString -> IO ()) -- ^ Handle stdout+ -> (ByteString -> IO ()) -- ^ Handle stderr+ -> CreateProcess+ -> Shell m (StreamingProcess m)+shellStreamableProcess handleStdout handleStderr p = do+ (_, mout, merr, ph) <- liftIO $ createProcess $ p+ { std_out = CreatePipe+ , std_err = CreatePipe+ }+ case (mout, merr) of+ (Just hout, Just herr) -> do+ -- TODO: This code is basically the same as that in Reflex.Process.createProcess, except for the action to take when new output is received+ let+ handleReader h (handler :: ByteString -> IO ()) = do+ hSetBuffering h LineBuffering+ fix $ \go -> do+ open <- hIsOpen h+ when open $ do+ readable <- hIsReadable h+ when readable $ do+ out <- BS.hGetSome h (2^(15 :: Int))+ unless (BS.null out) $ do+ handler out+ go++ appendIORef r out = atomicModifyIORef' r (\v -> (v <> BS.byteString out, ()))++ stdoutAcc <- liftIO $ newIORef mempty+ stderrAcc <- liftIO $ newIORef mempty+ outThread <- liftIO $ Async.async $ handleReader hout $ \out ->+ appendIORef stdoutAcc out *> handleStdout out+ errThread <- liftIO $ Async.async $ handleReader herr $ \out ->+ appendIORef stderrAcc out *> handleStderr out+ let finalize f =+ liftIO f+ `finally` liftIO (Async.uninterruptibleCancel outThread)+ `finally` liftIO (Async.uninterruptibleCancel errThread)+ `finally` do+ stdoutFinal <- liftIO $ builderToStrictBS <$> readIORef stdoutAcc+ stderrFinal <- liftIO $ builderToStrictBS <$> readIORef stderrAcc+ tellOutput (T.decodeUtf8 stdoutFinal, T.decodeUtf8 stderrFinal)+ return $ StreamingProcess+ { _streamingProcess_waitForProcess = finalize $ waitForProcess ph+ , _streamingProcess_terminateProcess = finalize $ terminateProcess ph+ , _streamingProcess_getProcessExitCode = finalize $ getProcessExitCode ph+ }+ _ -> error "shellStreamingProcess: Created pipes were not returned"+ where+ builderToStrictBS = LBS.toStrict . BS.toLazyByteString++-- | Like 'shellStreamableProcess' but instead of taking handlers for each+-- stream, it automatically buffers the output of each stream and returns+-- 'IO' actions to read and clear the buffer.+shellStreamableProcessBuffered+ :: (MonadIO m, MonadMask m)+ => CreateProcess+ -> Shell m (StreamingProcess m, IO ByteString, IO ByteString) -- ^ ('StreamingProcess', stdout, stderr)+shellStreamableProcessBuffered p = do+ stdoutBuf <- liftIO $ newIORef mempty+ stderrBuf <- liftIO $ newIORef mempty+ sp <- shellStreamableProcess (updateBuf stdoutBuf) (updateBuf stderrBuf) p+ pure (sp, eatBuf stdoutBuf, eatBuf stderrBuf)+ where+ updateBuf buf new = atomicModifyIORef' buf $ \old -> (old <> BS.byteString new, ())+ eatBuf buf = atomicModifyIORef' buf $ \out -> (mempty, LBS.toStrict $ BS.toLazyByteString out)+++-- | Run a shell process using the given runner function+shellCreateProcessWith+ :: MonadIO m+ => (CreateProcess -> IO (ExitCode, Text, Text))+ -> CreateProcess+ -> Shell m ()+shellCreateProcessWith f p = do+ (ex, out, err) <- liftIO $ f p+ tellOutput (out, err)+ case ex of+ ExitFailure c -> do+ liftIO $ T.putStrLn $ mconcat+ [ "Command failed: "+ , T.pack $ showCommand p+ , "\n"+ , err+ ]+ throwError c+ ExitSuccess -> return ()++-- | Run a shell process with the given environment variables added to the existing environment+shellCreateProcessWithEnv+ :: MonadIO m+ => Map String String+ -> CreateProcess+ -> Shell m ()+shellCreateProcessWithEnv envOverrides = shellCreateProcessWith f+ where+ f cmd = do+ envWithOverrides <- liftIO $ if Map.null envOverrides+ then return $ env cmd+ else Just . Map.toList . Map.union envOverrides . Map.fromList <$> getEnvironment+ readAndDecodeCreateProcess $ cmd { env = envWithOverrides }++-- | Execute a shell process with environment variables+runCreateProcessWithEnv :: Map String String -> CreateProcess -> IO (ExitCode, Text, Text)+runCreateProcessWithEnv menv p = execShell $ shellCreateProcessWithEnv menv p++-- | Execute a shell process+runCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)+runCreateProcess = runCreateProcessWithEnv mempty++-- | Run a shell process with stdout directed to the provided handle+shellCreateProcessWithStdOut+ :: MonadIO m+ => Handle+ -> CreateProcess+ -> Shell m ()+shellCreateProcessWithStdOut hndl cp = do+ let cp' = cp { std_out = UseHandle hndl, std_err = CreatePipe }+ shellCreateProcessWith f cp'+ where+ f cmd = withCreateProcess cmd $ \_ _ merr p -> case merr of+ Just errh -> do+ err <- waitReadHandle errh+ ec <- waitForProcess p+ hClose hndl+ return (ec, "", err)+ _ -> error "shellCreateProcessWithStdOut: Failed to get std_err handle"+ waitReadHandle :: Handle -> IO Text+ waitReadHandle h = do+ c <- fmap T.decodeUtf8 $ BS.hGetContents h+ withForkWait (evaluate $ rnf c) $ \wait -> wait >> hClose h+ return c++-- | Run a shell command with access to a temporary directory+inTempDirectory+ :: MonadIO m+ => String+ -> (FilePath -> Shell IO a)+ -> Shell m a+inTempDirectory label f = do+ (out, err, r) <- liftIO $ withSystemTempDirectory label $ \fp -> runShell $ f fp+ tellOutput (out, err)+ case r of+ Left ec -> throwError ec+ Right x -> return x++-- | Print a shell command+logCommand :: CreateProcess -> IO ()+logCommand = putStrLn . showCommand++-- | Convert a shell command to a string+showCommand :: CreateProcess -> String+showCommand p = case cmdspec p of+ ShellCommand str -> str+ RawCommand exe args -> mconcat $ L.intersperse " " $ exe : args
+ src/Coquina/Internal.hs view
@@ -0,0 +1,38 @@+module Coquina.Internal where++import Control.Concurrent (MVar, newEmptyMVar, forkIO, putMVar, takeMVar, killThread)+import Control.DeepSeq (rnf)+import Control.Exception (SomeException, evaluate, mask, try, throwIO, onException)+import Data.ByteString (hGetContents)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import System.Process+import System.Exit+import System.IO (hClose)++-- | The code below is taken from System.Process which unfortunately does not export this function+withForkWait :: IO () -> (IO () -> IO a) -> IO a+withForkWait async body = do+ waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+ mask $ \restore -> do+ tid <- forkIO $ try (restore async) >>= putMVar waitVar+ let wait = takeMVar waitVar >>= either throwIO return+ restore (body wait) `onException` killThread tid++-- | Like readCreateProcess, but ignores stdin and decodes bytes, assuming utf-8+readAndDecodeCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)+readAndDecodeCreateProcess cp =+ withCreateProcess (cp { std_out = CreatePipe, std_err = CreatePipe }) $ \_ mouth merrh ph -> case (mouth, merrh) of+ (Just outh, Just errh) -> do+ out <- fmap decodeUtf8 $ hGetContents outh+ err <- fmap decodeUtf8 $ hGetContents errh+ withForkWait (evaluate $ rnf out) $ \waitOut ->+ withForkWait (evaluate $ rnf err) $ \waitErr -> do+ waitOut+ waitErr+ hClose outh+ hClose errh+ exitCode <- waitForProcess ph+ return (exitCode, out, err)+ (Nothing, _) -> error "readAndDecodeCreateProcess: Failed to get std_out handle"+ (Just _, Nothing) -> error "readAndDecodeCreateProcess: Failed to get std_err handle"
+ test/unit-tests.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Concurrent.STM+import Control.Lens (_1, _2, (%~))+import Control.Monad.IO.Class (liftIO)+import Data.Function ((&))+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.Text (Text)+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T+import System.IO (hFlush)+import System.IO.Temp (withSystemTempFile)+import System.Process (proc)+import System.Timeout (timeout)+import System.Which (staticWhich)+import Test.Hspec (describe, hspec, it, shouldBe)++import Coquina (StreamingProcess (..), runShell, shellStreamableProcess)++main :: IO ()+main = hspec $+ describe "shellStreamableProcess" $+ it "reads stdout incrementally" $ do+ (allStdout, allStderr, result :: Either Int ([Text], [Text])) <- withSystemTempFile @IO "temp" $ \path h -> runShell $ do+ stdoutListeners <- liftIO $ newTVarIO (0 :: Int)+ stderrListeners <- liftIO $ newTVarIO (0 :: Int)++ procOuts <- liftIO $ newIORef ([], [])+ let+ waitForStdout = hFlush h *> waitForListeners stdoutListeners 1++ recordOutput listener setter x = do+ atomicModifyIORef' procOuts $ \vs ->+ (vs & setter %~ (T.decodeUtf8 x :), ())+ proceed listener++ sp <- shellStreamableProcess+ (recordOutput stdoutListeners _1)+ (recordOutput stderrListeners _2)+ (proc $(staticWhich "tail") ["-f", path])++ (maybe (error "Test timed out") pure =<<) $ liftIO $ timeout (5*10^(6::Int)) $ do+ T.hPutStrLn h "line1" *> waitForStdout+ T.hPutStrLn h "line2" *> waitForStdout+ T.hPutStrLn h "line3" *> waitForStdout++ _streamingProcess_terminateProcess sp++ liftIO $ readIORef procOuts++ allStdout `shouldBe` "line1\nline2\nline3\n"+ allStderr `shouldBe` ""+ result `shouldBe` Right (["line3\n", "line2\n", "line1\n"], [])+ where+ -- Help synchronize test with threads+ proceed var = atomically $ modifyTVar var (+1)++ waitForListeners var n = atomically $ do+ newStep <- readTVar var+ if newStep < n+ then retry+ else writeTVar var 0