{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Theme where import Clckwrks import Clckwrks.Monad import Clckwrks.ProfileData.Acid (HasRole(..)) import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Data.Text (Text, unpack) -- import Happstack.Server import HSP import Paths_clckwrks_theme_happstack (getDataDir) theme :: Theme theme = Theme { themeName = "happstack" , _themeTemplate = pageTemplate , themeBlog = blog , themeDataDir = getDataDir } pageTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body ) => Text -> headers -> body -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML pageTemplate ttl hdr bdy = do pid <- XMLGenT $ getPageId case pid of (PageId 1) -> home ttl hdr bdy _ -> standardTemplate ttl hdr

<% ttl %>

<% bdy %>

------------------------------------------------------------------------------ -- standard template ------------------------------------------------------------------------------ standardTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body ) => Text -> headers -> body -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML standardTemplate ttl hdrs bdy = <% ttl %> <% hdrs %> <% googleAnalytics %> <% bdy %>

<% do mu <- getUserId case mu of Nothing -> <% () %> (Just uid) -> do r <- query (HasRole uid (Set.singleton Administrator)) if not r then <% () %> else do pid <- lift getPageId <%>

admin console

edit this page

------------------------------------------------------------------------------ -- Home ------------------------------------------------------------------------------ summaryBox :: PageId -> String -> String -> GenXML (Clck ClckURL) summaryBox pid title iconURL =

<% title %>

<% getPageSummary pid %>

<% pageTitle %>

Posted on <% pageDate %> by <% authorName %> <% pageSrc %>

permalink

where authorName :: Clck ClckURL Text authorName = do mu <- getUsername pageAuthor return $ fromMaybe "Anonymous" mu blog :: XMLGenT (Clck ClckURL) XML blog = do ttl <- lift getBlogTitle standardTemplate ttl () $ <%>

<% ttl %>

<% postsHTML %>