{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE ImplicitParams        #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE ExistentialQuantification   #-}

module IHP.Test.Mocking where

import           Data.ByteString.Builder                   (toLazyByteString)
import qualified Data.ByteString.Lazy                      as LBS
import qualified Data.Vault.Lazy                           as Vault
import qualified Network.HTTP.Types                        as HTTP
import           Network.Wai
import           Network.Wai.Internal                      (ResponseReceived (..))
import           Network.Wai.Parse                         (Param (..))

import           Wai.Request.Params.Middleware                 (Respond)
import           IHP.ControllerSupport                     (InitControllerContext, Controller, runActionWithNewContext)
import           IHP.FrameworkConfig                       (ConfigBuilder (..), FrameworkConfig (..), RootApplication (..))
import qualified IHP.FrameworkConfig                       as FrameworkConfig
import           IHP.ModelSupport                          (createModelContext, withModelContext, Id', PrimaryKey, unpackId)
import           IHP.Prelude
import           IHP.Log.Types
import           IHP.Job.Types
import qualified Network.Wai as Wai
import IHP.LoginSupport.Types (CurrentUserRecord, currentUserVaultKey, currentUserIdVaultKey)
import IHP.Server (initMiddlewareStack)
import qualified IHP.Server as Server
import IHP.Controller.NotFound (handleNotFound)
import IHP.RouterSupport (FrontController)
import qualified IHP.PGListener as PGListener
import qualified IHP.ErrorController as ErrorController
import System.IO.Unsafe (unsafePerformIO)

type ContextParameters application = (?request :: Request, ?respond :: Respond, ?modelContext :: ModelContext, ?application :: application, InitControllerContext application, ?mocking :: MockContext application)

data MockContext application = InitControllerContext application => MockContext
    { forall application. MockContext application -> ModelContext
modelContext :: ModelContext
    , forall application. MockContext application -> FrameworkConfig
frameworkConfig :: FrameworkConfig
    , forall application. MockContext application -> Request
mockRequest :: Request
    , forall application. MockContext application -> Respond
mockRespond :: Respond
    , forall application. MockContext application -> application
application :: application
    , forall application. MockContext application -> Maybe PGListener
pgListener :: Maybe PGListener.PGListener
    }

-- | Run a request through the test middleware stack.
-- This applies the same middlewares that IHP.Server uses.
-- Used for initial setup only - actual request params are handled in callActionWithParams.
runTestMiddlewares :: FrameworkConfig -> ModelContext -> Maybe PGListener.PGListener -> Request -> IO Request
runTestMiddlewares :: FrameworkConfig
-> ModelContext -> Maybe PGListener -> Request -> IO Request
runTestMiddlewares FrameworkConfig
frameworkConfig ModelContext
modelContext Maybe PGListener
maybePgListener Request
baseRequest = do
    -- Capture the modified request after running through middlewares
    resultRef <- Request -> IO (IORef Request)
forall a. a -> IO (IORef a)
newIORef Request
baseRequest
    let captureApp Request
req Respond
respond = do
            IORef Request -> Request -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Request
resultRef Request
req
            Respond
respond (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
HTTP.status200 [] ByteString
"")

    middlewareStack <- initMiddlewareStack frameworkConfig modelContext maybePgListener

    -- Run request through middleware stack
    _ <- middlewareStack captureApp baseRequest (\Response
_ -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived)

    readIORef resultRef

{-# DEPRECATED mockContextNoDatabase "Use withMockContext instead for bracket-style resource management" #-}
mockContextNoDatabase :: (InitControllerContext application) => application -> ConfigBuilder -> IO (MockContext application)
mockContextNoDatabase :: forall application.
InitControllerContext application =>
application -> ConfigBuilder -> IO (MockContext application)
mockContextNoDatabase application
application ConfigBuilder
configBuilder = do
   frameworkConfig@(FrameworkConfig {databaseUrl}) <- ConfigBuilder -> IO FrameworkConfig
FrameworkConfig.buildFrameworkConfig ConfigBuilder
configBuilder
   logger <- newLogger (def :: LoggerSettings) { level = Warn } -- don't log queries
   modelContext <- createModelContext databaseUrl logger

   -- Start with a minimal request - the middleware stack will set up session, etc.
   let baseRequest = Request
defaultRequest
   let pgListener = Maybe a
forall a. Maybe a
Nothing
   mockRequest <- runTestMiddlewares frameworkConfig modelContext pgListener baseRequest
   let mockRespond = IO ResponseReceived -> b -> IO ResponseReceived
forall a b. a -> b -> a
const (ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived)

   pure MockContext{..}

-- | Bracket-style mock context creation with proper resource cleanup.
--
-- Uses 'withModelContext' to ensure the database pool is released when done.
-- Prefer this over 'mockContextNoDatabase'.
--
-- __Example:__ Use with hspec's 'aroundAll':
--
-- > tests :: Spec
-- > tests = aroundAll (withMockContext WebApplication config) do
-- >     it "should work" $ withContext do
-- >         ...
--
withMockContext :: (InitControllerContext application) => application -> ConfigBuilder -> (MockContext application -> IO a) -> IO a
withMockContext :: forall application a.
InitControllerContext application =>
application
-> ConfigBuilder -> (MockContext application -> IO a) -> IO a
withMockContext application
application ConfigBuilder
configBuilder MockContext application -> IO a
action =
    ConfigBuilder -> (FrameworkConfig -> IO a) -> IO a
forall result.
ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result
FrameworkConfig.withFrameworkConfig ConfigBuilder
configBuilder \FrameworkConfig
frameworkConfig -> do
        ByteString -> Logger -> (ModelContext -> IO a) -> IO a
forall a. ByteString -> Logger -> (ModelContext -> IO a) -> IO a
withModelContext FrameworkConfig
frameworkConfig.databaseUrl FrameworkConfig
frameworkConfig.logger \ModelContext
modelContext -> do
            ByteString -> Logger -> (PGListener -> IO a) -> IO a
forall a. ByteString -> Logger -> (PGListener -> IO a) -> IO a
PGListener.withPGListener FrameworkConfig
frameworkConfig.databaseUrl FrameworkConfig
frameworkConfig.logger \PGListener
pgListener' -> do
                let baseRequest :: Request
baseRequest = Request
defaultRequest
                let pgListener :: Maybe PGListener
pgListener = PGListener -> Maybe PGListener
forall a. a -> Maybe a
Just PGListener
pgListener'
                mockRequest <- FrameworkConfig
-> ModelContext -> Maybe PGListener -> Request -> IO Request
runTestMiddlewares FrameworkConfig
frameworkConfig ModelContext
modelContext Maybe PGListener
pgListener Request
baseRequest
                let mockRespond = IO ResponseReceived -> b -> IO ResponseReceived
forall a b. a -> b -> a
const (ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived)
                action MockContext{..}

-- | Build a WAI 'Application' from a 'MockContext' for use with @runSession@.
--
-- This mirrors the middleware stack from 'IHP.Server.run':
-- errorHandlerMiddleware wraps the app to catch exceptions and render error pages.
-- EarlyReturnException is caught inside runAction/runActionWithNewContext.
initTestApplication :: (FrontController RootApplication) => MockContext application -> IO Application
initTestApplication :: forall application.
FrontController RootApplication =>
MockContext application
-> IO (Request -> Respond -> IO ResponseReceived)
initTestApplication MockContext { FrameworkConfig
frameworkConfig :: forall application. MockContext application -> FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, ModelContext
modelContext :: forall application. MockContext application -> ModelContext
modelContext :: ModelContext
modelContext, Maybe PGListener
pgListener :: forall application. MockContext application -> Maybe PGListener
pgListener :: Maybe PGListener
pgListener } = do
    middleware <- FrameworkConfig
-> ModelContext -> Maybe PGListener -> IO Middleware
initMiddlewareStack FrameworkConfig
frameworkConfig ModelContext
modelContext Maybe PGListener
pgListener
    pure $ ErrorController.errorHandlerMiddleware frameworkConfig
         $ middleware
         $ Server.application handleNotFound (\Request -> Respond -> IO ResponseReceived
app -> Request -> Respond -> IO ResponseReceived
app)

-- | Combines 'withMockContext' and 'initTestApplication' into a single bracket.
--
-- __Example:__ Use with hspec's 'aroundAll':
--
-- > tests :: Spec
-- > tests = aroundAll (withMockContextAndApp WebApplication config) do
-- >     it "should work" $ withContextAndApp \application -> do
-- >         runSession (testGet "/foo") application >>= assertSuccess "bar"
--
withMockContextAndApp :: (InitControllerContext application, FrontController RootApplication) => application -> ConfigBuilder -> ((MockContext application, Application) -> IO a) -> IO a
withMockContextAndApp :: forall application a.
(InitControllerContext application,
 FrontController RootApplication) =>
application
-> ConfigBuilder
-> ((MockContext application,
     Request -> Respond -> IO ResponseReceived)
    -> IO a)
-> IO a
withMockContextAndApp application
application ConfigBuilder
configBuilder (MockContext application,
 Request -> Respond -> IO ResponseReceived)
-> IO a
action =
    application
-> ConfigBuilder -> (MockContext application -> IO a) -> IO a
forall application a.
InitControllerContext application =>
application
-> ConfigBuilder -> (MockContext application -> IO a) -> IO a
withMockContext application
application ConfigBuilder
configBuilder \MockContext application
ctx -> do
        app <- MockContext application
-> IO (Request -> Respond -> IO ResponseReceived)
forall application.
FrontController RootApplication =>
MockContext application
-> IO (Request -> Respond -> IO ResponseReceived)
initTestApplication MockContext application
ctx
        action (ctx, app)

-- | Like 'withContext' but for specs using 'withMockContextAndApp'.
-- The WAI 'Application' is passed to the callback.
withContextAndApp :: (ContextParameters application => Application -> IO a) -> (MockContext application, Application) -> IO a
withContextAndApp :: forall application a.
(ContextParameters application =>
 (Request -> Respond -> IO ResponseReceived) -> IO a)
-> (MockContext application,
    Request -> Respond -> IO ResponseReceived)
-> IO a
withContextAndApp ContextParameters application =>
(Request -> Respond -> IO ResponseReceived) -> IO a
action (MockContext application
ctx, Request -> Respond -> IO ResponseReceived
app) = (ContextParameters application => IO a)
-> MockContext application -> IO a
forall application a.
(ContextParameters application => IO a)
-> MockContext application -> IO a
withContext (ContextParameters application =>
(Request -> Respond -> IO ResponseReceived) -> IO a
(Request -> Respond -> IO ResponseReceived) -> IO a
action Request -> Respond -> IO ResponseReceived
app) MockContext application
ctx

-- | Run a IO action, setting implicit params based on supplied mock context
withContext :: (ContextParameters application => IO a) -> MockContext application -> IO a
withContext :: forall application a.
(ContextParameters application => IO a)
-> MockContext application -> IO a
withContext ContextParameters application => IO a
action mocking :: MockContext application
mocking@MockContext{application
Maybe PGListener
Request
ModelContext
FrameworkConfig
Respond
modelContext :: forall application. MockContext application -> ModelContext
frameworkConfig :: forall application. MockContext application -> FrameworkConfig
mockRequest :: forall application. MockContext application -> Request
mockRespond :: forall application. MockContext application -> Respond
application :: forall application. MockContext application -> application
pgListener :: forall application. MockContext application -> Maybe PGListener
modelContext :: ModelContext
frameworkConfig :: FrameworkConfig
mockRequest :: Request
mockRespond :: Respond
application :: application
pgListener :: Maybe PGListener
..} = let
    ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext
    ?request = ?request::Request
Request
mockRequest
    ?respond = ?respond::Respond
Respond
mockRespond
    ?application = application
?application::application
application
    ?mocking = ?mocking::MockContext application
MockContext application
mocking
  in do
    action

setupWithContext :: (ContextParameters application => IO a) -> MockContext application -> IO (MockContext application)
setupWithContext :: forall application a.
(ContextParameters application => IO a)
-> MockContext application -> IO (MockContext application)
setupWithContext ContextParameters application => IO a
action MockContext application
context = (ContextParameters application => IO a)
-> MockContext application -> IO a
forall application a.
(ContextParameters application => IO a)
-> MockContext application -> IO a
withContext IO a
ContextParameters application => IO a
action MockContext application
context IO a
-> IO (MockContext application) -> IO (MockContext application)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MockContext application -> IO (MockContext application)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MockContext application
context

-- | Runs a controller action in a mock environment
callAction :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO Response
callAction :: forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Response
callAction controller
controller = controller -> [Param] -> IO Response
forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> [Param] -> IO Response
callActionWithParams controller
controller []

-- | Runs a controller action in a mock environment
--
-- >>> callActionWithParams CreatePostAction [("title", "Hello World"), ("body", "lorem ipsum")|
-- Response { .. }
--
callActionWithParams :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> [Param] -> IO Response
callActionWithParams :: forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> [Param] -> IO Response
callActionWithParams controller
controller [Param]
params = do
    let MockContext { FrameworkConfig
frameworkConfig :: forall application. MockContext application -> FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, ModelContext
modelContext :: forall application. MockContext application -> ModelContext
modelContext :: ModelContext
modelContext } = ?mocking::MockContext application
MockContext application
?mocking

    -- Build request with real form body (let middleware parse it)
    requestBody <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (Bool -> [Param] -> ByteString
HTTP.renderSimpleQuery Bool
False [Param]
params)
    let readBody = IORef ByteString -> (ByteString -> Param) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
requestBody (\ByteString
body -> (ByteString
"", ByteString
body))
    let baseRequest = (IO ByteString -> Request -> Request
Wai.setRequestBodyChunks IO ByteString
readBody ?request::Request
Request
?request)
            { Wai.requestMethod = "POST"
            , Wai.requestHeaders = (HTTP.hContentType, "application/x-www-form-urlencoded") : filter ((/= HTTP.hContentType) . fst) (Wai.requestHeaders ?request)
            }

    -- Capture the response
    responseRef <- newIORef Nothing
    let captureRespond Response
response = do
            IORef (Maybe Response) -> Maybe Response -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Response)
responseRef (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
response)
            ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived

    -- Extract any override middleware stashed in the request vault by helpers
    -- like 'withUser'. We wrap it *innermost* around the controller so it runs
    -- after the full production stack (including 'sessionMiddleware' and
    -- 'authMw'). That makes it last-write-wins on vault keys like
    -- 'currentUserVaultKey', so test helpers can seed a mock user without
    -- fighting 'sessionMiddleware' (from wai-session-maybe), which
    -- unconditionally rewrites 'sessionVaultKey' from the request cookie.
    let overrideMiddleware = Middleware -> Maybe Middleware -> Middleware
forall a. a -> Maybe a -> a
fromMaybe Middleware
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Key Middleware -> Vault -> Maybe Middleware
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key Middleware
mockOverrideVaultKey (Request -> Vault
Wai.vault ?request::Request
Request
?request))

    -- Create the controller app
    let controllerApp Request
req Respond
respond = do
            let ?request = ?request::Request
Request
req
            let ?respond = ?respond::Respond
Respond
respond
            controller -> IO ResponseReceived
forall application controller.
(Controller controller, ?request::Request, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext controller
controller

    -- Run through middleware stack (like the real server does).
    let MockContext { pgListener } = ?mocking
    middlewareStack <- initMiddlewareStack frameworkConfig modelContext pgListener
    _ <- middlewareStack (overrideMiddleware controllerApp) baseRequest captureRespond

    readIORef responseRef >>= \case
        Just Response
response -> Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
response
        Maybe Response
Nothing -> Text -> IO Response
forall a. Text -> a
error Text
"callActionWithParams: No response was returned by the controller"

-- | Run a Job in a mock environment
--
-- __Example:__
--
-- Let's say you have a Job called @JobPost@ that you would like to process as part of a test.
--
-- >  let postJob <- fetch ...
-- >
-- >  callJob postJob
--
-- Note that 'callJob' doesn't set the Job status that is initially set 'IHP.Job.Types.JobStatusNotStarted', as that is
-- done by the Job queue (see 'IHP.Job.Queue.jobDidSucceed' for example).
--
callJob :: forall application job. (ContextParameters application, Typeable application, Job job) => job -> IO ()
callJob :: forall application job.
(ContextParameters application, Typeable application, Job job) =>
job -> IO ()
callJob job
job = do
    let frameworkConfig :: FrameworkConfig
frameworkConfig = ?request::Request
Request
?request.frameworkConfig
    let ?context = ?context::FrameworkConfig
FrameworkConfig
frameworkConfig
    job -> IO ()
forall job.
(Job job, ?modelContext::ModelContext,
 ?context::FrameworkConfig) =>
job -> IO ()
perform job
job


-- | mockAction has been renamed to callAction
mockAction :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO Response
mockAction :: forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Response
mockAction = controller -> IO Response
forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Response
callAction

-- | Get contents of response
mockActionResponse :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO LBS.ByteString
mockActionResponse :: forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO ByteString
mockActionResponse = (Response -> IO ByteString
responseBody (Response -> IO ByteString) -> IO Response -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO Response -> IO ByteString)
-> (controller -> IO Response) -> controller -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. controller -> IO Response
forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Response
mockAction

-- | Get HTTP status of the controller
mockActionStatus :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO HTTP.Status
mockActionStatus :: forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Status
mockActionStatus = (Response -> Status) -> IO Response -> IO Status
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Status
responseStatus (IO Response -> IO Status)
-> (controller -> IO Response) -> controller -> IO Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. controller -> IO Response
forall application controller.
(Controller controller, ContextParameters application,
 Typeable application, Typeable controller) =>
controller -> IO Response
mockAction

responseBody :: Response -> IO LBS.ByteString
responseBody :: Response -> IO ByteString
responseBody Response
res =
  let (Status
status,ResponseHeaders
headers,(StreamingBody -> IO ByteString) -> IO ByteString
body) = Response
-> (Status, ResponseHeaders,
    (StreamingBody -> IO ByteString) -> IO ByteString)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res in
  (StreamingBody -> IO ByteString) -> IO ByteString
body ((StreamingBody -> IO ByteString) -> IO ByteString)
-> (StreamingBody -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \StreamingBody
f -> do
    content <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
    f (\Builder
chunk -> IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Builder
content (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk)) (return ())
    toLazyByteString <$> readIORef content

-- | Vault key holding a 'Wai.Middleware' that test helpers like 'withUser'
-- use to override request vault entries (e.g. 'currentUserVaultKey') *after*
-- the production middleware stack has run. 'callActionWithParams' reads this
-- key and wraps the controller innermost, so the override is guaranteed to
-- be the last writer — sidestepping 'sessionMiddleware'/'authMw', which
-- would otherwise clobber the mock state.
{-# NOINLINE mockOverrideVaultKey #-}
mockOverrideVaultKey :: Vault.Key Wai.Middleware
mockOverrideVaultKey :: Key Middleware
mockOverrideVaultKey = IO (Key Middleware) -> Key Middleware
forall a. IO a -> a
unsafePerformIO IO (Key Middleware)
forall a. IO (Key a)
Vault.newKey

-- | Set's the current user for the application
--
-- Example:
--
-- > user <- newRecord @User
-- >     |> set #email "marc@digitallyinduced.com"
-- >     |> createRecord
-- >
-- > response <- withUser user do
-- >     callAction CreatePostAction
--
-- In this example the 'currentUser' will refer to the newly
-- created user during the execution of CreatePostAction.
--
-- Internally this composes a 'Wai.Middleware' into 'mockOverrideVaultKey'
-- that seeds 'currentUserVaultKey' and 'currentUserIdVaultKey' with the
-- mock user. 'callActionWithParams' applies that middleware *innermost*,
-- so it runs after 'sessionMiddleware' and 'authMw' and wins on conflict.
--
withUser :: forall user result.
    ( ?request :: Request
    , ?respond :: Respond
    , user ~ CurrentUserRecord
    , HasField "id" user (Id' (GetTableName user))
    , PrimaryKey (GetTableName user) ~ UUID
    ) => user -> ((?request :: Request, ?respond :: Respond) => IO result) -> IO result
withUser :: forall user result.
(?request::Request, ?respond::Respond, user ~ CurrentUserRecord,
 HasField "id" user (Id' (GetTableName user)),
 PrimaryKey (GetTableName user) ~ UUID) =>
user
-> ((?request::Request, ?respond::Respond) => IO result)
-> IO result
withUser user
user (?request::Request, ?respond::Respond) => IO result
callback =
        let ?request = ?request::Request
Request
newRequest
        in IO result
(?request::Request, ?respond::Respond) => IO result
callback
    where
        currentRequest :: Request
currentRequest = ?request::Request
Request
?request

        existingOverride :: Wai.Middleware
        existingOverride :: Middleware
existingOverride = Middleware -> Maybe Middleware -> Middleware
forall a. a -> Maybe a -> a
fromMaybe Middleware
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Key Middleware -> Vault -> Maybe Middleware
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key Middleware
mockOverrideVaultKey (Request -> Vault
Wai.vault Request
currentRequest))

        userMw :: Wai.Middleware
        userMw :: Middleware
userMw Request -> Respond -> IO ResponseReceived
app Request
req Respond
respond =
            let req' :: Request
req' = Request
req
                    { Wai.vault
                        = Vault.insert currentUserVaultKey (Just user)
                        . Vault.insert currentUserIdVaultKey (Just (unpackId user.id))
                        $ Wai.vault req
                    }
            in Request -> Respond -> IO ResponseReceived
app Request
req' Respond
respond

        newVault :: Vault
newVault = Key Middleware -> Middleware -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key Middleware
mockOverrideVaultKey (Middleware
existingOverride Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Middleware
userMw) (Request -> Vault
Wai.vault Request
currentRequest)
        newRequest :: Request
newRequest = Request
currentRequest { Wai.vault = newVault }

-- | Turns a record id into a value that can be used with 'callActionWithParams'
--
-- __Example:__
--
-- Let's say you have a test like this:
--
-- >  let postId = cs $ show $ post.id
-- >
-- >  let params = [ ("postId", postId) ]
--
-- You can replace the @cs $ show $@ with a cleaner 'idToParam':
--
--
-- >  let postId = idToParam (libraryOpening.id)
-- >
-- >  let params = [ ("postId", postId) ]
--
idToParam :: forall table. (Show (Id' table)) => Id' table -> ByteString
idToParam :: forall (table :: Symbol).
Show (Id' table) =>
Id' table -> ByteString
idToParam Id' table
id = Id' table
id
    Id' table -> (Id' table -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Id' table -> Text
forall a. Show a => a -> Text
tshow
    Text -> (Text -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs