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

-- |
--
-- @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 = 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 = 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

-- | 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 = 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

-- |
--
-- @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 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

-- |
--
-- @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 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

-- |
--
-- @since 0.1.0.0
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)

-- 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: "
      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