module Network.AWS.Flow.Internal
( runAWS
, runFlowT
, runDecide
, throwStringError
, hoistStringEither
, maybeToFlowError
, newUid
) where
import Control.Applicative ( (<$>), (<*>) )
import Control.Lens ( (^.) )
import Control.Monad ( msum, mzero )
import Control.Monad.Base ( MonadBase, liftBase, liftBaseDefault )
import Control.Monad.Except ( MonadError, ExceptT, runExceptT, throwError )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.Logger ( LogStr, runLoggingT )
import Control.Monad.Reader ( MonadReader, ReaderT, ask, asks, local, runReaderT )
import Control.Monad.Trans.AWS ( AWST, Env, Error, runAWST )
import Control.Monad.Trans.Class ( MonadTrans, lift )
import Control.Monad.Trans.Control ( MonadBaseControl
, MonadTransControl
, StM
, StT
, ComposeSt
, liftBaseWith
, liftWith
, defaultLiftBaseWith
, defaultRestoreM
, restoreM
, restoreT )
import Data.Aeson ( FromJSON, Value(..), parseJSON, (.:) )
import Data.HashMap.Strict ( fromList, lookup )
import Data.Text ( pack )
import Data.UUID ( toString )
import Data.UUID.V4 ( nextRandom )
import Network.AWS.SWF
import Network.AWS.Flow.Types
import Prelude hiding ( lookup )
runFlowT :: MonadIO m => FlowEnv -> FlowT m a -> m (Either FlowError a)
runFlowT e (FlowT k) = runExceptT (runReaderT (runLoggingT k l) e) where
l = const . const . const $ feLogger e
instance MonadBase b m => MonadBase b (FlowT m) where
liftBase = liftBaseDefault
instance MonadBaseControl b m => MonadBaseControl b (FlowT m) where
type StM (FlowT m) a = ComposeSt FlowT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTrans FlowT where
lift = FlowT . lift . lift . lift
instance MonadTransControl FlowT where
type StT FlowT a =
StT (ExceptT FlowError) (StT (ReaderT FlowEnv) a)
liftWith f = FlowT $
liftWith $ \g ->
liftWith $ \h ->
liftWith $ \i ->
f (i . h . g . unFlowT)
restoreT = FlowT . restoreT . restoreT . restoreT
instance Monad m => MonadReader FlowEnv (FlowT m) where
ask = FlowT ask
local f = FlowT . local f . unFlowT
runDecideT :: MonadIO m => DecideEnv -> DecideT m a -> m (Either FlowError a)
runDecideT e (DecideT k) = runExceptT (runReaderT (runLoggingT k l) e) where
l = const . const . const $ deLogger e
instance MonadBase b m => MonadBase b (DecideT m) where
liftBase = liftBaseDefault
instance MonadBaseControl b m => MonadBaseControl b (DecideT m) where
type StM (DecideT m) a = ComposeSt DecideT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTrans DecideT where
lift = DecideT . lift . lift . lift
instance MonadTransControl DecideT where
type StT DecideT a =
StT (ExceptT FlowError) (StT (ReaderT DecideEnv) a)
liftWith f = DecideT $
liftWith $ \g ->
liftWith $ \h ->
liftWith $ \i ->
f (i . h . g . unDecideT)
restoreT = DecideT . restoreT . restoreT . restoreT
instance Monad m => MonadReader DecideEnv (DecideT m) where
ask = DecideT ask
local f = DecideT . local f . unDecideT
instance FromJSON Plan where
parseJSON (Object v) =
Plan <$>
v .: "start" <*>
v .: "specs" <*>
v .: "end"
parseJSON _ = mzero
instance FromJSON Spec where
parseJSON (Object v) =
msum
[ Work <$>
v .: "work"
, Sleep <$>
v .: "sleep"
]
parseJSON _ =
mzero
instance FromJSON End where
parseJSON (String v)
| v == "stop" = return Stop
| v == "continue" = return Continue
| otherwise = mzero
parseJSON _ = mzero
instance FromJSON Start where
parseJSON (Object v) =
Start <$>
v .: "flow"
parseJSON _ = mzero
instance FromJSON Task where
parseJSON (Object v) =
Task <$>
v .: "name" <*>
v .: "version" <*>
v .: "queue" <*>
v .: "timeout"
parseJSON _ = mzero
instance FromJSON Timer where
parseJSON (Object v) =
Timer <$>
v .: "name" <*>
v .: "timeout"
parseJSON _ = mzero
hoistAWSEither :: MonadError FlowError m => Either Error a -> m a
hoistAWSEither = either (throwError . AWSError) return
runAWS :: MonadFlow m => (FlowEnv -> Env) -> AWST m a -> m a
runAWS env action = do
e <- asks env
r <- runAWST e action
hoistAWSEither r
throwStringError :: MonadError FlowError m => String -> m a
throwStringError = throwError . FlowError
hoistStringEither :: MonadError FlowError m => Either String a -> m a
hoistStringEither = either throwStringError return
runDecide :: (MonadError FlowError m, MonadIO m)
=> (LogStr -> IO ()) -> Plan -> [HistoryEvent] -> DecideT m a -> m a
runDecide logger plan events action =
runDecideT env action >>= hoistFlowEither
where
env = DecideEnv logger plan events findEvent where
findEvent =
flip lookup $ fromList $ flip map events $ \e ->
(e ^. heEventId, e)
hoistFlowEither = either throwError return
maybeToEither :: e -> Maybe a -> Either e a
maybeToEither e = maybe (Left e) Right
maybeToFlowError :: MonadError FlowError m => String -> Maybe a -> m a
maybeToFlowError e = hoistStringEither . maybeToEither e
newUid :: MonadIO m => m Uid
newUid =
liftIO $ do
r <- nextRandom
return $ pack $ toString r