diff --git a/TestFunflow.hs b/TestFunflow.hs --- a/TestFunflow.hs +++ b/TestFunflow.hs @@ -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 diff --git a/funflow.cabal b/funflow.cabal --- a/funflow.cabal +++ b/funflow.cabal @@ -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 diff --git a/src/Control/Funflow/External.hs b/src/Control/Funflow/External.hs --- a/src/Control/Funflow/External.hs +++ b/src/Control/Funflow/External.hs @@ -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 diff --git a/src/Control/Funflow/External/Docker.hs b/src/Control/Funflow/External/Docker.hs --- a/src/Control/Funflow/External/Docker.hs +++ b/src/Control/Funflow/External/Docker.hs @@ -51,7 +51,7 @@ [ imageArg , stringParam (command cfg) ] ++ map textParam (args cfg) - , _etWriteToStdOut = False + , _etWriteToStdOut = NoOutputCapture } where mounts = outputMount : inputMounts diff --git a/src/Control/Funflow/External/Executor.hs b/src/Control/Funflow/External/Executor.hs --- a/src/Control/Funflow/External/Executor.hs +++ b/src/Control/Funflow/External/Executor.hs @@ -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 diff --git a/test/Funflow/SQLiteCoordinator.hs b/test/Funflow/SQLiteCoordinator.hs --- a/test/Funflow/SQLiteCoordinator.hs +++ b/test/Funflow/SQLiteCoordinator.hs @@ -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) <> ";" diff --git a/test/Funflow/TestFlows.hs b/test/Funflow/TestFlows.hs --- a/test/Funflow/TestFlows.hs +++ b/test/Funflow/TestFlows.hs @@ -88,7 +88,7 @@ r <- (arr Right <<< external (\() -> ExternalTask { _etCommand = "non-existent-executable-39fd1e85a0a05113938e0" , _etParams = [] - , _etWriteToStdOut = True + , _etWriteToStdOut = StdOutCapture })) `catch` arr (Left @SomeException . snd) -< ()