{-# 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
, ResponseException (..)
, jumpToAction
, requestBodyJSON
, startWebSocketApp
, startWebSocketAppAndFailOnHTTP
, 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(ControllerContext), customFieldsRef)
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 = 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 = 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 :: forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext,
?applicationContext::ApplicationContext,
?requestContext::RequestContext) =>
controller -> IO ResponseReceived
runAction controller
controller = do
let ?theAction = controller
controller
let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
?context forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "respond" a => a
#respond
let doRunAction :: IO ResponseReceived
doRunAction = do
ModelContext
authenticatedModelContext <- (?context::ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded ?modelContext::ModelContext
?modelContext
let ?modelContext = ModelContext
authenticatedModelContext
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction
(forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action controller
controller)
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 forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches` [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ResponseException -> IO ResponseReceived
handleResponseException, forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\SomeException
exception -> forall action.
(Show action, ?context::ControllerContext,
?applicationContext::ApplicationContext,
?requestContext::RequestContext) =>
SomeException -> action -> Text -> IO ResponseReceived
ErrorController.displayException SomeException
exception controller
controller Text
"")]
applyContextSetter :: (TypeMap.TMap -> TypeMap.TMap) -> ControllerContext -> IO ControllerContext
applyContextSetter :: (TMap -> TMap) -> ControllerContext -> IO ControllerContext
applyContextSetter TMap -> TMap
setter ctx :: ControllerContext
ctx@ControllerContext { IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: ControllerContext -> IORef TMap
customFieldsRef } = do
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef TMap
customFieldsRef ((TMap -> TMap) -> TMap -> TMap
applySetter TMap -> TMap
setter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ControllerContext
ctx { IORef TMap
customFieldsRef :: IORef TMap
$sel:customFieldsRef:ControllerContext :: IORef TMap
customFieldsRef }
where
fromSetter :: (TypeMap.TMap -> TypeMap.TMap) -> TypeMap.TMap
fromSetter :: (TMap -> TMap) -> TMap
fromSetter TMap -> TMap
f = TMap -> TMap
f TMap
TypeMap.empty
applySetter :: (TypeMap.TMap -> TypeMap.TMap) -> TypeMap.TMap -> TypeMap.TMap
applySetter :: (TMap -> TMap) -> TMap -> TMap
applySetter TMap -> TMap
f TMap
map = TMap -> TMap -> TMap
TypeMap.union ((TMap -> TMap) -> TMap
fromSetter TMap -> TMap
f) TMap
map
{-# INLINE newContextForAction #-}
newContextForAction
:: forall application controller
. ( Controller controller
, ?applicationContext :: ApplicationContext
, ?context :: RequestContext
, InitControllerContext application
, ?application :: application
, Typeable application
, Typeable controller
)
=> (TypeMap.TMap -> TypeMap.TMap) -> controller -> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction :: forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
?context::RequestContext, InitControllerContext application,
?application::application, Typeable application,
Typeable controller) =>
(TMap -> TMap)
-> controller
-> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction TMap -> TMap
contextSetter controller
controller = do
let ?modelContext = ApplicationContext -> ModelContext
ApplicationContext.modelContext ?applicationContext::ApplicationContext
?applicationContext
let ?requestContext = ?context::RequestContext
?context
ControllerContext
controllerContext <- (?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
let ?context = ControllerContext
controllerContext
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext ?application::application
?application
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (TypeRep -> ActionType
Context.ActionType (forall a. Typeable a => a -> TypeRep
Typeable.typeOf controller
controller))
(TMap -> TMap) -> ControllerContext -> IO ControllerContext
applyContextSetter TMap -> TMap
contextSetter ControllerContext
controllerContext
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
initContext @application) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException
exception :: SomeException) -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just (ResponseException Response
response) ->
let respond :: Response -> IO ResponseReceived
respond = ?context::ControllerContext
?context forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "respond" a => a
#respond
in Response -> IO ResponseReceived
respond Response
response
Maybe ResponseException
Nothing -> 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 ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ?context::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 <- forall application controller.
(Controller controller, ?applicationContext::ApplicationContext,
?context::RequestContext, InitControllerContext application,
?application::application, Typeable application,
Typeable controller) =>
(TMap -> TMap)
-> controller
-> IO (Either (IO ResponseReceived) ControllerContext)
newContextForAction (\TMap
t -> TMap
t) controller
controller
case Either (IO ResponseReceived) ControllerContext
contextOrResponse of
Left IO ResponseReceived
response -> IO ResponseReceived
response
Right ControllerContext
context -> do
let ?modelContext = ApplicationContext -> ModelContext
ApplicationContext.modelContext ?applicationContext::ApplicationContext
?applicationContext
let ?requestContext = ?context::RequestContext
?context
let ?context = ControllerContext
context
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 :: (?context::ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded ModelContext
modelContext = do
Maybe RowLevelSecurityContext
rowLevelSecurityContext <- forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext
case Maybe RowLevelSecurityContext
rowLevelSecurityContext of
Just RowLevelSecurityContext
context -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext { $sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
rowLevelSecurity = forall a. a -> Maybe a
Just RowLevelSecurityContext
context }
Maybe RowLevelSecurityContext
Nothing -> 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 -> IO ResponseReceived
startWebSocketApp :: forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
IO ResponseReceived -> IO ResponseReceived
startWebSocketApp IO ResponseReceived
onHTTP = do
let ?modelContext = ApplicationContext -> ModelContext
ApplicationContext.modelContext ?applicationContext::ApplicationContext
?applicationContext
let ?requestContext = ?context::RequestContext
?context
let respond :: Response -> IO ResponseReceived
respond = ?context::RequestContext
?context forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "respond" a => a
#respond
let request :: Request
request = ?context::RequestContext
?context forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "request" a => a
#request
let handleConnection :: PendingConnection -> IO ()
handleConnection PendingConnection
pendingConnection = do
Connection
connection <- PendingConnection -> IO Connection
WebSockets.acceptRequest PendingConnection
pendingConnection
ControllerContext
controllerContext <- (?requestContext::RequestContext) => IO ControllerContext
Context.newControllerContext
let ?context = ControllerContext
controllerContext
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext ?application::application
?application
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
initContext @application) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException
exception :: SomeException) -> forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Unexpected exception in initContext, " forall a. Semigroup a => a -> a -> a
<> 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
Request
request
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WebSockets.websocketsApp ConnectionOptions
WebSockets.defaultConnectionOptions PendingConnection -> IO ()
handleConnection
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) => IO ResponseReceived
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
IO ResponseReceived
startWebSocketAppAndFailOnHTTP = forall webSocketApp application.
(?applicationContext::ApplicationContext, ?context::RequestContext,
InitControllerContext application, ?application::application,
Typeable application, WSApp webSocketApp) =>
IO ResponseReceived -> IO ResponseReceived
startWebSocketApp @webSocketApp @application (Response -> IO ResponseReceived
respond 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
?context forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "respond" a => a
#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
forall controller.
(Controller controller, ?context::ControllerContext,
?modelContext::ModelContext, ?theAction::controller) =>
IO ()
beforeAction @action
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 =
?context::ControllerContext
?context
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestBody" a => a
#requestBody
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
RequestContext.JSONBody { ByteString
$sel:rawPayload:FormBody :: RequestBody -> ByteString
rawPayload :: ByteString
rawPayload } -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
rawPayload
RequestBody
_ -> Request -> IO ByteString
Network.Wai.lazyRequestBody (?context::ControllerContext) => Request
request
getRequestPath :: (?context :: ControllerContext) => ByteString
getRequestPath :: (?context::ControllerContext) => ByteString
getRequestPath = Request -> ByteString
Network.Wai.rawPathInfo (?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPath #-}
getRequestPathAndQuery :: (?context :: ControllerContext) => ByteString
getRequestPathAndQuery :: (?context::ControllerContext) => ByteString
getRequestPathAndQuery = Request -> ByteString
Network.Wai.rawPathInfo (?context::ControllerContext) => Request
request forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Network.Wai.rawQueryString (?context::ControllerContext) => Request
request
{-# INLINABLE getRequestPathAndQuery #-}
getHeader :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
ByteString
name = forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup (forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) (Request -> RequestHeaders
Network.Wai.requestHeaders (?context::ControllerContext) => Request
request)
{-# INLINABLE getHeader #-}
setHeader :: (?context :: ControllerContext) => Header -> IO ()
Header
header = do
Maybe RequestHeaders
maybeHeaders <- forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext @[Header]
let headers :: RequestHeaders
headers = forall a. a -> Maybe a -> a
fromMaybe [] Maybe RequestHeaders
maybeHeaders
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
Context.putContext (Header
header forall a. a -> [a] -> [a]
: RequestHeaders
headers)
{-# INLINABLE setHeader #-}
addResponseHeaders :: [Header] -> Response -> Response
RequestHeaders
headers = (RequestHeaders -> RequestHeaders) -> Response -> Response
Network.Wai.mapResponseHeaders (\RequestHeaders
hs -> RequestHeaders
headers forall a. Semigroup a => a -> a -> a
<> RequestHeaders
hs)
{-# INLINABLE addResponseHeaders #-}
addResponseHeadersFromContext :: (?context :: ControllerContext) => Response -> IO Response
Response
response = do
Maybe RequestHeaders
maybeHeaders <- forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
Context.maybeFromContext @[Header]
let headers :: RequestHeaders
headers = forall a. a -> Maybe a -> a
fromMaybe [] Maybe RequestHeaders
maybeHeaders
let responseWithHeaders :: Response
responseWithHeaders = RequestHeaders -> Response -> Response
addResponseHeaders RequestHeaders
headers Response
response
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
responseWithHeaders
{-# INLINABLE addResponseHeadersFromContext #-}
request :: (?context :: ControllerContext) => Network.Wai.Request
request :: (?context::ControllerContext) => Request
request = (?context::ControllerContext) => RequestContext
requestContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "request" a => a
#request
{-# INLINE request #-}
{-# INLINE getFiles #-}
getFiles :: (?context :: ControllerContext) => [File Data.ByteString.Lazy.ByteString]
getFiles :: (?context::ControllerContext) => [File ByteString]
getFiles = (?context::ControllerContext) => RequestContext
requestContext
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestBody" a => a
#requestBody
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 :: (?context::ControllerContext) => RequestContext
requestContext = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext ?context::ControllerContext
?context
{-# INLINE requestContext #-}
requestBodyJSON :: (?context :: ControllerContext) => Aeson.Value
requestBodyJSON :: (?context::ControllerContext) => Value
requestBodyJSON =
?context::ControllerContext
?context
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestBody" a => a
#requestBody
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
RequestContext.JSONBody { $sel:jsonPayload:FormBody :: RequestBody -> Maybe Value
jsonPayload = Just Value
value } -> Value
value
RequestBody
_ -> 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 RequestHeaders)
contentType = forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup 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 = forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
rawPayload
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext.JSONBody { Maybe Value
jsonPayload :: Maybe Value
$sel:jsonPayload:FormBody :: Maybe Value
jsonPayload, ByteString
rawPayload :: ByteString
$sel:rawPayload:FormBody :: ByteString
rawPayload }
Maybe (MapValue RequestHeaders)
_ -> do
([Param]
params, [File ByteString]
files) <- forall y.
ParseRequestBodyOptions
-> BackEnd y -> Request -> IO ([Param], [File y])
WaiParse.parseRequestBodyEx (FrameworkConfig
frameworkConfig forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "parseRequestBodyOptions" a => a
#parseRequestBodyOptions) forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
WaiParse.lbsBackEnd Request
request
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestContext.FormBody { [Param]
[File ByteString]
$sel:params:FormBody :: [Param]
files :: [File ByteString]
params :: [Param]
$sel:files:FormBody :: [File ByteString]
.. }
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: (?context::ControllerContext) => Response -> IO ()
respondAndExit Response
response = do
Response
responseWithHeaders <- (?context::ControllerContext) => Response -> IO Response
addResponseHeadersFromContext Response
response
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 :: forall configParameter context.
(?context::context, ConfigProvider context,
Typeable configParameter) =>
configParameter
getAppConfig = ?context::context
?context.frameworkConfig.appConfig
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @configParameter
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not find " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (forall {k} (t :: k). Proxy t
Typeable.Proxy @configParameter))) forall a. Semigroup a => a -> a -> a
<>[Char]
" in config"))
{-# INLINE getAppConfig #-}