{-# 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.Status                 as HTTP
import           Network.Wai
import           Network.Wai.Internal                      (ResponseReceived (..))
import           Network.Wai.Parse                         (Param (..))

import           IHP.ApplicationContext                    (ApplicationContext (..))
import qualified IHP.AutoRefresh.Types                     as AutoRefresh
import           IHP.Controller.RequestContext             (RequestBody (..), RequestContext (..))
import           IHP.ControllerSupport                     (InitControllerContext, Controller, runActionWithNewContext)
import           IHP.FrameworkConfig                       (ConfigBuilder (..), FrameworkConfig (..))
import qualified IHP.FrameworkConfig                       as FrameworkConfig
import           IHP.ModelSupport                          (createModelContext, Id')
import           IHP.Prelude
import           IHP.Log.Types
import           IHP.Job.Types
import qualified IHP.Test.Database as Database
import Test.Hspec
import qualified Data.Text as Text
import qualified Network.Wai as Wai
import qualified IHP.LoginSupport.Helper.Controller as Session
import qualified Network.Wai.Session
import qualified Data.Serialize as Serialize
import qualified Control.Exception as Exception
import qualified IHP.PGListener as PGListener

type ContextParameters application = (?applicationContext :: ApplicationContext, ?context :: RequestContext, ?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 -> RequestContext
requestContext :: RequestContext
    , forall application. MockContext application -> ApplicationContext
applicationContext :: ApplicationContext
    , forall application. MockContext application -> application
application :: application
    }

-- | Create contexts that can be used for mocking
withIHPApp :: (InitControllerContext application) => application -> ConfigBuilder -> (MockContext application -> IO ()) -> IO ()
withIHPApp :: forall application.
InitControllerContext application =>
application
-> ConfigBuilder -> (MockContext application -> IO ()) -> IO ()
withIHPApp application
application ConfigBuilder
configBuilder MockContext application -> IO ()
hspecAction = do
    ConfigBuilder -> (FrameworkConfig -> IO ()) -> IO ()
forall result.
ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result
FrameworkConfig.withFrameworkConfig ConfigBuilder
configBuilder \FrameworkConfig
frameworkConfig -> do
        let FrameworkConfig { Int
dbPoolMaxConnections :: Int
$sel:dbPoolMaxConnections:FrameworkConfig :: FrameworkConfig -> Int
dbPoolMaxConnections, NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
$sel:dbPoolIdleTime:FrameworkConfig :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime, ByteString
databaseUrl :: ByteString
$sel:databaseUrl:FrameworkConfig :: FrameworkConfig -> ByteString
databaseUrl } = FrameworkConfig
frameworkConfig

        Logger
logger <- LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { $sel:level:LoggerSettings :: LogLevel
level = LogLevel
Warn } -- don't log queries

        let initTestDatabase :: IO TestDatabase
initTestDatabase = ByteString -> IO TestDatabase
Database.createTestDatabase ByteString
databaseUrl
        let cleanupTestDatabase :: TestDatabase -> IO ()
cleanupTestDatabase TestDatabase
testDatabase = ByteString -> TestDatabase -> IO ()
Database.deleteDatabase ByteString
databaseUrl TestDatabase
testDatabase
        let withTestDatabase :: (TestDatabase -> IO ()) -> IO ()
withTestDatabase = IO TestDatabase
-> (TestDatabase -> IO ()) -> (TestDatabase -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket IO TestDatabase
initTestDatabase TestDatabase -> IO ()
cleanupTestDatabase

        (TestDatabase -> IO ()) -> IO ()
withTestDatabase \TestDatabase
testDatabase -> do
            ModelContext
modelContext <- NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
dbPoolIdleTime Int
dbPoolMaxConnections (TestDatabase
testDatabase.url) Logger
logger

            Key (Session IO ByteString ByteString)
session <- IO (Key (Session IO ByteString ByteString))
forall a. IO (Key a)
Vault.newKey
            PGListener
pgListener <- ModelContext -> IO PGListener
PGListener.init ModelContext
modelContext
            IORef AutoRefreshServer
autoRefreshServer <- AutoRefreshServer -> IO (IORef AutoRefreshServer)
forall a. a -> IO (IORef a)
newIORef (PGListener -> AutoRefreshServer
AutoRefresh.newAutoRefreshServer PGListener
pgListener)
            let sessionVault :: Vault
sessionVault = Key (Session IO ByteString ByteString)
-> Session IO ByteString ByteString -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Session IO ByteString ByteString)
session Session IO ByteString ByteString
forall a. Monoid a => a
mempty Vault
Vault.empty
            let applicationContext :: ApplicationContext
applicationContext = ApplicationContext { $sel:modelContext:ApplicationContext :: ModelContext
modelContext = ModelContext
modelContext, Key (Session IO ByteString ByteString)
session :: Key (Session IO ByteString ByteString)
$sel:session:ApplicationContext :: Key (Session IO ByteString ByteString)
session, IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
$sel:autoRefreshServer:ApplicationContext :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
frameworkConfig :: FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: FrameworkConfig
frameworkConfig, PGListener
pgListener :: PGListener
$sel:pgListener:ApplicationContext :: PGListener
pgListener }

            let requestContext :: RequestContext
requestContext = RequestContext
                 { $sel:request:RequestContext :: Request
request = Request
defaultRequest {vault :: Vault
vault = Vault
sessionVault}
                 , $sel:requestBody:RequestContext :: RequestBody
requestBody = [Param] -> [File ByteString] -> RequestBody
FormBody [] []
                 , $sel:respond:RequestContext :: Respond
respond = IO ResponseReceived -> Respond
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)
                 , $sel:vault:RequestContext :: Key (Session IO ByteString ByteString)
vault = Key (Session IO ByteString ByteString)
session
                 , $sel:frameworkConfig:RequestContext :: FrameworkConfig
frameworkConfig = FrameworkConfig
frameworkConfig }

            (MockContext application -> IO ()
hspecAction MockContext { application
ModelContext
RequestContext
ApplicationContext
$sel:modelContext:MockContext :: ModelContext
$sel:requestContext:MockContext :: RequestContext
$sel:applicationContext:MockContext :: ApplicationContext
$sel:application:MockContext :: application
application :: application
modelContext :: ModelContext
applicationContext :: ApplicationContext
requestContext :: RequestContext
.. })


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
frameworkConfig@(FrameworkConfig {Int
$sel:dbPoolMaxConnections:FrameworkConfig :: FrameworkConfig -> Int
dbPoolMaxConnections :: Int
dbPoolMaxConnections, NominalDiffTime
$sel:dbPoolIdleTime:FrameworkConfig :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
dbPoolIdleTime, ByteString
$sel:databaseUrl:FrameworkConfig :: FrameworkConfig -> ByteString
databaseUrl :: ByteString
databaseUrl}) <- ConfigBuilder -> IO FrameworkConfig
FrameworkConfig.buildFrameworkConfig ConfigBuilder
configBuilder
   let databaseConnection :: a
databaseConnection = a
forall a. HasCallStack => a
undefined
   Logger
logger <- LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { $sel:level:LoggerSettings :: LogLevel
level = LogLevel
Warn } -- don't log queries
   ModelContext
modelContext <- NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
dbPoolIdleTime Int
dbPoolMaxConnections ByteString
databaseUrl Logger
logger

   Key (Session IO ByteString ByteString)
session <- IO (Key (Session IO ByteString ByteString))
forall a. IO (Key a)
Vault.newKey
   let sessionVault :: Vault
sessionVault = Key (Session IO ByteString ByteString)
-> Session IO ByteString ByteString -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Session IO ByteString ByteString)
session Session IO ByteString ByteString
forall a. Monoid a => a
mempty Vault
Vault.empty
   PGListener
pgListener <- ModelContext -> IO PGListener
PGListener.init ModelContext
modelContext
   IORef AutoRefreshServer
autoRefreshServer <- AutoRefreshServer -> IO (IORef AutoRefreshServer)
forall a. a -> IO (IORef a)
newIORef (PGListener -> AutoRefreshServer
AutoRefresh.newAutoRefreshServer PGListener
pgListener)
   let applicationContext :: ApplicationContext
applicationContext = ApplicationContext { $sel:modelContext:ApplicationContext :: ModelContext
modelContext = ModelContext
modelContext, Key (Session IO ByteString ByteString)
$sel:session:ApplicationContext :: Key (Session IO ByteString ByteString)
session :: Key (Session IO ByteString ByteString)
session, IORef AutoRefreshServer
$sel:autoRefreshServer:ApplicationContext :: IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, PGListener
$sel:pgListener:ApplicationContext :: PGListener
pgListener :: PGListener
pgListener }

   let requestContext :: RequestContext
requestContext = RequestContext
         { $sel:request:RequestContext :: Request
request = Request
defaultRequest {vault :: Vault
vault = Vault
sessionVault}
         , $sel:requestBody:RequestContext :: RequestBody
requestBody = [Param] -> [File ByteString] -> RequestBody
FormBody [] []
         , $sel:respond:RequestContext :: Respond
respond = \Response
resp -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived
         , $sel:vault:RequestContext :: Key (Session IO ByteString ByteString)
vault = Key (Session IO ByteString ByteString)
session
         , $sel:frameworkConfig:RequestContext :: FrameworkConfig
frameworkConfig = FrameworkConfig
frameworkConfig }

   MockContext application -> IO (MockContext application)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MockContext{application
ModelContext
RequestContext
ApplicationContext
$sel:modelContext:MockContext :: ModelContext
$sel:requestContext:MockContext :: RequestContext
$sel:applicationContext:MockContext :: ApplicationContext
$sel:application:MockContext :: application
application :: application
modelContext :: ModelContext
applicationContext :: ApplicationContext
requestContext :: RequestContext
..}

-- | 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
ModelContext
RequestContext
ApplicationContext
$sel:modelContext:MockContext :: forall application. MockContext application -> ModelContext
$sel:requestContext:MockContext :: forall application. MockContext application -> RequestContext
$sel:applicationContext:MockContext :: forall application. MockContext application -> ApplicationContext
$sel:application:MockContext :: forall application. MockContext application -> application
modelContext :: ModelContext
requestContext :: RequestContext
applicationContext :: ApplicationContext
application :: application
..} = let
    ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext
    ?context = ?context::RequestContext
RequestContext
requestContext
    ?applicationContext = ?applicationContext::ApplicationContext
ApplicationContext
applicationContext
    ?application = application
?application::application
application
    ?mocking = ?mocking::MockContext application
MockContext application
mocking
  in do
    IO a
ContextParameters application => IO a
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
    IORef (Maybe Response)
responseRef <- Maybe Response -> IO (IORef (Maybe Response))
forall a. a -> IO (IORef a)
newIORef Maybe Response
forall a. Maybe a
Nothing
    let customRespond :: Respond
customRespond 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
    let requestContextWithOverridenRespond :: RequestContext
requestContextWithOverridenRespond = ?context::RequestContext
RequestContext
?context { $sel:respond:RequestContext :: Respond
respond = Respond
customRespond, $sel:requestBody:RequestContext :: RequestBody
requestBody = [Param] -> [File ByteString] -> RequestBody
FormBody [Param]
params [] }
    let ?context = ?context::RequestContext
RequestContext
requestContextWithOverridenRespond
    controller -> IO ResponseReceived
forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext controller
controller
    Maybe Response
maybeResponse <- IORef (Maybe Response) -> IO (Maybe Response)
forall a. IORef a -> IO a
readIORef IORef (Maybe Response)
responseRef
    case Maybe Response
maybeResponse of
        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
"mockAction: The action did not render a response"

-- | 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 = ?context::RequestContext
RequestContext
?context.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 =<<) (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
    IORef Builder
content <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
    StreamingBody
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)) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> IO Builder -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
content

-- | Asserts that the response body contains the given text.
responseBodyShouldContain :: Response -> Text -> IO ()
responseBodyShouldContain :: Response -> Text -> IO ()
responseBodyShouldContain Response
response Text
includedText = do
    Text
body :: Text <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> IO ByteString
responseBody Response
response
    Text
body Text -> (Text -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (Text
includedText `Text.isInfixOf`)

-- | Asserts that the response body does not contain the given text.
responseBodyShouldNotContain :: Response -> Text -> IO ()
responseBodyShouldNotContain :: Response -> Text -> IO ()
responseBodyShouldNotContain Response
response Text
includedText = do
    Text
body :: Text <- ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> IO ByteString
responseBody Response
response
    Text
body Text -> (Text -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldNotSatisfy` (Text
includedText `Text.isInfixOf`)

-- | Asserts that the response status is equal to the given status.
responseStatusShouldBe :: Response -> HTTP.Status -> IO ()
responseStatusShouldBe :: Response -> Status -> IO ()
responseStatusShouldBe Response
response Status
status = Response -> Status
responseStatus Response
response Status -> Status -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Status
status

-- | 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 function overrides the session cookie passed to
-- the application.
--
withUser :: forall user application userId result.
    ( ?mocking :: MockContext application
    , ?applicationContext :: ApplicationContext
    , ?context :: RequestContext
    , Serialize.Serialize userId
    , HasField "id" user userId
    , KnownSymbol (GetModelName user)
    ) => user -> ((?context :: RequestContext) => IO result) -> IO result
withUser :: forall user application userId result.
(?mocking::MockContext application,
 ?applicationContext::ApplicationContext, ?context::RequestContext,
 Serialize userId, HasField "id" user userId,
 KnownSymbol (GetModelName user)) =>
user -> ((?context::RequestContext) => IO result) -> IO result
withUser user
user (?context::RequestContext) => IO result
callback =
        let ?context = ?context::RequestContext
RequestContext
newContext
        in IO result
(?context::RequestContext) => IO result
callback
    where
        newContext :: RequestContext
newContext = ?context::RequestContext
RequestContext
?context { $sel:request:RequestContext :: Request
request = Request
newRequest }
        newRequest :: Request
newRequest = Request
request { vault :: Vault
Wai.vault = Vault
newVault }

        newSession :: Network.Wai.Session.Session IO ByteString ByteString
        newSession :: Session IO ByteString ByteString
newSession = (ByteString -> IO (Maybe ByteString)
lookupSession, ByteString -> ByteString -> IO ()
forall {f :: * -> *} {p} {p}. Applicative f => p -> p -> f ()
insertSession)

        lookupSession :: ByteString -> IO (Maybe ByteString)
lookupSession ByteString
key = if ByteString
key ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
sessionKey
            then Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
sessionValue)
            else Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing

        insertSession :: p -> p -> f ()
insertSession p
key p
value = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        newVault :: Vault
newVault = Key (Session IO ByteString ByteString)
-> Session IO ByteString ByteString -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Session IO ByteString ByteString)
vaultKey Session IO ByteString ByteString
newSession (Request -> Vault
Wai.vault Request
request)
        RequestContext { Request
$sel:request:RequestContext :: RequestContext -> Request
request :: Request
request, $sel:vault:RequestContext :: RequestContext -> Key (Session IO ByteString ByteString)
vault = Key (Session IO ByteString ByteString)
vaultKey } = ?mocking::MockContext application
MockContext application
?mocking.requestContext

        sessionValue :: ByteString
sessionValue = userId -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode (user
user.id)
        sessionKey :: ByteString
sessionKey = ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (forall user. KnownSymbol (GetModelName user) => ByteString
Session.sessionKey @user)

-- | 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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Id' table -> Text
forall a. Show a => a -> Text
tshow
    Text -> (Text -> ByteString) -> ByteString
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs