packages feed

loup 0.0.5 → 0.0.6

raw patch · 7 files changed

+67/−72 lines, 7 filesdep −monad-control

Dependencies removed: monad-control

Files

loup.cabal view
@@ -1,5 +1,5 @@ name:                  loup-version:               0.0.5+version:               0.0.6 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@@ -39,7 +39,6 @@                      , conduit                      , lifted-async                      , lifted-base-                     , monad-control                      , preamble                      , time                      , turtle
src/Network/AWS/Loup/Act.hs view
@@ -20,29 +20,33 @@  -- | Poll for activity. ---pollActivity :: MonadAmazonCtx c m => Text -> TaskList -> m (Maybe Text, Maybe Text)-pollActivity domain list = do-  pfatrs <- send $ pollForActivityTask domain list-  return (pfatrs ^. pfatrsTaskToken, pfatrs ^. pfatrsInput)+pollActivity :: MonadStatsCtx c m => Text -> TaskList -> m (Maybe Text, Maybe Text)+pollActivity domain list =+  runResourceT $ runAmazonCtx $ do+    pfatrs <- send $ pollForActivityTask domain list+    return (pfatrs ^. pfatrsTaskToken, pfatrs ^. pfatrsInput)  -- | Cancel activity. ---cancelActivity :: MonadAmazonCtx c m => Text -> m ()+cancelActivity :: MonadStatsCtx c m => Text -> m () cancelActivity token =-  void $ send $ respondActivityTaskCanceled token+  runResourceT $ runAmazonCtx $+    void $ send $ respondActivityTaskCanceled token  -- | Fail activity. ---failActivity :: MonadAmazonCtx c m => Text -> m ()+failActivity :: MonadStatsCtx c m => Text -> m () failActivity token =-  void $ send $ respondActivityTaskFailed token+  runResourceT $ runAmazonCtx $+    void $ send $ respondActivityTaskFailed token  -- | Hearbeat. ---heartbeat :: MonadAmazonCtx c m => Text -> m Bool-heartbeat token = do-  rathrs <- send $ recordActivityTaskHeartbeat token-  return $ rathrs ^. rathrsCancelRequested+heartbeat :: MonadStatsCtx c m => Text -> m Bool+heartbeat token =+  runResourceT $ runAmazonCtx $ do+    rathrs <- send $ recordActivityTaskHeartbeat token+    return $ rathrs ^. rathrsCancelRequested  -- | Run a managed action inside a temp directory. --@@ -58,7 +62,7 @@  -- | Run heartbeat. ---runHeartbeat :: MonadAmazonCtx c m => Text -> Int -> m ()+runHeartbeat :: MonadStatsCtx c m => Text -> Int -> m () runHeartbeat token interval = do   traceInfo "heartbeat" mempty   liftIO $ threadDelay $ interval * 1000000@@ -69,7 +73,7 @@  -- | Run command with input. ---runActivity :: MonadAmazonCtx c m => Text -> Bool -> Text -> Maybe Text -> m ()+runActivity :: MonadStatsCtx c m => Text -> Bool -> Text -> Maybe Text -> m () runActivity token copy command input = do   traceInfo "run" [ "command" .= command, "input" .= input]   intempdir copy $ do@@ -79,9 +83,9 @@  -- | Actor logic - poll for work, download artifacts, run command, upload artifacts. ---act :: MonadAmazonCtx c m => Text -> Text -> Int -> Bool -> Text -> m ()+act :: MonadStatsCtx c m => Text -> Text -> Int -> Bool -> Text -> m () act domain queue interval copy command =-  preAmazonCtx [ "label" .= LabelAct, "domain" .= domain, "queue" .= queue ] $ do+  preStatsCtx [ "label" .= LabelAct, "domain" .= domain, "queue" .= queue ] $ do     traceInfo "poll" mempty     (token, input) <- pollActivity domain (taskList queue)     maybe_ token $ \token' -> do@@ -93,5 +97,5 @@ -- actMain :: MonadControl m => Text -> Text -> Int -> Int -> Bool -> Text -> m () actMain domain queue count interval copy command =-  runResourceT $ runCtx $ runStatsCtx $ runAmazonCtx $+  runResourceT $ runCtx $ runStatsCtx $     runConcurrent $ replicate count $ forever $ act domain queue interval copy command
src/Network/AWS/Loup/Converge.hs view
@@ -20,34 +20,37 @@  -- | List open workflows. ---listWorkflows :: MonadAmazonCtx c m => Text -> ActivityType -> m [Text]-listWorkflows domain activity = do-  let etf = executionTimeFilter $ posixSecondsToUTCTime $ fromIntegral (0 :: Int)-      wtf = workflowTypeFilter (activity ^. atName)-  weis <- pages $ set loweTypeFilter (return wtf) $ listOpenWorkflowExecutions domain etf-  let predicate wei = maybe True not $ wei ^. weiCancelRequested-  return $ view weWorkflowId . view weiExecution <$> filter predicate (join $ view weiExecutionInfos <$> weis)+listWorkflows :: MonadStatsCtx c m => Text -> ActivityType -> m [Text]+listWorkflows domain activity =+  runResourceT $ runAmazonCtx $ do+    let etf = executionTimeFilter $ posixSecondsToUTCTime $ fromIntegral (0 :: Int)+        wtf = workflowTypeFilter (activity ^. atName)+    weis <- pages $ set loweTypeFilter (return wtf) $ listOpenWorkflowExecutions domain etf+    let predicate wei = maybe True not $ wei ^. weiCancelRequested+    return $ view weWorkflowId . view weiExecution <$> filter predicate (join $ view weiExecutionInfos <$> weis)  -- | Start a workflow. ---startWorkflow :: MonadAmazonCtx c m => Text -> ActivityType -> TaskList -> Text -> Maybe Text -> m ()-startWorkflow domain activity list wid input = do-  let wt = workflowType (activity ^. atName) (activity ^. atVersion)-  void $ send $ startWorkflowExecution domain wid wt-    & sTaskList .~ return list-    & sInput .~ input+startWorkflow :: MonadStatsCtx c m => Text -> ActivityType -> TaskList -> Text -> Maybe Text -> m ()+startWorkflow domain activity list wid input =+  runResourceT $ runAmazonCtx $ do+    let wt = workflowType (activity ^. atName) (activity ^. atVersion)+    void $ send $ startWorkflowExecution domain wid wt+      & sTaskList .~ return list+      & sInput .~ input  -- | Cancel a workflow. ---cancelWorkflow :: MonadAmazonCtx c m => Text -> Text -> m ()+cancelWorkflow :: MonadStatsCtx c m => Text -> Text -> m () cancelWorkflow domain wid =-  void $ send $ requestCancelWorkflowExecution domain wid+  runResourceT $ runAmazonCtx $+    void $ send $ requestCancelWorkflowExecution domain wid  -- | Converger logic - get running workers and converge against pool. ---converge :: MonadAmazonCtx c m => Text -> Pool -> m ()+converge :: MonadStatsCtx c m => Text -> Pool -> m () converge domain pool =-  preAmazonCtx [ "label" .= LabelDecide, "domain" .= domain ] $ do+  preStatsCtx [ "label" .= LabelDecide, "domain" .= domain ] $ do     let activity = pool ^. pTask ^. tActivityType     wids <- fromList <$> listWorkflows domain activity     let fold kvs as action = do@@ -66,6 +69,6 @@ -- convergeMain :: MonadControl m => Text -> FilePath -> m () convergeMain domain file =-  runResourceT $ runCtx $ runStatsCtx $ runAmazonCtx $ do+  runCtx $ runStatsCtx $ do     pools <- liftIO $ join . maybeToList <$> decodeFile file     runConcurrent $ converge domain <$> pools
src/Network/AWS/Loup/Ctx.hs view
@@ -6,7 +6,6 @@ -- module Network.AWS.Loup.Ctx   ( runAmazonCtx-  , preAmazonCtx   , runDecisionCtx   ) where @@ -44,12 +43,12 @@  -- | Run bottom TransT. ---runBotTransT :: (MonadMain m, HasCtx c) => c -> TransT c m a -> m a+runBotTransT :: (MonadControl m, HasCtx c) => c -> TransT c m a -> m a runBotTransT c action = runTransT c $ catches action [ Handler botErrorCatch, Handler botSomeExceptionCatch ]  -- | Run top TransT. ---runTopTransT :: (MonadMain m, HasStatsCtx c) => c -> TransT c m a -> m a+runTopTransT :: (MonadControl m, HasStatsCtx c) => c -> TransT c m a -> m a runTopTransT c action = runBotTransT c $ catch action topSomeExceptionCatch  -- | Run amazon context.@@ -60,16 +59,9 @@   e <- newEnv Oregon $ FromEnv "AWS_ACCESS_KEY_ID" "AWS_SECRET_ACCESS_KEY" mempty   runTopTransT (AmazonCtx c e) action --- | Update amazon context's preamble.----preAmazonCtx :: MonadAmazonCtx c m => Pairs -> TransT AmazonCtx m a -> m a-preAmazonCtx preamble action = do-  c <- view amazonCtx <&> cPreamble <>~ preamble-  runBotTransT c action- -- | Run decision context. ---runDecisionCtx :: MonadAmazonCtx c m => Plan -> [HistoryEvent] -> TransT DecisionCtx m a -> m a+runDecisionCtx :: MonadStatsCtx c m => Plan -> [HistoryEvent] -> TransT DecisionCtx m a -> m a runDecisionCtx plan events action = do-  c <- view amazonCtx-  runBotTransT (DecisionCtx c plan events) action+  c <- view statsCtx+  runTopTransT (DecisionCtx c plan events) action
src/Network/AWS/Loup/Decide.hs view
@@ -20,17 +20,19 @@  -- | Poll for decision. ---pollDecision :: MonadAmazonCtx c m => Text -> TaskList -> m (Maybe Text, [HistoryEvent])-pollDecision domain list = do-  pfdtrs <- pages $ pollForDecisionTask domain list-  return (join $ headMay $ view pfdtrsTaskToken <$> pfdtrs, reverse $ join $ view pfdtrsEvents <$> pfdtrs)+pollDecision :: MonadStatsCtx c m => Text -> TaskList -> m (Maybe Text, [HistoryEvent])+pollDecision domain list =+  runResourceT $ runAmazonCtx $ do+    pfdtrs <- pages $ pollForDecisionTask domain list+    return (join $ headMay $ view pfdtrsTaskToken <$> pfdtrs, reverse $ join $ view pfdtrsEvents <$> pfdtrs)  -- | Successful decision completion. ---completeDecision :: MonadAmazonCtx c m => Text -> [Decision] -> m ()+completeDecision :: MonadStatsCtx c m => Text -> [Decision] -> m () completeDecision token decisions =-  void $ send $ respondDecisionTaskCompleted token-    & rdtcDecisions .~ decisions+  runResourceT $ runAmazonCtx $+    void $ send $ respondDecisionTaskCompleted token+      & rdtcDecisions .~ decisions  -- | Schedule activity decision. --@@ -119,6 +121,8 @@   traceInfo "canceled" mempty   return [ cancelActivity ] +-- | When we run out of events.+-- nothing :: MonadDecisionCtx c m => m [Decision] nothing = do   events <- view dcEvents@@ -145,9 +149,9 @@  -- | Decider logic - poll for decisions, make decisions. ---decide :: MonadAmazonCtx c m => Text -> Plan -> m ()+decide :: MonadStatsCtx c m => Text -> Plan -> m () decide domain plan =-  preAmazonCtx [ "label" .= LabelDecide, "domain" .= domain ] $ do+  preStatsCtx [ "label" .= LabelDecide, "domain" .= domain ] $ do     traceInfo "poll" mempty     (token, events) <- pollDecision domain (plan ^. pDecisionTask ^. tTaskList)     maybe_ token $ \token' -> do@@ -161,6 +165,6 @@ -- decideMain :: MonadControl m => Text -> FilePath -> m () decideMain domain file =-  runResourceT $ runCtx $ runStatsCtx $ runAmazonCtx $ do+  runCtx $ runStatsCtx $ do     plans <- liftIO $ join . maybeToList <$> decodeFile file     runConcurrent $ forever . decide domain <$> plans
src/Network/AWS/Loup/Prelude.hs view
@@ -13,7 +13,6 @@  import Control.Concurrent.Async.Lifted import Control.Monad.Trans.AWS-import Control.Monad.Trans.Control import Data.Aeson import Data.ByteString.Lazy            hiding (map) import Data.Conduit
src/Network/AWS/Loup/Types/Ctx.hs view
@@ -47,27 +47,21 @@ -- Decision context. -- data DecisionCtx = DecisionCtx-  { _dcAmazonCtx :: AmazonCtx+  { _dcStatsCtx :: StatsCtx     -- ^ Parent context.-  , _dcPlan      :: Plan+  , _dcPlan     :: Plan     -- ^ Decision plan.-  , _dcEvents    :: [HistoryEvent]+  , _dcEvents   :: [HistoryEvent]     -- ^ History events.   } -$(makeClassyConstraints ''DecisionCtx [''HasAmazonCtx])--instance HasAmazonCtx DecisionCtx where-  amazonCtx = dcAmazonCtx+$(makeClassyConstraints ''DecisionCtx [''HasStatsCtx])  instance HasStatsCtx DecisionCtx where-  statsCtx = amazonCtx . statsCtx+  statsCtx = dcStatsCtx  instance HasCtx DecisionCtx where   ctx = statsCtx . ctx--instance HasEnv DecisionCtx where-  environment = amazonCtx . environment  type MonadDecisionCtx c m =   ( MonadStatsCtx c m