{-# 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

-- | Define a response to provide for any matched requests
data Matcher where
  -- | Matches calls to 'send' where the given predicate holds
  --
  -- @since 0.1.0.0
  SendMatcher
    :: forall a
     . (AWSRequest a, Typeable a, Typeable (AWSResponse a))
    => (a -> Bool)
    -> Either Error (AWSResponse a)
    -> Matcher
  -- | Matches calls to 'await' where the given predicate holds
  --
  -- @since 0.1.0.0
  AwaitMatcher
    :: forall a
     . (AWSRequest a, Typeable a)
    => (Waiter.Wait a -> a -> Bool)
    -> Either Error Waiter.Accept
    -> Matcher

-- |
--
-- @since 0.1.0.0
newtype Matchers = Matchers
  { Matchers -> [Matcher]
unMatchers :: [Matcher]
  }
  deriving newtype (NonEmpty Matchers -> Matchers
Matchers -> Matchers -> Matchers
(Matchers -> Matchers -> Matchers)
-> (NonEmpty Matchers -> Matchers)
-> (forall b. Integral b => b -> Matchers -> Matchers)
-> Semigroup 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
$c<> :: Matchers -> Matchers -> Matchers
<> :: Matchers -> Matchers -> Matchers
$csconcat :: NonEmpty Matchers -> Matchers
sconcat :: NonEmpty Matchers -> Matchers
$cstimes :: forall b. Integral b => b -> Matchers -> Matchers
stimes :: forall b. Integral b => b -> Matchers -> Matchers
Semigroup, Semigroup Matchers
Matchers
Semigroup Matchers =>
Matchers
-> (Matchers -> Matchers -> Matchers)
-> ([Matchers] -> Matchers)
-> Monoid Matchers
[Matchers] -> Matchers
Matchers -> Matchers -> Matchers
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Matchers
mempty :: Matchers
$cmappend :: Matchers -> Matchers -> Matchers
mappend :: Matchers -> Matchers -> Matchers
$cmconcat :: [Matchers] -> Matchers
mconcat :: [Matchers] -> Matchers
Monoid)

-- |
--
-- @since 0.1.0.0
class HasMatchers env where
  matchersL :: Lens' env Matchers

-- |
--
-- @since 0.1.0.0
instance HasMatchers Matchers where
  matchersL :: Lens' Matchers Matchers
matchersL = (Matchers -> f Matchers) -> Matchers -> f Matchers
forall a. a -> a
id

-- | Add a 'Matcher' for the duration of the block
--
-- @since 0.1.0.0
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 = [Matcher] -> m a -> m a
forall env (m :: * -> *) a.
(MonadReader env m, HasMatchers env) =>
[Matcher] -> m a -> m a
withMatchers ([Matcher] -> m a -> m a)
-> (Matcher -> [Matcher]) -> Matcher -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matcher -> [Matcher]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Add multiple 'Matcher's for the duration of the block
--
-- @since 0.1.0.0
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 = (env -> env) -> m a -> m a
forall a. (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((env -> env) -> m a -> m a) -> (env -> env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ (Matchers -> Identity Matchers) -> env -> Identity env
forall env. HasMatchers env => Lens' env Matchers
Lens' env Matchers
matchersL ((Matchers -> Identity Matchers) -> env -> Identity env)
-> Matchers -> env -> env
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Matcher] -> Matchers
Matchers [Matcher]
ms

-- |
--
-- @since 0.1.0.0
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 (Maybe (Either Error (AWSResponse a))
 -> m (Either Error (AWSResponse a)))
-> m (Maybe (Either Error (AWSResponse a)))
-> m (Either Error (AWSResponse a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Matcher -> Maybe (Either Error (AWSResponse a)))
-> m (Maybe (Either Error (AWSResponse a)))
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
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
matchReq (a -> Maybe ()) -> Maybe a -> Maybe ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
req
      Either Error (AWSResponse a)
-> Maybe (Either Error (AWSResponse a))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Either Error (AWSResponse a)
resp
    AwaitMatcher {} -> Maybe (Either Error (AWSResponse a))
forall a. Maybe a
Nothing

-- |
--
-- @since 0.1.0.0
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 (Maybe (Either Error Accept) -> m (Either Error Accept))
-> m (Maybe (Either Error Accept)) -> m (Either Error Accept)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Matcher -> Maybe (Either Error Accept))
-> m (Maybe (Either Error Accept))
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 {} -> Maybe (Either Error Accept)
forall a. Maybe a
Nothing
    AwaitMatcher Wait a -> a -> Bool
matchReq Either Error Accept
acc -> do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Maybe Bool -> Maybe ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wait a -> a -> Bool
matchReq (Wait a -> a -> Bool) -> Maybe (Wait a) -> Maybe (a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wait a -> Maybe (Wait a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Wait a
w Maybe (a -> Bool) -> Maybe a -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
req
      Either Error Accept -> Maybe (Either Error Accept)
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 <- Getting Matchers env Matchers -> m Matchers
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Matchers env Matchers
forall env. HasMatchers env => Lens' env Matchers
Lens' env Matchers
matchersL
  Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ (Matcher -> Maybe a) -> [Matcher] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Matcher -> Maybe a
f ([Matcher] -> [a]) -> [Matcher] -> [a]
forall a b. (a -> b) -> a -> b
$ Matchers -> [Matcher]
unMatchers Matchers
matchers

-- |
--
-- @since 0.1.0.0
newtype UnmatchedRequestError = UnmatchedRequestError
  { UnmatchedRequestError -> String
unmatchedRequestType :: String
  }
  deriving anyclass (Show UnmatchedRequestError
Typeable UnmatchedRequestError
(Typeable UnmatchedRequestError, Show UnmatchedRequestError) =>
(UnmatchedRequestError -> SomeException)
-> (SomeException -> Maybe UnmatchedRequestError)
-> (UnmatchedRequestError -> String)
-> Exception UnmatchedRequestError
SomeException -> Maybe UnmatchedRequestError
UnmatchedRequestError -> String
UnmatchedRequestError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: UnmatchedRequestError -> SomeException
toException :: UnmatchedRequestError -> SomeException
$cfromException :: SomeException -> Maybe UnmatchedRequestError
fromException :: SomeException -> Maybe UnmatchedRequestError
$cdisplayException :: UnmatchedRequestError -> String
displayException :: UnmatchedRequestError -> String
Exception)

-- Morally-speaking, Show should be reserved for a Haskell-like string
-- representation (derived is best), and displayException is where you make it
-- human-readable. Sadly, too many tools (*cough* hspec) use show instead of
-- displayException, and we want it to look nice there. Sigh.
--
-- https://github.com/hspec/hspec/issues/289
instance Show UnmatchedRequestError where
  show :: UnmatchedRequestError -> String
show UnmatchedRequestError
ex =
    String
"Unexpected AWS request made within MockT: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnmatchedRequestError -> String
unmatchedRequestType UnmatchedRequestError
ex
      String -> ShowS
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 =
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ UnmatchedRequestError -> IO a
forall e a. Exception e => e -> IO a
throwIO (UnmatchedRequestError -> IO a) -> UnmatchedRequestError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> UnmatchedRequestError
UnmatchedRequestError (String -> UnmatchedRequestError)
-> String -> UnmatchedRequestError
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy req -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy req -> TypeRep) -> Proxy req -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @req)
    a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure