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


import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
import Text.Blaze.Html (Html)
import qualified IHP.Controller.Context as Context
import IHP.Controller.Layout
import IHP.FlashMessages (consumeFlashMessagesMiddleware)

renderPlain :: (?request :: Request) => LByteString -> IO ()
renderPlain :: (?request::Request) => LByteString -> IO ()
renderPlain LByteString
text = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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) => Html -> IO ()
respondHtml :: (?request::Request) => Html -> IO ()
respondHtml Html
html = do
        let !bs :: LByteString
bs = Html -> LByteString
Blaze.renderHtml Html
html
        -- We force the full evaluation of the blaze html to catch any runtime errors
        -- with the IHP error middleware. Without this, certain thunks might only cause
        -- an error when warp is building the response string. But then it's already too
        -- late to catch the exception and the user will only get the default warp error
        -- message instead of our nice IHP error message design.
        _ <- Int64 -> IO Int64
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (LByteString -> Int64
Data.ByteString.Lazy.length LByteString
bs)
        respondAndExitWithHeaders $ responseLBS status200 [(hContentType, "text/html; charset=utf-8"), (hConnection, "keep-alive")] bs
{-# INLINE respondHtml #-}

respondSvg :: (?request :: Request) => Html -> IO ()
respondSvg :: (?request::Request) => Html -> IO ()
respondSvg Html
html = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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")] (Html -> Builder
Blaze.renderHtmlBuilder Html
html)
{-# INLINABLE respondSvg #-}

renderHtml :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request) => view -> IO Html
renderHtml :: forall view.
(View view, ?context::ControllerContext, ?request::Request) =>
view -> IO Html
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 -> Html
forall theView.
(View theView, ?context::ControllerContext, ?view::theView,
 ?request::Request) =>
theView -> Html
ViewSupport.html view
?view::view
?view)
    pure boundHtml
{-# INLINE renderHtml #-}

renderFile :: (?request :: Request) => String -> ByteString -> IO ()
renderFile :: (?request::Request) => String -> ByteString -> IO ()
renderFile String
filePath ByteString
contentType = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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) => Data.Aeson.ToJSON json => json -> IO ()
renderJson :: forall json. (?request::Request, ToJSON json) => json -> IO ()
renderJson json
json = Status -> json -> IO ()
forall json.
(?request::Request, ToJSON json) =>
Status -> json -> IO ()
renderJsonWithStatusCode Status
status200 json
json
{-# INLINE renderJson #-}

renderJsonWithStatusCode :: (?request :: Request) => Data.Aeson.ToJSON json => Status -> json -> IO ()
renderJsonWithStatusCode :: forall json.
(?request::Request, ToJSON json) =>
Status -> json -> IO ()
renderJsonWithStatusCode Status
statusCode json
json = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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) => LByteString -> IO ()
renderXml :: (?request::Request) => LByteString -> IO ()
renderXml LByteString
xml = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ()
renderJson' :: forall json.
(?request::Request) =>
ResponseHeaders -> ToJSON json => json -> IO ()
renderJson' ResponseHeaders
additionalHeaders json
json = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
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' #-}

data PolymorphicRender
    = PolymorphicRender
        { PolymorphicRender -> Maybe (IO ())
html :: Maybe (IO ())
        , PolymorphicRender -> Maybe (IO ())
json :: Maybe (IO ())
        }

-- | Can be used to render different responses for html, json, etc. requests based on `Accept` header
-- Example:
--
-- > show :: Action
-- > show = do
-- >     renderPolymorphic polymorphicRender {
-- >         html = renderHtml [hsx|<div>Hello World</div>|]
-- >         json = renderJson True
-- >     }
--
-- This will render @Hello World@ for normal browser requests and @true@ when requested via an ajax request
{-# INLINE renderPolymorphic #-}
renderPolymorphic :: (?context :: ControllerContext, ?request :: Request) => PolymorphicRender -> IO ()
renderPolymorphic :: (?context::ControllerContext, ?request::Request) =>
PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender { Maybe (IO ())
html :: PolymorphicRender -> Maybe (IO ())
html :: Maybe (IO ())
html, Maybe (IO ())
json :: PolymorphicRender -> Maybe (IO ())
json :: Maybe (IO ())
json } = do
    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
request.requestHeaders)
    case Maybe ByteString
acceptHeader of
        -- Fast path: no Accept header or starts with text/html — dispatch directly
        Maybe ByteString
Nothing | Just IO ()
handler <- Maybe (IO ())
html -> IO ()
handler
        Just ByteString
h | ByteString
"text/html" ByteString -> ByteString -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` ByteString
h, Just IO ()
handler <- Maybe (IO ())
html -> IO ()
handler
        Maybe ByteString
_ -> do
            let accept :: ByteString
accept = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"text/html" Maybe ByteString
acceptHeader
            let send406Error :: IO ()
send406Error = (?request::Request) => Response -> IO ()
Response -> IO ()
respondAndExitWithHeaders (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
responseLBS Status
status406 [] LByteString
"Could not find any acceptable response format"
            let formats :: Element [[(MediaType, IO ())]]
formats = [[(MediaType, IO ())]] -> Element [[(MediaType, IO ())]]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
mono -> Element mono
concat [
                        case Maybe (IO ())
html of
                            Just IO ()
handler -> [(MediaType
"text/html", IO ()
handler)]
                            Maybe (IO ())
Nothing -> [(MediaType, IO ())]
forall a. Monoid a => a
mempty
                         ,
                        case Maybe (IO ())
json of
                            Just IO ()
handler -> [(MediaType
"application/json", IO ()
handler)]
                            Maybe (IO ())
Nothing -> [(MediaType, IO ())]
forall a. Monoid a => a
mempty
                    ]
            IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe IO ()
send406Error ([(MediaType, IO ())] -> ByteString -> Maybe (IO ())
forall b. [(MediaType, b)] -> ByteString -> Maybe b
Accept.mapAcceptMedia [(MediaType, IO ())]
Element [[(MediaType, IO ())]]
formats ByteString
accept)

polymorphicRender :: PolymorphicRender
polymorphicRender :: PolymorphicRender
polymorphicRender = Maybe (IO ()) -> Maybe (IO ()) -> PolymorphicRender
PolymorphicRender Maybe (IO ())
forall a. Maybe a
Nothing Maybe (IO ())
forall a. Maybe a
Nothing


{-# INLINE render #-}
render :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => view -> IO ()
render :: forall view.
(View view, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
view -> IO ()
render !view
view = do
    let !currentRequest :: Request
currentRequest = ?request::Request
Request
?request
    (?context::ControllerContext, ?request::Request) =>
PolymorphicRender -> IO ()
PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender
            { html :: Maybe (IO ())
html = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just do
                    let next :: Request -> Respond -> IO ResponseReceived
next Request
request Respond
respond = do
                            let ?request = ?request::Request
Request
request in ((view -> IO Html
forall view.
(View view, ?context::ControllerContext, ?request::Request) =>
view -> IO Html
renderHtml view
view) IO Html -> (Html -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (?request::Request) => Html -> IO ()
Html -> IO ()
respondHtml)
                            String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error String
"unreachable"
                    _ <- Middleware
consumeFlashMessagesMiddleware Request -> Respond -> IO ResponseReceived
next Request
currentRequest ?respond::Respond
Respond
?respond
                    pure ()
            , json :: Maybe (IO ())
json = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Value -> IO ()
forall json. (?request::Request, ToJSON json) => json -> IO ()
renderJson (view -> Value
forall theView. View theView => theView -> Value
ViewSupport.json view
view)
            }