{-# LANGUAGE BangPatterns #-}
module IHP.Controller.Render where
import ClassyPrelude
import Network.Wai (responseLBS, responseBuilder, responseFile)
import Network.HTTP.Types (Status, status200, status406)
import Network.HTTP.Types.Header
import qualified IHP.ViewSupport as ViewSupport
import qualified Data.Aeson
import IHP.ControllerSupport
import qualified Network.HTTP.Media as Accept


import IHP.HSX.Markup (Markup, MarkupM(..))
import qualified IHP.Controller.Context as Context
import IHP.Controller.Layout
import IHP.FlashMessages (consumeFlashMessagesMiddleware)

renderPlain :: (?request :: Request, ?respond :: Respond) => LByteString -> IO ResponseReceived
renderPlain :: (?request::Request, ?respond::Respond) =>
LByteString -> IO ResponseReceived
renderPlain LByteString
text = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status200 [(HeaderName
hContentType, ByteString
"text/plain")] LByteString
text
{-# INLINE renderPlain #-}

respondHtml :: (?request :: Request, ?respond :: Respond) => Markup -> IO ResponseReceived
respondHtml :: (?request::Request, ?respond::Respond) =>
Markup -> IO ResponseReceived
respondHtml (Markup Builder
builder) = do
        -- Pass the Builder directly to WAI, avoiding the intermediate lazy
        -- ByteString allocation that responseLBS would require.
        (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status200 [(HeaderName
hContentType, ByteString
"text/html; charset=utf-8"), (HeaderName
hConnection, ByteString
"keep-alive")] Builder
builder
{-# INLINE respondHtml #-}

respondSvg :: (?request :: Request, ?respond :: Respond) => Markup -> IO ResponseReceived
respondSvg :: (?request::Request, ?respond::Respond) =>
Markup -> IO ResponseReceived
respondSvg (Markup Builder
builder) =
        (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status200 [(HeaderName
hContentType, ByteString
"image/svg+xml"), (HeaderName
hConnection, ByteString
"keep-alive")] Builder
builder
{-# INLINABLE respondSvg #-}

renderHtml :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request) => view -> IO Markup
renderHtml :: forall view.
(View view, ?context::ControllerContext, ?request::Request) =>
view -> IO Markup
renderHtml !view
view = do
    let ?view = view
?view::view
view
    view -> IO ()
forall theView.
(View theView, ?context::ControllerContext, ?request::Request) =>
theView -> IO ()
ViewSupport.beforeRender view
view
    frozenContext <- ControllerContext -> IO ControllerContext
Context.freeze ?context::ControllerContext
ControllerContext
?context

    let ?context = frozenContext
    (ViewLayout layout) <- getLayout

    let boundHtml = let ?context = ?context::ControllerContext
ControllerContext
frozenContext; in (?context::ControllerContext, ?request::Request) => Layout
Layout
layout (view -> Markup
forall theView.
(View theView, ?context::ControllerContext, ?view::theView,
 ?request::Request) =>
theView -> Markup
ViewSupport.html view
?view::view
?view)
    pure boundHtml
{-# INLINE renderHtml #-}

renderFile :: (?request :: Request, ?respond :: Respond) => String -> ByteString -> IO ResponseReceived
renderFile :: (?request::Request, ?respond::Respond) =>
String -> ByteString -> IO ResponseReceived
renderFile String
filePath ByteString
contentType = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
status200 [(HeaderName
hContentType, ByteString
contentType)] String
filePath Maybe FilePart
forall a. Maybe a
Nothing
{-# INLINE renderFile #-}

renderJson :: (?request :: Request, ?respond :: Respond) => Data.Aeson.ToJSON json => json -> IO ResponseReceived
renderJson :: forall json.
(?request::Request, ?respond::Respond, ToJSON json) =>
json -> IO ResponseReceived
renderJson json
json = Status -> json -> IO ResponseReceived
forall json.
(?request::Request, ?respond::Respond, ToJSON json) =>
Status -> json -> IO ResponseReceived
renderJsonWithStatusCode Status
status200 json
json
{-# INLINE renderJson #-}

renderJsonWithStatusCode :: (?request :: Request, ?respond :: Respond) => Data.Aeson.ToJSON json => Status -> json -> IO ResponseReceived
renderJsonWithStatusCode :: forall json.
(?request::Request, ?respond::Respond, ToJSON json) =>
Status -> json -> IO ResponseReceived
renderJsonWithStatusCode Status
statusCode json
json = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
statusCode [(HeaderName
hContentType, ByteString
"application/json")] (json -> LByteString
forall a. ToJSON a => a -> LByteString
Data.Aeson.encode json
json)
{-# INLINE renderJsonWithStatusCode #-}

renderXml :: (?request :: Request, ?respond :: Respond) => LByteString -> IO ResponseReceived
renderXml :: (?request::Request, ?respond::Respond) =>
LByteString -> IO ResponseReceived
renderXml LByteString
xml = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status200 [(HeaderName
hContentType, ByteString
"application/xml")] LByteString
xml
{-# INLINE renderXml #-}

-- | Use 'setHeader' instead
renderJson' :: (?request :: Request, ?respond :: Respond) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ResponseReceived
renderJson' :: forall json.
(?request::Request, ?respond::Respond) =>
ResponseHeaders -> ToJSON json => json -> IO ResponseReceived
renderJson' ResponseHeaders
additionalHeaders json
json = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status200 ([(HeaderName
hContentType, ByteString
"application/json")] ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
additionalHeaders) (json -> LByteString
forall a. ToJSON a => a -> LByteString
Data.Aeson.encode json
json)
{-# INLINE renderJson' #-}

{-# INLINE render #-}
render :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived
render :: forall view.
(View view, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
view -> IO ResponseReceived
render !view
view = do
    let !currentRequest :: Request
currentRequest = ?request::Request
Request
?request
    Request -> view -> IO ResponseReceived
forall view.
(View view, ?context::ControllerContext, ?respond::Respond) =>
Request -> view -> IO ResponseReceived
renderHtmlView Request
currentRequest view
view

-- | Renders HTML or JSON based on the request's Accept header.
-- Requires both 'View' and 'JsonView' instances for the view type.
{-# INLINE renderHtmlOrJson #-}
renderHtmlOrJson :: forall view. (ViewSupport.View view, ViewSupport.JsonView view, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived
renderHtmlOrJson :: forall view.
(View view, JsonView view, ?context::ControllerContext,
 ?request::Request, ?respond::Respond) =>
view -> IO ResponseReceived
renderHtmlOrJson !view
view = do
    let !currentRequest :: Request
currentRequest = ?request::Request
Request
?request
    let acceptHeader :: Maybe (MapValue ResponseHeaders)
acceptHeader = ContainerKey ResponseHeaders
-> ResponseHeaders -> Maybe (MapValue ResponseHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup HeaderName
ContainerKey ResponseHeaders
hAccept (?request::Request
Request
?request.requestHeaders)
    case Maybe (MapValue ResponseHeaders)
acceptHeader of
        Maybe (MapValue ResponseHeaders)
Nothing -> Request -> view -> IO ResponseReceived
forall view.
(View view, ?context::ControllerContext, ?respond::Respond) =>
Request -> view -> IO ResponseReceived
renderHtmlView Request
currentRequest view
view
        Just MapValue ResponseHeaders
h | MapValue ResponseHeaders
"text/html" MapValue ResponseHeaders -> MapValue ResponseHeaders -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` MapValue ResponseHeaders
h -> Request -> view -> IO ResponseReceived
forall view.
(View view, ?context::ControllerContext, ?respond::Respond) =>
Request -> view -> IO ResponseReceived
renderHtmlView Request
currentRequest view
view
        Maybe (MapValue ResponseHeaders)
_ -> do
            let accept :: ByteString
accept = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"text/html" Maybe ByteString
Maybe (MapValue ResponseHeaders)
acceptHeader
            let send406Error :: IO ResponseReceived
send406Error = (?request::Request, ?respond::Respond) => Respond
Respond
respondWith Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status406 [] LByteString
"Could not find any acceptable response format"
            let formats :: [(MediaType, IO ResponseReceived)]
formats =
                    [ (MediaType
"text/html", Request -> view -> IO ResponseReceived
forall view.
(View view, ?context::ControllerContext, ?respond::Respond) =>
Request -> view -> IO ResponseReceived
renderHtmlView Request
currentRequest view
view)
                    , (MediaType
"application/json", Value -> IO ResponseReceived
forall json.
(?request::Request, ?respond::Respond, ToJSON json) =>
json -> IO ResponseReceived
renderJson (view -> Value
forall theView. JsonView theView => theView -> Value
ViewSupport.json view
view))
                    ]
            IO ResponseReceived
-> Maybe (IO ResponseReceived) -> IO ResponseReceived
forall a. a -> Maybe a -> a
fromMaybe IO ResponseReceived
send406Error ([(MediaType, IO ResponseReceived)]
-> ByteString -> Maybe (IO ResponseReceived)
forall b. [(MediaType, b)] -> ByteString -> Maybe b
Accept.mapAcceptMedia [(MediaType, IO ResponseReceived)]
formats ByteString
accept)

renderHtmlView :: (ViewSupport.View view, ?context :: ControllerContext, ?respond :: Respond) => Request -> view -> IO ResponseReceived
renderHtmlView :: forall view.
(View view, ?context::ControllerContext, ?respond::Respond) =>
Request -> view -> IO ResponseReceived
renderHtmlView Request
currentRequest view
view = do
    let next :: Request -> Respond -> IO ResponseReceived
next Request
request Respond
respond = do
            let ?request = ?request::Request
Request
request
            let ?respond = ?respond::Respond
Respond
respond
            (view -> IO Markup
forall view.
(View view, ?context::ControllerContext, ?request::Request) =>
view -> IO Markup
renderHtml view
view) IO Markup -> (Markup -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (?request::Request, ?respond::Respond) =>
Markup -> IO ResponseReceived
Markup -> IO ResponseReceived
respondHtml
    Middleware
consumeFlashMessagesMiddleware Request -> Respond -> IO ResponseReceived
next Request
currentRequest ?respond::Respond
Respond
?respond