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

module IHP.ControllerSupport
( Action'
, (|>)
, getRequestBody
, getRequestPath
, getRequestPathAndQuery
, getHeader
, request
, requestHeaders
, getFiles
, Controller (..)
, runAction
, ControllerContext
, InitControllerContext (..)
, runActionWithNewContext
, initActionContext
, respondWith
, respondAndExit
, earlyReturn
, jumpToAction
, requestBodyJSON
, startWebSocketApp
, startWebSocketAppAndFailOnHTTP
, setHeader
, getAppConfig
, Respond
, Request
, rlsContextVaultKey
, initRequestContext
, ResponseReceived
) where

import Prelude
import Data.IORef (IORef, modifyIORef', readIORef)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (fromMaybe)
import Control.Exception.Safe (SomeException, fromException, try, throwIO)
import qualified Control.Exception as Exception
import qualified IHP.ErrorController as ErrorController
import Data.Typeable (Typeable)
import IHP.HaskellSupport
import Network.Wai
import qualified Network.HTTP.Types as HTTP
import IHP.ModelSupport
import Network.Wai.Parse as WaiParse
import qualified Data.ByteString.Lazy
import Wai.Request.Params.Middleware (Respond)
import qualified Data.CaseInsensitive
import qualified Data.Typeable as Typeable
import IHP.FrameworkConfig.Types (FrameworkConfig (..), ConfigProvider)
import IHP.Controller.Response
import IHP.RequestVault () -- for HasField "frameworkConfig"/"logger"/"pgListener" on Request
import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware)
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 Network.Wai.Internal as WaiInternal
import qualified IHP.WebSocket as WebSockets
import qualified Data.TMap as TypeMap
import IHP.RequestVault.ModelContext
import IHP.ActionType (setActionType, actionTypeVaultKey, ActionType(..))
import IHP.RequestVault.Helper (lookupRequestVault)
import qualified IHP.Environment as Environment
import qualified Data.Vault.Lazy as Vault
import qualified Data.Text as Text
import System.IO.Unsafe (unsafePerformIO)

type Action' = IO ResponseReceived

-- | The WAI 'Request' threaded through controllers and views as the
-- @?context@ implicit parameter. All request-scoped state lives in
-- @request.vault@ (see 'IHP.RequestVault'). The type alias is preserved
-- for source compatibility with existing @?context :: ControllerContext@
-- type signatures.
type ControllerContext = Request

class (Show controller, Eq controller) => Controller controller where
    beforeAction :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => 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, ?respond :: Respond, ?request :: Request) => controller -> IO ResponseReceived

class InitControllerContext application where
    initContext :: (?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond, ?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, ?request::ControllerContext,
 ?respond::Respond, ?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, ?respond :: Respond) => controller -> IO ResponseReceived
runAction :: forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?respond::Respond) =>
controller -> IO ResponseReceived
runAction controller
controller = do
    let ?theAction = controller
?theAction::controller
controller
    let ?request = ?context::ControllerContext
?request::ControllerContext
ControllerContext
?context

    -- Exceptions are now caught by the error handler middleware
    authenticatedModelContext <- (?request::ControllerContext) => ModelContext -> IO ModelContext
ModelContext -> IO ModelContext
prepareRLSIfNeeded ?modelContext::ModelContext
ModelContext
?modelContext

    let ?modelContext = authenticatedModelContext
    beforeAction
    action controller

-- | Bind implicit parameters and run 'initContext' for a controller action.
-- Used by 'runActionWithNewContext' and WebSocket handlers.
{-# INLINE initActionContext #-}
initActionContext
    :: forall application controller
     . ( Controller controller
       , ?request :: Request
       , ?respond :: Respond
       , InitControllerContext application
       , ?application :: application
       , Typeable application
       , Typeable controller
       )
    => controller -> IO ControllerContext
initActionContext :: forall application controller.
(Controller controller, ?request::ControllerContext,
 ?respond::Respond, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ControllerContext
initActionContext controller
controller = do
    let ?modelContext = ?request::ControllerContext
ControllerContext
?request.modelContext
    let ?context = ?context::ControllerContext
?request::ControllerContext
ControllerContext
?request
    IO () -> IO ()
wrapInitContextException (forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?request::ControllerContext, ?respond::Respond,
 ?context::ControllerContext) =>
IO ()
forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
 ?request::ControllerContext, ?respond::Respond,
 ?context::ControllerContext) =>
IO ()
initContext @application)
    ControllerContext -> IO ControllerContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ?context::ControllerContext
ControllerContext
?context

-- | Bind implicit parameters from a raw WAI request, insert the action type
-- into the vault, and run 'initContext'. Specialized once per application type.
-- NOINLINE ensures GHC compiles one copy shared across all controllers.
--
-- Exceptions from 'initContext' (including 'EarlyReturnException') propagate
-- to the caller, which is expected to catch them.
{-# NOINLINE initRequestContext #-}
initRequestContext
    :: forall application
     . ( InitControllerContext application
       , ?application :: application
       , Typeable application
       )
    => Typeable.TypeRep -> Request -> Respond
    -> IO ControllerContext
initRequestContext :: forall application.
(InitControllerContext application, ?application::application,
 Typeable application) =>
TypeRep -> ControllerContext -> Respond -> IO ControllerContext
initRequestContext TypeRep
controllerTypeRep ControllerContext
waiRequest Respond
waiRespond = do
    let !request' :: ControllerContext
request' = ControllerContext
waiRequest { vault = Vault.insert actionTypeVaultKey (ActionType controllerTypeRep) waiRequest.vault }
    let ?request = ?request::ControllerContext
ControllerContext
request'
    let ?respond = ?respond::Respond
Respond
waiRespond
    let ?modelContext = ControllerContext
request'.modelContext
    let ?context = ?context::ControllerContext
?request::ControllerContext
ControllerContext
?request
    IO () -> IO ()
wrapInitContextException (forall application.
(InitControllerContext application, ?modelContext::ModelContext,
 ?request::ControllerContext, ?respond::Respond,
 ?context::ControllerContext) =>
IO ()
forall {k} (application :: k).
(InitControllerContext application, ?modelContext::ModelContext,
 ?request::ControllerContext, ?respond::Respond,
 ?context::ControllerContext) =>
IO ()
initContext @application)
    ControllerContext -> IO ControllerContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ?context::ControllerContext
ControllerContext
?context

-- | Wraps non-EarlyReturn exceptions from initContext in InitContextException
-- so the error handler middleware can show "while calling initContext".
wrapInitContextException :: IO () -> IO ()
wrapInitContextException :: IO () -> IO ()
wrapInitContextException IO ()
action =
    IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(SomeException
e :: SomeException) ->
        case SomeException -> Maybe EarlyReturnException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (EarlyReturnException ResponseReceived
_) -> SomeException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO SomeException
e  -- pass through early returns
            Maybe EarlyReturnException
Nothing -> InitContextException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (SomeException -> InitContextException
ErrorController.InitContextException SomeException
e)

{-# INLINE runActionWithNewContext #-}
runActionWithNewContext :: forall application controller. (Controller controller, ?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, Typeable controller) => controller -> IO ResponseReceived
runActionWithNewContext :: forall application controller.
(Controller controller, ?request::ControllerContext,
 ?respond::Respond, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ResponseReceived
runActionWithNewContext controller
controller =
    Middleware
earlyReturnMiddleware (\ControllerContext
request Respond
respond -> do
        let ?request = controller -> ControllerContext -> ControllerContext
forall controller.
Typeable controller =>
controller -> ControllerContext -> ControllerContext
setActionType controller
controller ControllerContext
request
        let ?respond = ?respond::Respond
Respond
respond
        context <- controller -> IO ControllerContext
forall application controller.
(Controller controller, ?request::ControllerContext,
 ?respond::Respond, InitControllerContext application,
 ?application::application, Typeable application,
 Typeable controller) =>
controller -> IO ControllerContext
initActionContext controller
controller
        let ?modelContext = requestModelContext ?request
        let ?context = context
        runAction controller
        ) ?request::ControllerContext
ControllerContext
?request ?respond::Respond
Respond
?respond

-- | 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 :: (?request :: Request) => ModelContext -> IO ModelContext
prepareRLSIfNeeded :: (?request::ControllerContext) => ModelContext -> IO ModelContext
prepareRLSIfNeeded ModelContext
modelContext = do
    rowLevelSecurityContext <- IORef (Maybe RowLevelSecurityContext)
-> IO (Maybe RowLevelSecurityContext)
forall a. IORef a -> IO a
readIORef (Key (IORef (Maybe RowLevelSecurityContext))
-> ControllerContext -> IORef (Maybe RowLevelSecurityContext)
forall value.
Typeable value =>
Key value -> ControllerContext -> value
lookupRequestVault Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey ?request::ControllerContext
ControllerContext
?request)
    case 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 prepareRLSIfNeeded #-}

rlsContextVaultKey :: Vault.Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey :: Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey = IO (Key (IORef (Maybe RowLevelSecurityContext)))
-> Key (IORef (Maybe RowLevelSecurityContext))
forall a. IO a -> a
unsafePerformIO IO (Key (IORef (Maybe RowLevelSecurityContext)))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE rlsContextVaultKey #-}

{-# INLINE startWebSocketApp #-}
startWebSocketApp :: forall webSocketApp application. (?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => webSocketApp -> IO ResponseReceived -> Application
startWebSocketApp :: forall webSocketApp application.
(?request::ControllerContext, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp
-> IO ResponseReceived
-> ControllerContext
-> Respond
-> IO ResponseReceived
startWebSocketApp webSocketApp
initialState IO ResponseReceived
onHTTP ControllerContext
waiRequest Respond
waiRespond = do
    let ?modelContext = ControllerContext -> ModelContext
requestModelContext ?request::ControllerContext
ControllerContext
?request
    let ?request = ?request::ControllerContext
ControllerContext
waiRequest
    let ?respond = ?respond::Respond
Respond
waiRespond

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

            let ?context = ?request

            try (initContext @application) >>= \case
                Left (SomeException
exception :: SomeException) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected exception in initContext, " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
exception
                Right ()
context -> do
                    webSocketApp -> Connection -> IO ()
forall state.
(WSApp state, ?request::ControllerContext,
 ?modelContext::ModelContext) =>
state -> Connection -> IO ()
WebSockets.startWSApp webSocketApp
initialState Connection
connection

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

    -- On a successful handshake 'websocketsApp' returns a 'ResponseRaw'
    -- wrapping a streaming handler plus a fallback 'Response'. Warp runs the
    -- raw handler and the client correctly receives HTTP 101 Switching
    -- Protocols — but request-logger middlewares (e.g. IHP's Apache access
    -- log in Production) compute the logged status from the fallback's
    -- builder/stream form, and wai-websockets hard-codes that fallback to
    -- 'status500' with a "WebSockets are not supported by your WAI handler"
    -- body. The result is that every successful WebSocket upgrade gets
    -- logged as
    --
    --     GET /DataSyncController HTTP/1.1 500 -
    --
    -- even though nginx / the actual client sees 101.
    --
    -- 'Wai.mapResponseStatus' is explicitly a no-op on 'ResponseRaw' (see
    -- the @mapResponseStatus _ r\@(ResponseRaw _ _) = r@ case in wai), so we
    -- have to pattern-match the raw constructor from 'Network.Wai.Internal'
    -- and rebuild the fallback 'Response' ourselves. We use 'status200'
    -- instead of the semantically correct 'status101' because Warp's
    -- @hasBody@ check (@sc >= 200 && sc /= 204 && sc /= 304@) treats 1xx
    -- as bodyless — causing it to send only the fallback headers and skip
    -- the raw streaming handler entirely, which breaks the WebSocket
    -- handshake. The on-the-wire status remains 101 (sent by the raw
    -- handler); the rewritten fallback status only affects what
    -- request-logger middlewares observe.
    ControllerContext
waiRequest
        ControllerContext
-> (ControllerContext -> Maybe Response) -> Maybe Response
forall a b. a -> (a -> b) -> b
|> ConnectionOptions
-> (PendingConnection -> IO ())
-> ControllerContext
-> Maybe Response
WebSockets.websocketsApp ConnectionOptions
connectionOptions PendingConnection -> IO ()
handleConnection
        Maybe Response
-> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. a -> (a -> b) -> b
|> \case
            Just Response
response -> Respond
waiRespond (Response -> Response
rewriteWebSocketFallbackStatus Response
response)
            Maybe Response
Nothing -> IO ResponseReceived
onHTTP
{-# INLINE startWebSocketAppAndFailOnHTTP #-}
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application. (?request :: Request, ?respond :: Respond, InitControllerContext application, ?application :: application, Typeable application, WebSockets.WSApp webSocketApp) => webSocketApp -> Application
startWebSocketAppAndFailOnHTTP :: forall webSocketApp application.
(?request::ControllerContext, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp -> ControllerContext -> Respond -> IO ResponseReceived
startWebSocketAppAndFailOnHTTP webSocketApp
initialState = forall webSocketApp application.
(?request::ControllerContext, ?respond::Respond,
 InitControllerContext application, ?application::application,
 Typeable application, WSApp webSocketApp) =>
webSocketApp
-> IO ResponseReceived
-> ControllerContext
-> Respond
-> IO ResponseReceived
startWebSocketApp @webSocketApp @application webSocketApp
initialState (?respond::Respond
Respond
?respond Respond -> Respond
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")

-- | Rewrite the 'ResponseRaw' fallback produced by 'Network.Wai.Handler.WebSockets.websocketsApp'
-- so the fallback 'Response' reports @200 OK@ instead of the hard-coded @status500@
-- from wai-websockets. We cannot use @status101@ here because Warp's @hasBody@
-- predicate returns @False@ for all 1xx statuses, causing Warp to skip the raw
-- streaming handler and serve the fallback headers directly — which breaks the
-- WebSocket handshake (see #2628). @status200@ is the closest non-alarming status
-- that Warp's @hasBody@ accepts. See the comment in 'startWebSocketApp' for the
-- full rationale.
rewriteWebSocketFallbackStatus :: Response -> Response
rewriteWebSocketFallbackStatus :: Response -> Response
rewriteWebSocketFallbackStatus (WaiInternal.ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
handler Response
fallback) =
    (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
WaiInternal.ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
handler ((Status -> Status) -> Response -> Response
mapResponseStatus (Status -> Status -> Status
forall a b. a -> b -> a
const Status
HTTP.status200) Response
fallback)
rewriteWebSocketFallbackStatus Response
other = Response
other


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

getRequestBody :: (?request :: Request) => IO LBS.ByteString
getRequestBody :: (?request::ControllerContext) => IO ByteString
getRequestBody =
    ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ?request::ControllerContext
ControllerContext
?request.parsedBody.rawPayload

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

-- | Returns the request path and the query params, e.g. @/ShowUser?userId=9bd6b37b-2e53-40a4-bb7b-fdba67d6af42@
getRequestPathAndQuery :: (?request :: Request) => ByteString
getRequestPathAndQuery :: (?request::ControllerContext) => ByteString
getRequestPathAndQuery = ?request::ControllerContext
ControllerContext
?request.rawPathInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ?request::ControllerContext
ControllerContext
?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 :: (?request :: Request) => ByteString -> Maybe ByteString
getHeader :: (?request::ControllerContext) => ByteString -> Maybe ByteString
getHeader ByteString
name = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
Data.CaseInsensitive.mk ByteString
name) ?request::ControllerContext
ControllerContext
?request.requestHeaders
{-# INLINABLE getHeader #-}

-- | Set a header value for a given header name.
--
-- >>> setHeader ("Content-Language", "en")
--
setHeader :: (?request :: Request) => Header -> IO ()
setHeader :: (?request::ControllerContext) => Header -> IO ()
setHeader Header
header = do
    let headersRef :: IORef ResponseHeaders
headersRef = Key (IORef ResponseHeaders)
-> ControllerContext -> IORef ResponseHeaders
forall value.
Typeable value =>
Key value -> ControllerContext -> value
lookupRequestVault Key (IORef ResponseHeaders)
responseHeadersVaultKey ?request::ControllerContext
ControllerContext
?request
    IORef ResponseHeaders
-> (ResponseHeaders -> ResponseHeaders) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ResponseHeaders
headersRef (Header
header Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:)
{-# 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 :: (?request :: Request) => Request
request :: (?request::ControllerContext) => ControllerContext
request = ?request::ControllerContext
ControllerContext
?request
{-# INLINE request #-}

{-# INLINE getFiles #-}
getFiles :: (?request :: Request) => [File Data.ByteString.Lazy.ByteString]
getFiles :: (?request::ControllerContext) => [File ByteString]
getFiles =
    case ?request::ControllerContext
ControllerContext
?request.parsedBody of
        FormBody { [File ByteString]
files :: [File ByteString]
files :: RequestBody -> [File ByteString]
files } -> [File ByteString]
files
        RequestBody
_ -> []

requestBodyJSON :: (?request :: Request, ?respond :: Respond) => IO Aeson.Value
requestBodyJSON :: (?request::ControllerContext, ?respond::Respond) => IO Value
requestBodyJSON =
    case ?request::ControllerContext
ControllerContext
?request.parsedBody of
        JSONBody { jsonPayload :: RequestBody -> Maybe Value
jsonPayload = Just Value
value } -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
        JSONBody { jsonPayload :: RequestBody -> Maybe Value
jsonPayload = Maybe Value
Nothing, ByteString
rawPayload :: ByteString
rawPayload :: RequestBody -> ByteString
rawPayload } -> do
            let isDev :: Bool
isDev = ?request::ControllerContext
ControllerContext
?request.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            let errorMessage :: Text
errorMessage = Text
"Expected JSON body, but could not decode the request body"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if ByteString -> Bool
LBS.null ByteString
rawPayload
                        then Text
". The request body is empty."
                        else if Bool
isDev
                            then Text
". The raw request body was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall {a}. Show a => a -> Text
truncatePayload ByteString
rawPayload
                            else Text
".")
            Response -> IO Value
forall a.
(?request::ControllerContext, ?respond::Respond) =>
Response -> IO a
respondAndExit (Response -> IO Value) -> Response -> IO Value
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
HTTP.status400 [(HeaderName
hContentType, ByteString
"application/json")] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
                Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object [(Key
"error", Text -> Value
Aeson.String Text
errorMessage)]
            where
                truncatePayload :: a -> Text
truncatePayload a
payload =
                    let shown :: String
shown = a -> String
forall a. Show a => a -> String
show a
payload
                        maxLen :: Int
maxLen = Int
200
                    in if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
shown Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLen
                        then String -> Text
Text.pack (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
maxLen String
shown) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"... (truncated)"
                        else String -> Text
Text.pack String
shown
        FormBody {} ->
            Response -> IO Value
forall a.
(?request::ControllerContext, ?respond::Respond) =>
Response -> IO a
respondAndExit (Response -> IO Value) -> Response -> IO Value
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
HTTP.status400 [(HeaderName
hContentType, ByteString
"application/json")] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
                Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object [(Key
"error", Text -> Value
Aeson.String Text
"Expected JSON body, but the request has a form content type. Make sure to set 'Content-Type: application/json' in the request header.")]

-- | 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 a b. a -> (a -> b) -> b
|> forall a. Typeable a => TMap -> Maybe a
TypeMap.lookup @configParameter
        Maybe configParameter
-> (Maybe configParameter -> configParameter) -> configParameter
forall a b. a -> (a -> b) -> b
|> configParameter -> Maybe configParameter -> configParameter
forall a. a -> Maybe a -> a
fromMaybe (String -> configParameter
forall a. HasCallStack => String -> a
error (String
"Could not find " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> String
forall a. Show a => a -> String
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))) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
" in config"))
{-# INLINE getAppConfig #-}