content: {-# 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 Data.ByteString.Builder as ByteString
  import IHP.FlashMessages.ControllerFunctions (initFlashMessages)
  
  renderPlain :: (?context :: ControllerContext) => LByteString -> IO ()
  renderPlain text = respondAndExit $ responseLBS status200 [(hContentType, "text/plain")] text
  {-# INLINABLE renderPlain #-}
  
  respondHtml :: (?context :: ControllerContext) => Html -> IO ()
  respondHtml html =
          -- The seq is required to force evaluation of `evaluatedBuilder` before returning the IO action. See below for details
          evaluatedBuilder `seq` (respondAndExit $ responseBuilder status200 [(hContentType, "text/html; charset=utf-8"), (hConnection, "keep-alive")] evaluatedBuilder)
      where
          builder = Blaze.renderHtmlBuilder html
          builderAsByteString = ByteString.toLazyByteString builder
  
          -- 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.
          evaluatedBuilder = Data.ByteString.Lazy.length builderAsByteString `seq` ByteString.lazyByteString builderAsByteString
  {-# INLINABLE respondHtml #-}
  
  respondSvg :: (?context :: ControllerContext) => Html -> IO ()
  respondSvg html = respondAndExit $ responseBuilder status200 [(hContentType, "image/svg+xml"), (hConnection, "keep-alive")] (Blaze.renderHtmlBuilder html)
  {-# INLINABLE respondSvg #-}
  
  renderHtml :: forall view. (ViewSupport.View view, ?context :: ControllerContext) => view -> IO Html
  renderHtml !view = do
      let ?view = view
      initFlashMessages
      ViewSupport.beforeRender view
      frozenContext <- Context.freeze ?context
  
      let ?context = frozenContext
      let layout = case Context.maybeFromFrozenContext @ViewLayout of
              Just (ViewLayout layout) -> layout
              Nothing -> id
  
      let boundHtml = let ?context = frozenContext in layout (ViewSupport.html ?view)
      pure boundHtml
  {-# INLINABLE renderHtml #-}
  
  renderFile :: (?context :: ControllerContext) => String -> ByteString -> IO ()
  renderFile filePath contentType = respondAndExit $ responseFile status200 [(hContentType, contentType)] filePath Nothing
  {-# INLINABLE renderFile #-}
  
  renderJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ()
  renderJson json = renderJsonWithStatusCode status200 json
  {-# INLINABLE renderJson #-}
  
  renderJsonWithStatusCode :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => Status -> json -> IO ()
  renderJsonWithStatusCode statusCode json = respondAndExit $ responseLBS statusCode [(hContentType, "application/json")] (Data.Aeson.encode json)
  {-# INLINABLE renderJsonWithStatusCode #-}
  
  renderXml :: (?context :: ControllerContext) => LByteString -> IO ()
  renderXml xml = respondAndExit $ responseLBS status200 [(hContentType, "application/xml")] xml
  {-# INLINABLE renderXml #-}
  
  -- | Use 'setHeader' intead
  renderJson' :: (?context :: ControllerContext) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ()
  renderJson' additionalHeaders json = respondAndExit $ responseLBS status200 ([(hContentType, "application/json")] <> additionalHeaders) (Data.Aeson.encode json)
  {-# INLINABLE renderJson' #-}
  
  data PolymorphicRender
      = PolymorphicRender
          { html :: 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 PolymorphicRender { html, json } = do
      let headers = Network.Wai.requestHeaders request
      let acceptHeader = snd (fromMaybe (hAccept, "text/html") (List.find (\(headerName, _) -> headerName == hAccept) headers)) :: ByteString
      let send406Error = respondAndExit $ responseLBS status406 [] "Could not find any acceptable response format"
      let formats = concat [
                  case html of
                      Just handler -> [("text/html", handler)]
                      Nothing -> mempty
                   ,
                  case json of
                      Just handler -> [("application/json", handler)]
                      Nothing -> mempty
              ]
      fromMaybe send406Error (Accept.mapAcceptMedia formats acceptHeader)
  
  polymorphicRender :: PolymorphicRender
  polymorphicRender = PolymorphicRender Nothing Nothing
  
  
  {-# INLINABLE render #-}
  render :: forall view. (ViewSupport.View view, ?context :: ControllerContext) => view -> IO ()
  render !view = do
      renderPolymorphic PolymorphicRender
              { html = Just $ (renderHtml view) >>= respondHtml
              , json = Just $ renderJson (ViewSupport.json view)
              }
  
  