packages feed

wolf 0.2.14 → 0.3.0

raw patch · 35 files changed

+1565/−50 lines, 35 filesdep +conduit-combinatorsdep +directorydep +filemanipdep ~basenew-component:exe:shake-wolfnew-component:exe:wolf-actornew-component:exe:wolf-decider

Dependencies added: conduit-combinators, directory, filemanip, lifted-async, lifted-base, optparse-generic, process, shake, template-haskell, text-manipulate

Dependency ranges changed: base

Files

+ Shakefile.hs view
@@ -0,0 +1,315 @@+#!/usr/bin/env stack+{- stack+    runghc+    --package basic-prelude+    --package directory+    --package shake+ -}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Shake makefile for project.+--+import BasicPrelude+import Data.Char+import Development.Shake+import Development.Shake.FilePath+import System.Directory++-- | This file used for version change detection.+--+thisFile :: FilePath+thisFile = "Shakefile.hs"++-- | Location of build supporting files.+--+buildDir :: FilePath+buildDir = ".build"++-- | Location of stack's work files.+--+stackDir :: FilePath+stackDir = ".stack-work"++-- | Build directory where "touch" files are kept.+--+fakeDir :: FilePath+fakeDir = buildDir </> "fake"++-- | Build directory where docker files are kept.+--+dockerDir :: Action FilePath+dockerDir = do+  dir <- liftIO getCurrentDirectory+  return $ buildDir </> takeFileName dir++-- | Fake directory path builder.+--+fd :: FilePath -> FilePath+fd = (fakeDir </>)++-- | Remove right excess on string.+--+rstrip :: String -> String+rstrip = reverse . dropWhile isSpace . reverse++-- | Typeful command args with return string.+--+cmdArgs :: String -> [String] -> Action String+cmdArgs c as = rstrip . fromStdout <$> cmd c as++-- | Typeful command args with no return.+--+cmdArgs_ :: String -> [String] -> Action ()+cmdArgs_ c as = unit $ cmd c as++-- | Run commands in a dir with return string.+--+_cmdArgsDir :: FilePath -> String -> [String] -> Action String+_cmdArgsDir d c as = rstrip . fromStdout <$> cmd (Cwd d) c as++-- | Run commands in a dir with no return.+--+cmdArgsDir_ :: FilePath -> String -> [String] -> Action ()+cmdArgsDir_ d c as = unit $ cmd (Cwd d) c as++-- | Run docker command in docker dir.+--+docker :: [String] -> Action ()+docker args = do+  dir <- dockerDir+  cmdArgsDir_ dir "docker" args++-- | Stack command.+--+stack :: [String] -> Action ()+stack = cmdArgs_ "stack"++-- | Stack exec command.+--+_stackExec :: String -> [String] -> Action ()+_stackExec cmd' args = stack $ "exec" : cmd' : "--" : args++-- | Sylish command.+--+stylish :: [String] -> Action ()+stylish = cmdArgs_ "stylish-haskell"++-- | Lint command.+--+lint :: [String] -> Action ()+lint = cmdArgs_ "hlint"++-- | Git command.+--+git :: [String] -> Action String+git = cmdArgs "git"++-- | m4 command.+--+m4 :: [String] -> Action String+m4 = cmdArgs "m4"++-- | Version.+--+version :: Action String+version = git [ "describe", "--tags", "--abbrev=0" ]++-- | Touch a file for fake files.+--+touchFile :: FilePath -> Action ()+touchFile = flip writeFile' mempty++-- | Copy a file if changed, creating parent directories.+--+copyFileChanged' :: FilePath -> FilePath -> Action ()+copyFileChanged' a b = do+  liftIO $ createDirectoryIfMissing True $ dropFileName b+  copyFileChanged a b++-- | Preprocess a file with m4+--+preprocess :: FilePattern -> FilePath -> Action [(String, String)] -> Rules ()+preprocess target file macros =+  target %> \out -> do+    need [ file ]+    let f k v = "-D" <> k <> "=" <> v+    macros' <- macros+    content <- m4 $ file : (uncurry f <$> macros')+    writeFileChanged out content++-- | Use a fake file to keep track of the last time an file-free action ran.+--+fake :: [FilePattern] -> String -> ([FilePath] -> Action ()) -> Rules ()+fake pats target act = do+  fd target %> \out -> do+    files <- getDirectoryFiles "." pats+    need files+    act files+    touchFile out++  phony target $+    need [ fd target ]++-- | Global rules+--+globalRules :: Rules ()+globalRules = do+  let pats =+        [ "stack.yaml"+        , "Shakefile.hs"+        , "main//*.hs"+        , "src//*.hs"+        , "test//*.hs"+        ]++  -- | wolf.cabal+  --+  preprocess "wolf.cabal" "wolf.cabal.m4" $ do+    v <- version+    return [ ("VERSION", v) ]++  -- | build+  --+  fake pats "build" $ \_files -> do+    stack [ "build", "--fast" ]++  -- | build-error+  --+  fake pats "build-error" $ \_files -> do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--ghc-options=-Werror" ]++  -- | build-tests+  --+  fake pats "build-tests" $ \_files -> do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--test", "--no-run-tests" ]++  -- | build-tests-error+  --+  fake pats "build-tests-error" $ \_files -> do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--test", "--no-run-tests", "--ghc-options=-Werror" ]++  -- | tests+  --+  phony "tests" $ do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--test" ]++  -- | tests-error+  --+  phony "tests-error" $ do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--test", "--ghc-options=-Werror" ]++  -- | ghci+  --+  phony "ghci" $ do+    need [ "wolf.cabal" ]+    stack [ "ghci", "--fast" ]++  -- | ghci-tests+  --+  phony "ghci-tests" $ do+    need [ "wolf.cabal" ]+    stack [ "ghci", "--fast", "--test" ]++  -- | install+  --+  fake pats "install" $ \_files -> do+    need [ "wolf.cabal" ]+    stack [ "build", "--fast", "--copy-bins" ]++  -- | publish+  --+  phony "publish" $ do+    need [ "wolf.cabal" ]+    stack [ "sdist" ]+    stack [ "upload", "." ]++  -- | clean+  --+  phony "clean" $ do+    need [ "wolf.cabal" ]+    stack [ "clean" ]+    removeFilesAfter buildDir [ "//*" ]++  -- | clear+  --+  phony "clear" $+    forM_ [ fakeDir ] $ \dir ->+      removeFilesAfter dir [ "//*" ]++  -- | wipe+  --+  phony "wipe" $ do+    removeFilesAfter buildDir [ "//*" ]+    removeFilesAfter stackDir [ "//*" ]++  -- | sanity+  --+  phony "sanity" $+    need [ "tests-error", "lint" ]++-- | Haskell source rules+--+hsRules :: Rules ()+hsRules = do+  let pats =+        [ "Shakefile.hs"+        , "main//*.hs"+        , "src//*.hs"+        , "test//*.hs"+        ]++  -- | format+  --+  fake pats "format" $ \files -> do+    need [ ".stylish-haskell.yaml" ]+    stylish $ [ "-c", ".stylish-haskell.yaml", "-i" ] <> files++  -- | lint+  --+  fake pats "lint" $ \files ->+    lint files++-- | Docker rules+--+dockerRules :: Rules ()+dockerRules = do+  let pats =+        [ "Dockerfile"+        , "Shakefile.hs"+        , ".dockerignore"+        , "stack.yaml"+        , "registrar.cabal"+        , "main//*.hs"+        , "src//*.hs"+        ]++  -- | docker:setup+  --+  fake pats "docker:setup" $ \files ->+    forM_ files $ \file -> do+      dir <- dockerDir+      copyFileChanged' file $ dir </> file++  -- | docker:build+  --+  phony "docker:build" $ do+    need [ "docker:setup" ]+    docker [ "build", "." ]++-- | Main entry point+--+main :: IO ()+main = do+  v <- getHashedShakeVersion [thisFile]+  shakeArgs shakeOptions { shakeFiles = buildDir, shakeVersion = v } $ do+    want [ "tests-error", "lint", "format" ]+    globalRules+    hsRules+    dockerRules
main/Act.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} module Act   ( main   ) where -import           BasicPrelude hiding ( ByteString, (</>), (<.>), hash, length, readFile, find )+import           BasicPrelude                 hiding (ByteString, find, hash, length,+                                               readFile, (<.>), (</>)) import           Codec.Compression.GZip import           Control.Monad.Trans.Resource import           Data.Aeson.Encode-import           Data.ByteString ( length )-import qualified Data.ByteString.Lazy as BL-import           Data.Text ( pack, strip )-import           Data.Text.Lazy ( toStrict )-import           Data.Text.Lazy.Builder hiding ( fromText )-import           Data.Yaml hiding ( Parser )-import           Filesystem.Path ( (<.>), dropExtension )+import           Data.ByteString              (length)+import qualified Data.ByteString.Lazy         as BL+import           Data.Text                    (pack, strip)+import           Data.Text.Lazy               (toStrict)+import           Data.Text.Lazy.Builder       hiding (fromText)+import           Data.Yaml                    hiding (Parser)+import           Filesystem.Path              (dropExtension, (<.>)) import           Network.AWS.Data.Crypto import           Network.AWS.Flow import           Options-import           Options.Applicative hiding ( action )-import           Shelly hiding ( FilePath, (<.>), bash )+import           Options.Applicative          hiding (action)+import           Shelly                       hiding (FilePath, bash, (<.>))  data Args = Args   { aConfig        :: FilePath@@ -124,10 +126,10 @@       dataOutput file =         catch_sh_maybe (readfile file) where           catch_sh_maybe action =-            catch_sh (liftM Just action) $ \(_ :: SomeException) -> return Nothing+            catch_sh (Just <$> action) $ \(_ :: SomeException) -> return Nothing       storeInput dir =         forM_ blobs $ \(key, blob) -> do-          paths <- liftM strip $ run "dirname" [key]+          paths <- strip <$> run "dirname" [key]           mkdir_p $ dir </> paths           writeArtifact (dir </> key) blob       storeOutput dir = do@@ -136,7 +138,7 @@       docker dataDir storeDir Container{..} =         handler $ do           devices <- forM cDevices $ \device ->-            liftM strip $ run "readlink" ["-f", device]+            strip <$> run "readlink" ["-f", device]           run_ "docker" $ concat             [["run"]             , concatMap (("--device" :)  . return) devices
main/Act2.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} module Act2   ( main   ) where -import           BasicPrelude hiding ( ByteString, (</>), (<.>), hash, length, readFile, find )+import           BasicPrelude                 hiding (ByteString, find, hash, length,+                                               readFile, (<.>), (</>)) import           Codec.Compression.GZip import           Control.Monad.Trans.Resource import           Data.Aeson.Encode-import           Data.ByteString ( length )-import qualified Data.ByteString.Lazy as BL-import           Data.Text ( pack, strip )-import           Data.Text.Lazy ( toStrict )-import           Data.Text.Lazy.Builder hiding ( fromText )-import           Data.Yaml hiding ( Parser )-import           Filesystem.Path ( (<.>), dropExtension )+import           Data.ByteString              (length)+import qualified Data.ByteString.Lazy         as BL+import           Data.Text                    (pack, strip)+import           Data.Text.Lazy               (toStrict)+import           Data.Text.Lazy.Builder       hiding (fromText)+import           Data.Yaml                    hiding (Parser)+import           Filesystem.Path              (dropExtension, (<.>)) import           Network.AWS.Data.Crypto import           Network.AWS.Flow import           Options-import           Options.Applicative hiding ( action )-import           Shelly hiding ( FilePath, (<.>), bash )+import           Options.Applicative          hiding (action)+import           Shelly                       hiding (FilePath, bash, (<.>))  data Args = Args   { aConfig      :: FilePath@@ -101,10 +103,10 @@       dataOutput file =         catch_sh_maybe (readfile file) where           catch_sh_maybe action =-            catch_sh (liftM Just action) $ \(_ :: SomeException) -> return Nothing+            catch_sh (Just <$> action) $ \(_ :: SomeException) -> return Nothing       storeInput dir =         forM_ blobs $ \(key, blob) -> do-          paths <- liftM strip $ run "dirname" [key]+          paths <- strip <$> run "dirname" [key]           mkdir_p $ dir </> paths           writeArtifact (dir </> key) blob       storeOutput dir = do
main/Decide.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+ module Decide   ( main   ) where@@ -5,7 +7,7 @@ import BasicPrelude import Control.Concurrent.Async import Control.Monad.Trans.Resource-import Data.Yaml hiding ( Parser )+import Data.Yaml                    hiding (Parser) import Network.AWS.Flow import Options import Options.Applicative
main/Execute.hs view
@@ -1,12 +1,14 @@+{-# LANGUAGE RecordWildCards #-}+ module Execute   ( main   ) where -import BasicPrelude hiding ( readFile )+import BasicPrelude                 hiding (readFile) import Control.Concurrent.Async import Control.Monad.Trans.Resource import Data.Text.IO-import Data.Yaml hiding ( Parser )+import Data.Yaml                    hiding (Parser) import Network.AWS.Flow import Options import Options.Applicative
main/Register.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE RecordWildCards #-}+ module Register   ( main   ) where  import BasicPrelude import Control.Concurrent.Async-import Control.Monad.Trans.Resource hiding ( register )-import Data.Yaml hiding ( Parser )+import Control.Monad.Trans.Resource hiding (register)+import Data.Yaml                    hiding (Parser) import Network.AWS.Flow import Options import Options.Applicative
+ main/actor.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Run actor.+--+import Network.AWS.Wolf+import Options.Generic++-- | Args+--+-- Program arguments.+--+data Args = Args+  { config  :: FilePath+    -- ^ Configuration file.+  , queue   :: Text+    -- ^ Queue to listen to act on.+  , command :: String+    -- ^ Command to run.+  } deriving (Show, Generic)++instance ParseRecord Args++-- | Run actor.+--+main :: IO ()+main = do+  args <- getRecord "Actor"+  runResourceT $ actMain+    (config args)+    (queue args)+    (command args)
+ main/decider.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Run actor.+--+import Network.AWS.Wolf+import Options.Generic++-- | Args+--+-- Program arguments.+--+data Args = Args+  { config :: FilePath+    -- ^ Configuration file.+  , plan   :: FilePath+    -- ^ Plan file to decide on.+  } deriving (Show, Generic)++instance ParseRecord Args++-- | Run decider.+--+main :: IO ()+main = do+  args <- getRecord "Decider"+  runResourceT $ decideMain+    (config args)+    (plan args)
src/Network/AWS/Flow.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}  module Network.AWS.Flow   ( register@@ -26,17 +27,17 @@  import           Network.AWS.Flow.Env import           Network.AWS.Flow.Logger+import           Network.AWS.Flow.Prelude hiding (ByteString, Metadata, handle) import           Network.AWS.Flow.S3 import           Network.AWS.Flow.SWF import           Network.AWS.Flow.Types import           Network.AWS.Flow.Uid-import           Network.AWS.Flow.Prelude hiding ( ByteString, Metadata, handle )  import           Control.Monad.Catch import           Data.Char-import qualified Data.HashMap.Strict as Map-import           Data.Text ( pack )-import           Formatting hiding ( string )+import qualified Data.HashMap.Strict      as Map+import           Data.Text                (pack)+import           Formatting               hiding (string) import           Network.AWS.SWF import           Network.HTTP.Types import           Safe@@ -85,7 +86,7 @@ actException :: MonadFlow m => Token -> SomeException -> m () actException token e = do   logError' $ sformat ("event=act-exception " % stext) $ show e-  maybe' ((textToString $ show e) =~ exitCode) (respondActivityTaskFailedAction token) $ \code -> do+  maybe' (textToString (show e) =~ exitCode) (respondActivityTaskFailedAction token) $ \code ->     if code == 255 then respondActivityTaskCanceledAction token else       respondActivityTaskFailedAction token
src/Network/AWS/Flow/Env.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+ module Network.AWS.Flow.Env   ( flowEnv   ) where
src/Network/AWS/Flow/Logger.hs view
@@ -12,7 +12,7 @@ import Data.Time.Clock import Data.Time.Format import Data.Version-import Formatting hiding ( now )+import Formatting               hiding (now) import Paths_wolf import System.Log.FastLogger
src/Network/AWS/Flow/Prelude.hs view
@@ -7,10 +7,12 @@   , maybe'   ) where -import BasicPrelude hiding ( (<.>), uncons )+import BasicPrelude            hiding (uncons, (<.>)) import Control.Lens import Control.Monad.Reader import Control.Monad.Trans.AWS++{-# ANN module ("HLint: ignore Use import/export shortcut"::String) #-}  maybe_ :: Monad m => Maybe a -> (a -> m ()) -> m () maybe_ m f = maybe (return ()) f m
src/Network/AWS/Flow/S3.hs view
@@ -4,16 +4,18 @@   , putObjectAction   ) where -import Network.AWS.Flow.Prelude hiding ( ByteString, hash, stripPrefix )+import Network.AWS.Flow.Prelude hiding (ByteString, hash, stripPrefix) import Network.AWS.Flow.Types  import Data.Conduit-import Data.Conduit.List hiding ( concatMap, map, mapMaybe ) import Data.Conduit.Binary-import Data.Text hiding ( concatMap, map )+import Data.Conduit.List        hiding (concatMap, map, mapMaybe)+import Data.Text                hiding (concatMap, map) import Network.AWS.Data.Body import Network.AWS.Data.Text import Network.AWS.S3++{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}  -- Actions
src/Network/AWS/Flow/SWF.hs view
@@ -18,11 +18,11 @@   , startChildWorkflowExecutionDecision   ) where -import Network.AWS.Flow.Prelude hiding ( Metadata )+import Network.AWS.Flow.Prelude hiding (Metadata) import Network.AWS.Flow.Types  import Data.Conduit-import Data.Conduit.List hiding ( concatMap )+import Data.Conduit.List        hiding (concatMap) import Network.AWS.SWF import Safe
src/Network/AWS/Flow/Types.hs view
@@ -1,14 +1,14 @@ {-# OPTIONS  -fno-warn-orphans          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  module Network.AWS.Flow.Types where -import Network.AWS.Flow.Prelude hiding ( ByteString, catch )+import Network.AWS.Flow.Prelude     hiding (ByteString, catch)  import Control.Monad.Base import Control.Monad.Catch
+ src/Network/AWS/Wolf.hs view
@@ -0,0 +1,9 @@+-- | Public Module+--+module Network.AWS.Wolf+  ( module Exports+  ) where++import Network.AWS.Wolf.Act     as Exports+import Network.AWS.Wolf.Decide  as Exports+import Network.AWS.Wolf.Prelude as Exports
+ src/Network/AWS/Wolf/Act.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | SWF Actor logic.+--+module Network.AWS.Wolf.Act+  ( act+  , actMain+  ) where++import Data.Aeson+import Network.AWS.Wolf.Ctx+import Network.AWS.Wolf.File+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.S3+import Network.AWS.Wolf.SWF+import Network.AWS.Wolf.Trace+import Network.AWS.Wolf.Types+import System.Process++-- | Download artifacts to the store input directory.+--+download :: MonadAmazonStore c m => FilePath -> m ()+download dir = do+  ks <- listArtifacts+  forM_ ks $ \k -> do+    traceInfo "get-artifact" [ "key" .= k ]+    getArtifact (dir </> textToString k) k++-- | Upload artifacts from the store output directory.+--+upload :: MonadAmazonStore c m => FilePath -> m ()+upload dir = do+  fs <- findRegularFiles dir+  forM_ fs $ \f -> do+    let k = stripPrefix' (textFromString dir) (textFromString f)+    traceInfo "put-artifact" [ "key" .= k ]+    traverse (putArtifact f) k++-- | callCommand wrapper that maybe returns an exception.+--+callCommand' :: MonadMain m => String -> m (Maybe SomeException)+callCommand' command =+  handle (return . Just) $ do+    liftIO $ callCommand command+    return Nothing++-- | Run command and maybe returns an exception.+--+run :: MonadCtx c m => String -> m (Maybe SomeException)+run command =+  preCtx [ "command" .= command ] $ do+    traceInfo "begin" mempty+    e <- callCommand' command+    traceInfo "end" [ "exception" .= (displayException <$> e) ]+    return e++-- | Actor logic - poll for work, download artifacts, run command, upload artifacts.+--+act :: MonadConf c m => Text -> String -> m ()+act queue command =+  preConfCtx [ "label" .= LabelAct ] $+    runAmazonCtx $+      runAmazonWorkCtx queue $ do+        traceInfo "poll" mempty+        (token, uid, input) <- pollActivity+        maybe_ token $ \token' ->+          maybe_ uid $ \uid' ->+            withCurrentWorkDirectory uid' $ \wd ->+              runAmazonStoreCtx uid' $ do+                traceInfo "start" [ "input" .= input, "dir" .= wd ]+                dd  <- dataDirectory wd+                sd  <- storeDirectory wd+                isd <- inputDirectory sd+                osd <- outputDirectory sd+                writeJson (dd </> "control.json") (Control uid')+                writeText (dd </> "input.json") input+                download isd+                e <- run command+                upload osd+                output <- readText (dd </> "output.json")+                maybe (completeActivity token' output) (const $ failActivity token') e+                traceInfo "finish" [ "output" .= output ]++-- | Run actor from main with config file.+--+actMain :: MonadMain m => FilePath -> Text -> String -> m ()+actMain cf queue command =+  runCtx $ do+    conf <- readYaml cf+    runConfCtx conf $+      forever $ act queue command
+ src/Network/AWS/Wolf/Aeson.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Aeson generic deriving options.+--+module Network.AWS.Wolf.Aeson+  ( camelOptions+  , snakeOptions+  , spinalOptions+  ) where++import Data.Aeson.Types+import Data.Char+import Data.Text+import Data.Text.Manipulate+import Network.AWS.Wolf.Prelude hiding (dropWhile)++-- | Remove characters up to the first upper case character.+--+unprefix :: Text -> Text+unprefix = dropWhile (not . isUpper)++-- | Derive fields with camelCase.+--+camelOptions :: Options+camelOptions = defaultOptions+  { fieldLabelModifier     = unpack . toCamel . unprefix . pack+  , constructorTagModifier = unpack . toCamel . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }++-- | Derive fields with snake_case.+--+snakeOptions :: Options+snakeOptions = defaultOptions+  { fieldLabelModifier     = unpack . toSnake . unprefix . pack+  , constructorTagModifier = unpack . toSnake . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }++-- | Derive fields with spinal-case.+--+spinalOptions :: Options+spinalOptions = defaultOptions+  { fieldLabelModifier     = unpack . toSpinal . unprefix . pack+  , constructorTagModifier = unpack . toSpinal . unprefix . lowerHead . pack+  , omitNothingFields      = True+  }
+ src/Network/AWS/Wolf/Ctx.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.AWS.Wolf.Ctx+  ( runCtx+  , preCtx+  , runConfCtx+  , preConfCtx+  , runAmazonCtx+  , preAmazonCtx+  , runAmazonStoreCtx+  , preAmazonStoreCtx+  , runAmazonWorkCtx+  , preAmazonWorkCtx+  ) where++import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.AWS+import Data.Aeson+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.Trace+import Network.AWS.Wolf.Types++-- | Run monad transformer, picking up logger from context.+--+runTransT :: HasCtx c => c -> TransT c m a -> m a+runTransT c m =+  runReaderT (runLoggingT (unTransT m) (c ^. cTrace)) c++-- | Run base context.+--+runCtx :: MonadIO m => TransT Ctx m a -> m a+runCtx action = do+  t <- liftIO $ newStderrTrace LevelInfo+  runTransT (Ctx mempty t) action++-- | Update base context's preamble.+--+preCtx :: MonadCtx c m => Pairs -> TransT Ctx m a -> m a+preCtx preamble action = do+  c <- view ctx <&> cPreamble <>~ preamble+  runTransT c action++-- | Run configuration context.+--+runConfCtx :: MonadCtx c m => Conf -> TransT ConfCtx m a -> m a+runConfCtx conf action = do+  let preamble =+        [ "domain" .= (conf ^. cDomain)+        , "bucket" .= (conf ^. cBucket)+        , "prefix" .= (conf ^. cPrefix)+        ]+  c <- view ctx <&> cPreamble <>~ preamble+  runTransT (ConfCtx c conf) action++-- | Update configuration context's preamble.+--+preConfCtx :: MonadConf c m => Pairs -> TransT ConfCtx m a -> m a+preConfCtx preamble action = do+  c <- view confCtx <&> cPreamble <>~ preamble+  runTransT c action++-- | Run amazon context.+--+runAmazonCtx :: MonadConf c m => TransT AmazonCtx m a -> m a+runAmazonCtx action = do+  c <- view confCtx+  e <- newEnv Oregon $ FromEnv "AWS_ACCESS_KEY_ID" "AWS_SECRET_ACCESS_KEY" mempty+  runTransT (AmazonCtx c e) action++-- | Update amazon context's preamble.+--+preAmazonCtx :: MonadAmazon c m => Pairs -> TransT AmazonCtx m a -> m a+preAmazonCtx preamble action = do+  c <- view amazonCtx <&> cPreamble <>~ preamble+  runTransT c action++-- | Run amazon store context.+--+runAmazonStoreCtx :: MonadAmazon c m => Text -> TransT AmazonStoreCtx m a -> m a+runAmazonStoreCtx uid action = do+  let preamble = [ "uid" .= uid ]+  c <- view amazonCtx <&> cPreamble <>~ preamble+  p <- (<\> uid) . view cPrefix <$> view ccConf+  runTransT (AmazonStoreCtx c uid p) action++-- | Update amazon context's preamble.+--+preAmazonStoreCtx :: MonadAmazonStore c m => Pairs -> TransT AmazonStoreCtx m a -> m a+preAmazonStoreCtx preamble action = do+  c <- view amazonStoreCtx <&> cPreamble <>~ preamble+  runTransT c action++-- | Run amazon work context.+--+runAmazonWorkCtx :: MonadAmazon c m => Text -> TransT AmazonWorkCtx m a -> m a+runAmazonWorkCtx queue action = do+  let preamble = [ "queue" .= queue ]+  c <- view amazonCtx <&> cPreamble <>~ preamble+  runTransT (AmazonWorkCtx c queue) action++-- | Update amazon context's preamble.+--+preAmazonWorkCtx :: MonadAmazonWork c m => Pairs -> TransT AmazonWorkCtx m a -> m a+preAmazonWorkCtx preamble action = do+  c <- view amazonWorkCtx <&> cPreamble <>~ preamble+  runTransT c action
+ src/Network/AWS/Wolf/Decide.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | SWF Decider logic.+--+module Network.AWS.Wolf.Decide+  ( decide+  , decideMain+  ) where++import Data.Aeson+import Network.AWS.Wolf.Ctx+import Network.AWS.Wolf.File+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.SWF+import Network.AWS.Wolf.Trace+import Network.AWS.Wolf.Types++-- | Decider logic - poll for decisions, make decisions.+--+decide :: MonadConf c m => Plan -> m ()+decide plan =+  preConfCtx [ "label" .= LabelDecide ] $+    runAmazonCtx $+      runAmazonWorkCtx (plan ^. pStart ^. ptQueue) $ do+        traceInfo "poll" mempty+        (token, _events) <- pollDecision+        maybe_ token $ \_token' -> do+          traceInfo "start" mempty+          traceInfo "finish" mempty++-- | Run decider from main with config file.+--+decideMain :: MonadMain m => FilePath -> FilePath -> m ()+decideMain cf pf =+  runCtx $ do+    conf <- readYaml cf+    runConfCtx conf $ do+      plans <- readYaml pf+      runConcurrent $+        (forever . decide) <$> plans
+ src/Network/AWS/Wolf/File.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Files, directories, and encoding / decoding file functions.+--+module Network.AWS.Wolf.File+  ( findRegularFiles+  , dataDirectory+  , storeDirectory+  , inputDirectory+  , outputDirectory+  , writeText+  , readText+  , writeJson+  , readYaml+  , withCurrentWorkDirectory+  ) where++import           Data.Aeson+import qualified Data.ByteString          as BS+import qualified Data.ByteString.Lazy     as LBS+import           Data.Time+import           Data.Yaml                hiding (encode)+import           Network.AWS.Wolf.Prelude hiding (find)+import           System.Directory+import           System.FilePath.Find+import           System.IO                hiding (readFile, writeFile)++-- | Recursively find all files under a directory.+--+findRegularFiles :: MonadIO m => FilePath -> m [FilePath]+findRegularFiles =+  liftIO . find always (fileType ==? RegularFile)++-- | Determine path to data directory and create it.+--+dataDirectory :: MonadIO m => FilePath -> m FilePath+dataDirectory dir = do+  let dir' = dir </> "data"+  liftIO $ createDirectoryIfMissing True dir'+  return dir'++-- | Determine path to store directory and create it.+--+storeDirectory :: MonadIO m => FilePath -> m FilePath+storeDirectory dir = do+  let dir' = dir </> "store"+  liftIO $ createDirectoryIfMissing True dir'+  return dir'++-- | Determine path to store input directory and create it.+--+inputDirectory :: MonadIO m => FilePath -> m FilePath+inputDirectory dir = do+  let dir' = dir </> "input"+  liftIO $ createDirectoryIfMissing True dir'+  return dir'++-- | Determine path to store output directory and create it.+--+outputDirectory :: MonadIO m => FilePath -> m FilePath+outputDirectory dir = do+  let dir' = dir </> "output"+  liftIO $ createDirectoryIfMissing True dir'+  return dir'++-- | Maybe write text to a file.+--+writeText :: MonadIO m => FilePath -> Maybe Text -> m ()+writeText file contents =+  liftIO $ void $ traverse (writeFile file) contents++-- | Maybe read text from a file.+--+readText :: MonadIO m => FilePath -> m (Maybe Text)+readText file =+ liftIO $ do+   b <- doesFileExist file+   if not b then return mempty else+     return <$> readFile file++-- | Encode from JSON and write file.+--+writeJson :: (MonadIO m, ToJSON a) => FilePath -> a -> m ()+writeJson file item =+  liftIO $ withFile file WriteMode $ \h ->+    BS.hPut h $ LBS.toStrict $ encode item++-- | Read file and decode it from YAML.+--+readYaml :: (MonadIO m, FromJSON a) => FilePath -> m a+readYaml file =+  liftIO $ withFile file ReadMode $ \h -> do+    body <- BS.hGetContents h+    eitherThrowIO $ decodeEither body++-- | Get a temporary timestamped work directory.+--+getWorkDirectory :: MonadIO m => Text -> m FilePath+getWorkDirectory uid =+  liftIO $ do+    td   <- getTemporaryDirectory+    time <- getCurrentTime+    let dir = td </> formatTime defaultTimeLocale "%FT%T%z" time </> textToString uid+    createDirectoryIfMissing True dir+    return dir++-- | Copy directory contents recursively.+--+copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> m ()+copyDirectoryRecursive fd td =+  liftIO $ do+    createDirectoryIfMissing True td+    cs <- filter (`notElem` [".", ".."]) <$> getDirectoryContents fd+    forM_ cs $ \c -> do+      let fc = fd </> c+          tc = td </> c+      e <- doesDirectoryExist fc+      bool (copyFile fc tc) (copyDirectoryRecursive fc tc) e++-- | Setup a temporary work directory.+--+withWorkDirectory :: MonadBaseControlIO m => Text -> (FilePath -> m a) -> m a+withWorkDirectory uid =+  bracket (getWorkDirectory uid) (liftIO . removeDirectoryRecursive)++-- | Change to directory and then return to current directory.+--+withCurrentDirectory :: MonadBaseControlIO m => FilePath -> (FilePath -> m a) -> m a+withCurrentDirectory wd action =+  bracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ \cd -> do+    liftIO $ setCurrentDirectory wd+    action cd++-- | Setup a temporary work directory and copy current directory files to it.+--+withCurrentWorkDirectory :: MonadBaseControlIO m => Text -> (FilePath -> m a) -> m a+withCurrentWorkDirectory uid action =+  withWorkDirectory uid $ \wd ->+    withCurrentDirectory wd $ \cd -> do+      copyDirectoryRecursive cd wd+      action wd+
+ src/Network/AWS/Wolf/Lens.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | makeClassy with constraints.+--+module Network.AWS.Wolf.Lens+  ( makeClassyConstraints+  ) where++import Language.Haskell.TH+import Network.AWS.Wolf.Prelude++-- | makeClassy with list of class constraints.+--+makeClassyConstraints :: Name -> [Name] -> DecsQ+makeClassyConstraints name names = do+  decls <- makeClassy name+  return $ addConstraints names decls++-- | Add constaints to a class.+--+addConstraints :: [Name] -> [Dec] -> [Dec]+addConstraints names = \case+  ClassD cs n tvs f d : ds ->+    ClassD (newConstraints names tvs ++ cs) n tvs f d : ds+  ds -> ds++-- | Create new constaints.+--+newConstraints :: [Name] -> [TyVarBndr] -> [Type]+newConstraints ns =+  loop where+    loop = \case+      PlainTV name : _tvs ->+        flip map ns $ \n ->+          AppT (ConT n) (VarT name)+      _tv : tvs -> loop tvs+      [] -> []
+ src/Network/AWS/Wolf/Prelude.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Local Prelude.+--+module Network.AWS.Wolf.Prelude+  ( module Exports+  , runResourceT+  , maybe_+  , eitherThrowIO+  , runConcurrent+  , textFromString+  , stripPrefix'+  , (<\>)+  , MonadBaseControlIO+  , MonadMain+  ) where++import BasicPrelude                    as Exports hiding (stripPrefix)+import Control.Concurrent.Async.Lifted+import Control.Lens                    as Exports hiding (uncons, (.=), (<.>))+import Control.Monad.Catch+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Data.Text                       hiding (map)++-- | Maybe that returns () if Nothing+--+maybe_ :: Monad m => Maybe a -> (a -> m ()) -> m ()+maybe_ = flip $ maybe $ return ()++-- | Throw userError on either error.+--+eitherThrowIO :: MonadIO m => Either String a -> m a+eitherThrowIO = either (liftIO . throwIO . userError) return++-- | Run a list of actions concurrently.+--+runConcurrent :: MonadBaseControl IO m => [m a] -> m ()+runConcurrent = void . runConcurrently . sequenceA . map Concurrently++-- | Reverse of textToString+--+textFromString :: String -> Text+textFromString = pack++-- | Strip the prefix with a '/' tacked on to the prefix.+--+stripPrefix' :: Text -> Text -> Maybe Text+stripPrefix' prefix =+  stripPrefix (prefix <\> mempty)++-- | </> for Text.+--+(<\>) :: Text -> Text -> Text+(<\>) = (<>) . (<> "/")++type MonadBaseControlIO m =+  ( MonadBaseControl IO m+  , MonadIO m+  )++type MonadMain m =+  ( MonadBaseControlIO m+  , MonadResource m+  , MonadCatch m+  )
+ src/Network/AWS/Wolf/S3.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | S3 Calls.+--+module Network.AWS.Wolf.S3+  ( listArtifacts+  , getArtifact+  , putArtifact+  ) where++import Control.Monad.Trans.AWS+import Data.Conduit+import Data.Conduit.Binary+import Data.Conduit.Combinators hiding (sinkFile, sourceFile)+import Data.Conduit.List        hiding (map, mapMaybe)+import Data.Text+import Network.AWS.Data.Body+import Network.AWS.Data.Text+import Network.AWS.S3           hiding (cBucket)+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.Types++-- | List keys in bucket with prefix.+--+listArtifacts :: MonadAmazonStore c m => m [Text]+listArtifacts = do+  b    <- view cBucket <$> view ccConf+  p    <- view ascPrefix+  lors <- paginate (set loPrefix (return p) $ listObjects (BucketName b)) $$ consume+  return $ mapMaybe (stripPrefix' p) $ toText . view oKey <$> join (view lorsContents <$> lors)++-- | Get object in bucket with key.+--+getArtifact :: MonadAmazonStore c m => FilePath -> Text -> m ()+getArtifact file key = do+  b    <- view cBucket <$> view ccConf+  p    <- view ascPrefix+  gors <- send $ getObject (BucketName b) (ObjectKey (p <\> key))+  sinkBody (gors ^. gorsBody) (sinkFile file)++-- | Put object in bucket with key.+--+putArtifact :: MonadAmazonStore c m => FilePath -> Text -> m ()+putArtifact file key = do+  b          <- view cBucket <$> view ccConf+  p          <- view ascPrefix+  (sha, len) <- sourceFile file $$ getZipSink $ (,) <$> ZipSink sinkSHA256 <*> ZipSink lengthE+  void $ send $ putObject (BucketName b) (ObjectKey (p <\> key)) $+    Hashed $ HashedStream sha len $ sourceFile file
+ src/Network/AWS/Wolf/SWF.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | SWF Calls.+--+module Network.AWS.Wolf.SWF+  ( pollActivity+  , pollDecision+  , completeActivity+  , failActivity+  ) where++import Control.Monad.Trans.AWS+import Data.Conduit+import Data.Conduit.List        hiding (concatMap, map)+import Network.AWS.SWF+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.Types++-- | Poll for activities.+--+pollActivity :: MonadAmazonWork c m => m (Maybe Text, Maybe Text, Maybe Text)+pollActivity = do+  d      <- view cDomain <$> view ccConf+  tl     <- taskList <$> view awcQueue+  pfatrs <- send (pollForActivityTask d tl)+  return+    ( pfatrs ^. pfatrsTaskToken+    , view weWorkflowId <$> pfatrs ^. pfatrsWorkflowExecution+    , pfatrs ^. pfatrsInput+    )++-- | Poll for decisions.+--+pollDecision :: MonadAmazonWork c m => m (Maybe Text, [HistoryEvent])+pollDecision = do+  d      <- view cDomain <$> view ccConf+  tl     <- taskList <$> view awcQueue+  pfdtrs <- paginate (pollForDecisionTask d tl) $$ consume+  return+    ( join $ listToMaybe $ map (view pfdtrsTaskToken) pfdtrs+    , reverse $ concatMap (view pfdtrsEvents) pfdtrs+    )++-- | Successfull job completion.+--+completeActivity :: MonadAmazon c m => Text -> Maybe Text -> m ()+completeActivity token output =+  void $ send $ set ratcResult output $ respondActivityTaskCompleted token++-- | Job failure.+--+failActivity :: MonadAmazon c m => Text -> m ()+failActivity token =+  void $ send $ respondActivityTaskFailed token
+ src/Network/AWS/Wolf/Trace.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Tracing functionality around MonadLogger.+--+module Network.AWS.Wolf.Trace+  ( newStderrTrace+  , newStdoutTrace+  , nullTrace++  , traceDebug+  , traceInfo+  , traceWarn+  , traceError+  ) where++import           Control.Monad.Logger+import           Data.Aeson+import           Data.Aeson.Encode+import qualified Data.HashMap.Strict      as M+import qualified Data.Text.Lazy           as LT+import           Data.Text.Lazy.Builder+import           Data.Time+import           Data.Version+import           Network.AWS.Wolf.Prelude+import           Network.AWS.Wolf.Types+import           Paths_wolf+import           System.Log.FastLogger++-- | Trace out only if gte configured level.+--+levelTrace :: LogLevel -> LoggerSet -> Trace+levelTrace level ls _loc _source level' s =+  unless (level' < level) $ do+    pushLogStr ls s+    flushLogStr ls++-- | New logger to stderr.+--+newStderrTrace :: MonadIO m => LogLevel -> m Trace+newStderrTrace level =+  liftIO $ levelTrace level <$> newStderrLoggerSet defaultBufSize++-- | New logger to stdout.+--+newStdoutTrace :: MonadIO m => LogLevel -> m Trace+newStdoutTrace level =+  liftIO $ levelTrace level <$> newStdoutLoggerSet defaultBufSize++-- | Logger to nowhere.+--+nullTrace :: Trace+nullTrace _loc _source _level _s =+  return ()++-- | Trace out event with preamble and timestamp.+--+trace :: MonadCtx c m => (Text -> m ()) -> Text -> Pairs -> m ()+trace logN e ps = do+  t <- liftIO getCurrentTime+  let preamble =+        [ "version" .= showVersion version+        , "run"     .= LabelWolf+        , "event"   .= e+        , "time"    .= t+        ]+  p <- view cPreamble+  logN $ LT.toStrict $ toLazyText $ (<> singleton '\n') $+    encodeToTextBuilder $ Object $ M.fromList $ preamble <> p <> ps++-- | Debug tracing.+--+traceDebug :: MonadCtx c m => Text -> Pairs -> m ()+traceDebug = trace logDebugN++-- | Info tracing.+--+traceInfo :: MonadCtx c m => Text -> Pairs -> m ()+traceInfo = trace logInfoN++-- | Warn tracing.+--+traceWarn :: MonadCtx c m => Text -> Pairs -> m ()+traceWarn = trace logWarnN++-- | Error tracing.+--+traceError :: MonadCtx c m => Text -> Pairs -> m ()+traceError = trace logErrorN
+ src/Network/AWS/Wolf/Types.hs view
@@ -0,0 +1,12 @@+-- | Export all the modules in the Types directory.+--+module Network.AWS.Wolf.Types+  ( module Exports+  ) where++import Network.AWS.Wolf.Types.Alias   as Exports+import Network.AWS.Wolf.Types.Ctx     as Exports+import Network.AWS.Wolf.Types.Plan    as Exports+import Network.AWS.Wolf.Types.Product as Exports+import Network.AWS.Wolf.Types.Sum     as Exports+import Network.AWS.Wolf.Types.Trans   as Exports
+ src/Network/AWS/Wolf/Types/Alias.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Various alias types.+--+module Network.AWS.Wolf.Types.Alias where++import Control.Monad.Logger+import Data.Aeson+import Network.AWS.Wolf.Prelude++-- | Pairs+--+type Pairs = [(Text, Value)]++-- | Trace+--+type Trace = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+ src/Network/AWS/Wolf/Types/Ctx.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Context objects for monad transformers.+--+module Network.AWS.Wolf.Types.Ctx where++import Control.Monad.Catch+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.AWS+import Control.Monad.Trans.Resource+import Network.AWS.Wolf.Lens+import Network.AWS.Wolf.Prelude+import Network.AWS.Wolf.Types.Alias+import Network.AWS.Wolf.Types.Product++-- | Ctx+--+-- Base context, supports tracing.+--+data Ctx = Ctx+  { _cPreamble :: Pairs+    -- ^ Object to encode on every trace line.+  , _cTrace    :: Trace+    -- ^ Configurable tracing function.+  }++$(makeClassy ''Ctx)++type MonadCtx c m =+  ( MonadBaseControlIO m+  , MonadReader c m+  , MonadLogger m+  , MonadCatch m+  , MonadResource m+  , HasCtx c+  )++-- | ConfCtx+--+-- Configuration context.+--+data ConfCtx = ConfCtx+  { _ccCtx  :: Ctx+    -- ^ Parent context.+  , _ccConf :: Conf+    -- ^ Configuration parameters.+  }++$(makeClassyConstraints ''ConfCtx [''HasCtx])++instance HasCtx ConfCtx where+  ctx = ccCtx++type MonadConf c m =+  ( MonadCtx c m+  , HasConfCtx c+  )++-- | AmazonCtx+--+-- Amazon context.+--+data AmazonCtx = AmazonCtx+  { _acConfCtx :: ConfCtx+    -- ^ Parent context.+  , _acEnv     :: Env+    -- ^ Amazon environment.+  }++$(makeClassyConstraints ''AmazonCtx [''HasConfCtx, ''HasEnv])++instance HasConfCtx AmazonCtx where+  confCtx = acConfCtx++instance HasCtx AmazonCtx where+  ctx = confCtx . ccCtx++instance HasEnv AmazonCtx where+  environment = acEnv++type MonadAmazon c m =+  ( MonadConf c m+  , HasAmazonCtx c+  , AWSConstraint c m+  )++-- | AmazonStoreCtx+--+-- Amazon store context.+--+data AmazonStoreCtx = AmazonStoreCtx+  { _ascAmazonCtx :: AmazonCtx+    -- ^ Parent context.+  , _ascUid       :: Text+    -- ^ Workflow uid.+  , _ascPrefix    :: Text+    -- ^ Object prefix.+  }++$(makeClassyConstraints ''AmazonStoreCtx [''HasAmazonCtx])++instance HasAmazonCtx AmazonStoreCtx where+  amazonCtx = ascAmazonCtx++instance HasConfCtx AmazonStoreCtx where+   confCtx = amazonCtx . acConfCtx++instance HasCtx AmazonStoreCtx where+   ctx = confCtx . ccCtx++instance HasEnv AmazonStoreCtx where+   environment = amazonCtx . acEnv++type MonadAmazonStore c m =+   ( MonadAmazon c m+   , HasAmazonStoreCtx c+   )++-- | AmazonStoreCtx+--+-- Amazon work context.+--+data AmazonWorkCtx = AmazonWorkCtx+  { _awcAmazonCtx :: AmazonCtx+    -- ^ Parent context.+  , _awcQueue     :: Text+    -- ^ Workflow queue.+  }++$(makeClassyConstraints ''AmazonWorkCtx [''HasAmazonCtx])++instance HasAmazonCtx AmazonWorkCtx where+  amazonCtx = awcAmazonCtx++instance HasConfCtx AmazonWorkCtx where+   confCtx = amazonCtx . acConfCtx++instance HasCtx AmazonWorkCtx where+   ctx = confCtx . ccCtx++instance HasEnv AmazonWorkCtx where+   environment = amazonCtx . acEnv++type MonadAmazonWork c m =+   ( MonadAmazon c m+   , HasAmazonWorkCtx c+   )
+ src/Network/AWS/Wolf/Types/Plan.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Specifications for plans.+--+module Network.AWS.Wolf.Types.Plan where++import Data.Aeson.TH+import Network.AWS.Wolf.Aeson+import Network.AWS.Wolf.Prelude++-- | Plan Task+--+-- Work task.+--+data PlanTask = PlanTask+  { _ptName    :: Text+    -- ^ Name of task.+  , _ptVersion :: Text+    -- ^ Version of task.+  , _ptQueue   :: Text+    -- ^ Queue for task.+  , _ptTimeout :: Text+    -- ^ Timeout for task.+  } deriving (Show, Eq)++$(makeLenses ''PlanTask)+$(deriveJSON spinalOptions ''PlanTask)++-- | Plan+--+-- Group of tasks.+--+data Plan = Plan+  { _pStart :: PlanTask+    -- ^ Flow task.+  , _pTasks :: [PlanTask]+    -- ^ Worker tasks.+  } deriving (Show, Eq)++$(makeLenses ''Plan)+$(deriveJSON spinalOptions ''Plan)
+ src/Network/AWS/Wolf/Types/Product.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Various product types.+--+module Network.AWS.Wolf.Types.Product where++import Data.Aeson.TH+import Network.AWS.Wolf.Aeson+import Network.AWS.Wolf.Prelude++-- | Conf+--+-- SWF and S3 configuration parameters.+--+data Conf = Conf+  { _cTimeout     :: Int+    -- ^ SWF regular timeout.+  , _cPollTimeout :: Int+    -- ^ SWF polling timeout.+  , _cDomain      :: Text+    -- ^ SWF domain.+  , _cBucket      :: Text+    -- ^ S3 bucket.+  , _cPrefix      :: Text+    -- ^ S3 prefix.+  } deriving (Show, Eq)++$(makeLenses ''Conf)+$(deriveJSON spinalOptions ''Conf)++-- | Control+--+data Control = Control+  { _cRunUid :: Text+    -- ^ Run uid of workflow.+  } deriving (Show, Eq)++$(makeLenses ''Control)+$(deriveJSON spinalOptions ''Control)
+ src/Network/AWS/Wolf/Types/Sum.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Various sum types.+--+module Network.AWS.Wolf.Types.Sum where++import Data.Aeson.TH+import Network.AWS.Wolf.Aeson+import Network.AWS.Wolf.Prelude++-- | LabelType+--+-- Tags for referencing workers.+--+data LabelType+  = LabelWolf+  | LabelAct+  | LabelDecide+  deriving (Show, Eq)++$(deriveJSON spinalOptions ''LabelType)
+ src/Network/AWS/Wolf/Types/Trans.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++-- | Monad transformer.+--+module Network.AWS.Wolf.Types.Trans where++import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Network.AWS.Wolf.Prelude++-- | Monad transformer for reading and logging.+--+newtype TransT c m a = TransT+  { unTransT :: LoggingT (ReaderT c m) a+    -- ^ LoggingT and ReaderT transformer.+  } deriving (Functor, Applicative, Monad, MonadLogger, MonadReader c, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance MonadBase b m => MonadBase b (TransT c m) where+  liftBase = liftBaseDefault++instance MonadBaseControl b m => MonadBaseControl b (TransT c m) where+    type StM (TransT c m) a = ComposeSt (TransT c) m a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM++instance MonadTransControl (TransT c) where+  type StT (TransT c) a = StT (ReaderT c) a+  liftWith f = TransT $+    liftWith $ \g ->+      liftWith $ \h ->+        f (h . g . unTransT)+  restoreT = TransT . restoreT . restoreT++instance MonadTrans (TransT c) where+  lift = TransT . lift . lift++instance MonadResource m => MonadResource (TransT c m) where+  liftResourceT = lift . liftResourceT
test/Test/Network/AWS/Flow.hs view
@@ -11,7 +11,7 @@ assertUserError :: String -> IO a -> IO () assertUserError s action =   handleJust check (const $ return ()) $ do-    void $ action+    void action     assertFailure $ "missed user error: " ++ s where       check e = guard $ userError s == e
wolf.cabal view
@@ -1,5 +1,5 @@ name:                wolf-version:             0.2.14+version:             0.3.0 synopsis:            Amazon Simple Workflow Service Wrapper. homepage:            https://github.com/swift-nav/wolf license:             MIT@@ -21,6 +21,7 @@  library   exposed-modules:     Network.AWS.Flow+                     , Network.AWS.Wolf   other-modules:       Network.AWS.Flow.Env                      , Network.AWS.Flow.Logger                      , Network.AWS.Flow.Prelude@@ -28,6 +29,23 @@                      , Network.AWS.Flow.SWF                      , Network.AWS.Flow.Types                      , Network.AWS.Flow.Uid+                     , Network.AWS.Wolf.Act+                     , Network.AWS.Wolf.Aeson+                     , Network.AWS.Wolf.Ctx+                     , Network.AWS.Wolf.Decide+                     , Network.AWS.Wolf.File+                     , Network.AWS.Wolf.Lens+                     , Network.AWS.Wolf.Prelude+                     , Network.AWS.Wolf.S3+                     , Network.AWS.Wolf.SWF+                     , Network.AWS.Wolf.Trace+                     , Network.AWS.Wolf.Types+                     , Network.AWS.Wolf.Types.Alias+                     , Network.AWS.Wolf.Types.Ctx+                     , Network.AWS.Wolf.Types.Plan+                     , Network.AWS.Wolf.Types.Product+                     , Network.AWS.Wolf.Types.Sum+                     , Network.AWS.Wolf.Types.Trans                      , Paths_wolf   default-language:    Haskell2010   hs-source-dirs:      src@@ -41,23 +59,31 @@                      , basic-prelude                      , bytestring                      , conduit+                     , conduit-combinators                      , conduit-extra+                     , directory                      , exceptions                      , fast-logger+                     , filemanip                      , formatting                      , http-conduit                      , http-types                      , lens+                     , lifted-async+                     , lifted-base                      , monad-control                      , monad-logger                      , mtl                      , mtl-compat                      , optparse-applicative+                     , process                      , regex-applicative                      , regex-compat                      , resourcet                      , safe+                     , template-haskell                      , text+                     , text-manipulate                      , time                      , transformers                      , transformers-base@@ -185,3 +211,30 @@   default-extensions:  OverloadedStrings                        RecordWildCards                        NoImplicitPrelude++executable wolf-actor+  hs-source-dirs:      main+  main-is:             actor.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2+  build-depends:       base+                     , wolf+                     , optparse-generic+  default-language:    Haskell2010++executable wolf-decider+  hs-source-dirs:      main+  main-is:             decider.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2+  build-depends:       base+                     , wolf+                     , optparse-generic+  default-language:    Haskell2010++executable shake-wolf+  main-is:             Shakefile.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2+  build-depends:       base >= 4.7 && < 5+                     , basic-prelude+                     , directory+                     , shake+  default-language:    Haskell2010