module Control.Monad.Trans.AWS
(
AWS
, AWST
, MonadAWS
, runAWST
, Env
, envAuth
, envRegion
, envManager
, envLogger
, scoped
, Credentials (..)
, AWS.newEnv
, AWS.getEnv
, debug
, whenDebug
, Region (..)
, within
, Error
, hoistEither
, throwAWSError
, verify
, verifyWith
, send
, send_
, sendCatch
, paginate
, paginateCatch
, presign
, module Network.AWS.Types
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Lens
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Data.Conduit
import Data.Text (Text)
import Data.Time
import Network.AWS (Env, envRegion, envLogger, envAuth, envManager)
import qualified Network.AWS as AWS
import Network.AWS.Auth
import qualified Network.AWS.Types as Types
import Network.AWS.Types hiding (debug)
type Error = ServiceError String
type AWS = AWST IO
type MonadAWS m =
( MonadBaseControl IO m
, MonadCatch m
, MonadResource m
, MonadError Error m
, MonadReader Env m
)
newtype AWST m a = AWST
{ unAWST :: ReaderT (Env, InternalState) (ExceptT Error m) a
} deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadIO
, MonadPlus
, MonadThrow
, MonadCatch
, MonadError Error
)
instance Monad m => MonadReader Env (AWST m) where
ask = AWST (fst `liftM` ask)
local f = AWST . local (first f) . unAWST
instance MonadTrans AWST where
lift = AWST . lift . lift
instance MonadBase b m => MonadBase b (AWST m) where
liftBase = liftBaseDefault
instance MonadTransControl AWST where
newtype StT AWST a = StTAWS
{ unStTAWS :: StT (ExceptT Error) (StT (ReaderT (Env, InternalState)) a)
}
liftWith f = AWST $
liftWith $ \g ->
liftWith $ \h ->
f (liftM StTAWS . h . g . unAWST)
restoreT = AWST . restoreT . restoreT . liftM unStTAWS
instance MonadBaseControl b m => MonadBaseControl b (AWST m) where
newtype StM (AWST m) a = StMAWST { unStMAWST :: ComposeSt AWST m a }
liftBaseWith = defaultLiftBaseWith StMAWST
restoreM = defaultRestoreM unStMAWST
instance MFunctor AWST where
hoist nat m = AWST (ReaderT (ExceptT . nat . runAWST' m))
instance MMonad AWST where
embed f m = liftM2 (,) ask resources
>>= f . runAWST' m
>>= either throwError return
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m)
=> MonadResource (AWST m) where
liftResourceT f = resources >>= liftIO . runInternalState f
runAWST :: MonadBaseControl IO m => Env -> AWST m a -> m (Either Error a)
runAWST e m = runResourceT (withInternalState (runAWST' m . (e,)))
runAWST' :: AWST m a -> (Env, InternalState) -> m (Either Error a)
runAWST' (AWST k) = runExceptT . runReaderT k
resources :: Monad m => AWST m InternalState
resources = AWST (ReaderT (return . snd))
hoistEither :: (MonadError Error m, AWSError e) => Either e a -> m a
hoistEither = either throwAWSError return
throwAWSError :: (MonadError Error m, AWSError e) => e -> m a
throwAWSError = throwError . awsError
verify :: (AWSError e, MonadError Error m)
=> Prism' e a
-> e
-> m ()
verify p e
| isn't p e = throwAWSError e
| otherwise = return ()
verifyWith :: (AWSError e, MonadError Error m)
=> Prism' e a
-> (a -> Bool)
-> e
-> m ()
verifyWith p f e = either (const err) g (matching p e)
where
g x | f x = return ()
| otherwise = err
err = throwAWSError e
scoped :: MonadReader Env m => (Env -> m a) -> m a
scoped f = ask >>= f
debug :: (MonadIO m, MonadReader Env m) => Text -> m ()
debug t = view envLogger >>= (`Types.debug` t)
whenDebug :: MonadReader Env m => m () -> m ()
whenDebug f = do
l <- view envLogger
case l of
Debug _ -> f
_ -> return ()
within :: MonadReader Env m => Region -> m a -> m a
within r = local (envRegion .~ r)
send :: ( MonadCatch m
, MonadResource m
, MonadReader Env m
, MonadError Error m
, AWSRequest a
)
=> a
-> m (Rs a)
send = sendCatch >=> hoistEither
send_ :: ( MonadCatch m
, MonadResource m
, MonadReader Env m
, MonadError Error m
, AWSRequest a
)
=> a
-> m ()
send_ = void . send
sendCatch :: ( MonadCatch m
, MonadResource m
, MonadReader Env m
, AWSRequest a
)
=> a
-> m (Response a)
sendCatch rq = scoped (`AWS.send` rq)
paginate :: ( MonadCatch m
, MonadResource m
, MonadReader Env m
, MonadError Error m
, AWSPager a
)
=> a
-> Source m (Rs a)
paginate rq = paginateCatch rq $= awaitForever (hoistEither >=> yield)
paginateCatch :: ( MonadCatch m
, MonadResource m
, MonadReader Env m
, AWSPager a
)
=> a
-> Source m (Response a)
paginateCatch rq = scoped (`AWS.paginate` rq)
presign :: ( MonadIO m
, MonadReader Env m
, AWSRequest a
, AWSPresigner (Sg (Sv a))
)
=> a
-> UTCTime
-> UTCTime
-> m (Signed a (Sg (Sv a)))
presign rq t x = scoped (\e -> AWS.presign e rq t x)