{-# LANGUAGE FlexibleContexts, RecordWildCards #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Clckwrks.Page.API
( PageId(..)
-- , getPage
-- , getPageId
-- , getPageTitle
-- , getPageTitleSlug
-- , getPageContent
, getPagesSummary
, getPageSummary
, getPageMenu
, getPosts
, extractExcerpt
, getBlogTitle
, googleAnalytics
) where
import Clckwrks ( UserId )
import Clckwrks.Acid (GetUACCT(..))
import Clckwrks.Monad ( Clck, ClckT(..), ClckState(..), Content(..)
, getEnableAnalytics, query, update
)
import Clckwrks.Page.Acid ( PagesSummary(..), Page(..), PageById(..), PageId(..)
, Slug(..), AllPosts(..), GetBlogTitle(..))
import Clckwrks.Page.Monad ( PageM, markupToContent )
import Clckwrks.Page.Types ( PublishStatus )
import Clckwrks.Page.URL ( PageURL(ViewPageSlug))
import Clckwrks.URL (ClckURL(..))
import Control.Applicative ((<$>))
import Control.Monad.State (get)
import Control.Monad.Trans (MonadIO)
import Data.Text (Text)
import Data.Time (UTCTime)
import qualified Data.Text as Text
import Clckwrks.Page.Types (toSlug)
import Happstack.Server (Happstack, escape, internalServerError, toResponse)
import HSP hiding (escape)
import HSP.Google.Analytics (analyticsAsync)
import Text.HTML.TagSoup ( (~==), isTagCloseName, isTagOpenName, parseTags
, renderTags, sections)
{-
getPage :: PageM Page
getPage =
do ClckState{..} <- get
mPage <- query (PageById currentPage)
case mPage of
Nothing -> escape $ internalServerError $ toResponse ("getPage: invalid PageId " ++ show (unPageId currentPage))
(Just p) -> return p
getPageId :: PageM PageId
getPageId = currentPage <$> get
getPageTitle :: PageM Text
getPageTitle = pageTitle <$> getPage
getPageTitleSlug :: PageM (Text, Maybe Slug)
getPageTitleSlug =
do p <- getPage
return (pageTitle p, pageSlug p)
getPageContent :: PageM Content
getPageContent =
do mrkup <- pageSrc <$> getPage
markupToContent mrkup
-}
getPagesSummary :: PageM [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)]
getPagesSummary = query PagesSummary
getPageMenu :: GenXML PageM
getPageMenu =
do ps <- query PagesSummary
case ps of
[] -> <div>No pages found.</div>
_ -> <ul class="page-menu">
<% mapM (\(pid, ttl, slug,_,_,_) -> <li><a href=(ViewPageSlug pid (toSlug ttl slug)) title=ttl><% ttl %></a></li>) ps %>
</ul>
getPageSummary :: PageId -> PageM Content
getPageSummary pid =
do mPage <- query (PageById pid)
case mPage of
Nothing ->
return $ PlainText $ Text.pack $ "Invalid PageId " ++ (show $ unPageId pid)
(Just pge) ->
extractExcerpt pge
getBlogTitle :: PageM Text
getBlogTitle = query GetBlogTitle
extractExcerpt :: (MonadIO m, Functor m, Happstack m) =>
Page
-> ClckT url m Content
extractExcerpt Page{..} =
case pageExcerpt of
(Just excerpt) ->
markupToContent excerpt
Nothing ->
do c <- markupToContent pageSrc
case c of
(TrustedHtml html) ->
let tags = parseTags html
paragraphs = sections (~== "<p>") tags
paragraph = case paragraphs of
[] -> Text.pack "no summary available."
(p:ps) -> renderTags $ takeThrough (not . isTagCloseName (Text.pack "p")) $ filter (not . isTagOpenName (Text.pack "img")) p
in return (TrustedHtml paragraph)
(PlainText text) ->
return (PlainText text)
takeThrough :: (a -> Bool) -> [a] -> [a]
takeThrough _ [] = []
takeThrough f (p:ps)
| f p = p : takeThrough f ps
| otherwise = []
-- | get all posts, sorted reverse cronological
getPosts :: XMLGenT (PageM) [Page]
getPosts = query AllPosts
-- | create a google analytics tracking code block
--
-- This will under two different conditions:
--
-- * the 'enableAnalytics' field in 'ClckState' is 'False'
--
-- * the 'uacct' field in 'PageState' is 'Nothing'
googleAnalytics :: XMLGenT (PageM) XML
googleAnalytics =
do enabled <- getEnableAnalytics
case enabled of
False -> return $ cdata ""
True ->
do muacct <- query GetUACCT
case muacct of
Nothing -> return $ cdata ""
(Just uacct) ->
analyticsAsync uacct