{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, ConstrainedClassMethods, ScopedTypeVariables, FunctionalDependencies, AllowAmbiguousTypes #-}

module IHP.ControllerSupport
( Action'
, (|>)
, getRequestBody
, getRequestPath
, getRequestPathAndQuery
, getHeader
, RequestContext (RequestContext)
, request
, requestHeaders
, getFiles
, Controller (..)
, runAction
, createRequestContext
, ControllerContext
, InitControllerContext (..)
, runActionWithNewContext
, newContextForAction
, respondAndExit
, jumpToAction
, requestBodyJSON
, startWebSocketApp
, startWebSocketAppAndFailOnHTTP
, setHeader
, getAppConfig
) where

import ClassyPrelude
import IHP.HaskellSupport
import Network.Wai (Request, ResponseReceived, responseLBS, requestHeaders)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai
import IHP.ModelSupport
import IHP.ApplicationContext (ApplicationContext (..))
import Network.Wai.Parse as WaiParse
import qualified Data.ByteString.Lazy
import qualified IHP.Controller.RequestContext as RequestContext
import IHP.Controller.RequestContext (RequestContext, Respond)
import qualified Data.CaseInsensitive
import qualified IHP.ErrorController as ErrorController
import qualified Data.Typeable as Typeable
import IHP.FrameworkConfig (FrameworkConfig (..), ConfigProvider(..))
import qualified IHP.Controller.Context as Context
import IHP.Controller.Context (ControllerContext(ControllerContext), customFieldsRef)
import IHP.Controller.Response
import Network.HTTP.Types.Header
import qualified Data.Aeson as Aeson
import qualified Network.Wai.Handler.WebSockets as WebSockets
import qualified Network.WebSockets as WebSockets
import qualified IHP.WebSocket as WebSockets
import qualified Data.TMap as TypeMap

type Action' = IO ResponseReceived

class (Show controller, Eq controller) => Controller controller where
    beforeAction :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => IO ()
    beforeAction = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINABLE beforeAction #-}
    action :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => controller -> IO ()

class InitControllerContext application where
    initContext :: (?modelContext :: ModelContext, ?requestContext :: RequestContext, ?applicationContext :: ApplicationContext, ?context :: ControllerContext) => IO ()
    initContext = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINABLE initContext #-}

instance InitControllerContext () where
    initContext :: (?modelContext::ModelContext, ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-# INLINE runAction #-}
runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext) => controller -> IO ResponseReceived
runAction :: forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext,
 ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext) =>
controller -> IO ResponseReceived
runAction controller
controller = do
    let ?theAction = controller
?theAction::controller
controller
    let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
ControllerContext
?context.requestContext.respond

    let doRunAction :: IO ResponseReceived
doRunAction = do
            ModelContext
authenticatedModelContext <- (?context::ControllerContext) => ModelContext -> IO ModelContext
ModelContext -> IO ModelContext
prepareRLSIfNeeded ?modelContext::ModelContext
ModelContext
?modelContext

            let ?modelContext = ?modelContext::ModelContext
ModelContext
authenticatedModelContext
            IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction
            (controller -> IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action controller
controller)
            controller -> IO ResponseReceived
forall controller.
(Show controller, ?context::ControllerContext) =>
controller -> IO ResponseReceived
ErrorController.handleNoResponseReturned controller
controller

    let handleResponseException :: ResponseException -> IO ResponseReceived
handleResponseException  (ResponseException Response
response) = Response -> IO ResponseReceived
respond Response
response

    IO ResponseReceived
doRunAction IO ResponseReceived
-> [Handler IO ResponseReceived] -> IO ResponseReceived
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches` [ (ResponseException -> IO ResponseReceived)
-> Handler IO ResponseReceived
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ResponseException -> IO ResponseReceived
handleResponseException, (SomeException -> IO ResponseReceived)
-> Handler IO ResponseReceived
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\SomeException
exception -> SomeException -> controller -> Text -> IO ResponseReceived
forall action.
(Show action, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
"")]

{-# INLINE newContextForAction #-}
newContextForAction
    :: forall application controller
     . ( Controller controller
       , ?applicationContext :: ApplicationContext
       , ?context :: RequestContext
       , InitControllerContext application
       , ?application :: application
       , Typeable application
       , Typeable controller
       )
    => controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction :: forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction controller
controller = do
    let ?modelContext = ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.modelContext
    let ?requestContext = ?context::RequestContext
?requestContext::RequestContext
RequestContext
?context
    ControllerContext
controllerContext <- IO ControllerContext
(?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
    let ?context = ?context::ControllerContext
ControllerContext
controllerContext
    application -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext application
?application::application
?application
    ActionType -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (TypeRep -> ActionType
Context.ActionType (controller -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf controller
controller))

    IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException ()
    -> IO (Either (IO ResponseReceived) ControllerContext))
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left (SomeException
exception :: SomeException) -> do
            Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ResponseReceived) ControllerContext
 -> IO (Either (IO ResponseReceived) ControllerContext))
-> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a b. (a -> b) -> a -> b
$ IO ResponseReceived
-> Either (IO ResponseReceived) ControllerContext
forall a b. a -> Either a b
Left (IO ResponseReceived
 -> Either (IO ResponseReceived) ControllerContext)
-> IO ResponseReceived
-> Either (IO ResponseReceived) ControllerContext
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe ResponseException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                Just (ResponseException Response
response) ->
                    let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
ControllerContext
?context.requestContext.respond
                    in Response -> IO ResponseReceived
respond Response
response
                Maybe ResponseException
Nothing -> SomeException -> controller -> Text -> IO ResponseReceived
forall action.
(Show action, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
" while calling initContext"
        Right ()
_ -> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ResponseReceived) ControllerContext
 -> IO (Either (IO ResponseReceived) ControllerContext))
-> Either (IO ResponseReceived) ControllerContext
-> IO (Either (IO ResponseReceived) ControllerContext)
forall a b. (a -> b) -> a -> b
$ ControllerContext -> Either (IO ResponseReceived) ControllerContext
forall a b. b -> Either a b
Right ?context::ControllerContext
ControllerContext
?context

{-# INLINE runActionWithNewContext #-}
runActionWithNewContext :: forall application controller. (Controller controller, ?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => controller -> IO ResponseReceived
runActionWithNewContext :: forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext controller
controller = do
    Either (IO ResponseReceived) ControllerContext
contextOrResponse <- controller -> IO (Either (IO ResponseReceived) ControllerContext)
forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
 ?context::RequestContext, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction controller
controller
    case Either (IO ResponseReceived) ControllerContext
contextOrResponse of
        Left IO ResponseReceived
response -> IO ResponseReceived
response
        Right ControllerContext
context -> do
            let ?modelContext = ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.modelContext
            let ?requestContext = ?context::RequestContext
?requestContext::RequestContext
RequestContext
?context
            let ?context = ?context::ControllerContext
ControllerContext
context
            controller -> IO ResponseReceived
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext,
 ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext) =>
controller -> IO ResponseReceived
runAction controller
controller

-- | If 'IHP.LoginSupport.Helper.Controller.enableRowLevelSecurityIfLoggedIn' was called, this will copy the
-- the prepared RowLevelSecurityContext from the controller context into the ModelContext.
--
-- If row leve security wasn't enabled, this will just return the current model context.
prepareRLSIfNeeded :: (?context :: ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded :: (?context::ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded ModelContext
modelContext = do
    Maybe RowLevelSecurityContext
rowLevelSecurityContext <- IO (Maybe RowLevelSecurityContext)
forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext
    case Maybe RowLevelSecurityContext
rowLevelSecurityContext of
        Just RowLevelSecurityContext
context -> ModelContext -> IO ModelContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext { rowLevelSecurity = Just context }
        Maybe RowLevelSecurityContext
Nothing -> ModelContext -> IO ModelContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext

{-# INLINE startWebSocketApp #-}
startWebSocketApp :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => IO ResponseReceived -> Network.Wai.Application
startWebSocketApp :: forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
IO ResponseReceived -> Application
startWebSocketApp IO ResponseReceived
onHTTP Request
request Response -> IO ResponseReceived
respond = do
    let ?modelContext = ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.modelContext
    RequestContext
requestContext <- ApplicationContext
-> Request
-> (Response -> IO ResponseReceived)
-> IO RequestContext
createRequestContext ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext Request
request Response -> IO ResponseReceived
respond
    let ?requestContext = ?requestContext::RequestContext
RequestContext
requestContext

    let handleConnection :: PendingConnection -> IO ()
handleConnection PendingConnection
pendingConnection = do
            Connection
connection <- PendingConnection -> IO Connection
WebSockets.acceptRequest PendingConnection
pendingConnection

            ControllerContext
controllerContext <- IO ControllerContext
(?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
            let ?context = ?context::ControllerContext
ControllerContext
controllerContext

            application -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext application
?application::application
?application

            IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
 ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left (SomeException
exception :: SomeException) -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected exception in initContext, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception
                Right ()
context -> do
                    forall state.
(WSApp state, ?applicationContext::ApplicationContext,
 ?requestContext::RequestContext, ?context::ControllerContext,
 ?modelContext::ModelContext) =>
Connection -> IO ()
WebSockets.startWSApp @webSocketApp Connection
connection

    let connectionOptions :: ConnectionOptions
connectionOptions = forall state. WSApp state => ConnectionOptions
WebSockets.connectionOptions @webSocketApp

    Request
request
        Request -> (Request -> Maybe Response) -> Maybe Response
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WebSockets.websocketsApp ConnectionOptions
connectionOptions PendingConnection -> IO ()
handleConnection
        Maybe Response
-> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
            Just Response
response -> Response -> IO ResponseReceived
respond Response
response
            Maybe Response
Nothing -> IO ResponseReceived
onHTTP
{-# INLINE startWebSocketAppAndFailOnHTTP #-}
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application. (?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => Network.Wai.Application
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
Application
startWebSocketAppAndFailOnHTTP = forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
IO ResponseReceived -> Application
startWebSocketApp @webSocketApp @application (Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
responseLBS Status
HTTP.status400 [(CI ByteString
hContentType, ByteString
"text/plain")] ByteString
"This endpoint is only available via a WebSocket")
    where
        respond :: Response -> IO ResponseReceived
respond = ?context::RequestContext
RequestContext
?context.respond


jumpToAction :: forall action. (Controller action, ?context :: ControllerContext, ?modelContext :: ModelContext) => action -> IO ()
jumpToAction :: forall action.
(Controller action, ?context::ControllerContext,
 ?modelContext::ModelContext) =>
action -> IO ()
jumpToAction action
theAction = do
    let ?theAction = action
?theAction::action
theAction
    forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction @action
    action -> IO ()
forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action action
theAction

{-# INLINE getRequestBody #-}
getRequestBody :: (?context :: ControllerContext) => IO LByteString
getRequestBody :: (?context::ControllerContext) => IO ByteString
getRequestBody =
    case ?context::ControllerContext
ControllerContext
?context.requestContext.requestBody of
        RequestContext.JSONBody { ByteString
rawPayload :: ByteString
rawPayload :: RequestBody -> ByteString
rawPayload } -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
rawPayload
        RequestBody
_ -> Request -> IO ByteString
Network.Wai.lazyRequestBody Request
(?context::ControllerContext) => Request
request

-- | Returns the request path, e.g. @/Users@ or @/CreateUser@
getRequestPath :: (?context :: ControllerContext) => ByteString
getRequestPath :: (?context::ControllerContext) => ByteString
getRequestPath = Request
(?context::ControllerContext) => Request
request.rawPathInfo
{-# INLINABLE getRequestPath #-}

-- | Returns the request path and the query params, e.g. @/ShowUser?userId=9bd6b37b-2e53-40a4-bb7b-fdba67d6af42@
getRequestPathAndQuery :: (?context :: ControllerContext) => ByteString
getRequestPathAndQuery :: (?context::ControllerContext) => ByteString
getRequestPathAndQuery = Request
(?context::ControllerContext) => Request
request.rawPathInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request
(?context::ControllerContext) => Request
request.rawQueryString
{-# INLINABLE getRequestPathAndQuery #-}

-- | Returns a header value for a given header name. Returns Nothing if not found
--
-- The header is looked up in a case insensitive way.
--
-- >>> getHeader "Content-Type"
-- Just "text/html"
--
-- >>> getHeader "X-My-Custom-Header"
-- Nothing
--
getHeader :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
getHeader :: (?context::ControllerContext) => ByteString -> Maybe ByteString
getHeader ByteString
name = ContainerKey RequestHeaders
-> RequestHeaders -> Maybe (MapValue RequestHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) Request
(?context::ControllerContext) => Request
request.requestHeaders
{-# INLINABLE getHeader #-}

-- | Set a header value for a given header name.
--
-- >>> setHeader ("Content-Language", "en")
--
setHeader :: (?context :: ControllerContext) => Header -> IO ()
setHeader :: (?context::ControllerContext) => Header -> IO ()
setHeader Header
header = do
    Maybe RequestHeaders
maybeHeaders <- forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext @[Header]
    let headers :: RequestHeaders
headers = RequestHeaders -> Maybe RequestHeaders -> RequestHeaders
forall a. a -> Maybe a -> a
fromMaybe [] Maybe RequestHeaders
maybeHeaders
    RequestHeaders -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (Header
header Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
headers)
{-# INLINABLE setHeader #-}

-- | Returns the current HTTP request.
--
-- See https://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:Request
request :: (?context :: ControllerContext) => Network.Wai.Request
request :: (?context::ControllerContext) => Request
request = RequestContext
(?context::ControllerContext) => RequestContext
requestContext.request
{-# INLINE request #-}

{-# INLINE getFiles #-}
getFiles :: (?context :: ControllerContext) => [File Data.ByteString.Lazy.ByteString]
getFiles :: (?context::ControllerContext) => [File ByteString]
getFiles =
    case RequestContext
(?context::ControllerContext) => RequestContext
requestContext.requestBody of
        RequestContext.FormBody { [File ByteString]
files :: [File ByteString]
files :: RequestBody -> [File ByteString]
files } -> [File ByteString]
files
        RequestBody
_ -> []

requestContext :: (?context :: ControllerContext) => RequestContext
requestContext :: (?context::ControllerContext) => RequestContext
requestContext = ?context::ControllerContext
ControllerContext
?context.requestContext
{-# INLINE requestContext #-}

requestBodyJSON :: (?context :: ControllerContext) => Aeson.Value
requestBodyJSON :: (?context::ControllerContext) => Value
requestBodyJSON =
    case ?context::ControllerContext
ControllerContext
?context.requestContext.requestBody of
        RequestContext.JSONBody { jsonPayload :: RequestBody -> Maybe Value
jsonPayload = Just Value
value } -> Value
value
        RequestBody
_ -> [Char] -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"Expected JSON body"

{-# INLINE createRequestContext #-}
createRequestContext :: ApplicationContext -> Request -> Respond -> IO RequestContext
createRequestContext :: ApplicationContext
-> Request
-> (Response -> IO ResponseReceived)
-> IO RequestContext
createRequestContext ApplicationContext { FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig :: ApplicationContext -> FrameworkConfig
frameworkConfig } Request
request Response -> IO ResponseReceived
respond = do
    let contentType :: Maybe (MapValue RequestHeaders)
contentType = ContainerKey RequestHeaders
-> RequestHeaders -> Maybe (MapValue RequestHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup ContainerKey RequestHeaders
CI ByteString
hContentType (Request -> RequestHeaders
requestHeaders Request
request)
    RequestBody
requestBody <- case Maybe (MapValue RequestHeaders)
contentType of
        Maybe (MapValue RequestHeaders)
"application/json" -> do
            ByteString
rawPayload <- Request -> IO ByteString
Network.Wai.lazyRequestBody Request
request
            let jsonPayload :: Maybe Value
jsonPayload = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
rawPayload
            RequestBody -> IO RequestBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext.JSONBody { Maybe Value
jsonPayload :: Maybe Value
jsonPayload :: Maybe Value
jsonPayload, ByteString
rawPayload :: ByteString
rawPayload :: ByteString
rawPayload }
        Maybe (MapValue RequestHeaders)
_ -> do
            ([Param]
params, [File ByteString]
files) <- ParseRequestBodyOptions
-> BackEnd ByteString -> Request -> IO ([Param], [File ByteString])
forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
WaiParse.parseRequestBodyEx FrameworkConfig
frameworkConfig.parseRequestBodyOptions BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
WaiParse.lbsBackEnd Request
request
            RequestBody -> IO RequestBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext.FormBody { [Param]
[File ByteString]
files :: [File ByteString]
params :: [Param]
files :: [File ByteString]
params :: [Param]
.. }

    RequestContext -> IO RequestContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext.RequestContext { Request
request :: Request
request :: Request
request, Response -> IO ResponseReceived
respond :: Response -> IO ResponseReceived
respond :: Response -> IO ResponseReceived
respond, RequestBody
requestBody :: RequestBody
requestBody :: RequestBody
requestBody, FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig }


-- | Returns a custom config parameter
--
-- >>> getAppConfig @StripePublicKey
-- StripePublicKey "pk_test_..."
--
-- Example:
--
-- First you need to define a custom config parameter in Config.hs:
--
-- > -- Config/Config.hs
-- > newtype StripePublicKey = StripePublicKey Text
-- >
-- > config :: ConfigBuilder
-- > config = do
-- >     -- ...
-- >     stripePublicKey <- StripePublicKey <$> env @Text "STRIPE_PUBLIC_KEY"
-- >     option stripePublicKey
--
-- Then you can access it using 'getAppConfig':
--
-- > action MyAction = do
-- >     let (StripePublicKey stripePublicKey) = getAppConfig @StripePublicKey
-- >
-- >     putStrLn ("Stripe public key: " <> stripePublicKey)
--
getAppConfig :: forall configParameter context. (?context :: context, ConfigProvider context, Typeable configParameter) => configParameter
getAppConfig :: forall configParameter context.
(?context::context, ConfigProvider context,
 Typeable configParameter) =>
configParameter
getAppConfig = context
?context::context
?context.frameworkConfig.appConfig
        TMap -> (TMap -> Maybe configParameter) -> Maybe configParameter
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @configParameter
        Maybe configParameter
-> (Maybe configParameter -> configParameter) -> configParameter
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> configParameter -> Maybe configParameter -> configParameter
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> configParameter
forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not find " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Proxy configParameter -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Typeable.Proxy @configParameter))) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>[Char]
" in config"))
{-# INLINE getAppConfig #-}