packages feed

loup (empty) → 0.0.1

raw patch · 15 files changed

+663/−0 lines, 15 filesdep +aesondep +amazonkadep +amazonka-swfsetup-changed

Dependencies added: aeson, amazonka, amazonka-swf, base, conduit, lifted-async, loup, monad-control, optparse-generic, preamble, shakers, turtle, uuid, yaml

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (C) 2015-2016 Swift Navigation Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Shakefile.hs view
@@ -0,0 +1,44 @@+#!/usr/bin/env stack+{- stack+    runghc+    --package shakers+ -}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Shake makefile for project.+--+import Development.Shakers++-- | Main entry point.+--+main :: IO ()+main = shakeMain $ do+  let pats =+        [ "stack.yaml"+        , "Shakefile.hs"+        , "main//*.hs"+        , "src//*.hs"+        ]++  -- | Haskell rules.+  --+  hsRules "."++  -- | Cabal rules.+  --+  cabalRules "." "loup.cabal"++  -- | Stack rules.+  --+  stackRules "." pats++  -- | sanity+  --+  fake "." pats "sanity" $ const $+    need [ "build-error", "lint" ]++  -- | Default things to run.+  --+  want [ "sanity", "format" ]
+ loup.cabal view
@@ -0,0 +1,67 @@+name:                  loup+version:               0.0.1+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+license:               MIT+license-file:          LICENSE+author:                Swift Navigation Inc.+maintainer:            Mark Fine <dev@swiftnav.com>+copyright:             Copyright (C) 2017 Swift Navigation, Inc.+category:              Network, AWS, Cloud, Distributed Computing+build-type:            Simple+cabal-version:         >= 1.22++source-repository head+  type:                git+  location:            git@github.com:swift-nav/loup.git++library+  exposed-modules:     Network.AWS.Loup+  other-modules:       Network.AWS.Loup.Act+                     , Network.AWS.Loup.Ctx+                     , Network.AWS.Loup.Decide+                     , Network.AWS.Loup.Prelude+                     , Network.AWS.Loup.Types+                     , Network.AWS.Loup.Types.Ctx+                     , Network.AWS.Loup.Types.Product+                     , Network.AWS.Loup.Types.Sum+  default-language:    Haskell2010+  hs-source-dirs:      src+  ghc-options:         -Wall+  build-depends:       aeson+                     , amazonka+                     , amazonka-swf+                     , base == 4.8.*+                     , conduit+                     , lifted-async+                     , monad-control+                     , preamble+                     , turtle+                     , uuid+                     , yaml++executable loup-actor+  hs-source-dirs:      main+  main-is:             actor.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:       base+                     , loup+                     , optparse-generic+  default-language:    Haskell2010++executable loup-decider+  hs-source-dirs:      main+  main-is:             decider.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:       base+                     , loup+                     , optparse-generic+  default-language:    Haskell2010++executable shake-loup+  main-is:             Shakefile.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:       base == 4.8.*+                     , shakers+  default-language:    Haskell2010
+ main/actor.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Run actor.+--+import Network.AWS.Loup+import Options.Generic++-- | Args+--+-- Program arguments.+--+data Args = Args+  { domain   :: Text+    -- ^ Workflow domain.+  , queue    :: Text+    -- ^ Queue to listen to act on.+  , interval :: Int+    -- ^ Interval to heartbeat at.+  , command  :: Text+    -- ^ Command to run.+  } deriving (Show, Generic)++instance ParseRecord Args++-- | Run actor.+--+main :: IO ()+main = do+  args <- getRecord "Actor"+  actMain+    (domain args)+    (queue args)+    (interval args)+    (command args)
+ main/decider.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Run actor.+--+import Network.AWS.Loup+import Options.Generic++-- | Args+--+-- Program arguments.+--+data Args = Args+  { domain :: Text+    -- ^ Configuration file.+  , plan   :: FilePath+    -- ^ Plan file to decide on.+  } deriving (Show, Generic)++instance ParseRecord Args++-- | Run decider.+--+main :: IO ()+main = do+  args <- getRecord "Decider"+  decideMain+    (domain args)+    (plan args)
+ src/Network/AWS/Loup.hs view
@@ -0,0 +1,10 @@+-- | Public Module+--+module Network.AWS.Loup+  ( module Exports+  ) where++import Network.AWS.Loup.Act     as Exports+import Network.AWS.Loup.Decide  as Exports+import Network.AWS.Loup.Prelude as Exports+import Network.AWS.Loup.Types   as Exports
+ src/Network/AWS/Loup/Act.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | SWF Actor logic.+--+module Network.AWS.Loup.Act+  ( act+  , actMain+  ) where++import Control.Concurrent.Async.Lifted+import Control.Monad.Trans.AWS+import Network.AWS.Loup.Ctx+import Network.AWS.Loup.Prelude+import Network.AWS.Loup.Types+import Network.AWS.SWF+import Turtle                          hiding (input)++-- | 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)++-- | Successful activity completion.+--+completeActivity :: MonadAmazonCtx c m => Text -> m ()+completeActivity token =+  void $ send $ respondActivityTaskCompleted token++-- | Hearbeat.+--+heartbeat :: MonadAmazonCtx c m => Text -> m ()+heartbeat token =+  void $ send $ recordActivityTaskHeartbeat token++-- | Run a managed action inside a temp directory.+--+intempdir :: MonadIO m => Managed a -> m ()+intempdir action =+  sh $ using $ do+    fromdir <- pwd+    todir   <- mktempdir "/tmp" "loup-"+    cptree fromdir todir+    cd todir+    action++-- | Run command with input.+--+runActivity :: MonadCtx c m => Text -> Maybe Text -> m ()+runActivity command input = do+  traceInfo "run" [ "command" .= command, "input" .= input]+  intempdir $ do+    liftIO $ maybe_ input $ writeTextFile "input.json"+    stdout $ inshell command mempty++-- | Actor logic - poll for work, download artifacts, run command, upload artifacts.+--+act :: MonadAmazonCtx c m => Text -> Text -> Int -> Text -> m ()+act domain queue interval command =+  preAmazonCtx [ "label" .= LabelAct, "domain" .= domain, "queue" .= queue ] $ do+    traceInfo "poll" mempty+    (token, input) <- pollActivity domain (taskList queue)+    maybe_ token $ \token' -> do+      traceInfo "start" mempty+      race_ (runEvery (interval * 1000000) $ heartbeat token') (runActivity command input)+      completeActivity token'+      traceInfo "finish" mempty++-- | Run actor from main with configuration.+--+actMain :: MonadControl m => Text -> Text -> Int -> Text -> m ()+actMain domain queue interval command =+  runResourceT $ runCtx $ runStatsCtx $ runAmazonCtx $+    forever $ act domain queue interval command
+ src/Network/AWS/Loup/Ctx.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Contexts for monad transformers.+--+module Network.AWS.Loup.Ctx+  ( runAmazonCtx+  , preAmazonCtx+  , runDecisionCtx+  ) where++import Control.Monad.Trans.AWS+import Data.Aeson+import Network.AWS.Loup.Prelude+import Network.AWS.Loup.Types+import Network.AWS.SWF++-- | Catcher for exceptions, traces and rethrows.+--+botSomeExceptionCatch :: MonadCtx c m => SomeException -> m a+botSomeExceptionCatch ex = do+  traceError "exception" [ "error" .= displayException ex ]+  throwIO ex++-- | Catcher for exceptions, emits stats and rethrows.+--+topSomeExceptionCatch :: MonadStatsCtx c m => SomeException -> m a+topSomeExceptionCatch ex = do+  statsIncrement "exception" [ "reason" =. show ex ]+  throwIO ex++-- | Run bottom TransT.+--+runBotTransT :: (MonadMain m, HasCtx c) => c -> TransT c m a -> m a+runBotTransT c action = runTransT c $ catch action botSomeExceptionCatch++-- | Run top TransT.+--+runTopTransT :: (MonadMain m, HasStatsCtx c) => c -> TransT c m a -> m a+runTopTransT c action = runBotTransT c $ catch action topSomeExceptionCatch++-- | Run amazon context.+--+runAmazonCtx :: MonadStatsCtx c m => TransT AmazonCtx m a -> m a+runAmazonCtx action = do+  c <- view statsCtx+  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 plan events action = do+  c <- view amazonCtx+  runBotTransT (DecisionCtx c plan events) action
+ src/Network/AWS/Loup/Decide.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | SWF Decider logic.+--+module Network.AWS.Loup.Decide+  ( decide+  , decideMain+  ) where++import Control.Monad.Trans.AWS+import Data.Conduit+import Data.Conduit.List        hiding (foldM)+import Data.UUID+import Data.UUID.V4+import Data.Yaml+import Network.AWS.Loup.Ctx+import Network.AWS.Loup.Prelude+import Network.AWS.Loup.Types+import Network.AWS.SWF++-- | Poll for decision.+--+pollDecision :: MonadAmazonCtx c m => Text -> TaskList -> m (Maybe Text, [HistoryEvent])+pollDecision domain list = do+  pfdtrs <- paginate (pollForDecisionTask domain list) $$ consume+  return (join $ headMay $ view pfdtrsTaskToken <$> pfdtrs, reverse $ join $ view pfdtrsEvents <$> pfdtrs)++-- | Successful decision completion.+--+completeDecision :: MonadAmazonCtx c m => Text -> [Decision] -> m ()+completeDecision token decisions =+  void $ send $ set rdtcDecisions decisions $ respondDecisionTaskCompleted token++scheduleActivity :: UUID -> ActivityType -> TaskList -> Maybe Text -> Decision+scheduleActivity uid activity list input = do+  let satda = scheduleActivityTaskDecisionAttributes activity (toText uid)+        & satdaTaskList .~ return list+        & satdaInput    .~ input+  set dScheduleActivityTaskDecisionAttributes (return satda) $ decision ScheduleActivityTask++completeActivity :: Decision+completeActivity = do+  let cweda = completeWorkflowExecutionDecisionAttributes+  set dCompleteWorkflowExecutionDecisionAttributes (return cweda) $ decision CompleteWorkflowExecution++cancelActivity :: Decision+cancelActivity = do+  let cweda = cancelWorkflowExecutionDecisionAttributes+  set dCancelWorkflowExecutionDecisionAttributes (return cweda) $ decision CancelWorkflowExecution++requestCancel :: UUID -> Decision+requestCancel uid = do+  let rcatda = requestCancelActivityTaskDecisionAttributes (toText uid)+  set dRequestCancelActivityTaskDecisionAttributes (return rcatda) $ decision RequestCancelActivityTask++findEvent :: MonadDecisionCtx c m => EventType -> m (Maybe HistoryEvent)+findEvent eventType = do+  let f []     = return Nothing+      f (e:es) = bool (f es) (return $ Just e) $ e ^. heEventType == eventType+  events <- view dcEvents+  f events++begin :: MonadDecisionCtx c m => HistoryEvent -> m [Decision]+begin event = do+  traceInfo "begin" mempty+  uid  <- liftIO nextRandom+  task <- view pActivityTask <$> view dcPlan+  let input = join $ view weseaInput <$> event ^. heWorkflowExecutionStartedEventAttributes+  return [ scheduleActivity uid (task ^. tActivityType) (task ^. tTaskList) input ]++cancel :: MonadDecisionCtx c m => m [Decision]+cancel = do+  traceInfo "cancel" mempty+  event <- findEvent ActivityTaskScheduled+  let uid = join $ fromText . view atseaActivityId <$> join (view heActivityTaskScheduledEventAttributes <$> event)+  return [ maybe cancelActivity requestCancel uid ]++completed :: MonadDecisionCtx c m => m [Decision]+completed = do+  traceInfo "completed" mempty+  return [ completeActivity ]++canceled :: MonadDecisionCtx c m => m [Decision]+canceled = do+  traceInfo "canceled" mempty+  return [ completeActivity ]++timedout :: MonadDecisionCtx c m => m [Decision]+timedout = do+  traceInfo "timedout" 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 :: MonadDecisionCtx c m => m [Decision]+failed = do+  traceInfo "failed" mempty+  return [ cancelActivity ]++-- | Schedule decision based on history events.+--+schedule :: MonadDecisionCtx c m => m [Decision]+schedule = do+  traceInfo "schedule" mempty+  let f []                                                     = return mempty+      f (e:es)+        | 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+        | otherwise                                            = f es+  events <- view dcEvents+  f events++-- | Decider logic - poll for decisions, make decisions.+--+decide :: MonadAmazonCtx c m => Text -> Plan -> m ()+decide domain plan =+  preAmazonCtx [ "label" .= LabelDecide, "domain" .= domain, "plan" .= plan ] $ do+    traceInfo "poll" mempty+    (token, events) <- pollDecision domain (plan ^. pDecisionTask ^. tTaskList)+    maybe_ token $ \token' -> do+      traceInfo "start" mempty+      runDecisionCtx plan events $ do+        decisions <- schedule+        completeDecision token' decisions+      traceInfo "finish" mempty++-- | Run decider from main with configuration.+--+decideMain :: MonadControl m => Text -> FilePath -> m ()+decideMain domain file =+  runResourceT $ runCtx $ runStatsCtx $ runAmazonCtx $ do+    plans <- liftIO $ join . maybeToList <$> decodeFile file+    runConcurrent $ forever . decide domain <$> plans
+ src/Network/AWS/Loup/Prelude.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Local Prelude.+--+module Network.AWS.Loup.Prelude+  ( module Exports+  , runConcurrent+  , runEvery+  ) where++import Control.Concurrent+import Control.Concurrent.Async.Lifted+import Control.Monad.Trans.Control+import Preamble                        as Exports++-- | Run a list of actions concurrently.+--+runConcurrent :: MonadBaseControl IO m => [m a] -> m ()+runConcurrent = void . runConcurrently . sequenceA . map Concurrently++-- | Run an action every interval.+--+runEvery :: MonadIO m => Int -> m a -> m b+runEvery ms action =+  forever $ do+    liftIO $ threadDelay ms+    action
+ src/Network/AWS/Loup/Types.hs view
@@ -0,0 +1,9 @@+-- | Export all the modules in the Types directory.+--+module Network.AWS.Loup.Types+  ( module Exports+  ) where++import Network.AWS.Loup.Types.Ctx     as Exports+import Network.AWS.Loup.Types.Product as Exports+import Network.AWS.Loup.Types.Sum     as Exports
+ src/Network/AWS/Loup/Types/Ctx.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Context objects for monad transformers.+--+module Network.AWS.Loup.Types.Ctx+  ( module Network.AWS.Loup.Types.Ctx+  ) where++import Control.Monad.Trans.AWS+import Network.AWS.Loup.Prelude+import Network.AWS.Loup.Types.Product+import Network.AWS.SWF++-- | AmazonCtx+--+-- Amazon context.+--+data AmazonCtx = AmazonCtx+  { _acStatsCtx :: StatsCtx+    -- ^ Parent context.+  , _acEnv      :: Env+    -- ^ Amazon environment.+  }++$(makeClassyConstraints ''AmazonCtx [''HasStatsCtx, ''HasEnv])++instance HasStatsCtx AmazonCtx where+  statsCtx = acStatsCtx++instance HasCtx AmazonCtx where+  ctx = statsCtx . ctx++instance HasEnv AmazonCtx where+  environment = acEnv++type MonadAmazonCtx c m =+  ( MonadStatsCtx c m+  , HasAmazonCtx c+  , AWSConstraint c m+  )++-- | DecisionsCtx+--+-- Decision context.+--+data DecisionCtx = DecisionCtx+  { _dcAmazonCtx :: AmazonCtx+    -- ^ Parent context.+  , _dcPlan      :: Plan+    -- ^ Decision plan.+  , _dcEvents    :: [HistoryEvent]+    -- ^ History events.+  }++$(makeClassyConstraints ''DecisionCtx [''HasAmazonCtx])++instance HasAmazonCtx DecisionCtx where+  amazonCtx = dcAmazonCtx++instance HasStatsCtx DecisionCtx where+  statsCtx = amazonCtx . statsCtx++instance HasCtx DecisionCtx where+  ctx = statsCtx . ctx++instance HasEnv DecisionCtx where+  environment = amazonCtx . environment++type MonadDecisionCtx c m =+  ( MonadStatsCtx c m+  , HasDecisionCtx c+  )
+ src/Network/AWS/Loup/Types/Product.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Various product types.+--+module Network.AWS.Loup.Types.Product+  ( module Network.AWS.Loup.Types.Product+  ) where++import Data.Aeson.TH+import Network.AWS.Loup.Prelude+import Network.AWS.SWF++-- | Task+--+-- Activity and Decision task.+--+data Task = Task+  { _tActivityType :: ActivityType+    -- ^ Activity type.+  , _tTaskList     :: TaskList+    -- ^ Task list.+  } deriving (Show, Eq)++$(makeLenses ''Task)+$(deriveJSON spinalOptions ''Task)++-- | Plan+--+-- Group of tasks.+--+data Plan = Plan+  { _pDecisionTask :: Task+    -- ^ Decision task.+  , _pActivityTask :: Task+    -- ^ Activity task.+  } deriving (Show, Eq)++$(makeLenses ''Plan)+$(deriveJSON spinalOptions ''Plan)
+ src/Network/AWS/Loup/Types/Sum.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Various sum types.+--+module Network.AWS.Loup.Types.Sum where++import Data.Aeson.TH+import Network.AWS.Loup.Prelude++-- | LabelType+--+-- Tags for referencing workers.+--+data LabelType+  = LabelAct+  | LabelDecide+  deriving (Show, Eq)++$(deriveJSON spinalOptions ''LabelType)