summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormarkfine <>2016-08-19 21:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-08-19 21:21:00 (GMT)
commit40be20635f9c7123dd348a1e21964c7e36317d3f (patch)
tree41eb1e9bdf0e1a3f6a6822bea26e57628d6848ec
parent65cdda287293a4a4c253c137618c7160bc970a9d (diff)
version 0.2.80.2.8
-rw-r--r--main/Act.hs50
-rw-r--r--main/Act2.hs23
-rw-r--r--src/Network/AWS/Flow.hs17
-rw-r--r--wolf.cabal2
4 files changed, 50 insertions, 42 deletions
diff --git a/main/Act.hs b/main/Act.hs
index 7498f51..72ec4a4 100644
--- a/main/Act.hs
+++ b/main/Act.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
module Act
( main
) where
@@ -74,16 +75,19 @@ instance ToJSON Control where
encodeText :: ToJSON a => a -> Text
encodeText = toStrict . toLazyText . encodeToTextBuilder . toJSON
-exec :: MonadIO m => Args -> Container -> Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact])
+handler :: MonadBaseControl IO m => m () -> m (Maybe SomeException)
+handler a = handle (return . Just) $ a >> return Nothing
+
+exec :: MonadIO m => Args -> Container -> Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact], Maybe SomeException)
exec Args{..} container uid metadata blobs =
shelly $ withDir $ \dir dataDir storeDir -> do
control $ dataDir </> pack "control.json"
storeInput $ storeDir </> pack "input"
dataInput $ dataDir </> pack "input.json"
- maybe (docker dataDir storeDir container) (bash dir container) aContainerless
+ e <- maybe (docker dataDir storeDir container) (bash dir container) aContainerless
result <- dataOutput $ dataDir </> pack "output.json"
artifacts <- storeOutput $ storeDir </> pack "output"
- return (result, artifacts) where
+ return (result, artifacts, e) where
withDir action =
withTmpDir $ \dir -> do
mkdir $ dir </> pack "data"
@@ -129,25 +133,27 @@ exec Args{..} container uid metadata blobs =
storeOutput dir = do
artifacts <- findWhen test_f dir
forM artifacts $ readArtifact dir
- docker dataDir storeDir Container{..} = do
- devices <- forM cDevices $ \device ->
- liftM strip $ run "readlink" ["-f", device]
- run_ "docker" $ concat
- [["run"]
- , concatMap (("--device" :) . return) devices
- , concatMap (("--env" :) . return) cEnvironment
- , concatMap (("--link" :) . return) cLink
- , concatMap (("--volume" :) . return) $
- toTextIgnore dataDir <> ":/app/data" :
- toTextIgnore storeDir <> ":/app/store" : cVolumes
- , [cImage]
- , words cCommand
- ]
- bash dir Container{..} bashDir = do
- files <- ls $ fromText $ pack bashDir
- forM_ files $ flip cp_r dir
- cd dir
- maybe (return ()) (uncurry $ run_ . fromText) $ uncons $ words cCommand
+ docker dataDir storeDir Container{..} =
+ handler $ do
+ devices <- forM cDevices $ \device ->
+ liftM strip $ run "readlink" ["-f", device]
+ run_ "docker" $ concat
+ [["run"]
+ , concatMap (("--device" :) . return) devices
+ , concatMap (("--env" :) . return) cEnvironment
+ , concatMap (("--link" :) . return) cLink
+ , concatMap (("--volume" :) . return) $
+ toTextIgnore dataDir <> ":/app/data" :
+ toTextIgnore storeDir <> ":/app/store" : cVolumes
+ , [cImage]
+ , words cCommand
+ ]
+ bash dir Container{..} bashDir =
+ handler $ do
+ files <- ls $ fromText $ pack bashDir
+ forM_ files $ flip cp_r dir
+ cd dir
+ maybe (return ()) (uncurry $ run_ . fromText) $ uncons $ words cCommand
call :: Args -> IO ()
call Args{..} = do
diff --git a/main/Act2.hs b/main/Act2.hs
index fdfb0a8..e866ce1 100644
--- a/main/Act2.hs
+++ b/main/Act2.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
module Act2
( main
) where
@@ -50,16 +51,19 @@ instance ToJSON Control where
encodeText :: ToJSON a => a -> Text
encodeText = toStrict . toLazyText . encodeToTextBuilder . toJSON
-exec :: MonadIO m => Text -> Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact])
+handler :: MonadBaseControl IO m => m () -> m (Maybe SomeException)
+handler a = handle (return . Just) $ a >> return Nothing
+
+exec :: MonadIO m => Text -> Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact], Maybe SomeException)
exec cmdline uid metadata blobs =
shelly $ withDir $ \dir dataDir storeDir -> do
control $ dataDir </> pack "control.json"
storeInput $ storeDir </> pack "input"
dataInput $ dataDir </> pack "input.json"
- bash dir
+ e <- bash dir
result <- dataOutput $ dataDir </> pack "output.json"
artifacts <- storeOutput $ storeDir </> pack "output"
- return (result, artifacts) where
+ return (result, artifacts, e) where
withDir action =
withTmpDir $ \dir -> do
mkdir $ dir </> pack "data"
@@ -93,12 +97,13 @@ exec cmdline uid metadata blobs =
storeOutput dir = do
artifacts <- findWhen test_f dir
forM artifacts $ readArtifact dir
- bash dir = do
- bashDir <- pwd
- files <- ls bashDir
- forM_ files $ flip cp_r dir
- cd dir
- maybe (return ()) (uncurry $ run_ . fromText) $ uncons $ words cmdline
+ bash dir =
+ handler $ do
+ bashDir <- pwd
+ files <- ls bashDir
+ forM_ files $ flip cp_r dir
+ cd dir
+ maybe (return ()) (uncurry $ run_ . fromText) $ uncons $ words cmdline
call :: Args -> IO ()
call Args{..} = do
diff --git a/src/Network/AWS/Flow.hs b/src/Network/AWS/Flow.hs
index add4e33..a051012 100644
--- a/src/Network/AWS/Flow.hs
+++ b/src/Network/AWS/Flow.hs
@@ -36,7 +36,6 @@ import Control.Monad.Catch
import Data.Char
import qualified Data.HashMap.Strict as Map
import Data.Text ( pack )
-import Data.Typeable
import Formatting hiding ( string )
import Network.AWS.SWF
import Network.HTTP.Types
@@ -94,13 +93,12 @@ exitCode =
actException :: MonadFlow m => Token -> SomeException -> m ()
actException token e = do
- logError' $ sformat ("event=act-exception-type " % stext) $ show $ typeOf e
logError' $ sformat ("event=act-exception " % stext) $ show e
maybe' ((textToString $ show e) =~ exitCode) (respondActivityTaskFailedAction token) $ \code -> do
if code == 255 then respondActivityTaskCanceledAction token else
respondActivityTaskFailedAction token
-act :: MonadFlow m => Queue -> (Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact])) -> m ()
+act :: MonadFlow m => Queue -> (Uid -> Metadata -> [Blob] -> m (Metadata, [Artifact], Maybe SomeException)) -> m ()
act queue action =
handle serializeError $ do
logInfo' "event=act"
@@ -112,13 +110,12 @@ act queue action =
unless (null keys) $ logInfo' $ sformat ("event=list-blobs uid=" % stext) uid
blobs <- forM keys $ getObjectAction uid
unless (null blobs) $ logInfo' $ sformat ("event=blobs uid=" % stext) uid
- handle (actException token) $ do
- (output, artifacts) <- action uid input blobs
- maybe_ output $ logDebug' . sformat ("event=act-output " % stext)
- logInfo' $ sformat ("event=act-finish uid=" % stext) uid
- forM_ artifacts $ putObjectAction uid
- unless (null artifacts) $ logInfo' $ sformat ("event=artifacts uid=" % stext) uid
- respondActivityTaskCompletedAction token output
+ (output, artifacts, e) <- action uid input blobs
+ maybe_ output $ logDebug' . sformat ("event=act-output " % stext)
+ logInfo' $ sformat ("event=act-finish uid=" % stext) uid
+ forM_ artifacts $ putObjectAction uid
+ unless (null artifacts) $ logInfo' $ sformat ("event=artifacts uid=" % stext) uid
+ maybe (respondActivityTaskCompletedAction token output) (actException token) e
decide :: MonadFlow m => Plan -> m ()
decide plan@Plan{..} =
diff --git a/wolf.cabal b/wolf.cabal
index bad5a2c..ff22967 100644
--- a/wolf.cabal
+++ b/wolf.cabal
@@ -1,5 +1,5 @@
name: wolf
-version: 0.2.7
+version: 0.2.8
synopsis: Amazon Simple Workflow Service Wrapper.
homepage: https://github.com/swift-nav/wolf
license: MIT