Internal.hs

{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE QuasiQuotes            #-}

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

The internal party for View, including Hamletic.
-}


module Yu.Core.View.Internal
       ( Hamletic(..)
       , yuLayout
       , yuErrorHandler
         -- * layouts
       , layoutBootstrap
       ) where

import           Yesod.Core
import           Yesod.Core.Handler
import           Yesod.Core.Json
import           Yu.Core.Model
import           Yu.Import.Text     (Text)
import qualified Yu.Import.Text     as T
import           Yu.Utils.Handler

-- | Hamtletic
--
--   Limit, and test
class (MonadHandler m, Mongodic a m) => Hamletic a m | m -> a where
  getTitle        :: m Text  -- ^ get title
  getFramePrefix :: m Text  -- ^ get the prefix path of frame
  getVersion      :: m Text  -- ^ get the version of blog itself or application
  getRaw          :: m Bool  -- ^ return raw html


-- | layout for layout
type YuLayout site = (  PageContent (Route site)
                       -> Html -- hd
                       -> Text -- title
                       -> Html -- nav
                       -> Html -- top
                       -> Html -- bottom
                       -> ((Route site -> [(Text, Text)] -> Text) -> Html)
                       )

-- | layout with bootstrap
layoutBootstrap :: Yesod site => YuLayout site
layoutBootstrap pageContent hd title nav top bottom = [hamlet|
  $newline never
  $doctype 5
  <html>
    <head>
      <title> #{pageTitle pageContent} - #{title}
      <meta charset=utf-8>
      <meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no">
      #{hd}
      ^{pageHead pageContent}
    <body>
      #{nav}
      <div id="container">
        #{top}
        <div id="main-part">
          ^{pageBody pageContent}
      #{bottom}
  |]

{-|
The example, or say template for layout

@
layoutXx pageContent hd title nav top bottom = [hamlet|
  $newline never
  $doctype 5
  \<html>\
    \<head\>
      \<title\> #{pageTitle pageContent} - #{title}
      \<meta charset=utf-8\>
      \<meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no"\>
      #{hd}
      ^{pageHead pageContent}
    \<body\>
      #{nav}
      #{top}
      ^{pageBody pageContent}
      #{bottom}
  |]
@
-}

-- | the default of yu with Yesod
yuLayout :: (Hamletic a (HandlerT a IO),Yesod a)
            => YuLayout a        -- ^ the layout for yu
            -> WidgetT a IO ()     -- ^ widget
            -> HandlerT a IO Html  -- ^ return
yuLayout layout w = do
  framePrefix <- getFramePrefix
  title        <- getTitle
  pageContent <- widgetToPageContent w
  htmls <- runDbDefault $ do
    topHtml    <- fetchMaybeI fetchFrame [framePrefix,"top"]
    bottomHtml <- fetchMaybeI fetchFrame [framePrefix,"bottom"]
    navHtml    <- fetchMaybeI fetchFrame [framePrefix,"nav"]
    header      <- fetchMaybeI fetchFrame [framePrefix,"header"]
    case (topHtml,bottomHtml,navHtml,header) of
      (Just top, Just bottom, Just nav, Just hd) -> return $ Right (top,bottom,nav,hd)
      _                                          -> return $ Left "cannot launch frames"
  case htmls of
    Left err -> error err
    Right (top,bottom,nav,hd) -> withUrlRenderer $ layout pageContent hd title nav top bottom



-- | handler the error
yuErrorHandler :: Yesod site
                      => ErrorResponse -- ^ error
                      -> HandlerT site IO TypedContent
yuErrorHandler er = selectRep $ do
  provideJson er
  provideRep $
    defaultLayout [whamlet|
                          <h1> error
                          <p> #{T.show er}
                          |]