{-# LANGUAGE BangPatterns #-}
module IHP.Controller.Render where
import ClassyPrelude
import IHP.HaskellSupport
import Data.String.Conversions (cs)
import Network.Wai (Response, Request, responseLBS, requestBody, queryString, responseBuilder, responseFile)
import qualified Network.Wai
import Network.HTTP.Types (status200, status302, status406)
import Network.HTTP.Types.Header
import IHP.ModelSupport
import qualified Network.Wai.Util
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 GHC.Records
import qualified IHP.Controller.Context as Context
import IHP.Controller.Layout

renderPlain :: (?context :: ControllerContext) => LByteString -> IO ()
renderPlain :: LByteString -> IO ()
renderPlain LByteString
text = 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 :: Html -> IO ()
respondHtml Html
html = 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")] (Html -> Builder
Blaze.renderHtmlBuilder Html
html)
{-# INLINABLE respondHtml #-}

respondSvg :: (?context :: ControllerContext) => Html -> IO ()
respondSvg :: Html -> IO ()
respondSvg Html
html = 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 viewContext view controller. (ViewSupport.View view, ?theAction :: controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => view -> IO Html
renderHtml :: view -> IO Html
renderHtml !view
view = do
    let ?view = view

    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 = frozenContext
    let layout :: Layout
layout = case (?context::ControllerContext, Typeable ViewLayout) =>
Maybe ViewLayout
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 k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
    
    let boundHtml :: Html
boundHtml = let ?context = 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 (f :: * -> *) a. Applicative f => a -> f a
pure Html
boundHtml
{-# INLINABLE renderHtml #-}

renderFile :: (?context :: ControllerContext, ?modelContext :: ModelContext) => String -> ByteString -> IO ()
renderFile :: String -> ByteString -> IO ()
renderFile String
filePath ByteString
contentType = 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 :: json -> IO ()
renderJson json
json = 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")] (json -> LByteString
forall a. ToJSON a => a -> LByteString
Data.Aeson.encode json
json)
{-# INLINABLE renderJson #-}

renderJson' :: (?context :: ControllerContext) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ()
renderJson' :: ResponseHeaders -> ToJSON json => json -> IO ()
renderJson' ResponseHeaders
additionalHeaders json
json = 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' #-}

renderNotFound :: (?context :: ControllerContext) => IO ()
renderNotFound :: IO ()
renderNotFound = (?context::ControllerContext) => LByteString -> IO ()
LByteString -> IO ()
renderPlain LByteString
"Not Found"
{-# INLINABLE renderNotFound #-}

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 :: forall viewContext jsonType htmlType. (?context :: ControllerContext) => PolymorphicRender -> IO ()
renderPolymorphic :: PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender { Maybe (IO ())
html :: Maybe (IO ())
$sel:html:PolymorphicRender :: PolymorphicRender -> Maybe (IO ())
html, Maybe (IO ())
json :: Maybe (IO ())
$sel:json:PolymorphicRender :: PolymorphicRender -> 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 = 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 controller. (ViewSupport.View view, ?theAction :: controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => view -> IO ()
render :: view -> IO ()
render !view
view = do
    PolymorphicRender -> IO ()
forall viewContext jsonType htmlType.
(?context::ControllerContext) =>
PolymorphicRender -> IO ()
renderPolymorphic PolymorphicRender :: Maybe (IO ()) -> Maybe (IO ()) -> PolymorphicRender
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 viewContext view controller.
(View view, ?theAction::controller, ?context::ControllerContext,
 ?modelContext::ModelContext) =>
view -> IO Html
renderHtml view
view) IO Html -> (Html -> IO ()) -> IO ()
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)
            }