View.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeFamilies          #-}

{-|
Module       : Yu.Core.View
Description  : The view of Yu
Copyright    : (C) Qinka 2017
License      : GPL3
Maintainer   : me@qinka.pro
Stability    : experimental
Portability  : unknow

The view part of the Yu.
-}


module Yu.Core.View
       ( -- * responds
         respondPost
       , respondResourceT
       , respondResourceB
       , respondStatic
       , -- * reexport module
         module Yu.Core.View.Internal
       , module Yu.Core.View.Query
       ) where

import           Control.Monad.Writer.Lazy
import           Data.Maybe
import           Data.Monoid
import           Network.HTTP.Types        (status301)
import           Text.Blaze.Html           (Html, preEscapedToHtml)
import           Yesod.Core
import           Yesod.Core.Handler
import           Yesod.Core.Widget
import           Yu.Core.Model             (ResT (..))
import           Yu.Core.View.Internal
import           Yu.Core.View.Query
import           Yu.Import.ByteString      (ByteString)
import qualified Yu.Import.ByteString      as B
import           Yu.Import.Text            (Text)
import qualified Yu.Import.Text            as T
import           Yu.Utils.Handler

-- | response the post with ResT and html
respondPost :: (Yesod a, Hamletic a (HandlerT a IO))
             => ResT -- ^ resource index
             -> Html -- ^ html body
             -> HandlerT a IO TypedContent
respondPost res@ResT{..} rawBody = do
  willRaw <- getRaw
  isRaw   <- null <$> lookupHeader "YuRAW"
  body    <- if willRaw == isRaw then return rawBody
             else defaultLayout $ withHtml rawBody res
  respondSource "text/html" $ do
    sendChunkHtml body
    sendFlush

-- | with tags, import tags to js
withTags :: [Text] -- ^ tags
          -> WidgetT site IO ()
withTags tags = let tagsJ = toJSON tags in toWidget [julius|tags=#{tagsJ};|]

-- | with summary, import summary to page when it not Nothing
withSummary :: Maybe Html -- ^ summary html
             -> WidgetT site IO ()
withSummary (Just summaryHtml) = [whamlet|<summary id=sum>#{summaryHtml}|]
withSummary _                  = return ()

-- | with whose, import the author to the js
withWhose :: Maybe Text -- ^ author
           -> WidgetT site IO ()
withWhose (Just whose) = let w = showJs whose in toWidget [julius|author=#{w};|]
withWhose _                    = return ()

-- | with html combine the parts to one
withHtml :: Html -- ^ the html for main part
          -> ResT -- ^ resource
          -> WidgetT site IO ()
withHtml body ResT{..} = do
  setTitle $ toHtml rTitle
  withSummary $ preEscapedToHtml <$> rSummary
  [whamlet|#{body}|]
  withWhose rWhose
  withTags rTags


-- | respond resource(text)
respondResourceT :: (Yesod a, Hamletic a (HandlerT a IO))
                   => ResT    -- ^ resource index
                   -> Text    -- ^ text
                   -> HandlerT a IO TypedContent
respondResourceT ResT{..} text = do
  respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
    sendChunkText text
    sendFlush

-- | respond resource(binary)
respondResourceB :: (Yesod a, Hamletic a (HandlerT a IO))
                   => ResT    -- ^ resource index
                   -> ByteString    -- ^ text
                   -> HandlerT a IO TypedContent
respondResourceB ResT{..} bin = do
  respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
    sendChunkBS bin
    sendFlush


-- | response the static url
respondStatic :: (Yesod a, Hamletic a (HandlerT a IO))
               => ResT -- ^ index for resource
               -> Text -- ^ Url
               -> HandlerT a IO TypedContent
respondStatic _ url = redirectWith status301 url