funflow 1.0.1 → 1.1.0

raw patch · 7 files changed

+48/−28 lines, 7 files

Files

• TestFunflow.hs +2/−2
• funflow.cabal +1/−1
• src/Control/Funflow/External.hs +25/−6
• src/Control/Funflow/External/Docker.hs +1/−1
• src/Control/Funflow/External/Executor.hs +16/−15
• test/Funflow/SQLiteCoordinator.hs +2/−2
• test/Funflow/TestFlows.hs +1/−1

@@ -55,7 +55,7 @@     exFlow = external $ \t -> ExternalTask       { _etCommand = "/run/current-system/sw/bin/echo"       , _etParams = [textParam t]-      , _etWriteToStdOut = True+      , _etWriteToStdOut = StdOutCapture       }     flow = exFlow >>> readString_   in withSystemTempDir "test_output_external_" $ \storeDir -> do@@ -72,7 +72,7 @@     exFlow = external $ \(a, b) -> ExternalTask       { _etCommand = "/run/current-system/sw/bin/cat"       , _etParams = [contentParam a, contentParam b]-      , _etWriteToStdOut = True+      , _etWriteToStdOut = StdOutCapture       }     flow = proc (s1, s2) -> do       f1 <- writeString_ -< s1

@@ -1,5 +1,5 @@ Name:                funflow-Version:             1.0.1+Version:             1.1.0 Synopsis:            Workflows with arrows Description:         An arrow with resumable computations and logging

@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE QuasiQuotes                #-} {-# LANGUAGE TemplateHaskell            #-} -- | Definition of external tasks module Control.Funflow.External where@@ -148,17 +149,35 @@ outParam :: Param outParam = Param [ParamOut] +-- | Control how and where stdout from the process is captured. Some external+-- steps will write their output to stdout rather than to a file.+data OutputCapture+    -- | Specify that the step will write its output files directly, and that+    --   stdout will not be captured in the step output.+  = NoOutputCapture+    -- | Capture output to a file named 'out' in the output directory.+  | StdOutCapture+    -- | Capture output to a custom named file in the output directory.+  | CustomOutCapture (Path Rel File)+  deriving (Generic, Show)++-- | Get the file to write output to, if this is desired.+outputCaptureToRelFile :: OutputCapture -> Maybe (Path Rel File)+outputCaptureToRelFile NoOutputCapture         = Nothing+outputCaptureToRelFile StdOutCapture           = Just [relfile|out|]+outputCaptureToRelFile (CustomOutCapture file) = Just file++instance ContentHashable IO OutputCapture+instance FromJSON OutputCapture+instance ToJSON OutputCapture+instance Store OutputCapture+ -- | A monomorphic description of an external task. This is basically just --   a command which can be run. data ExternalTask = ExternalTask {     _etCommand       :: T.Text   , _etParams        :: [Param]-    -- | If this is set, then the process outputs on its stdout stream-    --   rather than writing to a file. In this case, output will be-    --   redirected into a file called 'out' in the output directory.-    --   Otherwise, the task is assumed to write itself to files in its-    --   working directory.-  , _etWriteToStdOut :: Bool+  , _etWriteToStdOut :: OutputCapture } deriving (Generic, Show)  instance ContentHashable IO ExternalTask

@@ -51,7 +51,7 @@       [ imageArg       , stringParam (command cfg)       ] ++ map textParam (args cfg)-  , _etWriteToStdOut = False+  , _etWriteToStdOut = NoOutputCapture   }   where     mounts = outputMount : inputMounts

@@ -12,20 +12,20 @@ module Control.Funflow.External.Executor where  import           Control.Concurrent                   (threadDelay)+import           Control.Concurrent.Async import           Control.Concurrent.MVar import           Control.Exception.Safe-import           Control.Concurrent.Async import qualified Control.Funflow.ContentStore         as CS import           Control.Funflow.External import           Control.Funflow.External.Coordinator import           Control.Lens-import           Control.Monad                        (forever, mzero, unless,-                                                       when)+import           Control.Monad                        (forever, mzero, unless) import           Control.Monad.Trans                  (lift) import           Control.Monad.Trans.Maybe import qualified Data.Aeson                           as Json import qualified Data.ByteString                      as BS-import           Data.Maybe                           (isJust)+import           Data.Foldable                        (for_)+import           Data.Maybe                           (isJust, isNothing) import           Data.Monoid                          ((<>)) import qualified Data.Text                            as T import           Katip                                as K@@ -68,7 +68,8 @@       CS.createMetadataFile store (td ^. tdOutput) [relfile|stderr|]     let       withFollowOutput-        | td ^. tdTask . etWriteToStdOut+        | td ^. tdTask . etWriteToStdOut . to outputCaptureToRelFile+              . to isNothing         = withFollowFile fpErr stderr         | otherwise         = withFollowFile fpErr stderr@@ -99,10 +100,10 @@         Param fields <- td ^. tdTask . etParams         ParamPath inputPath <- fields         case inputPath of-          IPItem item -> pure item+          IPItem item      -> pure item           -- XXX: Store these references as well.           IPExternalFile _ -> mzero-          IPExternalDir _ -> mzero+          IPExternalDir _  -> mzero     CS.setInputs store (td ^. tdOutput) inputItems     CS.setMetadata store (td ^. tdOutput)       ("external-task"::T.Text)@@ -119,8 +120,8 @@           end <- getTime Monotonic           case exitCode of             ExitSuccess   -> do-              when (td ^. tdTask . etWriteToStdOut) $-                copyFile fpOut (fp </> [relfile|out|])+              for_ (td ^. tdTask . etWriteToStdOut . to outputCaptureToRelFile)+                $ \file -> copyFile fpOut (fp </> file)               return $ Right (diffTimeSpec start end)             ExitFailure i ->               return $ Left (diffTimeSpec start end, i)@@ -128,15 +129,15 @@         -- execution was successful         Right (Right r) -> return $ Right r         -- execution failed-        Right (Left e) -> return $ Left (Right e)+        Right (Left e)  -> return $ Left (Right e)         -- executor itself failed-        Left e -> return $ Left (Left e)+        Left e          -> return $ Left (Left e)   case status of-    CS.Missing (Left e) -> return (ExecutorFailure e)+    CS.Missing (Left e)        -> return (ExecutorFailure e)     CS.Missing (Right (t, ec)) -> return (Failure t ec)-    CS.Pending () -> return AlreadyRunning-    CS.Complete (Nothing, _) -> return Cached-    CS.Complete (Just t, _) -> return (Success t)+    CS.Pending ()              -> return AlreadyRunning+    CS.Complete (Nothing, _)   -> return Cached+    CS.Complete (Just t, _)    -> return (Success t)   where     logError = flip withException $ \(e::SomeException) ->       $(logTM) ErrorS . ls $ displayException e

@@ -69,14 +69,14 @@ echo :: SimpleFlow String CS.Item echo = external $ \msg -> ExternalTask   { _etCommand = "echo"-  , _etWriteToStdOut = True+  , _etWriteToStdOut = StdOutCapture   , _etParams = ["-n", fromString msg]   }  sleepEcho :: SimpleFlow (Double, String) CS.Item sleepEcho = external $ \(time, msg) -> ExternalTask   { _etCommand = "sh"-  , _etWriteToStdOut = True+  , _etWriteToStdOut = StdOutCapture   , _etParams =       [ "-c"       , "sleep " <> fromString (show time) <> ";"

@@ -88,7 +88,7 @@   r <- (arr Right <<< external (\() -> ExternalTask     { _etCommand = "non-existent-executable-39fd1e85a0a05113938e0"     , _etParams = []-    , _etWriteToStdOut = True+    , _etWriteToStdOut = StdOutCapture     }))     `catch` arr (Left @SomeException . snd)     -< ()