{-# LANGUAGE AllowAmbiguousTypes #-}
module Control.Monad.AWS.Matchers
( Matchers
, HasMatchers (..)
, Matcher (..)
, withMatcher
, withMatchers
, matchSend
, matchAwait
, UnmatchedRequestError (..)
) where
import Prelude
import Amazonka (AWSRequest, AWSResponse, Error)
import qualified Amazonka.Waiter as Waiter
import Control.Exception (Exception (..), throwIO)
import Control.Lens (Lens', view, (<>~))
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader (..))
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable
data Matcher where
SendMatcher
:: forall a
. (AWSRequest a, Typeable a, Typeable (AWSResponse a))
=> (a -> Bool)
-> Either Error (AWSResponse a)
-> Matcher
AwaitMatcher
:: forall a
. (AWSRequest a, Typeable a)
=> (Waiter.Wait a -> a -> Bool)
-> Either Error Waiter.Accept
-> Matcher
newtype Matchers = Matchers
{ Matchers -> [Matcher]
unMatchers :: [Matcher]
}
deriving newtype (NonEmpty Matchers -> Matchers
Matchers -> Matchers -> Matchers
forall b. Integral b => b -> Matchers -> Matchers
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Matchers -> Matchers
$cstimes :: forall b. Integral b => b -> Matchers -> Matchers
sconcat :: NonEmpty Matchers -> Matchers
$csconcat :: NonEmpty Matchers -> Matchers
<> :: Matchers -> Matchers -> Matchers
$c<> :: Matchers -> Matchers -> Matchers
Semigroup, Semigroup Matchers
Matchers
[Matchers] -> Matchers
Matchers -> Matchers -> Matchers
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Matchers] -> Matchers
$cmconcat :: [Matchers] -> Matchers
mappend :: Matchers -> Matchers -> Matchers
$cmappend :: Matchers -> Matchers -> Matchers
mempty :: Matchers
$cmempty :: Matchers
Monoid)
class HasMatchers env where
matchersL :: Lens' env Matchers
instance HasMatchers Matchers where
matchersL :: Lens' Matchers Matchers
matchersL = forall a. a -> a
id
withMatcher :: (MonadReader env m, HasMatchers env) => Matcher -> m a -> m a
withMatcher :: forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
Matcher -> m a -> m a
withMatcher = forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
[Matcher] -> m a -> m a
withMatchers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
withMatchers :: (MonadReader env m, HasMatchers env) => [Matcher] -> m a -> m a
withMatchers :: forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
[Matcher] -> m a -> m a
withMatchers [Matcher]
ms = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall env. HasMatchers env => Lens' env Matchers
matchersL forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Matcher] -> Matchers
Matchers [Matcher]
ms
matchSend
:: forall m env a
. ( MonadIO m
, MonadReader env m
, HasMatchers env
, Typeable a
, Typeable (AWSResponse a)
)
=> a
-> m (Either Error (AWSResponse a))
matchSend :: forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasMatchers env, Typeable a,
Typeable (AWSResponse a)) =>
a -> m (Either Error (AWSResponse a))
matchSend a
req = forall req (m :: * -> *) a.
(MonadIO m, Typeable req) =>
Maybe a -> m a
throwUnmatched @a forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
(Matcher -> Maybe a) -> m (Maybe a)
firstMatcher Matcher -> Maybe (Either Error (AWSResponse a))
go
where
go :: Matcher -> Maybe (Either Error (AWSResponse a))
go = \case
SendMatcher a -> Bool
matchReq Either Error (AWSResponse a)
resp -> do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
matchReq forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
req
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Either Error (AWSResponse a)
resp
AwaitMatcher {} -> forall a. Maybe a
Nothing
matchAwait
:: forall m env a
. (MonadIO m, MonadReader env m, HasMatchers env, Typeable a)
=> Waiter.Wait a
-> a
-> m (Either Error Waiter.Accept)
matchAwait :: forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasMatchers env, Typeable a) =>
Wait a -> a -> m (Either Error Accept)
matchAwait Wait a
w a
req = forall req (m :: * -> *) a.
(MonadIO m, Typeable req) =>
Maybe a -> m a
throwUnmatched @a forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
(Matcher -> Maybe a) -> m (Maybe a)
firstMatcher Matcher -> Maybe (Either Error Accept)
go
where
go :: Matcher -> Maybe (Either Error Accept)
go = \case
SendMatcher {} -> forall a. Maybe a
Nothing
AwaitMatcher Wait a -> a -> Bool
matchReq Either Error Accept
acc -> do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wait a -> a -> Bool
matchReq forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Wait a
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
req
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Either Error Accept
acc
firstMatcher
:: (MonadReader env m, HasMatchers env)
=> (Matcher -> Maybe a)
-> m (Maybe a)
firstMatcher :: forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
(Matcher -> Maybe a) -> m (Maybe a)
firstMatcher Matcher -> Maybe a
f = do
Matchers
matchers <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasMatchers env => Lens' env Matchers
matchersL
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Matcher -> Maybe a
f forall a b. (a -> b) -> a -> b
$ Matchers -> [Matcher]
unMatchers Matchers
matchers
newtype UnmatchedRequestError = UnmatchedRequestError
{ UnmatchedRequestError -> String
unmatchedRequestType :: String
}
deriving anyclass (Show UnmatchedRequestError
Typeable UnmatchedRequestError
SomeException -> Maybe UnmatchedRequestError
UnmatchedRequestError -> String
UnmatchedRequestError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: UnmatchedRequestError -> String
$cdisplayException :: UnmatchedRequestError -> String
fromException :: SomeException -> Maybe UnmatchedRequestError
$cfromException :: SomeException -> Maybe UnmatchedRequestError
toException :: UnmatchedRequestError -> SomeException
$ctoException :: UnmatchedRequestError -> SomeException
Exception)
instance Show UnmatchedRequestError where
show :: UnmatchedRequestError -> String
show UnmatchedRequestError
ex =
String
"Unexpected AWS request made within MockT: "
forall a. Semigroup a => a -> a -> a
<> UnmatchedRequestError -> String
unmatchedRequestType UnmatchedRequestError
ex
forall a. Semigroup a => a -> a -> a
<> String
"\nUse withMatcher to add a Matcher for this request"
throwUnmatched :: forall req m a. (MonadIO m, Typeable req) => Maybe a -> m a
throwUnmatched :: forall req (m :: * -> *) a.
(MonadIO m, Typeable req) =>
Maybe a -> m a
throwUnmatched =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> UnmatchedRequestError
UnmatchedRequestError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @req)
forall (f :: * -> *) a. Applicative f => a -> f a
pure