loup 0.0.2 → 0.0.3

raw patch · 5 files changed

+39/−30 lines, 5 filesdep +lifted-basedep +unordered-containers

Dependencies added: lifted-base, unordered-containers

Files

• loup.cabal +3/−1
• src/Network/AWS/Loup/Act.hs +7/−7
• src/Network/AWS/Loup/Converge.hs +4/−3
• src/Network/AWS/Loup/Ctx.hs +13/−1
• src/Network/AWS/Loup/Decide.hs +12/−18

@@ -1,5 +1,5 @@ name:                  loup-version:               0.0.2+version:               0.0.3 synopsis:              Amazon Simple Workflow Service Wrapper for Work Pools. description:           Loup is a wrapper around Amazon Simple Workflow Service for Work Pools. homepage:              https://github.com/swift-nav/loup@@ -38,10 +38,12 @@                      , bytestring                      , conduit                      , lifted-async+                     , lifted-base                      , monad-control                      , preamble                      , time                      , turtle+                     , unordered-containers                      , uuid                      , yaml 

@@ -25,18 +25,18 @@   pfatrs <- send $ pollForActivityTask domain list   return (pfatrs ^. pfatrsTaskToken, pfatrs ^. pfatrsInput) --- | Successful activity completion.----completeActivity :: MonadAmazonCtx c m => Text -> m ()-completeActivity token =-  void $ send $ respondActivityTaskCompleted token- -- | Cancel activity. -- cancelActivity :: MonadAmazonCtx c m => Text -> m () cancelActivity token =   void $ send $ respondActivityTaskCanceled token +-- | Fail activity.+--+failActivity :: MonadAmazonCtx c m => Text -> m ()+failActivity token =+  void $ send $ respondActivityTaskFailed token+ -- | Hearbeat. -- heartbeat :: MonadAmazonCtx c m => Text -> m Bool@@ -74,7 +74,7 @@   intempdir $ do     liftIO $ maybe_ input $ writeTextFile "input.json"     stdout $ inshell command mempty-  completeActivity token+  failActivity token  -- | Actor logic - poll for work, download artifacts, run command, upload artifacts. --

@@ -10,10 +10,11 @@   ) where  import Control.Monad.Trans.AWS+import Data.HashSet             hiding (filter) import Data.Time.Clock.POSIX import Data.Yaml import Network.AWS.Loup.Ctx-import Network.AWS.Loup.Prelude+import Network.AWS.Loup.Prelude hiding (delete) import Network.AWS.Loup.Types import Network.AWS.SWF @@ -48,9 +49,9 @@ converge domain pool =   preAmazonCtx [ "label" .= LabelDecide, "domain" .= domain, "pool" .= pool ] $ do     let activity = pool ^. pTask ^. tActivityType-    wids  <- listWorkflows domain activity+    wids <- fromList <$> listWorkflows domain activity     let fold kvs as action = do-          let g k v bs = if k `elem` bs then return $ k `delete` bs else action k v >> return bs+          let g k v bs = if k `member` bs then return $ k `delete` bs else action k v >> return bs           ifoldrM g as kvs     wids' <- fold (pool ^. pWorkers) wids $ \wid input -> do       traceInfo "start" [ "wid" .= wid, "input" .= input ]

@@ -10,6 +10,7 @@   , runDecisionCtx   ) where +import Control.Exception.Lifted import Control.Monad.Trans.AWS import Data.Aeson import Network.AWS.Loup.Prelude@@ -23,6 +24,17 @@   traceError "exception" [ "error" .= displayException ex ]   throwIO ex +-- | Catch TransportError's.+--+botErrorCatch :: MonadCtx c m => Error -> m a+botErrorCatch ex = do+  case ex of+    TransportError _ ->+      return ()+    _ ->+      traceError "exception" [ "error" .= displayException ex ]+  throwIO ex+ -- | Catcher for exceptions, emits stats and rethrows. -- topSomeExceptionCatch :: MonadStatsCtx c m => SomeException -> m a@@ -33,7 +45,7 @@ -- | Run bottom TransT. -- runBotTransT :: (MonadMain m, HasCtx c) => c -> TransT c m a -> m a-runBotTransT c action = runTransT c $ catch action botSomeExceptionCatch+runBotTransT c action = runTransT c $ catches action [ Handler botErrorCatch, Handler botSomeExceptionCatch ]  -- | Run top TransT. --

@@ -101,29 +101,22 @@   traceInfo "completed" mempty   return [ completeActivity ] --- | Canceled workflow step.----canceled :: MonadDecisionCtx c m => m [Decision]-canceled = do-  traceInfo "canceled" mempty-  return [ completeActivity ]---- | Timed out workflow step.+-- | Restart workflow step. ---timedout :: MonadDecisionCtx c m => m [Decision]-timedout = do-  traceInfo "timedout" mempty+restart :: MonadDecisionCtx c m => m [Decision]+restart = do+  traceInfo "restart" mempty   uid   <- liftIO nextRandom   task  <- view pActivityTask <$> view dcPlan   event <- findEvent WorkflowExecutionStarted   let input = join $ view weseaInput <$> join (view heWorkflowExecutionStartedEventAttributes <$> event)   return [ scheduleActivity uid (task ^. tActivityType) (task ^. tTaskList) input ] --- | Failed workflow step.+-- | Cancel failed workflow step. ---failed :: MonadDecisionCtx c m => m [Decision]-failed = do-  traceInfo "failed" mempty+canceled :: MonadDecisionCtx c m => m [Decision]+canceled = do+  traceInfo "canceled" mempty   return [ cancelActivity ]  -- | Schedule decision based on history events.@@ -136,9 +129,10 @@         | e ^. heEventType == WorkflowExecutionStarted         = begin e         | e ^. heEventType == WorkflowExecutionCancelRequested = cancel         | e ^. heEventType == ActivityTaskCompleted            = completed-        | e ^. heEventType == ActivityTaskCanceled             = canceled-        | e ^. heEventType == ActivityTaskTimedOut             = timedout-        | e ^. heEventType == RequestCancelActivityTaskFailed  = failed+        | e ^. heEventType == ActivityTaskCanceled             = completed+        | e ^. heEventType == ActivityTaskTimedOut             = restart+        | e ^. heEventType == ActivityTaskFailed               = restart+        | e ^. heEventType == RequestCancelActivityTaskFailed  = canceled         | otherwise                                            = f es   events <- view dcEvents   f events