{-# 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)
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
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))
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 TestSP = ()
type IdPConfigSPId TestSP = Void
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 api.
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 api (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
_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
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]
..}
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
.)
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