{-# 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
import IHP.Controller.Session (sessionVaultKey)
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
}
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
dbPoolMaxConnections :: FrameworkConfig -> Int
dbPoolMaxConnections, NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
dbPoolIdleTime :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime, ByteString
databaseUrl :: ByteString
databaseUrl :: FrameworkConfig -> ByteString
databaseUrl } = FrameworkConfig
frameworkConfig
Logger
logger <- LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { level = Warn }
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
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)
sessionVaultKey Session IO ByteString ByteString
forall a. Monoid a => a
mempty Vault
Vault.empty
let applicationContext :: ApplicationContext
applicationContext = ApplicationContext { modelContext :: ModelContext
modelContext = ModelContext
modelContext, IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, PGListener
pgListener :: PGListener
pgListener :: PGListener
pgListener }
let requestContext :: RequestContext
requestContext = RequestContext
{ request :: Request
request = Request
defaultRequest {vault = sessionVault}
, requestBody :: RequestBody
requestBody = [Param] -> [File ByteString] -> RequestBody
FormBody [] []
, respond :: 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)
, frameworkConfig :: FrameworkConfig
frameworkConfig = FrameworkConfig
frameworkConfig }
(MockContext application -> IO ()
hspecAction MockContext { application
ModelContext
RequestContext
ApplicationContext
modelContext :: ModelContext
requestContext :: RequestContext
applicationContext :: ApplicationContext
application :: 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
dbPoolMaxConnections :: FrameworkConfig -> Int
dbPoolMaxConnections :: Int
dbPoolMaxConnections, NominalDiffTime
dbPoolIdleTime :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
dbPoolIdleTime, ByteString
databaseUrl :: 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 { level = Warn }
ModelContext
modelContext <- NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
dbPoolIdleTime Int
dbPoolMaxConnections ByteString
databaseUrl Logger
logger
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)
sessionVaultKey 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 { modelContext :: ModelContext
modelContext = ModelContext
modelContext, IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, PGListener
pgListener :: PGListener
pgListener :: PGListener
pgListener }
let requestContext :: RequestContext
requestContext = RequestContext
{ request :: Request
request = Request
defaultRequest {vault = sessionVault}
, requestBody :: RequestBody
requestBody = [Param] -> [File ByteString] -> RequestBody
FormBody [] []
, respond :: Respond
respond = \Response
resp -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ResponseReceived
, frameworkConfig :: 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
modelContext :: ModelContext
requestContext :: RequestContext
applicationContext :: ApplicationContext
application :: application
application :: application
modelContext :: ModelContext
applicationContext :: ApplicationContext
requestContext :: RequestContext
..}
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
modelContext :: forall application. MockContext application -> ModelContext
requestContext :: forall application. MockContext application -> RequestContext
applicationContext :: forall application. MockContext application -> ApplicationContext
application :: 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
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 []
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 { respond = customRespond, requestBody = FormBody 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"
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 :: 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
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
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
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`)
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`)
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
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 { request = newRequest }
newRequest :: Request
newRequest = Request
request { Wai.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)
sessionVaultKey Session IO ByteString ByteString
newSession (Request -> Vault
Wai.vault Request
request)
RequestContext { Request
request :: RequestContext -> Request
request :: Request
request } = ?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)
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