module Network.AWS.Flow.Types where
import Network.AWS.Flow.Prelude hiding ( ByteString, catch )
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Logger
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Data.Aeson
import Data.ByteString.Lazy
import Network.AWS.Data.Crypto
import Network.AWS.SWF.Types
type Uid = Text
type Name = Text
type Version = Text
type Queue = Text
type Token = Text
type Timeout = Text
type Metadata = Maybe Text
type Artifact = (Text, Digest SHA256, Integer, ByteString)
type Blob = (Text, ByteString)
type Log = LogStr -> IO ()
data FlowConfig = FlowConfig
{ fcRegion :: Region
, fcCredentials :: Credentials
, fcTimeout :: Int
, fcPollTimeout :: Int
, fcDomain :: Text
, fcBucket :: Text
, fcPrefix :: Text
}
instance FromJSON Region where
parseJSON (String v)
| v == "eu-west-1" = return Ireland
| v == "eu-central-1" = return Frankfurt
| v == "ap-northeast-1" = return Tokyo
| v == "ap-southeast-1" = return Singapore
| v == "ap-southeast-2" = return Sydney
| v == "cn-north-1" = return Beijing
| v == "us-east-1" = return NorthVirginia
| v == "us-west-1" = return NorthCalifornia
| v == "us-west-2" = return Oregon
| v == "us-gov-west-1" = return GovCloud
| v == "fips-us-gov-west-1" = return GovCloudFIPS
| v == "sa-east-1" = return SaoPaulo
| otherwise = mzero
parseJSON _ = mzero
instance FromJSON Credentials where
parseJSON (Object v) =
FromEnv <$>
v .: "access-key-env-var" <*>
v .: "secret-key-env-var" <*>
pure Nothing
parseJSON _ = mzero
instance FromJSON FlowConfig where
parseJSON (Object v) =
FlowConfig <$>
v .: "region" <*>
v .: "credentials" <*>
v .: "timeout" <*>
v .: "poll-timeout" <*>
v .: "domain" <*>
v .: "bucket" <*>
v .: "prefix"
parseJSON _ = mzero
data FlowEnv = FlowEnv
{ feLogger :: Log
, feEnv :: Env
, feTimeout :: Seconds
, fePollTimeout :: Seconds
, feDomain :: Text
, feBucket :: Text
, fePrefix :: Text
}
newtype FlowT m a = FlowT
{ unFlowT :: LoggingT (AWST' FlowEnv m) a
} deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadLogger
)
type MonadFlow m =
( MonadCatch m
, MonadThrow m
, MonadResource m
, MonadLogger m
, MonadReader FlowEnv m
)
instance MonadThrow m => MonadThrow (FlowT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (FlowT m) where
catch (FlowT m) f = FlowT (catch m (unFlowT . f))
instance MonadBase b m => MonadBase b (FlowT m) where
liftBase = liftBaseDefault
instance MonadTrans FlowT where
lift = FlowT . lift . lift
instance MonadTransControl FlowT where
type StT FlowT a = StT (ReaderT FlowEnv) a
liftWith f = FlowT $
liftWith $ \g ->
liftWith $ \h ->
f (h . g . unFlowT)
restoreT = FlowT . restoreT . restoreT
instance MonadBaseControl b m => MonadBaseControl b (FlowT m) where
type StM (FlowT m) a = ComposeSt FlowT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadResource m => MonadResource (FlowT m) where
liftResourceT = lift . liftResourceT
instance Monad m => MonadReader FlowEnv (FlowT m) where
ask = FlowT ask
local f = FlowT . local f . unFlowT
reader = FlowT . reader
instance HasEnv FlowEnv where
environment = lens feEnv (\s a -> s { feEnv = a })
runFlowT :: FlowEnv -> FlowT m a -> m a
runFlowT e (FlowT m) = runAWST e (runLoggingT m (const . const . const $ feLogger e))
data DecideEnv = DecideEnv
{ deLogger :: Log
, dePlan :: Plan
, deEvents :: [HistoryEvent]
, deFindEvent :: Integer -> Maybe HistoryEvent
}
newtype DecideT m a = DecideT
{ unDecideT :: LoggingT (ReaderT DecideEnv m) a
} deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadLogger
)
type MonadDecide m =
( MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader DecideEnv m
)
instance MonadThrow m => MonadThrow (DecideT m) where
throwM = lift . throwM
instance MonadBase b m => MonadBase b (DecideT m) where
liftBase = liftBaseDefault
instance MonadTrans DecideT where
lift = DecideT . lift . lift
instance MonadTransControl DecideT where
type StT DecideT a = StT (ReaderT DecideEnv) a
liftWith f = DecideT $
liftWith $ \g ->
liftWith $ \h ->
f (h . g . unDecideT)
restoreT = DecideT . restoreT . restoreT
instance MonadBaseControl b m => MonadBaseControl b (DecideT m) where
type StM (DecideT m) a = ComposeSt DecideT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance Monad m => MonadReader DecideEnv (DecideT m) where
ask = DecideT ask
local f = DecideT . local f . unDecideT
reader = DecideT . reader
runDecideT :: DecideEnv -> DecideT m a -> m a
runDecideT e (DecideT m) = runReaderT (runLoggingT m (const . const . const $ deLogger e)) e
data Task = Task
{ tskName :: Name
, tskVersion :: Version
, tskQueue :: Queue
, tskTimeout :: Timeout
} deriving ( Eq, Read, Show )
instance FromJSON Task where
parseJSON (Object v) =
Task <$>
v .: "name" <*>
v .: "version" <*>
v .: "queue" <*>
v .: "timeout"
parseJSON _ = mzero
data Timer = Timer
{ tmrName :: Name
, tmrTimeout :: Timeout
} deriving ( Eq, Read, Show )
instance FromJSON Timer where
parseJSON (Object v) =
Timer <$>
v .: "name" <*>
v .: "timeout"
parseJSON _ = mzero
data Start = Start
{ strtTask :: Task
} deriving ( Eq, Read, Show )
instance FromJSON Start where
parseJSON (Object v) =
Start <$>
v .: "flow"
parseJSON _ = mzero
data Spec
= Work
{ wrkTask :: Task
}
| Sleep
{ slpTimer :: Timer
} deriving ( Eq, Read, Show )
instance FromJSON Spec where
parseJSON (Object v) =
msum
[ Work <$>
v .: "work"
, Sleep <$>
v .: "sleep"
]
parseJSON _ =
mzero
data End
= Stop
| Continue
deriving ( Eq, Read, Show )
instance FromJSON End where
parseJSON (String v)
| v == "stop" = return Stop
| v == "continue" = return Continue
| otherwise = mzero
parseJSON _ = mzero
data Plan = Plan
{ plnStart :: Start
, plnSpecs :: [Spec]
, plnEnd :: End
} deriving ( Eq, Read, Show )
instance FromJSON Plan where
parseJSON (Object v) =
Plan <$>
v .: "start" <*>
v .: "specs" <*>
v .: "end"
parseJSON _ = mzero