Source

haskellblog / src / Blog / Templates.hs

Full commit
{-# OPTIONS_GHC -fglasgow-exts #-}
module Blog.Templates
where

import Blog.Forms (emailWidget, nameWidget, messageWidget, formatWidget, usernameWidget, passwordWidget, CommentStage(..))
import Blog.Links
import Blog.Utils (escapeHtmlString)
import Data.Maybe (fromJust)
import Ella.Forms.Base
import Ella.Forms.Widgets (makeLabel)
import Ella.Forms.Widgets.TextInput (TextInput)
import Ella.GenUtils (utf8)
import System.Locale (defaultTimeLocale)
import System.Time (toUTCTime, formatCalendarTime)
import System.Time.Utils (epochToClockTime)
import Text.XHtml
import Text.StringTemplate
import Text.StringTemplate.Classes (SElem(..))
import qualified Blog.Category as C
import qualified Blog.Comment as Cm
import qualified Blog.Post as P
import qualified Blog.Settings as Settings
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import qualified Data.Map as Map

-- Widgets

commentNameLabel       = makeLabel "Name:" nameWidget
commentNameWidget c    = setVal (Cm.name c) nameWidget
commentEmailLabel      = makeLabel "Email:" emailWidget
commentEmailWidget c   = setVal (Cm.email c) emailWidget
commentFormatLabel     = "Format:"
commentFormatWidget c  = setVal (show $ fromEnum $ Cm.format c) formatWidget
commentMessageLabel    = "Message:"
commentMessageWidget c = setVal (Cm.text_raw c) messageWidget
commentSubmitButton    = submit "submit" "Post"
commentPreviewButton   = submit "preview" "Preview"

loginUsernameLabel = makeLabel "User name:" usernameWidget
loginUsernameWidget :: Map.Map String String -> TextInput
loginUsernameWidget loginData = setVal (fromJust $ Map.lookup "username" loginData) usernameWidget
loginPasswordLabel = makeLabel "Password: " passwordWidget
loginPasswordWidget :: Map.Map String String -> TextInput
loginPasswordWidget loginData = setVal (fromJust $ Map.lookup "password" loginData) passwordWidget

-- General HTML fragments

-- TODO - fix this to be able to work with URLs that have query
-- strings already.
pagingLinks :: String     -- ^ Base URL
            -> Int        -- ^ Current page
            -> Bool       -- ^ True if there is another page
            -> Html
pagingLinks url page shownext =
    (thediv ! [theclass "paginglinks"]
     << ((if page > 1
          then makeLink url (page - 1) "« Back"
          else thespan << "« Back")
         +++
         (toHtml " | ")
         +++
         (if shownext
          then makeLink url (page + 1) "Next »"
          else thespan << "Next »")
        )
     )
    where makeLink url page text = toHtml (hotlink (url ++ "?p=" ++ (show page)) << text)

formatName name = if null name
                  then "Anonymous Coward"
                  else name

categoryLink c = toHtml $ hotlink (categoryUrl c) << (C.name c)

postLink p = toHtml $ hotlink (postUrl p) << (P.title p)

showDate timestamp = formatCalendarTime defaultTimeLocale  "%e %B %Y" (toUTCTime $ epochToClockTime timestamp)


-- HStringTemplate related:

-- Allow for heterogeneous lists
data ToSElemD = forall a. ToSElem a => ToSElemD a

instance ToSElem ToSElemD where
    toSElem (ToSElemD x) = toSElem x

-- Allow Html to be inserted
instance ToSElem Html where
    toSElem x = BS (utf8 $ showHtmlFragment x)

encT = utf8 . escapeHtmlString -- use for text which might contain unicode or HTML chars
encH = utf8                    -- use for HTML


-- Convert to form needed for templates
postTemplateInfo :: P.Post -> Map.Map String ToSElemD
postTemplateInfo p = Map.fromList [ ("title", ToSElemD $ encT $ P.title p)
                                  , ("date", ToSElemD $ showDate $ P.timestamp p)
                                  , ("summary", ToSElemD $ encH $ P.summary_formatted p)
                                  , ("full", ToSElemD $ encH $ P.post_formatted p)
                                  , ("url", ToSElemD $ encT $ postUrl p)
                                  , ("commentsOpen", ToSElemD $ P.comments_open p)
                                  ]

categoryTemplateInfo :: C.Category -> Map.Map String ToSElemD
categoryTemplateInfo c = Map.fromList [ ("name", ToSElemD $ encT $ C.name c)
                                      , ("url", ToSElemD $ encT $ categoryUrl c)
                                      ]

commentTemplateInfo :: Cm.Comment -> Map.Map String ToSElemD
commentTemplateInfo cm = Map.fromList [ ("name", ToSElemD $ encT $ Cm.name cm)
                                      , ("formattedName", ToSElemD $ encT $ formatName $ Cm.name cm)
                                      , ("isAuthor", ToSElemD $ Cm.name cm == Settings.blog_author_name)
                                      , ("date", ToSElemD $ showDate $ Cm.timestamp cm)
                                      , ("textFormatted", ToSElemD $ encH $ Cm.text_formatted cm)
                                      , ("email", ToSElemD $ encT $ Cm.email cm)
                                      ]