{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

module SAML2.WebSSO.Test.Util.TestSP where

import Control.Concurrent.MVar
import Control.Exception (ErrorCall (..), throwIO)
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Crypto.Random.Types (MonadRandom (..))
import Data.EitherR
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map as Map
import Data.Maybe
import Data.Time
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.Void (Void)
import SAML2.WebSSO as SAML
import SAML2.WebSSO.API.Example (GetAllIdPs (..), simpleGetIdPConfigBy, simpleIsAliveID', simpleStoreID', simpleUnStoreID')
import SAML2.WebSSO.Test.Util.Types
import Servant
import System.IO
import System.IO.Silently (hCapture)
import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.Internal (runWaiSession)
import Text.XML.DSig as SAML
import URI.ByteString (pathL)
import URI.ByteString.QQ (uri)
import Prelude hiding (head)

-- | FUTUREWORK: we already have 'SimpleSP'; is there a good reason why we need both types?
newtype TestSP a = TestSP {forall a. TestSP a -> ReaderT (MVar Ctx) (ExceptT SimpleError IO) a
runTestSP :: ReaderT CtxV (ExceptT SimpleError IO) a}
  deriving ((forall a b. (a -> b) -> TestSP a -> TestSP b)
-> (forall a b. a -> TestSP b -> TestSP a) -> Functor TestSP
forall a b. a -> TestSP b -> TestSP a
forall a b. (a -> b) -> TestSP a -> TestSP b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TestSP a -> TestSP b
fmap :: forall a b. (a -> b) -> TestSP a -> TestSP b
$c<$ :: forall a b. a -> TestSP b -> TestSP a
<$ :: forall a b. a -> TestSP b -> TestSP a
Functor, Functor TestSP
Functor TestSP =>
(forall a. a -> TestSP a)
-> (forall a b. TestSP (a -> b) -> TestSP a -> TestSP b)
-> (forall a b c.
    (a -> b -> c) -> TestSP a -> TestSP b -> TestSP c)
-> (forall a b. TestSP a -> TestSP b -> TestSP b)
-> (forall a b. TestSP a -> TestSP b -> TestSP a)
-> Applicative TestSP
forall a. a -> TestSP a
forall a b. TestSP a -> TestSP b -> TestSP a
forall a b. TestSP a -> TestSP b -> TestSP b
forall a b. TestSP (a -> b) -> TestSP a -> TestSP b
forall a b c. (a -> b -> c) -> TestSP a -> TestSP b -> TestSP c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> TestSP a
pure :: forall a. a -> TestSP a
$c<*> :: forall a b. TestSP (a -> b) -> TestSP a -> TestSP b
<*> :: forall a b. TestSP (a -> b) -> TestSP a -> TestSP b
$cliftA2 :: forall a b c. (a -> b -> c) -> TestSP a -> TestSP b -> TestSP c
liftA2 :: forall a b c. (a -> b -> c) -> TestSP a -> TestSP b -> TestSP c
$c*> :: forall a b. TestSP a -> TestSP b -> TestSP b
*> :: forall a b. TestSP a -> TestSP b -> TestSP b
$c<* :: forall a b. TestSP a -> TestSP b -> TestSP a
<* :: forall a b. TestSP a -> TestSP b -> TestSP a
Applicative, Applicative TestSP
Applicative TestSP =>
(forall a b. TestSP a -> (a -> TestSP b) -> TestSP b)
-> (forall a b. TestSP a -> TestSP b -> TestSP b)
-> (forall a. a -> TestSP a)
-> Monad TestSP
forall a. a -> TestSP a
forall a b. TestSP a -> TestSP b -> TestSP b
forall a b. TestSP a -> (a -> TestSP b) -> TestSP b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. TestSP a -> (a -> TestSP b) -> TestSP b
>>= :: forall a b. TestSP a -> (a -> TestSP b) -> TestSP b
$c>> :: forall a b. TestSP a -> TestSP b -> TestSP b
>> :: forall a b. TestSP a -> TestSP b -> TestSP b
$creturn :: forall a. a -> TestSP a
return :: forall a. a -> TestSP a
Monad, Monad TestSP
Monad TestSP => (forall a. IO a -> TestSP a) -> MonadIO TestSP
forall a. IO a -> TestSP a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> TestSP a
liftIO :: forall a. IO a -> TestSP a
MonadIO, MonadReader CtxV, MonadError SimpleError)

instance HasConfig TestSP where
  getConfig :: TestSP Config
getConfig = (Ctx -> Getting Config Ctx Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config Ctx Config
Lens' Ctx Config
ctxConfig) (Ctx -> Config) -> TestSP Ctx -> TestSP Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Ctx -> TestSP Ctx
forall a. IO a -> TestSP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Ctx -> TestSP Ctx)
-> (MVar Ctx -> IO Ctx) -> MVar Ctx -> TestSP Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Ctx -> IO Ctx
forall a. MVar a -> IO a
readMVar (MVar Ctx -> TestSP Ctx) -> TestSP (MVar Ctx) -> TestSP Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TestSP (MVar Ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask)

instance HasLogger TestSP

instance HasCreateUUID TestSP

instance HasNow TestSP where
  -- Make TestSP to move forward in time after each look at the clock.
  getNow :: TestSP Time
getNow = (Ctx -> (Ctx, Time)) -> TestSP Time
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
(Ctx -> (Ctx, a)) -> m a
modifyCtx (\Ctx
ctx -> (Ctx
ctx Ctx -> (Ctx -> Ctx) -> Ctx
forall a b. a -> (a -> b) -> b
& (Time -> Identity Time) -> Ctx -> Identity Ctx
Lens' Ctx Time
ctxNow ((Time -> Identity Time) -> Ctx -> Identity Ctx)
-> (Time -> Time) -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (NominalDiffTime
1 NominalDiffTime -> Time -> Time
`addTime`), Ctx
ctx Ctx -> Getting Time Ctx Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Ctx Time
Lens' Ctx Time
ctxNow))

-- | These helpers are very similar to the ones in "SAML2.WebSSO.API.Example".  Exercise to the
-- reader: implement only once, use twice.  (Some hints: None of the "lens through IORef/MVar/etc"
-- libraries took off. There's http://hackage.haskell.org/package/monad-var but I haven't looked at
-- it. You might also want to read ekmett's comments at
-- https://www.reddit.com/r/haskell/comments/8gc8p0/extensible_monadic_lenses/. Don't ask me about
-- monadic lenses though, I'm really clueless.)
simpleStoreID ::
  (MonadIO m, MonadReader (MVar ctx) m) =>
  Lens' ctx (Map.Map (ID a) Time) ->
  ID a ->
  Time ->
  m ()
simpleStoreID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> Time -> m ()
simpleStoreID Lens' ctx (Map (ID a) Time)
sel ID a
item Time
endOfLife = do
  MVar ctx
store <- m (MVar ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar ctx -> (ctx -> IO ctx) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ctx
store (ctx -> IO ctx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ctx -> IO ctx) -> (ctx -> ctx) -> ctx -> IO ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (ID a) Time -> Identity (Map (ID a) Time))
-> ctx -> Identity ctx
Lens' ctx (Map (ID a) Time)
sel ((Map (ID a) Time -> Identity (Map (ID a) Time))
 -> ctx -> Identity ctx)
-> (Map (ID a) Time -> Map (ID a) Time) -> ctx -> ctx
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
forall {k} (a :: k).
ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
simpleStoreID' ID a
item Time
endOfLife))

simpleUnStoreID ::
  (MonadIO m, MonadReader (MVar ctx) m) =>
  Lens' ctx (Map.Map (ID a) Time) ->
  ID a ->
  m ()
simpleUnStoreID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m ()
simpleUnStoreID Lens' ctx (Map (ID a) Time)
sel ID a
item = do
  MVar ctx
store <- m (MVar ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar ctx -> (ctx -> IO ctx) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ctx
store (ctx -> IO ctx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ctx -> IO ctx) -> (ctx -> ctx) -> ctx -> IO ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (ID a) Time -> Identity (Map (ID a) Time))
-> ctx -> Identity ctx
Lens' ctx (Map (ID a) Time)
sel ((Map (ID a) Time -> Identity (Map (ID a) Time))
 -> ctx -> Identity ctx)
-> (Map (ID a) Time -> Map (ID a) Time) -> ctx -> ctx
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ID a -> Map (ID a) Time -> Map (ID a) Time
forall {k} (a :: k). ID a -> Map (ID a) Time -> Map (ID a) Time
simpleUnStoreID' ID a
item))

simpleIsAliveID ::
  (MonadIO m, MonadReader (MVar ctx) m, SP m) =>
  Lens' ctx (Map.Map (ID a) Time) ->
  ID a ->
  m Bool
simpleIsAliveID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m, SP m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m Bool
simpleIsAliveID Lens' ctx (Map (ID a) Time)
sel ID a
item = do
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  MVar ctx
store <- m (MVar ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
  ctx
items <- IO ctx -> m ctx
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ctx -> m ctx) -> IO ctx -> m ctx
forall a b. (a -> b) -> a -> b
$ MVar ctx -> IO ctx
forall a. MVar a -> IO a
readMVar MVar ctx
store
  Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Time -> ID a -> Map (ID a) Time -> Bool
forall {k} (a :: k). Time -> ID a -> Map (ID a) Time -> Bool
simpleIsAliveID' Time
now ID a
item (ctx
items ctx
-> Getting (Map (ID a) Time) ctx (Map (ID a) Time)
-> Map (ID a) Time
forall s a. s -> Getting a s a -> a
^. Getting (Map (ID a) Time) ctx (Map (ID a) Time)
Lens' ctx (Map (ID a) Time)
sel)

instance SPStoreID AuthnRequest TestSP where
  storeID :: ID AuthnRequest -> Time -> TestSP ()
storeID = Lens' Ctx (Map (ID AuthnRequest) Time)
-> ID AuthnRequest -> Time -> TestSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> Time -> m ()
simpleStoreID (Map (ID AuthnRequest) Time -> f (Map (ID AuthnRequest) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID AuthnRequest) Time)
ctxRequestStore
  unStoreID :: ID AuthnRequest -> TestSP ()
unStoreID = Lens' Ctx (Map (ID AuthnRequest) Time)
-> ID AuthnRequest -> TestSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m ()
simpleUnStoreID (Map (ID AuthnRequest) Time -> f (Map (ID AuthnRequest) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID AuthnRequest) Time)
ctxRequestStore
  isAliveID :: ID AuthnRequest -> TestSP Bool
isAliveID = Lens' Ctx (Map (ID AuthnRequest) Time)
-> ID AuthnRequest -> TestSP Bool
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m, SP m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m Bool
simpleIsAliveID (Map (ID AuthnRequest) Time -> f (Map (ID AuthnRequest) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID AuthnRequest) Time)
ctxRequestStore

instance SPStoreID Assertion TestSP where
  storeID :: ID Assertion -> Time -> TestSP ()
storeID = Lens' Ctx (Map (ID Assertion) Time)
-> ID Assertion -> Time -> TestSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> Time -> m ()
simpleStoreID (Map (ID Assertion) Time -> f (Map (ID Assertion) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID Assertion) Time)
ctxAssertionStore
  unStoreID :: ID Assertion -> TestSP ()
unStoreID = Lens' Ctx (Map (ID Assertion) Time) -> ID Assertion -> TestSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m ()
simpleUnStoreID (Map (ID Assertion) Time -> f (Map (ID Assertion) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID Assertion) Time)
ctxAssertionStore
  isAliveID :: ID Assertion -> TestSP Bool
isAliveID = Lens' Ctx (Map (ID Assertion) Time) -> ID Assertion -> TestSP Bool
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader (MVar ctx) m, SP m) =>
Lens' ctx (Map (ID a) Time) -> ID a -> m Bool
simpleIsAliveID (Map (ID Assertion) Time -> f (Map (ID Assertion) Time))
-> Ctx -> f Ctx
Lens' Ctx (Map (ID Assertion) Time)
ctxAssertionStore

instance SPStoreIdP SimpleError TestSP where
  type IdPConfigExtra TestSP = ()
  type IdPConfigSPId TestSP = Void -- FUTUREWORK: can we do better than this?
  storeIdPConfig :: IdPConfig (IdPConfigExtra TestSP) -> TestSP ()
storeIdPConfig IdPConfig (IdPConfigExtra TestSP)
_ = () -> TestSP ()
forall a. a -> TestSP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  getIdPConfig :: IdPId -> TestSP (IdPConfig (IdPConfigExtra TestSP))
getIdPConfig = TestSP [IdPConfig_]
-> (IdPConfig_ -> IdPId) -> IdPId -> TestSP IdPConfig_
forall err (m :: * -> *) a.
(MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
m [IdPConfig_] -> (IdPConfig_ -> a) -> a -> m IdPConfig_
simpleGetIdPConfigBy TestSP [IdPConfig_]
readIdPs (IdPConfig_ -> Getting IdPId IdPConfig_ IdPId -> IdPId
forall s a. s -> Getting a s a -> a
^. Getting IdPId IdPConfig_ IdPId
forall extra (f :: * -> *).
Functor f =>
(IdPId -> f IdPId) -> IdPConfig extra -> f (IdPConfig extra)
idpId)
  getIdPConfigByIssuerOptionalSPId :: Issuer
-> Maybe (IdPConfigSPId TestSP)
-> TestSP (IdPConfig (IdPConfigExtra TestSP))
getIdPConfigByIssuerOptionalSPId Issuer
issuer Maybe (IdPConfigSPId TestSP)
_ = TestSP [IdPConfig_]
-> (IdPConfig_ -> Issuer) -> Issuer -> TestSP IdPConfig_
forall err (m :: * -> *) a.
(MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
m [IdPConfig_] -> (IdPConfig_ -> a) -> a -> m IdPConfig_
simpleGetIdPConfigBy TestSP [IdPConfig_]
readIdPs (IdPConfig_ -> Getting Issuer IdPConfig_ Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const Issuer IdPMetadata)
-> IdPConfig_ -> Const Issuer IdPConfig_
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const Issuer IdPMetadata)
 -> IdPConfig_ -> Const Issuer IdPConfig_)
-> ((Issuer -> Const Issuer Issuer)
    -> IdPMetadata -> Const Issuer IdPMetadata)
-> Getting Issuer IdPConfig_ Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Issuer -> Const Issuer Issuer)
-> IdPMetadata -> Const Issuer IdPMetadata
Lens' IdPMetadata Issuer
edIssuer) Issuer
issuer

instance GetAllIdPs SimpleError TestSP where
  getAllIdPs :: TestSP [IdPConfig (IdPConfigExtra TestSP)]
getAllIdPs = ((IdPConfig_, SampleIdP) -> IdPConfig_)
-> [(IdPConfig_, SampleIdP)] -> [IdPConfig_]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IdPConfig_, SampleIdP) -> IdPConfig_
forall a b. (a, b) -> a
fst ([(IdPConfig_, SampleIdP)] -> [IdPConfig_])
-> (Ctx -> [(IdPConfig_, SampleIdP)]) -> Ctx -> [IdPConfig_]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ctx
-> Getting [(IdPConfig_, SampleIdP)] Ctx [(IdPConfig_, SampleIdP)]
-> [(IdPConfig_, SampleIdP)]
forall s a. s -> Getting a s a -> a
^. Getting [(IdPConfig_, SampleIdP)] Ctx [(IdPConfig_, SampleIdP)]
Lens' Ctx [(IdPConfig_, SampleIdP)]
ctxIdPs) (Ctx -> [IdPConfig_]) -> TestSP Ctx -> TestSP [IdPConfig_]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TestSP (MVar Ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask TestSP (MVar Ctx) -> (MVar Ctx -> TestSP Ctx) -> TestSP Ctx
forall a b. TestSP a -> (a -> TestSP b) -> TestSP b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Ctx -> TestSP Ctx
forall a. IO a -> TestSP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Ctx -> TestSP Ctx)
-> (MVar Ctx -> IO Ctx) -> MVar Ctx -> TestSP Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Ctx -> IO Ctx
forall a. MVar a -> IO a
readMVar)

instance SPHandler SimpleError TestSP where
  type NTCTX TestSP = CtxV

  nt :: forall x. CtxV -> TestSP x -> Handler x
  nt :: forall x. MVar Ctx -> TestSP x -> Handler x
nt = MVar Ctx -> TestSP x -> Handler x
forall x. MVar Ctx -> TestSP x -> Handler x
handlerFromTestSP

readIdPs :: TestSP [IdPConfig_]
readIdPs :: TestSP [IdPConfig_]
readIdPs = (((IdPConfig_, SampleIdP) -> IdPConfig_)
-> [(IdPConfig_, SampleIdP)] -> [IdPConfig_]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IdPConfig_, SampleIdP) -> IdPConfig_
forall a b. (a, b) -> a
fst ([(IdPConfig_, SampleIdP)] -> [IdPConfig_])
-> (Ctx -> [(IdPConfig_, SampleIdP)]) -> Ctx -> [IdPConfig_]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ctx
-> Getting [(IdPConfig_, SampleIdP)] Ctx [(IdPConfig_, SampleIdP)]
-> [(IdPConfig_, SampleIdP)]
forall s a. s -> Getting a s a -> a
^. Getting [(IdPConfig_, SampleIdP)] Ctx [(IdPConfig_, SampleIdP)]
Lens' Ctx [(IdPConfig_, SampleIdP)]
ctxIdPs) (Ctx -> [IdPConfig_]) -> TestSP Ctx -> TestSP [IdPConfig_]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TestSP (MVar Ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask TestSP (MVar Ctx) -> (MVar Ctx -> TestSP Ctx) -> TestSP Ctx
forall a b. TestSP a -> (a -> TestSP b) -> TestSP b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Ctx -> TestSP Ctx
forall a. IO a -> TestSP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Ctx -> TestSP Ctx)
-> (MVar Ctx -> IO Ctx) -> MVar Ctx -> TestSP Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Ctx -> IO Ctx
forall a. MVar a -> IO a
readMVar))

handlerFromTestSP :: CtxV -> TestSP a -> Handler a
handlerFromTestSP :: forall x. MVar Ctx -> TestSP x -> Handler x
handlerFromTestSP MVar Ctx
ctx (TestSP ReaderT (MVar Ctx) (ExceptT SimpleError IO) a
m) = ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (ExceptT SimpleError IO a -> ExceptT ServerError IO a)
-> ExceptT SimpleError IO a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError a) -> ExceptT ServerError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError a) -> ExceptT ServerError IO a)
-> (ExceptT SimpleError IO a -> IO (Either ServerError a))
-> ExceptT SimpleError IO a
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either SimpleError a -> Either ServerError a)
-> IO (Either SimpleError a) -> IO (Either ServerError a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SimpleError -> ServerError)
-> Either SimpleError a -> Either ServerError a
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL SimpleError -> ServerError
toServerError) (IO (Either SimpleError a) -> IO (Either ServerError a))
-> (ExceptT SimpleError IO a -> IO (Either SimpleError a))
-> ExceptT SimpleError IO a
-> IO (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT SimpleError IO a -> IO (Either SimpleError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SimpleError IO a -> Handler a)
-> ExceptT SimpleError IO a -> Handler a
forall a b. (a -> b) -> a -> b
$ ReaderT (MVar Ctx) (ExceptT SimpleError IO) a
m ReaderT (MVar Ctx) (ExceptT SimpleError IO) a
-> MVar Ctx -> ExceptT SimpleError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` MVar Ctx
ctx

ioFromTestSP :: CtxV -> TestSP a -> IO a
ioFromTestSP :: forall a. MVar Ctx -> TestSP a -> IO a
ioFromTestSP MVar Ctx
ctx TestSP a
m = (ServerError -> IO a)
-> (a -> IO a) -> Either ServerError a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO a)
-> (ServerError -> ErrorCall) -> ServerError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall)
-> (ServerError -> String) -> ServerError -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerError -> String
forall a. Show a => a -> String
show) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ServerError a -> IO a) -> IO (Either ServerError a) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ExceptT ServerError IO a -> IO (Either ServerError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ServerError IO a -> IO (Either ServerError a))
-> (Handler a -> ExceptT ServerError IO a)
-> Handler a
-> IO (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler a -> ExceptT ServerError IO a
forall a. Handler a -> ExceptT ServerError IO a
runHandler' (Handler a -> IO (Either ServerError a))
-> Handler a -> IO (Either ServerError a)
forall a b. (a -> b) -> a -> b
$ MVar Ctx -> TestSP a -> Handler a
forall x. MVar Ctx -> TestSP x -> Handler x
handlerFromTestSP MVar Ctx
ctx TestSP a
m)

withapp ::
  forall (api :: Type).
  (HasServer api '[]) =>
  Proxy api ->
  ServerT api TestSP ->
  IO CtxV ->
  SpecWith (CtxV, Application) ->
  Spec
withapp :: forall api.
HasServer api '[] =>
Proxy api
-> ServerT api TestSP
-> IO (MVar Ctx)
-> SpecWith (MVar Ctx, Application)
-> Spec
withapp Proxy api
proxy ServerT api TestSP
handler IO (MVar Ctx)
mkctx = IO (MVar Ctx, Application)
-> SpecWith (MVar Ctx, Application) -> Spec
forall st.
IO (st, Application) -> SpecWith (st, Application) -> Spec
withState (IO (MVar Ctx)
mkctx IO (MVar Ctx)
-> (MVar Ctx -> (MVar Ctx, Application))
-> IO (MVar Ctx, Application)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \MVar Ctx
ctx -> (MVar Ctx
ctx, MVar Ctx -> Application
app MVar Ctx
ctx))
  where
    app :: MVar Ctx -> Application
app MVar Ctx
ctx = Proxy api -> Server api -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy api
proxy (Proxy api
-> (forall x. TestSP x -> Handler x)
-> ServerT api TestSP
-> Server api
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) (forall err (m :: * -> *) x.
SPHandler err m =>
NTCTX m -> m x -> Handler x
nt @SimpleError @TestSP MVar Ctx
NTCTX TestSP
ctx) ServerT api TestSP
handler :: Server api)

capture' :: HasCallStack => IO a -> IO a
capture' :: forall a. HasCallStack => IO a -> IO a
capture' IO a
action =
  [Handle] -> IO a -> IO (String, a)
forall a. [Handle] -> IO a -> IO (String, a)
hCapture [Handle
stdout, Handle
stderr] IO a
action IO (String, a) -> ((String, a) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (String
"", a
out) -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
out
    (String
noise, a
_) -> String -> IO a
forall a. HasCallStack => String -> a
error (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
noise

captureApplication :: HasCallStack => Application -> Application
captureApplication :: HasCallStack => Application -> Application
captureApplication Application
app Request
req Response -> IO ResponseReceived
cont = IO ResponseReceived -> IO ResponseReceived
forall a. HasCallStack => IO a -> IO a
capture' (Application
app Request
req Response -> IO ResponseReceived
cont)

runtest :: (CtxV -> WaiSession () a) -> (CtxV, Application) -> IO a
runtest :: forall a.
(MVar Ctx -> WaiSession () a) -> (MVar Ctx, Application) -> IO a
runtest MVar Ctx -> WaiSession () a
test (MVar Ctx
ctx, Application
app) = WaiSession () a -> Application -> IO a
forall a. WaiSession () a -> Application -> IO a
runWaiSession (MVar Ctx -> WaiSession () a
test MVar Ctx
ctx) Application
app


runtest' :: WaiSession () a -> ((CtxV, Application) -> IO a)
runtest' :: forall a. WaiSession () a -> (MVar Ctx, Application) -> IO a
runtest' WaiSession () a
action = (MVar Ctx -> WaiSession () a) -> (MVar Ctx, Application) -> IO a
forall a.
(MVar Ctx -> WaiSession () a) -> (MVar Ctx, Application) -> IO a
runtest (\MVar Ctx
_ctx -> WaiSession () a
action)

mkTestCtxSimple :: MonadIO m => m CtxV
mkTestCtxSimple :: forall (m :: * -> *). MonadIO m => m (MVar Ctx)
mkTestCtxSimple = IO (MVar Ctx) -> m (MVar Ctx)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Ctx) -> m (MVar Ctx)) -> IO (MVar Ctx) -> m (MVar Ctx)
forall a b. (a -> b) -> a -> b
$ do
  let _ctxNow :: Time
_ctxNow = Time
timeNow -- constant time value, see below
      _ctxConfig :: Config
_ctxConfig = Config
fallbackConfig Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& (Level -> Identity Level) -> Config -> Identity Config
Lens' Config Level
cfgLogLevel ((Level -> Identity Level) -> Config -> Identity Config)
-> Level -> Config -> Config
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Level
Fatal
      _ctxIdPs :: a
_ctxIdPs = a
forall a. Monoid a => a
mempty
      _ctxAssertionStore :: a
_ctxAssertionStore = a
forall a. Monoid a => a
mempty
      _ctxRequestStore :: a
_ctxRequestStore = a
forall a. Monoid a => a
mempty
  Ctx -> IO (MVar Ctx)
forall a. a -> IO (MVar a)
newMVar Ctx {[(IdPConfig_, SampleIdP)]
Map (ID Assertion) Time
Map (ID AuthnRequest) Time
Time
Config
forall a. Monoid a => a
_ctxNow :: Time
_ctxConfig :: Config
_ctxIdPs :: forall a. Monoid a => a
_ctxAssertionStore :: forall a. Monoid a => a
_ctxRequestStore :: forall a. Monoid a => a
_ctxNow :: Time
_ctxConfig :: Config
_ctxIdPs :: [(IdPConfig_, SampleIdP)]
_ctxAssertionStore :: Map (ID Assertion) Time
_ctxRequestStore :: Map (ID AuthnRequest) Time
..}

mkTestCtxWithIdP :: MonadIO m => m CtxV
mkTestCtxWithIdP :: forall (m :: * -> *). MonadIO m => m (MVar Ctx)
mkTestCtxWithIdP = IO (MVar Ctx) -> m (MVar Ctx)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Ctx) -> m (MVar Ctx)) -> IO (MVar Ctx) -> m (MVar Ctx)
forall a b. (a -> b) -> a -> b
$ do
  MVar Ctx
ctxmv <- IO (MVar Ctx)
forall (m :: * -> *). MonadIO m => m (MVar Ctx)
mkTestCtxSimple
  (IdPConfig_, SampleIdP)
testcfg <- IO (IdPConfig_, SampleIdP)
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
m (IdPConfig_, SampleIdP)
makeTestIdPConfig
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Ctx -> (Ctx -> IO Ctx) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Ctx
ctxmv (Ctx -> IO Ctx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx -> IO Ctx) -> (Ctx -> Ctx) -> Ctx -> IO Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(IdPConfig_, SampleIdP)] -> Identity [(IdPConfig_, SampleIdP)])
-> Ctx -> Identity Ctx
Lens' Ctx [(IdPConfig_, SampleIdP)]
ctxIdPs (([(IdPConfig_, SampleIdP)] -> Identity [(IdPConfig_, SampleIdP)])
 -> Ctx -> Identity Ctx)
-> [(IdPConfig_, SampleIdP)] -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(IdPConfig_, SampleIdP)
testcfg]))
  MVar Ctx -> IO (MVar Ctx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar Ctx
ctxmv

-- | construct a hypothetical idp configuration from sample metadata and credentials, without
-- actually registering it.
makeTestIdPConfig :: (MonadIO m, MonadRandom m) => m (IdPConfig (), SampleIdP)
makeTestIdPConfig :: forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
m (IdPConfig_, SampleIdP)
makeTestIdPConfig = do
  IdPId
_idpId <- UUID -> IdPId
IdPId (UUID -> IdPId) -> m UUID -> m IdPId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
  sampleIdP :: SampleIdP
sampleIdP@(SampleIdP IdPMetadata
_idpMetadata SignPrivCreds
_ SignCreds
_ SignedCertificate
_) <- m SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
makeSampleIdPMetadata
  let _edIssuer :: Issuer
_edIssuer = IdPMetadata
_idpMetadata IdPMetadata
-> ((Issuer -> Const Issuer Issuer)
    -> IdPMetadata -> Const Issuer IdPMetadata)
-> Issuer
forall s a. s -> Getting a s a -> a
^. (Issuer -> Const Issuer Issuer)
-> IdPMetadata -> Const Issuer IdPMetadata
Lens' IdPMetadata Issuer
edIssuer
      _edRequestURI :: URI
_edRequestURI = IdPMetadata
_idpMetadata IdPMetadata -> Getting URI IdPMetadata URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI IdPMetadata URI
Lens' IdPMetadata URI
edRequestURI
      _edCertAuthnResponse :: NonEmpty SignedCertificate
_edCertAuthnResponse = IdPMetadata
_idpMetadata IdPMetadata
-> Getting
     (NonEmpty SignedCertificate)
     IdPMetadata
     (NonEmpty SignedCertificate)
-> NonEmpty SignedCertificate
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty SignedCertificate)
  IdPMetadata
  (NonEmpty SignedCertificate)
Lens' IdPMetadata (NonEmpty SignedCertificate)
edCertAuthnResponse
      _idpExtraInfo :: ()
_idpExtraInfo = ()
  (IdPConfig_, SampleIdP) -> m (IdPConfig_, SampleIdP)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdPConfig {()
IdPId
IdPMetadata
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: ()
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: ()
..}, SampleIdP
sampleIdP)

makeSampleIdPMetadata :: HasCallStack => (MonadIO m, MonadRandom m) => m SampleIdP
makeSampleIdPMetadata :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
makeSampleIdPMetadata = do
  Issuer
issuer <- m Issuer
forall (m :: * -> *). MonadIO m => m Issuer
makeIssuer
  URI
requri <- do
    ByteString
uuid <- UUID -> ByteString
UUID.toASCIIBytes (UUID -> ByteString) -> m UUID -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
    URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ [uri|https://requri.net/|] URI -> (URI -> URI) -> URI
forall a b. a -> (a -> b) -> b
& (ByteString -> Identity ByteString) -> URI -> Identity URI
forall a (f :: * -> *).
Functor f =>
(ByteString -> f ByteString) -> URIRef a -> f (URIRef a)
pathL ((ByteString -> Identity ByteString) -> URI -> Identity URI)
-> ByteString -> URI -> URI
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
uuid)
  (SignPrivCreds
privcreds, SignCreds
creds, SignedCertificate
cert) <- Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
forall (m :: * -> *).
(MonadRandom m, MonadIO m) =>
Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
SAML.mkSignCredsWithCert Maybe DateTime
forall a. Maybe a
Nothing Int
96
  SampleIdP -> m SampleIdP
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SampleIdP -> m SampleIdP) -> SampleIdP -> m SampleIdP
forall a b. (a -> b) -> a -> b
$ IdPMetadata
-> SignPrivCreds -> SignCreds -> SignedCertificate -> SampleIdP
SampleIdP (Issuer -> URI -> NonEmpty SignedCertificate -> IdPMetadata
IdPMetadata Issuer
issuer URI
requri (SignedCertificate
cert SignedCertificate
-> [SignedCertificate] -> NonEmpty SignedCertificate
forall a. a -> [a] -> NonEmpty a
:| [])) SignPrivCreds
privcreds SignCreds
creds SignedCertificate
cert

makeIssuer :: MonadIO m => m Issuer
makeIssuer :: forall (m :: * -> *). MonadIO m => m Issuer
makeIssuer = do
  UUID
uuid <- IO UUID -> m UUID
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
  (String -> m Issuer)
-> (URI -> m Issuer) -> Either String URI -> m Issuer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (IO Issuer -> m Issuer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Issuer -> m Issuer)
-> (String -> IO Issuer) -> String -> m Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> IO Issuer
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO Issuer)
-> (String -> ErrorCall) -> String -> IO Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall) -> (String -> String) -> String -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show)
    (Issuer -> m Issuer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Issuer -> m Issuer) -> (URI -> Issuer) -> URI -> m Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Issuer
Issuer)
    (ST -> Either String URI
forall (m :: * -> *). MonadError String m => ST -> m URI
SAML.parseURI' (ST
"https://issuer.net/_" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> UUID -> ST
UUID.toText UUID
uuid))

mkTestSPMetadata :: (Monad m, HasConfig m) => m SPMetadata
mkTestSPMetadata :: forall (m :: * -> *). (Monad m, HasConfig m) => m SPMetadata
mkTestSPMetadata = do
  let _spID :: ID m
_spID = ST -> ID m
forall {k} (m :: k). ST -> ID m
mkID ST
"_4b7e1488-c0c6-11e8-aef0-9fe604f9513a"
      _spValidUntil :: UTCTime
_spValidUntil = Time -> UTCTime
fromTime (Time -> UTCTime) -> Time -> UTCTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Time -> Time
addTime (NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
365) Time
timeNow
      _spCacheDuration :: a
_spCacheDuration = a
2592000
      _spOrgName :: XmlText
_spOrgName = ST -> XmlText
mkXmlText ST
"drnick"
      _spOrgDisplayName :: XmlText
_spOrgDisplayName = ST -> XmlText
mkXmlText ST
"drnick"
      _spContacts :: [ContactPerson]
_spContacts = [ContactPerson
fallbackContact]
  URI
_spOrgURL <- (Issuer -> Getting URI Issuer URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Issuer URI
Iso' Issuer URI
fromIssuer) (Issuer -> URI) -> m Issuer -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Issuer
forall (m :: * -> *). (Functor m, HasConfig m) => m Issuer
defSPIssuer
  URI
_spResponseURL <- m URI
forall (m :: * -> *). (Functor m, HasConfig m) => m URI
defResponseURI
  SPMetadata -> m SPMetadata
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SPMetadata {[ContactPerson]
UTCTime
NominalDiffTime
URI
ID SPMetadata
XmlText
forall {a}. Num a => a
forall {k} {m :: k}. ID m
_spID :: forall {k} {m :: k}. ID m
_spValidUntil :: UTCTime
_spCacheDuration :: forall {a}. Num a => a
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spContacts :: [ContactPerson]
_spOrgURL :: URI
_spResponseURL :: URI
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
..}

-- | Use this to see more output on a per-test basis.
verbose :: Ctx -> Ctx
verbose :: Ctx -> Ctx
verbose = (Config -> Identity Config) -> Ctx -> Identity Ctx
Lens' Ctx Config
ctxConfig ((Config -> Identity Config) -> Ctx -> Identity Ctx)
-> ((Level -> Identity Level) -> Config -> Identity Config)
-> (Level -> Identity Level)
-> Ctx
-> Identity Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Level -> Identity Level) -> Config -> Identity Config
Lens' Config Level
cfgLogLevel ((Level -> Identity Level) -> Ctx -> Identity Ctx)
-> Level -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Level
Debug

timeLongAgo :: Time
timeLongAgo :: Time
timeLongAgo = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"1918-04-14T09:58:58.457Z"

timeInALongTime :: Time
timeInALongTime :: Time
timeInALongTime = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2045-04-14T09:58:58.457Z"

timeNow :: Time
timeNow :: Time
timeNow = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2018-03-11T17:13:13Z"

timeIn5seconds :: Time
timeIn5seconds :: Time
timeIn5seconds = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2018-03-11T17:13:18Z"

timeIn10seconds :: Time
timeIn10seconds :: Time
timeIn10seconds = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2018-03-11T17:13:23Z"

timeIn10minutes :: Time
timeIn10minutes :: Time
timeIn10minutes = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2018-03-11T17:23:00.01Z"

timeIn20minutes :: Time
timeIn20minutes :: Time
timeIn20minutes = HasCallStack => String -> Time
String -> Time
unsafeReadTime String
"2018-03-11T17:33:00Z"

modifyCtx :: (HasCallStack, MonadIO m, MonadReader CtxV m) => (Ctx -> (Ctx, a)) -> m a
modifyCtx :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
(Ctx -> (Ctx, a)) -> m a
modifyCtx Ctx -> (Ctx, a)
f = do
  MVar Ctx
ctx <- m (MVar Ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
  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
$ MVar Ctx -> (Ctx -> IO (Ctx, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Ctx
ctx ((Ctx, a) -> IO (Ctx, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ctx, a) -> IO (Ctx, a))
-> (Ctx -> (Ctx, a)) -> Ctx -> IO (Ctx, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (Ctx, a)
f)

modifyCtx_ :: (HasCallStack, MonadIO m, MonadReader CtxV m) => (Ctx -> Ctx) -> m ()
modifyCtx_ :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
(Ctx -> Ctx) -> m ()
modifyCtx_ = (Ctx -> (Ctx, ())) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
(Ctx -> (Ctx, a)) -> m a
modifyCtx ((Ctx -> (Ctx, ())) -> m ())
-> ((Ctx -> Ctx) -> Ctx -> (Ctx, ())) -> (Ctx -> Ctx) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,()) (Ctx -> (Ctx, ())) -> (Ctx -> Ctx) -> Ctx -> (Ctx, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

-- | Run an action at a time specified relative to now.  This does NOT support hspec's 'parallel'.
timeTravel :: (HasCallStack, MonadIO m, MonadReader CtxV m) => NominalDiffTime -> m a -> m a
timeTravel :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
NominalDiffTime -> m a -> m a
timeTravel NominalDiffTime
distance m a
action = do
  let mv :: NominalDiffTime -> m ()
mv NominalDiffTime
dist_ = (Ctx -> Ctx) -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadReader (MVar Ctx) m) =>
(Ctx -> Ctx) -> m ()
modifyCtx_ ((Time -> Identity Time) -> Ctx -> Identity Ctx
Lens' Ctx Time
ctxNow ((Time -> Identity Time) -> Ctx -> Identity Ctx)
-> (Time -> Time) -> Ctx -> Ctx
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (NominalDiffTime
dist_ NominalDiffTime -> Time -> Time
`addTime`))
  NominalDiffTime -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadReader (MVar Ctx) m) =>
NominalDiffTime -> m ()
mv NominalDiffTime
distance
  a
result <- m a
action
  NominalDiffTime -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadReader (MVar Ctx) m) =>
NominalDiffTime -> m ()
mv (- NominalDiffTime
distance)
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result