{-# 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
, respondAndExit
, ResponseException (..)
, jumpToAction
, requestBodyJSON
, startWebSocketApp
, setHeader
, addResponseHeaders
, addResponseHeadersFromContext
, getAppConfig
) where
import ClassyPrelude
import IHP.HaskellSupport
import Network.Wai (Response, Request, ResponseReceived, responseLBS, requestHeaders)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai
import IHP.ModelSupport
import IHP.ApplicationContext (ApplicationContext (..))
import qualified IHP.ApplicationContext as 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 Control.Exception as Exception
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)
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.Typeable as Typeable
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE initContext #-}
{-# INLINE runAction #-}
runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext) => controller -> IO ResponseReceived
runAction :: controller -> IO ResponseReceived
runAction controller
controller = do
let ?theAction = controller
let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
ControllerContext
?context ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext RequestContext
-> (RequestContext -> Response -> IO ResponseReceived)
-> Response
-> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "respond"
-> RequestContext -> Response -> IO ResponseReceived
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "respond" (Proxy "respond")
Proxy "respond"
#respond
let doRunAction :: IO ResponseReceived
doRunAction = do
ModelContext
authenticatedModelContext <- (?context::ControllerContext) => ModelContext -> IO ModelContext
ModelContext -> IO ModelContext
prepareRLSIfNeeded ?modelContext::ModelContext
ModelContext
?modelContext
let ?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 runActionWithNewContext #-}
runActionWithNewContext :: forall application controller. (Controller controller, ?applicationContext :: ApplicationContext, ?context :: RequestContext, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => controller -> IO ResponseReceived
runActionWithNewContext :: controller -> IO ResponseReceived
runActionWithNewContext controller
controller = do
let ?modelContext = ApplicationContext.modelContext ?applicationContext
let ?requestContext = ?context
ControllerContext
controllerContext <- IO ControllerContext
(?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
let ?context = 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 ((InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
forall application.
(InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException () -> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException
exception :: SomeException) -> do
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 ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext RequestContext
-> (RequestContext -> Response -> IO ResponseReceived)
-> Response
-> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "respond"
-> RequestContext -> Response -> IO ResponseReceived
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "respond" (Proxy "respond")
Proxy "respond"
#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 ()
context -> do
controller -> IO ResponseReceived
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext,
?applicationContext::ApplicationContext,
?requestContext::RequestContext) =>
controller -> IO ResponseReceived
runAction controller
controller
prepareRLSIfNeeded :: (?context :: ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext { $sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
rowLevelSecurity = RowLevelSecurityContext -> Maybe RowLevelSecurityContext
forall a. a -> Maybe a
Just RowLevelSecurityContext
context }
Maybe RowLevelSecurityContext
Nothing -> ModelContext -> IO ModelContext
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
startWebSocketApp :: IO ResponseReceived
startWebSocketApp = do
let ?modelContext = ApplicationContext.modelContext ?applicationContext
let ?requestContext = ?context
let respond :: Response -> IO ResponseReceived
respond = ?context::RequestContext
RequestContext
?context RequestContext
-> (RequestContext -> Response -> IO ResponseReceived)
-> Response
-> IO ResponseReceived
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "respond"
-> RequestContext -> Response -> IO ResponseReceived
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "respond" (Proxy "respond")
Proxy "respond"
#respond
let request :: Request
request = ?context::RequestContext
RequestContext
?context RequestContext -> (RequestContext -> Request) -> Request
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "request" -> RequestContext -> Request
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "request" (Proxy "request")
Proxy "request"
#request
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 = 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 ((InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
forall application.
(InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
initContext @application) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
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
Connection -> IO ()
forall state.
(WSApp state, ?applicationContext::ApplicationContext,
?requestContext::RequestContext, ?context::ControllerContext,
?modelContext::ModelContext) =>
Connection -> IO ()
WebSockets.startWSApp @webSocketApp Connection
connection
Request
request
Request -> (Request -> Maybe Response) -> Maybe Response
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WebSockets.websocketsApp ConnectionOptions
WebSockets.defaultConnectionOptions 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 -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
HTTP.status400 [(HeaderName
hContentType, ByteString
"text/plain")] ByteString
"This endpoint is only available via a WebSocket"
jumpToAction :: forall action. (Controller action, ?context :: ControllerContext, ?modelContext :: ModelContext) => action -> IO ()
jumpToAction :: action -> IO ()
jumpToAction action
theAction = do
let ?theAction = theAction
(Controller action, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::action) =>
IO ()
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 :: IO ByteString
getRequestBody =
?context::ControllerContext
ControllerContext
?context
ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext
RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
RequestBody -> (RequestBody -> IO ByteString) -> IO ByteString
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
RequestContext.JSONBody { ByteString
$sel:rawPayload:FormBody :: RequestBody -> ByteString
rawPayload :: ByteString
rawPayload } -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
rawPayload
RequestBody
_ -> Request -> IO ByteString
Network.Wai.lazyRequestBody Request
(?context::ControllerContext) => Request
request
getRequestPath :: (?context :: ControllerContext) => ByteString
getRequestPath :: ByteString
getRequestPath = Request -> ByteString
Network.Wai.rawPathInfo Request
(?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPath #-}
getRequestPathAndQuery :: (?context :: ControllerContext) => ByteString
getRequestPathAndQuery :: ByteString
getRequestPathAndQuery = Request -> ByteString
Network.Wai.rawPathInfo Request
(?context::ControllerContext) => Request
request ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Network.Wai.rawQueryString Request
(?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPathAndQuery #-}
getHeader :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
ByteString
name = ContainerKey ResponseHeaders
-> ResponseHeaders -> Maybe (MapValue ResponseHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) (Request -> ResponseHeaders
Network.Wai.requestHeaders Request
(?context::ControllerContext) => Request
request)
{-# INLINABLE getHeader #-}
setHeader :: (?context :: ControllerContext) => Header -> IO ()
Header
header = do
Maybe ResponseHeaders
maybeHeaders <- (?context::ControllerContext, Typeable ResponseHeaders) =>
IO (Maybe ResponseHeaders)
forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext @[Header]
let headers :: ResponseHeaders
headers = ResponseHeaders -> Maybe ResponseHeaders -> ResponseHeaders
forall a. a -> Maybe a -> a
fromMaybe [] Maybe ResponseHeaders
maybeHeaders
ResponseHeaders -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (Header
header Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
headers)
{-# INLINABLE setHeader #-}
addResponseHeaders :: [Header] -> Response -> Response
ResponseHeaders
headers = (ResponseHeaders -> ResponseHeaders) -> Response -> Response
Network.Wai.mapResponseHeaders (\ResponseHeaders
hs -> ResponseHeaders
headers ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
hs)
{-# INLINABLE addResponseHeaders #-}
addResponseHeadersFromContext :: (?context :: ControllerContext) => Response -> IO Response
Response
response = do
Maybe ResponseHeaders
maybeHeaders <- (?context::ControllerContext, Typeable ResponseHeaders) =>
IO (Maybe ResponseHeaders)
forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext @[Header]
let headers :: ResponseHeaders
headers = ResponseHeaders -> Maybe ResponseHeaders -> ResponseHeaders
forall a. a -> Maybe a -> a
fromMaybe [] Maybe ResponseHeaders
maybeHeaders
let responseWithHeaders :: Response
responseWithHeaders = ResponseHeaders -> Response -> Response
addResponseHeaders ResponseHeaders
headers Response
response
Response -> IO Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
responseWithHeaders
{-# INLINABLE addResponseHeadersFromContext #-}
request :: (?context :: ControllerContext) => Network.Wai.Request
request :: Request
request = RequestContext
(?context::ControllerContext) => RequestContext
requestContext RequestContext -> (RequestContext -> Request) -> Request
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "request" -> RequestContext -> Request
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "request" (Proxy "request")
Proxy "request"
#request
{-# INLINE request #-}
{-# INLINE getFiles #-}
getFiles :: (?context :: ControllerContext) => [File Data.ByteString.Lazy.ByteString]
getFiles :: [File ByteString]
getFiles = RequestContext
(?context::ControllerContext) => RequestContext
requestContext
RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
RequestBody
-> (RequestBody -> [File ByteString]) -> [File ByteString]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
RequestContext.FormBody { [File ByteString]
$sel:files:FormBody :: RequestBody -> [File ByteString]
files :: [File ByteString]
files } -> [File ByteString]
files
RequestBody
_ -> []
requestContext :: (?context :: ControllerContext) => RequestContext
requestContext :: RequestContext
requestContext = Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext ?context::ControllerContext
ControllerContext
?context
{-# INLINE requestContext #-}
requestBodyJSON :: (?context :: ControllerContext) => Aeson.Value
requestBodyJSON :: Value
requestBodyJSON =
?context::ControllerContext
ControllerContext
?context
ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext
RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
RequestBody -> (RequestBody -> Value) -> Value
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
RequestContext.JSONBody { $sel:jsonPayload:FormBody :: 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 { Key (Session IO ByteString ByteString)
$sel:session:ApplicationContext :: ApplicationContext -> Key (Session IO ByteString ByteString)
session :: Key (Session IO ByteString ByteString)
session, FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: ApplicationContext -> FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig } Request
request Response -> IO ResponseReceived
respond = do
let contentType :: Maybe (MapValue ResponseHeaders)
contentType = ContainerKey ResponseHeaders
-> ResponseHeaders -> Maybe (MapValue ResponseHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup ContainerKey ResponseHeaders
HeaderName
hContentType (Request -> ResponseHeaders
requestHeaders Request
request)
RequestBody
requestBody <- case Maybe (MapValue ResponseHeaders)
contentType of
Maybe (MapValue ResponseHeaders)
"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 (f :: * -> *) a. Applicative f => a -> f a
pure JSONBody :: Maybe Value -> ByteString -> RequestBody
RequestContext.JSONBody { Maybe Value
jsonPayload :: Maybe Value
$sel:jsonPayload:FormBody :: Maybe Value
jsonPayload, ByteString
rawPayload :: ByteString
$sel:rawPayload:FormBody :: ByteString
rawPayload }
Maybe (MapValue ResponseHeaders)
_ -> 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 FrameworkConfig
-> (FrameworkConfig -> ParseRequestBodyOptions)
-> ParseRequestBodyOptions
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "parseRequestBodyOptions"
-> FrameworkConfig -> ParseRequestBodyOptions
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "parseRequestBodyOptions" (Proxy "parseRequestBodyOptions")
Proxy "parseRequestBodyOptions"
#parseRequestBodyOptions) BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
WaiParse.lbsBackEnd Request
request
RequestBody -> IO RequestBody
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormBody :: [Param] -> [File ByteString] -> RequestBody
RequestContext.FormBody { [Param]
[File ByteString]
$sel:params:FormBody :: [Param]
files :: [File ByteString]
params :: [Param]
$sel:files:FormBody :: [File ByteString]
.. }
RequestContext -> IO RequestContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext :: Request
-> (Response -> IO ResponseReceived)
-> RequestBody
-> Key (Session IO ByteString ByteString)
-> FrameworkConfig
-> RequestContext
RequestContext.RequestContext { Request
$sel:request:RequestContext :: Request
request :: Request
request, Response -> IO ResponseReceived
$sel:respond:RequestContext :: Response -> IO ResponseReceived
respond :: Response -> IO ResponseReceived
respond, RequestBody
$sel:requestBody:RequestContext :: RequestBody
requestBody :: RequestBody
requestBody, $sel:vault:RequestContext :: Key (Session IO ByteString ByteString)
vault = Key (Session IO ByteString ByteString)
session, FrameworkConfig
$sel:frameworkConfig:RequestContext :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig }
newtype ResponseException = ResponseException Response
instance Show ResponseException where show :: ResponseException -> [Char]
show ResponseException
_ = [Char]
"ResponseException { .. }"
instance Exception ResponseException
respondAndExit :: (?context::ControllerContext) => Response -> IO ()
respondAndExit :: Response -> IO ()
respondAndExit Response
response = do
Response
responseWithHeaders <- (?context::ControllerContext) => Response -> IO Response
Response -> IO Response
addResponseHeadersFromContext Response
response
ResponseException -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO (Response -> ResponseException
ResponseException Response
responseWithHeaders)
{-# INLINE respondAndExit #-}
getAppConfig :: forall configParameter context. (?context :: context, ConfigProvider context, Typeable configParameter) => configParameter
getAppConfig :: configParameter
getAppConfig = context
?context::context
?context
context -> (context -> FrameworkConfig) -> FrameworkConfig
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig
FrameworkConfig -> (FrameworkConfig -> TMap) -> TMap
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "appConfig" -> FrameworkConfig -> TMap
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "appConfig" (Proxy "appConfig")
Proxy "appConfig"
#appConfig
TMap -> (TMap -> Maybe configParameter) -> Maybe configParameter
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Typeable configParameter => TMap -> Maybe configParameter
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] -> ShowS
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 (Proxy configParameter
forall k (t :: k). Proxy t
Typeable.Proxy @configParameter))) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>[Char]
" in config"))
{-# INLINE getAppConfig #-}