{-# LANGUAGE BangPatterns #-}
module IHP.Controller.Render where
import ClassyPrelude
import Network.Wai (responseLBS, responseBuilder, responseFile)
import qualified 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 Data.List as List

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 qualified IHP.FrameworkConfig as FrameworkConfig
import qualified Data.ByteString.Builder as ByteString
import IHP.FlashMessages.ControllerFunctions (initFlashMessages)

renderPlain :: (?context :: ControllerContext) => LByteString -> IO ()
renderPlain :: (?context::ControllerContext) => LByteString -> IO ()
renderPlain LByteString
text = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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
{-# INLINABLE renderPlain #-}

respondHtml :: (?context :: ControllerContext) => Html -> IO ()
respondHtml :: (?context::ControllerContext) => Html -> IO ()
respondHtml Html
html =
        -- The seq is required to force evaluation of `maybeEvaluatedBuilder` before returning the IO action. See below for details
        Builder
maybeEvaluatedBuilder Builder -> IO () -> IO ()
forall a b. a -> b -> b
`seq` ((?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (Response -> IO ()) -> Response -> IO ()
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
maybeEvaluatedBuilder)
    where
        builder :: Builder
builder = Html -> Builder
Blaze.renderHtmlBuilder Html
html
        builderAsByteString :: LByteString
builderAsByteString = Builder -> LByteString
ByteString.toLazyByteString Builder
builder

        -- In dev mode we force the full evaluation of the blaze html expressions to catch
        -- any runtime errors with the IHP error middleware. Without this full evaluation
        -- 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.
        --
        -- In production we only evaluate lazy as it improves performance and these kind of
        -- errors are unlikely to happen in production
        --
        -- See https://github.com/digitallyinduced/ihp/issues/1028
        maybeEvaluatedBuilder :: Builder
maybeEvaluatedBuilder = if Bool
forall context. (?context::context, ConfigProvider context) => Bool
FrameworkConfig.isDevelopment
            then (LByteString -> Int64
Data.ByteString.Lazy.length LByteString
builderAsByteString) Int64 -> Builder -> Builder
forall a b. a -> b -> b
`seq` (LByteString -> Builder
ByteString.lazyByteString LByteString
builderAsByteString)
            else Builder
builder
{-# INLINABLE respondHtml #-}

respondSvg :: (?context :: ControllerContext) => Html -> IO ()
respondSvg :: (?context::ControllerContext) => Html -> IO ()
respondSvg Html
html = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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) => view -> IO Html
renderHtml :: forall view.
(View view, ?context::ControllerContext) =>
view -> IO Html
renderHtml !view
view = do
    let ?view = view
?view::view
view
    IO ()
(?context::ControllerContext) => IO ()
initFlashMessages
    view -> IO ()
forall theView.
(View theView, ?context::ControllerContext) =>
theView -> IO ()
ViewSupport.beforeRender view
view
    ControllerContext
frozenContext <- ControllerContext -> IO ControllerContext
Context.freeze ?context::ControllerContext
ControllerContext
?context

    let ?context = ?context::ControllerContext
ControllerContext
frozenContext
    let layout :: Layout
layout = case forall value.
(?context::ControllerContext, Typeable value) =>
Maybe value
Context.maybeFromFrozenContext @ViewLayout of
            Just (ViewLayout (?context::ControllerContext) => Layout
layout) -> (?context::ControllerContext) => Layout
Layout
layout
            Maybe ViewLayout
Nothing -> Layout
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

    let boundHtml :: Html
boundHtml = let ?context = ?context::ControllerContext
ControllerContext
frozenContext in Layout
layout (view -> Html
forall theView.
(View theView, ?context::ControllerContext, ?view::theView) =>
theView -> Html
ViewSupport.html view
?view::view
?view)
    Html -> IO Html
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html
boundHtml
{-# INLINABLE renderHtml #-}

renderFile :: (?context :: ControllerContext) => String -> ByteString -> IO ()
renderFile :: (?context::ControllerContext) => String -> ByteString -> IO ()
renderFile String
filePath ByteString
contentType = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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
{-# INLINABLE renderFile #-}

renderJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ()
renderJson :: forall json.
(?context::ControllerContext, ToJSON json) =>
json -> IO ()
renderJson json
json = Status -> json -> IO ()
forall json.
(?context::ControllerContext, ToJSON json) =>
Status -> json -> IO ()
renderJsonWithStatusCode Status
status200 json
json
{-# INLINABLE renderJson #-}

renderJsonWithStatusCode :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => Status -> json -> IO ()
renderJsonWithStatusCode :: forall json.
(?context::ControllerContext, ToJSON json) =>
Status -> json -> IO ()
renderJsonWithStatusCode Status
statusCode json
json = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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)
{-# INLINABLE renderJsonWithStatusCode #-}

renderXml :: (?context :: ControllerContext) => LByteString -> IO ()
renderXml :: (?context::ControllerContext) => LByteString -> IO ()
renderXml LByteString
xml = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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
{-# INLINABLE renderXml #-}

-- | Use 'setHeader' intead
renderJson' :: (?context :: ControllerContext) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ()
renderJson' :: forall json.
(?context::ControllerContext) =>
ResponseHeaders -> ToJSON json => json -> IO ()
renderJson' ResponseHeaders
additionalHeaders json
json = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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)
{-# INLINABLE 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
{-# INLINABLE renderPolymorphic #-}
renderPolymorphic :: (?context :: ControllerContext) => PolymorphicRender -> IO ()
renderPolymorphic :: (?context::ControllerContext) => PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender { Maybe (IO ())
$sel:html:PolymorphicRender :: PolymorphicRender -> Maybe (IO ())
html :: Maybe (IO ())
html, Maybe (IO ())
$sel:json:PolymorphicRender :: PolymorphicRender -> Maybe (IO ())
json :: Maybe (IO ())
json } = do
    let headers :: ResponseHeaders
headers = Request -> ResponseHeaders
Network.Wai.requestHeaders Request
(?context::ControllerContext) => Request
request
    let acceptHeader :: ByteString
acceptHeader = (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString)
-> Maybe (HeaderName, ByteString) -> (HeaderName, ByteString)
forall a. a -> Maybe a -> a
fromMaybe (HeaderName
hAccept, ByteString
"text/html") (((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(HeaderName
headerName, ByteString
_) -> HeaderName
headerName HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAccept) ResponseHeaders
headers)) :: ByteString
    let send406Error :: IO ()
send406Error = (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (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
acceptHeader)

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


{-# INLINABLE render #-}
render :: forall view. (ViewSupport.View view, ?context :: ControllerContext) => view -> IO ()
render :: forall theView.
(View theView, ?context::ControllerContext) =>
theView -> IO ()
render !view
view = do
    (?context::ControllerContext) => PolymorphicRender -> IO ()
PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender
            { $sel:html:PolymorphicRender :: Maybe (IO ())
html = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ (view -> IO Html
forall view.
(View view, ?context::ControllerContext) =>
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
>>= (?context::ControllerContext) => Html -> IO ()
Html -> IO ()
respondHtml
            , $sel:json:PolymorphicRender :: 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.
(?context::ControllerContext, ToJSON json) =>
json -> IO ()
renderJson (view -> Value
forall theView. View theView => theView -> Value
ViewSupport.json view
view)
            }