summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authornclarke <>2018-07-03 07:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-07-03 07:29:00 (GMT)
commit64ea52e9497cd0ea7c37ebb6112d24af83ab90ba (patch)
tree4edb6a8313ecc6f2433401171be7f3dd8e89a7e9
parent1f39d7f795db9c5c259526053806cb0d6e0cbfad (diff)
version 1.1.01.1.0
-rw-r--r--TestFunflow.hs4
-rw-r--r--funflow.cabal2
-rw-r--r--src/Control/Funflow/External.hs31
-rw-r--r--src/Control/Funflow/External/Docker.hs2
-rw-r--r--src/Control/Funflow/External/Executor.hs31
-rw-r--r--test/Funflow/SQLiteCoordinator.hs4
-rw-r--r--test/Funflow/TestFlows.hs2
7 files changed, 48 insertions, 28 deletions
diff --git a/TestFunflow.hs b/TestFunflow.hs
index 667d33d..63e7adf 100644
--- a/TestFunflow.hs
+++ b/TestFunflow.hs
@@ -55,7 +55,7 @@ externalTest = let
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 @@ storeTest = let
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
index d489107..9e02b66 100644
--- 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
index 318713c..2a5eb12 100644
--- 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 @@ gidParam = Param [ParamGid]
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
index 5631b76..c5398ae 100644
--- a/src/Control/Funflow/External/Docker.hs
+++ b/src/Control/Funflow/External/Docker.hs
@@ -51,7 +51,7 @@ toExternal cfg = ExternalTask
[ 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
index a74d6ad..1503767 100644
--- 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 @@ execute store td = logError $ do
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 @@ execute store td = logError $ do
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 @@ execute store td = logError $ do
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 @@ execute store td = logError $ do
-- 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
index 4851e9c..faaa734 100644
--- a/test/Funflow/SQLiteCoordinator.hs
+++ b/test/Funflow/SQLiteCoordinator.hs
@@ -69,14 +69,14 @@ runTestFlow wd flow' input =
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
index 3732c43..c0e578f 100644
--- a/test/Funflow/TestFlows.hs
+++ b/test/Funflow/TestFlows.hs
@@ -88,7 +88,7 @@ flowMissingExecutable = proc () -> do
r <- (arr Right <<< external (\() -> ExternalTask
{ _etCommand = "non-existent-executable-39fd1e85a0a05113938e0"
, _etParams = []
- , _etWriteToStdOut = True
+ , _etWriteToStdOut = StdOutCapture
}))
`catch` arr (Left @SomeException . snd)
-< ()