polysemy-process (empty) → 0.5.0.0

raw patch · 11 files changed

+583/−0 lines, 11 filesdep +asyncdep +basedep +bytestring

Dependencies added: async, base, bytestring, containers, polysemy, polysemy-conc, polysemy-plugin, polysemy-process, polysemy-resume, polysemy-test, polysemy-time, relude, stm, stm-chans, string-interpolate, tasty, template-haskell, text, time, typed-process

Files

• LICENSE +34/−0
• changelog.md +5/−0
• lib/Polysemy/Process.hs +24/−0
• lib/Polysemy/Process/Data/ProcessError.hs +5/−0
• lib/Polysemy/Process/Effect/Process.hs +42/−0
• lib/Polysemy/Process/Interpreter/Process.hs +41/−0
• lib/Polysemy/Process/Interpreter/ProcessIOE.hs +166/−0
• polysemy-process.cabal +209/−0
• readme.md +8/−0
• test/Main.hs +17/−0
• test/Polysemy/Process/Test/ProcessTest.hs +32/−0

@@ -0,0 +1,34 @@+Copyright (c) 2020 Torsten Schmits++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.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++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 HOLDERS 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,5 @@+# Unreleased++# 0.5.0.0++* Add the effect `Process`, wrapping `System.Process.Typed` using `Scoped`.

@@ -0,0 +1,24 @@+module Polysemy.Process (+  -- * Introduction+  -- $intro++  -- * Effect+  Process,+  recv,+  recvError,+  send,++  -- * Interpreters+  interpretProcessNative,+  interpretProcessIOE,+) where++import Polysemy.Process.Effect.Process (Process, recv, recvError, send)+import Polysemy.Process.Interpreter.Process (interpretProcessNative)+import Polysemy.Process.Interpreter.ProcessIOE (interpretProcessIOE)++-- $intro+-- This library provides an abstraction of a system process in the effect 'Process', whose constructors represent the+-- three standard file descriptors.+--+-- The values produced by the constructors are chunks of the process' output when using the default interpreter.

@@ -0,0 +1,5 @@+module Polysemy.Process.Data.ProcessError where++data ProcessError =+  Terminated Text+  deriving (Eq, Show)

@@ -0,0 +1,42 @@+{-# options_haddock prune #-}+-- |Description: Process Effect, Internal+module Polysemy.Process.Effect.Process where++import Polysemy.Conc.Effect.Scoped (Scoped, scoped)+import Polysemy.Resume (type (!!))++-- |Abstraction of a process with stdin/stdout/stderr.+--+-- This effect is intended to be used in a scoped manner:+--+-- @+-- import Polysemy.Resume+-- import Polysemy.Process+-- import qualified System.Process.Typed as System+--+-- prog :: Member (Scoped resource (Process Text Text e !! err)) r => Sem r Text+-- prog =+--  withProcess do+--    resumeAs "failed" do+--      send "input"+--      recv+--+-- main :: IO ()+-- main = do+--   out <- runConc $ interpretProcessNative (System.proc "cat" []) prog+--   putStrLn out+-- @+data Process i o e :: Effect where+  Recv :: Process i o e m o+  RecvError :: Process i o e m e+  Send :: i -> Process i o e m ()++makeSem ''Process++-- |Create a scoped resource for 'Process'.+withProcess ::+  ∀ resource i o e err r .+  Member (Scoped resource (Process i o e !! err)) r =>+  InterpreterFor (Process i o e !! err) r+withProcess =+  scoped @resource

@@ -0,0 +1,41 @@+{-# options_haddock prune #-}+-- |Description: Process Interpreters, Internal+module Polysemy.Process.Interpreter.Process where++import Polysemy.Async (Async)+import Polysemy.Conc (Race)+import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Interpreter.Scoped (runScoped)+import Polysemy.Error (fromException, runError)+import Polysemy.Resource (Resource, bracket)+import Polysemy.Resume (type (!!))+import Prelude hiding (fromException)+import qualified System.Process.Typed as System+import System.Process.Typed (+  ProcessConfig,+  startProcess,+  stopProcess,+  )++import Polysemy.Process.Effect.Process (Process)++withProcess ::+  Members [Resource, Embed IO] r =>+  ProcessConfig stdin stdout stderr ->+  (System.Process stdin stdout stderr -> Sem r a) ->+  Sem r a+withProcess config =+  bracket (embed @IO (startProcess config)) (runError @SomeException . fromException @SomeException . stopProcess)++-- |Interpret 'Process' with a system process resource.+interpretProcessNative ::+  ∀ resource i o e err stdin stdout stderr r .+  Members [Resource, Race, Async, Embed IO] r =>+  ProcessConfig stdin stdout stderr ->+  (∀ x. System.Process stdin stdout stderr -> (resource -> Sem r x) -> Sem r x) ->+  (resource -> InterpreterFor (Process i o e !! err) r) ->+  InterpreterFor (Scoped resource (Process i o e !! err)) r+interpretProcessNative config fromProcess =+  runScoped \ f ->+    withProcess config \ prc ->+      fromProcess prc f

@@ -0,0 +1,166 @@+{-# options_haddock prune #-}+-- |Description: Process Interpreters for stdpipes, Internal+module Polysemy.Process.Interpreter.ProcessIOE where++import Control.Concurrent.STM.TBMQueue (TBMQueue)+import Data.ByteString (hGetSome, hPut)+import Polysemy (InterpretersFor, insertAt)+import Polysemy.Async (Async)+import Polysemy.Conc.Async (withAsync_)+import qualified Polysemy.Conc.Data.QueueResult as QueueResult+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (Queue)+import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Interpreter.Queue.TBM (interpretQueueTBMWith, withTBMQueue)+import Polysemy.Resource (Resource)+import Polysemy.Resume (interpretResumable, stop, type (!!))+import Prelude hiding (fromException)+import qualified System.Process.Typed as System+import System.Process.Typed (+  ProcessConfig,+  createPipe,+  getStderr,+  getStdin,+  getStdout,+  setStderr,+  setStdin,+  setStdout,+  )++import Polysemy.Process.Data.ProcessError (ProcessError (Terminated))+import qualified Polysemy.Process.Effect.Process as Process+import Polysemy.Process.Effect.Process (Process)+import Polysemy.Process.Interpreter.Process (interpretProcessNative)++newtype In a =+  In { unIn :: a }+  deriving (Eq, Show)++newtype Out a =+  Out { unOut :: a }+  deriving (Eq, Show)++newtype Err a =+  Err { unErr :: a }+  deriving (Eq, Show)++data ProcessQueues =+  ProcessQueues {+    pqIn :: TBMQueue (In ByteString),+    pqOut :: TBMQueue (Out ByteString),+    pqErr :: TBMQueue (Err ByteString)+  }++processWithQueues :: ProcessConfig () () () -> ProcessConfig Handle Handle Handle+processWithQueues =+  setStdin createPipe . setStdout createPipe . setStderr createPipe++readQueue ::+  ∀ r .+  Members [Queue (In ByteString), Embed IO] r =>+  Bool ->+  Handle ->+  Sem r ()+readQueue discardWhenFull handle = do+  embed @IO (hSetBuffering handle NoBuffering)+  tryAny (hGetSome handle 4096) >>= traverse_ \ msg -> do+      if discardWhenFull then void (Queue.tryWrite (In msg)) else Queue.write (In msg)+      readQueue discardWhenFull handle++writeQueue ::+  ∀ r .+  Members [Queue (Out ByteString), Embed IO] r =>+  Handle ->+  Sem r ()+writeQueue handle = do+  embed @IO (hSetBuffering handle NoBuffering)+  spin+  where+    spin =+      Queue.read >>= \case+        QueueResult.Success (Out msg) ->+          traverse_ (const spin) =<< tryAny (hPut handle msg)+        _ ->+          pass++interpretQueues ::+  Members [Resource, Race, Embed IO] r =>+  ProcessQueues ->+  InterpretersFor [Queue (In ByteString), Queue (Out ByteString), Queue (Err ByteString)] r+interpretQueues (ProcessQueues inQ outQ errQ) =+  interpretQueueTBMWith errQ .+  interpretQueueTBMWith outQ .+  interpretQueueTBMWith inQ++interpretProcessWithQueues ::+  Members [Queue (In ByteString), Queue (Out ByteString), Queue (Err ByteString)] r =>+  InterpreterFor (Process ByteString ByteString ByteString !! ProcessError) r+interpretProcessWithQueues =+  interpretResumable \case+    Process.Recv ->+      Queue.read >>= \case+        QueueResult.Closed ->+          stop (Terminated "closed")+        QueueResult.NotAvailable ->+          stop (Terminated "impossible: empty")+        QueueResult.Success (In msg) ->+          pure msg+    Process.RecvError ->+      Queue.read >>= \case+        QueueResult.Closed ->+          stop (Terminated "closed")+        QueueResult.NotAvailable ->+          stop (Terminated "impossible: empty")+        QueueResult.Success (Err msg) ->+          pure msg+    Process.Send msg -> do+      whenM (Queue.closed @(Out ByteString)) (stop (Terminated "closed"))+      Queue.write (Out msg)++withSTMResources ::+  ∀ r a .+  Members [Resource, Embed IO] r =>+  Int ->+  (ProcessQueues -> Sem r a) ->+  Sem r a+withSTMResources qSize action = do+  withTBMQueue qSize \ inQ ->+    withTBMQueue qSize \ outQ ->+      withTBMQueue qSize \ errQ ->+        action (ProcessQueues inQ outQ errQ)++withProcessResources ::+  Members [Resource, Race, Async, Embed IO] r =>+  Bool ->+  Int ->+  System.Process Handle Handle Handle ->+  (ProcessQueues -> Sem r a) ->+  Sem r a+withProcessResources discardWhenFull qSize prc f =+  withSTMResources qSize \ qs ->+    interpretQueues qs $+    withAsync_ (readQueue discardWhenFull (getStderr prc)) $+    withAsync_ (readQueue discardWhenFull (getStdout prc)) $+    withAsync_ (writeQueue (getStdin prc)) $+    insertAt @0 (f qs)++interpretProcessQueues ::+  Members [Resource, Race, Async, Embed IO] r =>+  ProcessQueues ->+  InterpreterFor (Process ByteString ByteString ByteString !! ProcessError) r+interpretProcessQueues qs =+  interpretQueues qs .+  interpretProcessWithQueues .+  raiseUnder3++-- |Interpret 'Process' with a system process resource whose file descriptors are connected to three 'TBMQueue's,+-- producing 'ByteString's.+interpretProcessIOE ::+  Members [Resource, Race, Async, Embed IO] r =>+  Bool ->+  Int ->+  ProcessConfig () () () ->+  InterpreterFor (Scoped ProcessQueues (Process ByteString ByteString ByteString !! ProcessError)) r+interpretProcessIOE discardWhenFull qSize config =+  interpretProcessNative (processWithQueues config) (withProcessResources discardWhenFull qSize) interpretProcessQueues

@@ -0,0 +1,209 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           polysemy-process+version:        0.5.0.0+synopsis:       Polysemy Effects for System Processes+description:    See <https://hackage.haskell.org/package/polysemy-process/docs/Polysemy-Process.html>+category:       Concurrency+homepage:       https://github.com/tek/polysemy-conc#readme+bug-reports:    https://github.com/tek/polysemy-conc/issues+author:         Torsten Schmits+maintainer:     tek@tryp.io+copyright:      2021 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    readme.md+    changelog.md++source-repository head+  type: git+  location: https://github.com/tek/polysemy-conc++library+  exposed-modules:+      Polysemy.Process+      Polysemy.Process.Data.ProcessError+      Polysemy.Process.Effect.Process+      Polysemy.Process.Interpreter.Process+      Polysemy.Process.Interpreter.ProcessIOE+  other-modules:+      Paths_polysemy_process+  autogen-modules:+      Paths_polysemy_process+  hs-source-dirs:+      lib+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints+  build-depends:+      async+    , base ==4.*+    , bytestring+    , containers+    , polysemy >=1.6+    , polysemy-conc+    , polysemy-resume >=0.2+    , polysemy-time >=0.1.4+    , relude >=0.7+    , stm+    , stm-chans >=2+    , string-interpolate >=0.2+    , template-haskell+    , text+    , time+    , typed-process+  mixins:+      base hiding (Prelude)+    , polysemy-conc hiding (Prelude)+    , polysemy-conc (Polysemy.Conc.Prelude as Prelude)+  if impl(ghc >= 8.10)+    ghc-options: -Wunused-packages+  default-language: Haskell2010++test-suite polysemy-process-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Process.Test.ProcessTest+      Paths_polysemy_process+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base ==4.*+    , bytestring+    , polysemy+    , polysemy-conc+    , polysemy-plugin+    , polysemy-process+    , polysemy-resume+    , polysemy-test+    , tasty+    , typed-process+  mixins:+      base hiding (Prelude)+    , polysemy-conc hiding (Prelude)+    , polysemy-conc (Polysemy.Conc.Prelude as Prelude)+  if impl(ghc >= 8.10)+    ghc-options: -Wunused-packages+  default-language: Haskell2010

@@ -0,0 +1,8 @@+# About++This library provides a few convenience [polysemy] effects for using STM queues, MVars, signal handling and racing.++Please visit [hackage] for documentation.++[polysemy]: https://hackage.haskell.org/package/polysemy+[hackage]: https://hackage.haskell.org/package/polysemy-conc

@@ -0,0 +1,17 @@+module Main where++import Polysemy.Process.Test.ProcessTest (test_process)+import Polysemy.Test (unitTest)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "main" [+    testGroup "process" [+      unitTest "process" test_process+    ]+  ]++main :: IO ()+main =+  defaultMain tests

@@ -0,0 +1,32 @@+{-# options_ghc -fplugin=Polysemy.Plugin #-}++module Polysemy.Process.Test.ProcessTest where++import qualified Data.ByteString as ByteString+import Polysemy.Async (asyncToIOFinal)+import Polysemy.Conc.Interpreter.Race (interpretRace)+import Polysemy.Resume (resuming)+import Polysemy.Test (UnitTest, runTestAuto, (===))+import qualified System.Process.Typed as Process+import System.Process.Typed (ProcessConfig)++import qualified Polysemy.Process.Effect.Process as Process+import Polysemy.Process.Effect.Process (withProcess)+import Polysemy.Process.Interpreter.ProcessIOE (interpretProcessIOE)++config :: ProcessConfig () () ()+config =+  Process.proc "cat" []++message :: ByteString+message =+  ByteString.replicate 10 120++test_process :: UnitTest+test_process =+  runTestAuto $ interpretRace $ asyncToIOFinal $ interpretProcessIOE True 10 config do+    withProcess do+      response <- resuming (pure . show) do+        Process.send message+        Process.recv+      message === response