shellout (empty) → 0.1.0.0

raw patch · 7 files changed

+391/−0 lines, 7 filesdep +asyncdep +basedep +shelloutsetup-changed

Dependencies added: async, base, shellout, stm, text, typed-process

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +70/−0
• Setup.hs +2/−0
• examples/Main.hs +53/−0
• shellout.cabal +59/−0
• src/Shellout.hs +174/−0

@@ -0,0 +1,3 @@+# Changelog for shellout++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Logan McPhail (c) 2018++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 Author name here 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.

@@ -0,0 +1,70 @@+# shellout++A simple library for running standard processes in a threaded manager+, and responding to/doing things with stdout, stderr, and exits as they happen.++This was mainly built out of frustration that most libraries wait for a task+to complete before giving output.++Just initialize with a driver and off you go!++## Example++Here's a short annotated example on how to use this:++```haskell+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Shellout++import           Control.Concurrent (threadDelay)+import           Data.Monoid        ((<>))+import           Data.Text          (Text)+import qualified Data.Text.IO       as T++-- create a type to hold data that will be passed between all of your handlers,+-- where you could store things like the task name, a spinner's position+-- and last spin time, etc.+newtype Task = Task {name :: Text}++main :: IO ()+main = do+  -- create a 'driver', with functions that handle each type of output+  let driver = Shellout.Driver+        -- (optionally) do something with the task name, and initialize+        -- data that will be passed between your handlers. you could store+        -- things like the task name, a spinner's position and last spin time, etc.+        { Shellout.initialState =+          \taskName -> Task {name = taskName}++        -- what to do when polling returns `Nothing`, so it's waiting on+        -- more output from the task, but the task still hasn't exited.+        -- In this example, we just sleep.+        , Shellout.handleNothing =+          \task -> threadDelay 1000 >> pure task++        -- what to do on stdout from the shell command. You could colorize it,+        -- append it to list of output (you could keep a list of them in the `Task`), etc.+        , Shellout.handleOut =+          \task txt -> T.putStrLn (name task <> ": " <> txt) >> pure task++        -- what to do on stderr. Same things go as stdout.+        , Shellout.handleErr =+          \task txt -> T.putStrLn (name task <> ": " <> txt) >> pure task++        -- what to do when a task completes successfully+        , Shellout.handleSuccess =+          \task -> T.putStrLn $ (name task) <> " complete."++        -- what to do when a task doesn't complete successfully+        , Shellout.handleFailure =+          \task -> T.putStrLn $ (name task) <> " failed."+        }++  shell <- Shellout.new driver++  shell "listing directory" "ls"++  shell "listing hidden files" "ls -lah"+```

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Shellout++import           Control.Concurrent (threadDelay)+import           Data.Monoid        ((<>))+import           Data.Text          (Text)+import qualified Data.Text.IO       as T++-- create a type to hold data that will be passed between all of your handlers,+-- where you could store things like the task name, a spinner's position+-- and last spin time, etc.+newtype Task = Task {name :: Text}++main :: IO ()+main = do+  -- create a 'driver', with functions that handle each type of output+  let driver = Shellout.Driver+        -- (optionally) do something with the task name, and initialize+        -- data that will be passed between your handlers.+        { Shellout.initialState =+          \taskName -> Task {name = taskName}++        -- what to do when polling returns `Nothing`, so it's waiting on+        -- more output from the task, but the task still hasn't exited.+        -- In this example, we just sleep.+        , Shellout.handleNothing =+          \task -> threadDelay 1000 >> pure task++        -- what to do on stdout from the shell command. You could colorize it,+        -- append it to list of output (you could keep a list of them in the `Task`), etc.+        , Shellout.handleOut =+          \task txt -> T.putStrLn (name task <> ": " <> txt) >> pure task++        -- what to do on stderr. Same things go as stdout.+        , Shellout.handleErr =+          \task txt -> T.putStrLn (name task <> ": " <> txt) >> pure task++        -- what to do when a task completes successfully+        , Shellout.handleSuccess =+          \task -> T.putStrLn $ (name task) <> " complete."++        -- what to do when a task doesn't complete successfully+        , Shellout.handleFailure =+          \task -> T.putStrLn $ (name task) <> " failed."+        }++  shell <- Shellout.new driver++  shell "listing directory" "ls"++  shell "listing hidden files too" "ls -lah"

@@ -0,0 +1,59 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d6b4502f7da1a40315422c36f8a951aea21ff169c7154604924dd8c6d673639d++name:           shellout+version:        0.1.0.0+synopsis:       A threaded manager for Haskell that can run and stream external process output/err/exits+description:    Please see the README on Github at <https://github.com/loganmac/shellout#readme>+category:       System+homepage:       https://github.com/loganmac/shellout#readme+bug-reports:    https://github.com/loganmac/shellout/issues+author:         Logan McPhail+maintainer:     logan.airnomad@gmail.com+copyright:      2018 Logan McPhail+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/loganmac/shellout++library+  hs-source-dirs:+      src+  build-depends:+      async+    , base >=4.7 && <5+    , stm+    , text+    , typed-process+  exposed-modules:+      Shellout+  other-modules:+      Paths_shellout+  default-language: Haskell2010++executable example+  main-is: Main.hs+  hs-source-dirs:+      examples+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      async+    , base >=4.7 && <5+    , shellout+    , stm+    , text+    , typed-process+  other-modules:+      Paths_shellout+  default-language: Haskell2010

@@ -0,0 +1,174 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-| Shell is a threaded manager that can run external processes+    and call functions of the `Driver` on process output/err/exit.+-}+module Shellout+(Driver(..), Shell, TaskName, Cmd, new)+where++import           Control.Concurrent       (MVar, newEmptyMVar, putMVar,+                                           takeMVar)+import           Control.Concurrent.Async (Async, async, link)+import           Control.Concurrent.STM   (TQueue, atomically, newTQueue,+                                           readTQueue, tryReadTQueue,+                                           writeTQueue)+import           Control.Monad            (unless)+import           Data.Text                (Text, unpack)+import           Data.Text.IO             (hGetLine)+import           GHC.IO.Handle            (Handle)+import           System.Exit              (ExitCode (..), exitWith)+import           System.IO                (hIsEOF)+import           System.Process.Typed     (closed, createPipe, getStderr,+                                           getStdout, setStderr, setStdin,+                                           setStdout, shell, waitExitCode,+                                           withProcess)++--------------------------------------------------------------------------------+-- TYPES++-- | Driver is a collection of functions that+-- describe what to do on process output+data Driver a = Driver++  { -- | (optionally) do something with the task name, and initialize+  -- data that will be passed between your handlers. you could store+  -- things like the task name, a spinner's position and last spin time, etc.+  initialState    :: Text -> a+  -- | what to do when polling returns `Nothing`, so it's waiting on+  -- more output from the task, but the task still hasn't exited.+  -- usually it's sleep.+  , handleNothing :: a -> IO a+  -- | what to do on stdout from the shell command. You could colorize it,+  -- append it to list of output (you could keep a list in the `a`), etc.+  , handleOut     :: a -> Text -> IO a+  -- | what to do on stderr. Same things go as stdout.+  , handleErr     :: a -> Text -> IO a+  -- | what to do when a task completes successfully+  , handleSuccess :: a -> IO ()+  -- | what to do when a task doesn't complete successfully+  , handleFailure :: a -> IO ()+  }++-- | The output of running an external process+data Output = Msg Text | Err Text | Success | Failure Int++-- | Processor has an input channel (for sending commands)+-- and an output channel (for reading the output)+data Processor = Processor (TQueue Text) (TQueue Output)++-- | Shell takes a task name and an external command and+-- executes the given callbacks in the provided driver+type Shell = (TaskName -> Cmd -> IO ())++-- | Task is the description of an external process+type TaskName = Text++-- | Cmd is the external command like 'cat file.txt' to run+type Cmd = Text++--------------------------------------------------------------------------------+-- API++-- | creates a new processor to run external processes in,+-- spawns a thread to run the processor loop, then returns+-- a `Shell` that can send commands to the processor loop,+-- and react to them with functions from the `Driver`+new :: Driver a -> IO Shell+new driver = do+  processor <- Processor <$> newChan <*> newChan+  _         <- spawn $ processorLoop processor+  pure $ execute processor driver+  where newChan = atomically newTQueue++--------------------------------------------------------------------------------+-- EXECUTE / OUTPUT LOOP++-- | executes the given command in the processor+execute :: forall a. Processor -> Driver a -> TaskName -> Cmd -> IO ()+execute (Processor input output) driver task cmd = do+  send input cmd                               -- send the command to the Processor thread+  loop (initialState driver task)              -- start the output loop+  where+    -- | try to read from the channel, returning Nothing if no value available+    maybeReceive = atomically . tryReadTQueue++    loop :: a -> IO ()+    loop acc = do+      out <- maybeReceive output+      case out of+        Nothing -> do+          newAcc <- handleNothing driver acc+          loop newAcc+        Just (Msg msg) -> do+          newAcc <- handleOut driver acc msg+          loop newAcc+        Just (Err msg) -> do+          newAcc <- handleErr driver acc msg+          loop newAcc+        Just Success ->+          handleSuccess driver acc+        Just (Failure c) -> do+          handleFailure driver acc+          exitWith $ ExitFailure c++--------------------------------------------------------------------------------+-- | PROCESSOR LOOP++-- | run the command, putting any stdout, stderr, and exits into the output channel.+-- will wait until stdout and stderr are empty to write the exit code.+processorLoop :: Processor -> IO ()+processorLoop processor@(Processor input output) = do+  cmd <- atomically $ readTQueue input -- receive input++  let config = setStdin closed+             $ setStdout createPipe+             $ setStderr createPipe+             $ shell (unpack cmd)++  withProcess config $ \p -> do+    stdoutLock <- newEmptyMVar -- create locks for stdout/stderr+    stderrLock <- newEmptyMVar++    _ <- spawn $ sendOutput Msg (getStdout p) stdoutLock+    _ <- spawn $ sendOutput Err (getStderr p) stderrLock++    code <- waitExitCode p -- wait for the exit and output locks+    takeMVar stdoutLock+    takeMVar stderrLock++    let result = case code of+          ExitSuccess   -> Success+          ExitFailure i -> Failure i++    send output result++  processorLoop processor++  where+    -- | read from the handle until it's empty, writing the result+    -- (wrapped in the given wrapper type) to the output channel+    -- and then releasing the given lock+    sendOutput :: (Text -> Output) -> Handle -> MVar () -> IO ()+    sendOutput wrap handle lock = do+      let loop = do+            isDone <- hIsEOF handle+            unless isDone $ do+              out <- hGetLine handle+              send output $ wrap out+              loop+      loop+      putMVar lock () -- release the lock++--------------------------------------------------------------------------------+-- THREAD AND CHANNEL HELPERS++-- | new async thread, linked to calling thread (will rethrow exceptions on linked thread)+spawn :: IO a -> IO (Async a)+spawn x = do+  thread <- async x+  link thread+  pure thread++-- | write to the channel+send :: TQueue a -> a -> IO ()+send x = atomically . writeTQueue x