clckwrks-plugin-page (empty) → 0.1.2
raw patch · 20 files changed
+1586/−0 lines, 20 filesdep +acid-statedep +aesondep +attoparsecbuild-type:Customsetup-changed
Dependencies added: acid-state, aeson, attoparsec, base, clckwrks, containers, directory, filepath, happstack-authenticate, happstack-hsp, happstack-server, hsp, ixset, mtl, old-locale, random, reform, reform-happstack, reform-hsp, safecopy, tagsoup, template-haskell, text, time, utf8-string, uuid, web-plugins, web-routes, web-routes-happstack, web-routes-th
Files
- Clckwrks/Page/API.hs +138/−0
- Clckwrks/Page/Acid.hs +248/−0
- Clckwrks/Page/Admin/EditFeedConfig.hs +55/−0
- Clckwrks/Page/Admin/EditPage.hs +111/−0
- Clckwrks/Page/Admin/NewPage.hs +35/−0
- Clckwrks/Page/Admin/Pages.hs +48/−0
- Clckwrks/Page/Admin/PreviewPage.hs +35/−0
- Clckwrks/Page/Atom.hs +95/−0
- Clckwrks/Page/BlogPage.hs +38/−0
- Clckwrks/Page/Monad.hs +130/−0
- Clckwrks/Page/NavBarCallback.hs +21/−0
- Clckwrks/Page/Plugin.hs +111/−0
- Clckwrks/Page/PreProcess.hs +73/−0
- Clckwrks/Page/Route.hs +84/−0
- Clckwrks/Page/Types.hs +206/−0
- Clckwrks/Page/URL.hs +29/−0
- Clckwrks/Page/Verbatim.hs +16/−0
- LICENSE +30/−0
- Setup.hs +13/−0
- clckwrks-plugin-page.cabal +70/−0
+ Clckwrks/Page/API.hs view
@@ -0,0 +1,138 @@+{-# 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
+ Clckwrks/Page/Acid.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Page.Acid+ ( module Clckwrks.Page.Types+ -- * state+ , PageState+ , initialPageState+ -- * events+ , NewPage(..)+ , PageById(..)+ , GetPageTitle(..)+ , IsPublishedPage(..)+ , PagesSummary(..)+ , UpdatePage(..)+ , AllPosts(..)+ , AllPublishedPages(..)+ , GetFeedConfig(..)+ , SetFeedConfig(..)+ , GetBlogTitle(..)+ , GetOldUACCT(..)+ , ClearOldUACCT(..)+ ) where++import Clckwrks.Page.Types (Markup(..), PublishStatus(..), PreProcessor(..), PageId(..), PageKind(..), Page(..), Pages(..), FeedConfig(..), Slug(..), initialFeedConfig, slugify)+import Clckwrks.Page.Verbatim (verbatimText)+import Clckwrks.Types (Trust(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, modify, put)+import Control.Monad.Trans (liftIO)+import Data.Acid (AcidState, Query, Update, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable, IxSet, (@=), Proxy(..), empty, fromList, getOne, ixSet, ixFun, insert, toList, toDescList, updateIx)+import Data.Maybe (fromJust)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.String (fromString)+import Data.Text (Text)+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX(posixSecondsToUTCTime)+import qualified Data.Text as Text+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Happstack.Auth (UserId(..))+import HSP.Google.Analytics (UACCT)++data PageState_001 = PageState_001+ { nextPageId_001 :: PageId+ , pages_001 :: IxSet Page+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageState_001)++data PageState_002 = PageState_002+ { nextPageId_002 :: PageId+ , pages_002 :: IxSet Page+ , feedConfig_002 :: FeedConfig+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''PageState_002)++instance Migrate PageState_002 where+ type MigrateFrom PageState_002 = PageState_001+ migrate (PageState_001 npi pgs) =+ PageState_002 npi pgs (FeedConfig { feedUUID = fromJust $ UUID.fromString "fa6cf090-84d7-11e1-8001-0021cc712949"+ , feedTitle = fromString "Untitled Feed"+ , feedLink = fromString ""+ , feedAuthorName = fromString "Anonymous"+ })++data PageState = PageState+ { nextPageId :: PageId+ , pages :: IxSet Page+ , feedConfig :: FeedConfig+ , uacct :: Maybe UACCT+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 3 'extension ''PageState)++instance Migrate PageState where+ type MigrateFrom PageState = PageState_002+ migrate (PageState_002 npi pgs fc) =+ PageState npi pgs fc Nothing++initialPageMarkup :: Text+initialPageMarkup = [verbatimText|Congratulations! You are now running clckwrks! There are a few more steps you will want to take now.++Create an Account+-----------------++Go [here](/clck/auth/auth/create) and create an account for yourself.++Give yourself Administrator permissions+-------------------------------++After you create an account you will want to give yourself `Administrator` privileges. This can be done using the `clckwrks-cli` tool. *While the server is running* invoke `clckwrks-cli` and point it to the socket file:++ $ clckwrks-cli _state/profileData_socket++that should start an interactive session. If the server is running as `root`, then you may need to add a `sudo` in front. ++Assuming you are `UserId 1` you can now give yourself admin access:++ % user add-role 1 Administrator++You can run `help` for a list of other commands. Type `quit` to exit.++Explore the Admin console+-------------------------++Now you can explore the [Admin Console](/clck/admin/console).++|]++initialPageState :: IO PageState+initialPageState =+ do fc <- initialFeedConfig+ return $ PageState { nextPageId = PageId 2+ , pages = fromList [ Page { pageId = PageId 1+ , pageAuthor = UserId 1+ , pageTitle = "Welcome To clckwrks!"+ , pageSlug = Just $ slugify "Welcome to clckwrks"+ , pageSrc = Markup { preProcessors = [ Markdown ]+ , trust = Trusted+ , markup = initialPageMarkup+ }+ , pageExcerpt = Nothing+ , pageDate = posixSecondsToUTCTime 1334089928+ , pageUpdated = posixSecondsToUTCTime 1334089928+ , pageStatus = Published+ , pageKind = PlainPage+ , pageUUID = fromJust $ UUID.fromString "c306fe3a-8346-11e1-8001-0021cc712949"+ }+ ]+ , feedConfig = fc+ , uacct = Nothing+ }++pageById :: PageId -> Query PageState (Maybe Page)+pageById pid =+ do pgs <- pages <$> ask+ return $ getOne $ pgs @= pid++-- | get the 'pageTitle' for 'PageId'+getPageTitle :: PageId -> Query PageState (Maybe (Text, Maybe Slug))+getPageTitle pid =+ do mPage <- pageById pid+ case mPage of+ Nothing -> return $ Nothing+ (Just page) -> return $ Just (pageTitle page, pageSlug page)++-- | check if the 'PageId' corresponds to a published 'PageId'+isPublishedPage :: PageId -> Query PageState Bool+isPublishedPage pid =+ do pgs <- pages <$> ask+ case getOne $ pgs @= pid of+ Nothing -> return False+ (Just page) -> return $ pageStatus page == Published++pagesSummary :: Query PageState [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)]+pagesSummary =+ do pgs <- pages <$> ask+ return $ map (\page -> (pageId page, pageTitle page, pageSlug page, pageUpdated page, pageAuthor page, pageStatus page))+ (toList pgs)++updatePage :: Page -> Update PageState (Maybe String)+updatePage page =+ do ps@PageState{..} <- get+ case getOne $ pages @= (pageId page) of+ Nothing -> return $ Just $ "updatePage: Invalid PageId " ++ show (unPageId $ pageId page)+ (Just _) ->+ do put $ ps { pages = updateIx (pageId page) page pages }+ return Nothing++newPage :: PageKind -> UserId -> UUID -> UTCTime -> Update PageState Page+newPage pk uid uuid now =+ do ps@PageState{..} <- get+ let page = Page { pageId = nextPageId+ , pageAuthor = uid+ , pageTitle = "Untitled"+ , pageSlug = Nothing+ , pageSrc = Markup { preProcessors = [ Markdown ]+ , trust = Trusted+ , markup = Text.empty+ }+ , pageExcerpt = Nothing+ , pageDate = now+ , pageUpdated = now+ , pageStatus = Draft+ , pageKind = pk+ , pageUUID = uuid+ }+ put $ ps { nextPageId = PageId $ succ $ unPageId nextPageId+ , pages = insert page pages+ }+ return page++getFeedConfig :: Query PageState FeedConfig+getFeedConfig =+ do PageState{..} <- ask+ return feedConfig++getBlogTitle :: Query PageState Text+getBlogTitle =+ do PageState{..} <- ask+ return (feedTitle feedConfig)++setFeedConfig :: FeedConfig -> Update PageState ()+setFeedConfig fc =+ do ps <- get+ put $ ps { feedConfig = fc }++-- | get all 'Published' posts, sorted reverse cronological+allPosts :: Query PageState [Page]+allPosts =+ do pgs <- pages <$> ask+ return $ toDescList (Proxy :: Proxy UTCTime) (pgs @= Post @= Published)++-- | get all 'Published' pages, sorted in no particular order+allPublishedPages :: Query PageState [Page]+allPublishedPages =+ do pgs <- pages <$> ask+ return $ toList (pgs @= PlainPage @= Published)++-- | get the 'UACCT' for Google Analytics+--+-- DEPRECATED: moved to clckwrks / 'CoreState'+getOldUACCT :: Query PageState (Maybe UACCT)+getOldUACCT = uacct <$> ask++-- | zero out the UACCT code in 'PageState'. It belongs in 'CoreState'+-- now.+clearOldUACCT :: Update PageState ()+clearOldUACCT = modify $ \ps -> ps { uacct = Nothing }++$(makeAcidic ''PageState+ [ 'newPage+ , 'pageById+ , 'getPageTitle+ , 'isPublishedPage+ , 'pagesSummary+ , 'updatePage+ , 'allPosts+ , 'allPublishedPages+ , 'getFeedConfig+ , 'setFeedConfig+ , 'getBlogTitle+ , 'getOldUACCT+ , 'clearOldUACCT+ ])
+ Clckwrks/Page/Admin/EditFeedConfig.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Admin.EditFeedConfig where++import Clckwrks (ClckURL(Admin), AdminURL(Console), query, update)+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Acid (GetFeedConfig(..), SetFeedConfig(..))+import Clckwrks.Page.Monad (PageConfig(pageClckURL), PageM, PageForm, PageFormError)+import Clckwrks.Page.Types (FeedConfig(..))+import Clckwrks.Page.URL (PageURL(..))+import Control.Applicative ((<$>), (<*), (<*>))+import Control.Monad.Reader (ask)+import Data.Text (Text, pack)+import Happstack.Server (Response, seeOther, toResponse)+import HSP+import Text.Reform+import Text.Reform.Happstack+import Text.Reform.HSP.Text+import Web.Routes (showURL)++editFeedConfig :: PageURL -> PageM Response+editFeedConfig here =+ do feedConfig <- query $ GetFeedConfig+ action <- showURL here+ template "edit feed config" () $+ <%>+ <% reform (form action) "ep" updateFeedConfig Nothing (feedConfigForm feedConfig) %>+ </%>+ where+ updateFeedConfig :: FeedConfig -> PageM Response+ updateFeedConfig fc =+ do update (SetFeedConfig fc)+ showURL <- pageClckURL <$> ask+ seeOther (showURL (Admin Console) []) (toResponse ())++feedConfigForm :: FeedConfig -> PageForm FeedConfig+feedConfigForm fc@FeedConfig{..} =+ divHorizontal $+ fieldset $+ ((,) <$> (divControlGroup (label' "Feed Title" ++> (divControls $ inputText feedTitle)))+ <*> (divControlGroup (label' "Default Author Name" ++> (divControls $ inputText feedAuthorName)))+ <* (divControlGroup (divControls $ (inputSubmit (pack "Update") `setAttrs`[("class" := "btn")])))+ )+ `transformEither` toFeedConfig+ where+ label' str = (label str `setAttrs` [("class":="control-label")])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])++ toFeedConfig :: (Text, Text) -> Either PageFormError FeedConfig+ toFeedConfig (ttl, athr) =+ Right $ fc { feedTitle = ttl+ , feedAuthorName = athr+ }
+ Clckwrks/Page/Admin/EditPage.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Admin.EditPage+ ( editPage+ ) where++import Control.Applicative ((<$>), (<*>), (<*))+import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Monad (PageM, PageForm, PageFormError)+import Clckwrks.Page.Acid (Markup(..), Page(..), PageKind(..), PublishStatus(..), PreProcessor(..), PageById(..), UpdatePage(..))+import Clckwrks.Page.Types (PageId(..), Slug(..), toSlug, slugify)+import Clckwrks.Page.URL (PageURL(..), PageAdminURL(..))+import Data.Maybe (isJust, maybe)+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Data.Time.Clock (getCurrentTime)+import Text.Reform ((<++), (++>), mapView, transformEitherM)+import Text.Reform.Happstack (reform)+import Text.Reform.HSP.Text (form, button, inputCheckbox, inputText, label, inputSubmit, select, textarea, fieldset, ol, li, setAttrs)++data AfterSaveAction+ = EditSomeMore+ | VisitPage+ | ShowPreview++editPage :: PageURL -> PageId -> PageM Response+editPage here pid =+ do mPage <- query $ PageById pid+ case mPage of+ Nothing -> notFound $ toResponse $ "Page not found: " ++ show (unPageId pid)+ (Just page) ->+ do action <- showURL here+ template "edit page" () $+ <%>+ <% reform (form action) "ep" updatePage Nothing (pageFormlet page) %>+ </%>+ where+ updatePage :: (Page, AfterSaveAction) -> PageM Response+ updatePage (page, afterSaveAction) =+ do update (UpdatePage page)+ case afterSaveAction of+ EditSomeMore -> seeOtherURL (PageAdmin $ EditPage (pageId page))+ VisitPage -> seeOtherURL (ViewPageSlug (pageId page) (toSlug (pageTitle page) (pageSlug page)))+ ShowPreview -> seeOtherURL (PageAdmin $ PreviewPage (pageId page))+++pageFormlet :: Page -> PageForm (Page, AfterSaveAction)+pageFormlet page =+ divHorizontal $+ (fieldset $+ (,,,,,)+ <$> (divControlGroup (label' "Page Type" ++> (divControls $ select [(PlainPage, "page"), (Post, "post")] (== (pageKind page)))))+ <*> (divControlGroup (label' "Title" ++> (divControls $ inputText (pageTitle page) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge")])))+ <*> (divControlGroup (label' "Slug (optional)" ++> (divControls $ inputText (maybe Text.empty unSlug $ pageSlug page) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge")])))+ <*> (divControlGroup (divControls (inputCheckboxLabel "Highlight Haskell code using HsColour" hsColour)))+ <*> (divControlGroup (label' "Body" ++> (divControls $ textarea 80 25 (markup (pageSrc page)) `setAttrs` [("class" := "input-xxlarge")])))+ <*> (divFormActions+ ((,,) <$> (inputSubmit' (pack "Save"))+ <*> (inputSubmit' (pack "Preview") `setAttrs` ("class" := "btn btn-info"))+ <*> newPublishStatus (pageStatus page)))+ ) `transformEitherM` toPage++ where+ inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]+ inputCheckboxLabel lbl b =+ mapView (\xml -> [<label class="checkbox"><% xml %><% lbl %></label>])+ (inputCheckbox b)++ label' str = (label str `setAttrs` [("class":="control-label")])++ labelCB str = label str `setAttrs` [("class":="checkbox")]+-- divInline = mapView (\xml -> [<div class="checkbox inline"><% xml %></div>])+ divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])++ newPublishStatus :: PublishStatus -> PageForm (Maybe PublishStatus)+ newPublishStatus Published = fmap (const Draft) <$> (inputSubmit' (pack "Unpublish") `setAttrs` [("class" := "btn btn-warning")])+ newPublishStatus _ = fmap (const Published) <$> (inputSubmit' (pack "Publish") `setAttrs` [("class" := "btn btn-success")])+ hsColour = HsColour `elem` (preProcessors $ pageSrc page)+ toPage :: (MonadIO m) =>+ (PageKind, Text, Text, Bool, Text, (Maybe Text, Maybe Text, Maybe PublishStatus))+ -> m (Either PageFormError (Page, AfterSaveAction))+ toPage (kind, ttl, slug, haskell, bdy, (msave, mpreview, mpagestatus)) =+ do now <- liftIO $ getCurrentTime+ return $ Right $+ ( Page { pageId = pageId page+ , pageAuthor = pageAuthor page+ , pageTitle = ttl+ , pageSlug = if Text.null slug then Nothing else Just (slugify slug)+ , pageSrc = Markup { preProcessors = (if haskell then ([ HsColour ] ++) else id) [ Markdown ]+ , trust = Trusted+ , markup = bdy+ }+ , pageExcerpt = Nothing+ , pageDate = pageDate page+ , pageUpdated = now+ , pageStatus = case mpagestatus of+ (Just newStatus) -> newStatus+ Nothing -> pageStatus page+ , pageKind = kind+ , pageUUID = pageUUID page+ }+ , if isJust mpreview+ then ShowPreview+ else case mpagestatus of+ (Just Published) -> VisitPage+ _ -> EditSomeMore+ )
+ Clckwrks/Page/Admin/NewPage.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Admin.NewPage where++import Clckwrks+import Clckwrks.Page.Acid as Acid+import Clckwrks.Page.Monad (PageM)+import Clckwrks.Page.URL as URL (PageURL(..), PageAdminURL(NewPage, NewPost, EditPage))+import Clckwrks.Admin.Template (template)+import Data.UUID () -- instance Random UUID+import Data.Time.Clock (getCurrentTime)+import System.Random (randomIO)++newPage :: PageKind -> PageM Response+newPage pageKind =+ do method GET+ template "Create New Page/Post" () $+ <%>+ <form class="form-inline" action=(PageAdmin URL.NewPage) method="POST" enctype="multipart/form-data">+ <button class="btn" type="submit">Create New Page</button>+ </form>+ <form class="form-inline" action=(PageAdmin URL.NewPost) method="POST" enctype="multipart/form-data">+ <button class="btn" type="submit">Create New Post</button>+ </form>+ </%>++ <|>+ do method POST+ uuid <- liftIO $ randomIO+ now <- liftIO $ getCurrentTime+ muid <- getUserId+ case muid of+ Nothing -> escape $ internalServerError $ toResponse "Clcwrks.Admin.NewPage.newPage was unable to obtain the current UserId"+ (Just uid) ->+ do page <- update (Acid.NewPage pageKind uid uuid now)+ seeOtherURL (PageAdmin $ EditPage (pageId page))
+ Clckwrks/Page/Admin/Pages.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Admin.Pages where++import Clckwrks (UserId)+import Clckwrks.Monad (query)+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Acid (PagesSummary(..))+import Clckwrks.Page.Monad (PageM)+import Clckwrks.Page.URL (PageAdminURL(..), PageURL(..))+import Clckwrks.Page.Types (PageId(..), PublishStatus(..), Slug(..), publishStatusString)+import Data.Text (Text)+import Data.Time (UTCTime)+import Happstack.Server (Response)+import HSP++pages :: PageM Response+pages =+ do pages <- query PagesSummary+ template "Page List" () $ editList pages++editList :: [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)]+ -> GenChildList PageM+editList [] = <%><p>There are currently no pages.</p></%>+editList pgs =+ <%>+ <table class="table table-condensed">+ <thead>+ <tr>+ <th>Page Id</th>+ <th>Title</th>+ <th>Last Updated</th>+ <th>Status</th>+ </tr>+ </thead>+ <tbody>+ <% mapM editPageTR pgs %>+ </tbody>+ </table>+ </%>+ where+ editPageTR :: (PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus) -> GenXML PageM+ editPageTR (pid, ttl, _slug, updated, userId, published) =+ <tr>+ <td><% show $ unPageId pid %></td>+ <td><a href=(PageAdmin $ EditPage pid)><% ttl %></a></td>+ <td><% updated %></td>+ <td><% publishStatusString published %></td>+ </tr>
+ Clckwrks/Page/Admin/PreviewPage.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Admin.PreviewPage+ ( previewPage+ ) where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.ProfileData.Acid (HasRole(..))+import Clckwrks.Page.Acid (Page(..), PageId(..), PublishStatus(..), PageById(..))+import Clckwrks.Page.Monad (PageM, clckT2PageT, markupToContent)+import Clckwrks.Unauthorized ()+import Control.Monad.State (get)+import qualified Data.Set as Set+import Web.Plugins.Core (getTheme)++previewPage :: PageId -> PageM Response+previewPage pid =+ do mPage <- query $ PageById pid+ case mPage of+ Nothing -> do notFound ()+ template "Page not found" () $ <% "Page not found: " ++ show (unPageId pid) %>+ (Just page) ->+ do muid <- getUserId+ authorized <-+ case muid of+ Nothing -> return False+ (Just uid) -> query $ HasRole uid (Set.singleton Administrator)+ if authorized+ then do cs <- get+ (Just page) <- query (PageById pid)+ let ttl = pageTitle page+ bdy <- markupToContent (pageSrc page)+ clckT2PageT $ themeTemplate (plugins cs) ttl () bdy+ else unauthorized (toResponse $ "Sorry, you need Administrator access to view this page.")
+ Clckwrks/Page/Atom.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Atom where++import Control.Monad.Trans (liftIO)+import Clckwrks.Monad (Clck, Content(..), query, withAbs)+import Clckwrks.Page.Acid+import Clckwrks.Page.Monad (PageM, markupToContent)+import Clckwrks.Page.Types+import Clckwrks.ProfileData.Acid+import Clckwrks.Page.URL+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import Data.Maybe (fromMaybe)+import Data.String (fromString)+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (formatTime)+import Data.UUID (toString)+import Happstack.Server (Happstack, Response, ok, toResponseBS)+import HSP+import HSP.XML (renderXML)+import System.Locale (defaultTimeLocale)+import Web.Routes (showURL)++atom :: FeedConfig -- ^ feed configuration+ -> [Page] -- ^ pages to publish in feed+ -> PageM XML+atom FeedConfig{..} pages =+ do blogURL <- withAbs $ showURL Blog+ atomURL <- withAbs $ showURL AtomFeed+ unXMLGenT $ <feed xmlns="http://www.w3.org/2005/Atom">+ <title><% feedTitle %></title>+ <link type="text/html" href=blogURL />+ <link rel="self" type="application/atom+xml" href=atomURL />+ <author>+ <name><% feedAuthorName %></name>+ </author>+ <updated><% atomDate $ mostRecentUpdate pages %></updated>+ <id><% "urn:uuid:" ++ toString feedUUID %></id>+ <% mapM entry pages %>+ </feed>++mostRecentUpdate :: [Page] -- ^ pages to consider+ -> UTCTime -- ^ most recent updated time+mostRecentUpdate [] = posixSecondsToUTCTime 0+mostRecentUpdate pages =+ maximum $ map pageUpdated pages++entry :: Page+ -> PageM XML+entry Page{..} =+ do viewPageSlug <- withAbs $ showURL (ViewPageSlug pageId (toSlug pageTitle pageSlug))+ unXMLGenT $ <entry>+ <title><% pageTitle %></title>+ <link href=viewPageSlug />+ <id><% "urn:uuid:" ++ toString pageUUID %></id>+ <% author %>+ <updated><% atomDate pageUpdated %></updated>+ <% atomContent pageSrc %>+ </entry>+ where+ author :: XMLGenT PageM XML+ author =+ do mu <- query $ UsernameForId pageAuthor+ case mu of+ Nothing -> return $ cdata ""+ (Just n)+ | Text.null n ->+ return $ cdata ""+ | otherwise ->+ <author>+ <name><% n %></name>+ </author>++atomDate :: UTCTime -> String+atomDate time =+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" time++atomContent :: Markup -> PageM XML+atomContent markup =+ do c <- markupToContent markup+ case c of+ (PlainText txt) ->+ unXMLGenT $ <content type="text"><% txt %></content>+ (TrustedHtml html) ->+ unXMLGenT $ <content type="html"><% html %></content>++handleAtomFeed :: PageM Response+handleAtomFeed =+ do ps <- query AllPosts+ feedConfig <- query GetFeedConfig+ xml <- atom feedConfig ps+ ok $ toResponseBS (fromString "application/atom+xml;charset=utf-8") (UTF8.fromString $ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" ++ renderXML xml)
+ Clckwrks/Page/BlogPage.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.BlogPage where++import Clckwrks+import Clckwrks.Page.API+import Clckwrks.Page.Monad+import Clckwrks.Page.Types+import Clckwrks.Page.URL+import Control.Monad.State (get)++postsHTML :: XMLGenT PageM XML+postsHTML =+ do posts <- getPosts+ <ol class="blog-posts">+ <% mapM postHTML posts %>+ </ol>++postHTML :: Page -> XMLGenT PageM XML+postHTML Page{..} =+ <li class="blog-post">+ <h2><% pageTitle %></h2>+ <span class="pub-date"><% pageDate %></span>+ <% (markupToContent pageSrc) :: PageM Content %>+ <p><a href=(ViewPage pageId)>permalink</a></p>+ </li>++blog :: PageM Response+blog =+ do ttl <- getBlogTitle+ cs <- get++ bdy <- unXMLGenT $+ <div id="blog-content">+ <% postsHTML %>+ </div>++ clckT2PageT $ themeTemplate (plugins cs) ttl () bdy
+ Clckwrks/Page/Monad.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}+module Clckwrks.Page.Monad where++import Control.Applicative ((<$>))+import Control.Monad (foldM)+import Control.Monad.Reader (MonadReader(ask,local), ReaderT(runReaderT))+import Control.Monad.State (StateT, put, get, modify)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.Text.Lazy as LT+import Clckwrks.Acid (GetAcidState(..))+import Clckwrks.Monad (Content(..), ClckT(..), ClckFormT, ClckState(..), ClckPluginsSt(..), mapClckT, runClckT, withRouteClckT, getPreProcessors)+import Clckwrks.URL (ClckURL)+import Clckwrks.Page.Acid (PageState(..))+import Clckwrks.Page.Types (Markup(..), runPreProcessors)+import Clckwrks.Page.URL (PageURL(..), PageAdminURL(..))+import Clckwrks.Page.Types (PageId(..))+import Clckwrks.Plugin (clckPlugin)+import Control.Monad.Trans (lift)+import Data.Acid (AcidState)+import Data.Data (Typeable)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Happstack.Server (Happstack, Input, ServerPartT)+import HSP (Attr((:=)), Attribute(MkAttr), EmbedAsAttr(..), EmbedAsChild(..), IsName(toName), XMLGenT, XML, pAttrVal)+import Text.Reform (CommonFormError, FormError(..))+import Web.Plugins.Core (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn)+import Web.Routes (RouteT(..), showURL, withRouteT)++data PageConfig = PageConfig+ { pageState :: AcidState PageState+ , pageClckURL :: ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text+ }++type PageT m = ClckT PageURL (ReaderT PageConfig m)+type PageT' url m = ClckT url (ReaderT PageConfig m)+type PageM = ClckT PageURL (ReaderT PageConfig (ServerPartT IO))+type PageAdminM = ClckT PageAdminURL (ReaderT PageConfig (ServerPartT IO))+++runPageT :: PageConfig -> PageT m a -> ClckT PageURL m a+runPageT mc m = mapClckT f m+ where+ f r = runReaderT r mc++runPageT'' :: Monad m =>+ (PageURL -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> PageConfig+ -> PageT m a+ -> ClckT url m a+runPageT'' showPageURL stripeConfig m = ClckT $ withRouteT flattenURL $ unClckT $ runPageT stripeConfig $ m+ where+ flattenURL :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> (PageURL -> [(T.Text, Maybe T.Text)] -> T.Text))+ flattenURL _ u p = showPageURL u p+++-- withRouteClckT ?+flattenURLClckT :: (url1 -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> ClckT url1 m a+ -> ClckT url2 m a+flattenURLClckT showClckURL m = ClckT $ withRouteT flattenURL $ unClckT m+ where+ flattenURL _ = \u p -> showClckURL u p++clckT2PageT :: (Functor m, MonadIO m, Typeable url1) =>+ ClckT url1 m a+ -> PageT m a+clckT2PageT m =+ do p <- plugins <$> get+ (Just clckShowFn) <- getPluginRouteFn p (pluginName clckPlugin)+ flattenURLClckT clckShowFn $ mapClckT addReaderT m+ where+ addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)+ addReaderT m =+ do (a, cs) <- lift m+ return (a, cs)++data PageFormError+ = PageCFE (CommonFormError [Input])+ deriving Show++instance FormError PageFormError where+ type ErrorInputType PageFormError = [Input]+ commonFormError = PageCFE++instance (Functor m, Monad m) => EmbedAsChild (PageT m) PageFormError where+ asChild e = asChild (show e)++type PageForm = ClckFormT PageFormError PageM++instance (Monad m) => MonadReader PageConfig (PageT' url m) where+ ask = ClckT $ ask+ local f (ClckT m) = ClckT $ local f m++instance (Functor m, Monad m) => GetAcidState (PageT' url m) PageState where+ getAcidState =+ pageState <$> ask++instance (IsName n) => EmbedAsAttr PageM (Attr n PageURL) where+ asAttr (n := u) =+ do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))++instance (IsName n) => EmbedAsAttr PageM (Attr n ClckURL) where+ asAttr (n := url) =+ do showFn <- pageClckURL <$> ask+ asAttr $ MkAttr (toName n, pAttrVal (T.unpack $ showFn url []))+++-- | convert 'Markup' to 'Content' that can be embedded. Generally by running the pre-processors needed.+-- markupToContent :: (Functor m, MonadIO m, Happstack m) => Markup -> ClckT url m Content+markupToContent :: (Functor m, MonadIO m, Happstack m) =>+ Markup+ -> ClckT url m Content+markupToContent Markup{..} =+ do clckState <- get+ transformers <- getPreProcessors (plugins clckState)+ (Just clckRouteFn) <- getPluginRouteFn (plugins clckState) (pluginName clckPlugin)+ (markup', clckState') <- liftIO $ runClckT clckRouteFn clckState (foldM (\txt pp -> pp txt) (TL.fromStrict markup) transformers)+ put clckState'+ e <- liftIO $ runPreProcessors preProcessors trust (TL.toStrict markup')+ case e of+ (Left err) -> return (PlainText err)+ (Right html) -> return (TrustedHtml html)++{-+-- | update the 'currentPage' field of 'ClckState'+setCurrentPage :: (MonadIO m) => PageId -> PageT m ()+setCurrentPage pid =+ modify $ \s -> s { pageCurrent = pid }+-}
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Clckwrks.Page.NavBarCallback where++import Clckwrks (ClckT, ClckURL, NamedLink(..), query)+import Clckwrks.Page.Acid (AllPublishedPages(..), PageState)+import Clckwrks.Page.Types (Page(..))+import Clckwrks.Page.URL (PageURL(..))+import Data.Acid (AcidState)+import Data.Acid.Advanced (query')+import Data.Function (on)+import Data.List (sortBy)+import Data.Text (Text)++navBarCallback :: AcidState PageState+ -> (PageURL -> [(Text, Maybe Text)] -> Text)+ -> ClckT ClckURL IO (String, [NamedLink])+navBarCallback acidPageState showPageURL =+ do pages <- query' acidPageState AllPublishedPages+ let blogLink = NamedLink { namedLinkTitle = "Blog", namedLinkURL = showPageURL Blog [] }+ pageLinks = map (\p -> NamedLink (pageTitle p) (showPageURL (ViewPage (pageId p)) [])) pages+ return ("Page", blogLink : (sortBy (compare `on` namedLinkTitle) pageLinks))
+ Clckwrks/Page/Plugin.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts, OverloadedStrings #-}+module Clckwrks.Page.Plugin where++import Clckwrks ( ClckwrksConfig(clckTopDir), ClckState(plugins), ClckT(..), ClckURL, ClckPlugins, Theme+ , Role(..), ClckPluginsSt, addAdminMenu, addNavBarCallback, addPreProc, query, update+ )+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))+import Clckwrks.Plugin (clckPlugin)+import Clckwrks.Page.Acid (PageState, GetOldUACCT(..), ClearOldUACCT(..), initialPageState)+import Clckwrks.Page.NavBarCallback (navBarCallback)+import Clckwrks.Page.Monad (PageConfig(..), runPageT)+import Clckwrks.Page.PreProcess (pageCmd)+import Clckwrks.Page.Route (routePage)+import Clckwrks.Page.URL (PageURL(..), PageAdminURL(..))+import Clckwrks.Page.Types (PageId(..))+import Control.Applicative ((<$>))+import Control.Monad.State (get)+import Data.Acid (AcidState)+import Data.Acid.Advanced (update', query')+import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom,)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Happstack.Server (ServerPartT, Response, notFound, toResponse)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Web.Routes (toPathInfo, parseSegments, withRouteT, fromPathSegments)+import Web.Plugins.Core (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, addPostHook, initPlugin, getConfig, getPluginRouteFn)++pageHandler :: (PageURL -> [(Text, Maybe Text)] -> Text)+ -> PageConfig+ -> ClckPlugins+ -> [Text]+ -> ClckT ClckURL (ServerPartT IO) Response+pageHandler showPageURL pageConfig plugins paths =+ case parseSegments fromPathSegments paths of+ (Left e) -> notFound $ toResponse (show e)+ (Right u) ->+ ClckT $ withRouteT flattenURL $ unClckT $ runPageT pageConfig $ routePage u+ where+ flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (PageURL -> [(Text, Maybe Text)] -> Text))+ flattenURL _ u p = showPageURL u p++pageInit :: ClckPlugins+ -> IO (Maybe Text)+pageInit plugins =+ do (Just pageShowFn) <- getPluginRouteFn plugins (pluginName pagePlugin)+ (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ mTopDir <- clckTopDir <$> getConfig plugins+ let basePath = maybe "_state" (\td -> td </> "_state") mTopDir -- FIXME+ pageDir = maybe "_page" (\td -> td </> "_page") mTopDir+ cacheDir = pageDir </> "_cache"+ createDirectoryIfMissing True cacheDir++ ips <- initialPageState+ acid <- openLocalStateFrom (basePath </> "page") ips+ addCleanup plugins Always (createCheckpointAndClose acid)++ let pageConfig = PageConfig { pageState = acid+ , pageClckURL = clckShowFn+ }++ addPreProc plugins (pageCmd acid pageShowFn)+ addNavBarCallback plugins (navBarCallback acid pageShowFn)+ addHandler plugins (pluginName pagePlugin) (pageHandler pageShowFn pageConfig)+ addPostHook plugins (migrateUACCT acid)++ return Nothing++addPageAdminMenu :: ClckT url IO ()+addPageAdminMenu =+ do p <- plugins <$> get+ (Just pageShowURL) <- getPluginRouteFn p (pluginName pagePlugin)+ let newPageURL = pageShowURL (PageAdmin NewPage) []+ pagesURL = pageShowURL (PageAdmin Pages) []+ feedConfigURL = pageShowURL (PageAdmin EditFeedConfig) []+ addAdminMenu ("Pages/Posts"+ , [ (Set.fromList [Administrator, Editor], "New Page/Post" , newPageURL)+ , (Set.fromList [Administrator, Editor], "Edit Page/Post" , pagesURL)+ , (Set.fromList [Administrator, Editor], "Edit Feed Config", feedConfigURL)+ ]+ )++migrateUACCT :: AcidState PageState -> ClckT url IO ()+migrateUACCT acidPageState =+ do mOldUACCT <- query' acidPageState GetOldUACCT+ case mOldUACCT of+ Nothing -> return ()+ (Just uacct) ->+ do mNewUACCT <- query GetUACCT+ case mNewUACCT of+ Nothing -> update (SetUACCT $ Just uacct)+ (Just _) -> update' acidPageState ClearOldUACCT++pagePlugin :: Plugin PageURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+pagePlugin = Plugin+ { pluginName = "page"+ , pluginInit = pageInit+ , pluginDepends = ["clck"]+ , pluginToPathInfo = toPathInfo+ , pluginPostHook = addPageAdminMenu+ }++plugin :: ClckPlugins -- ^ plugins+ -> Text -- ^ baseURI+ -> IO (Maybe Text)+plugin plugins baseURI =+ initPlugin plugins baseURI pagePlugin+
+ Clckwrks/Page/PreProcess.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.PreProcess where++import Control.Monad.Trans (MonadIO(..))+import Control.Applicative ((<*>), (*>), (<$>), (<|>), optional)+import Clckwrks.Monad (ClckT, ClckState, transform, query, segments)+import Clckwrks.Page.Acid (GetPageTitle(..), PageState)+import Clckwrks.Page.URL (PageURL(ViewPageSlug))+import Clckwrks.Page.Types (PageId(..), slugify, toSlug)+import Data.Acid (AcidState(..))+import Data.Acid.Advanced (query')+import Data.Attoparsec.Text.Lazy (Parser, Result(..), anyChar, char, choice, decimal, parse, skipMany, space, stringCI, skipMany, try)+import Data.Attoparsec.Combinator (many1, manyTill, skipMany)+import Data.String (fromString)+import Data.Text (Text, pack)+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as B+import HSP+import HSP.HTML (renderAsHTML)+import Web.Routes (showURL)++-- TODO: move to reusable module+parseAttr :: Text -> Parser ()+parseAttr name =+ do skipMany space+ stringCI name+ skipMany space+ char '='+ skipMany space++qchar :: Parser Char+qchar = (char '\\' *> anyChar) <|> anyChar++text :: Parser Text+text = pack <$> many1 qchar++qtext :: Parser Text+qtext = pack <$> (char '"' *> manyTill qchar (try $ char '"'))++data PageCmd+ = LinkPage PageId (Maybe Text)+ deriving (Eq, Ord, Show)++pageId :: Parser PageCmd+pageId = LinkPage <$> (parseAttr (fromString "id") *> (PageId <$> decimal)) <*> (optional $ parseAttr (fromString "title") *> qtext)++parseCmd :: Parser PageCmd+parseCmd = pageId++pageCmd :: (Functor m, MonadIO m) =>+ AcidState PageState+ -> (PageURL -> [(Text, Maybe Text)] -> Text)+ -> TL.Text+ -> ClckT url m TL.Text+pageCmd pageAcid clckShowURL txt =+ case parse (segments "page" parseCmd) txt of+ (Fail _ _ e) -> return (TL.pack e)+ (Done _ segments) ->+ do b <- transform (applyCmd pageAcid clckShowURL) segments+ return $ B.toLazyText b++applyCmd pageAcid clckShowURL l@(LinkPage pid mTitle) =+ do (ttl, slug) <-+ case mTitle of+ (Just t) -> return (t, Just $ slugify t)+ Nothing -> do mttl <- query' pageAcid (GetPageTitle pid)+ case mttl of+ Nothing -> return $ (pack "Untitled", Nothing)+ (Just ttlSlug) -> return ttlSlug+ html <- unXMLGenT $ <a href=(clckShowURL (ViewPageSlug pid (toSlug ttl slug)) [])><% ttl %></a>+ return $ B.fromString $ concat $ lines $ renderAsHTML html
+ Clckwrks/Page/Route.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+module Clckwrks.Page.Route where++import Clckwrks (Role(..), requiresRole_)+import Clckwrks.Monad ( ClckState(plugins), query+ , update, setUnique, themeTemplate, nestURL+ )+import Clckwrks.Page.Types (Page(..), PageId(..), toSlug)+import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..), PageById(..))+import Clckwrks.Page.Admin.EditFeedConfig (editFeedConfig)+import Clckwrks.Page.Admin.EditPage (editPage)+import Clckwrks.Page.Admin.NewPage (newPage)+import Clckwrks.Page.Admin.Pages (pages)+import Clckwrks.Page.Admin.PreviewPage (previewPage)+import Clckwrks.Page.Atom (handleAtomFeed)+import Clckwrks.Page.Monad (PageConfig(pageClckURL), PageM, clckT2PageT, markupToContent)+import Clckwrks.Page.Types (PageKind(PlainPage, Post))+import Clckwrks.Page.BlogPage (blog)+import Clckwrks.Page.URL (PageURL(..), PageAdminURL(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get)+import Data.Text (Text)+import qualified Data.Set as Set+import Happstack.Server ( Response, Happstack, escape, notFound, toResponse+ , ok, internalServerError+ )+import HSP (unXMLGenT)+import Web.Routes.Happstack (seeOtherURL)+import Web.Plugins.Core (getTheme)++checkAuth :: PageURL+ -> PageM PageURL+checkAuth url =+ do showFn <- pageClckURL <$> ask+ let requiresRole = requiresRole_ showFn+ case url of+ ViewPage{} -> return url+ ViewPageSlug{} -> return url+ Blog{} -> return url+ AtomFeed{} -> return url+ PageAdmin {} -> requiresRole (Set.singleton Administrator) url++-- | routes for 'AdminURL'+routePageAdmin :: PageAdminURL -> PageM Response+routePageAdmin url =+ case url of+ (EditPage pid) -> editPage (PageAdmin url) pid+ NewPage -> newPage PlainPage+ NewPost -> newPage Post+ (PreviewPage pid) -> previewPage pid -- FIXME+ EditFeedConfig -> editFeedConfig (PageAdmin url)+ Pages -> pages++routePage :: PageURL+ -> PageM Response+routePage url' =+ do url <- checkAuth url'+ setUnique 0+ case url of+ (ViewPage pid) ->+ do r <- query (GetPageTitle pid)+ case r of+ Nothing ->+ notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid))+ (Just (title, slug)) ->+ seeOtherURL (ViewPageSlug pid (toSlug title slug))++ (ViewPageSlug pid _slug) ->+ do published <- query (IsPublishedPage pid)+ if published+ then do cs <- get+ (Just page) <- query (PageById pid)+ let ttl = pageTitle page+ bdy <- markupToContent (pageSrc page)+ clckT2PageT $ themeTemplate (plugins cs) ttl () bdy+ else do notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid))++ (Blog) -> blog++ AtomFeed ->+ do handleAtomFeed++ (PageAdmin adminURL) -> routePageAdmin adminURL
+ Clckwrks/Page/Types.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+module Clckwrks.Page.Types where++import Clckwrks.Markup.HsColour (hscolour)+import Clckwrks.Markup.Markdown (markdown)+import Clckwrks.Types (Trust(..))+import Control.Applicative ((<$>), optional)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Aeson (ToJSON(..), FromJSON(..))+import Data.Char (ord, toLower, isAlphaNum)+import Data.Data (Data, Typeable)+import Data.Maybe (fromMaybe)+import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.String (IsString, fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.UUID (UUID)+import Data.UUID.V5 (generateNamed, namespaceOID)+import Happstack.Auth (UserId(..))+import Web.Routes (PathInfo(..), anySegment)+import System.Random (randomIO)+++-- $(deriveSafeCopy 0 'base ''UUID)++instance PathInfo PageId where+ toPathSegments (PageId i) = toPathSegments i+ fromPathSegments = PageId <$> fromPathSegments++newtype PageId = PageId { unPageId :: Integer }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageId)++instance ToJSON PageId where+ toJSON (PageId i) = toJSON i+instance FromJSON PageId where+ parseJSON n = PageId <$> parseJSON n++data PreProcessor+ = HsColour+ | Markdown+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PreProcessor)++-- $(deriveJSON id ''PreProcessor)++runPreProcessors :: (MonadIO m) => [PreProcessor] -> Trust -> Text -> m (Either Text Text)+runPreProcessors [] _ txt = return (Right txt)+runPreProcessors (p:ps) trust txt =+ do e <- runPreProcessor p trust txt+ case e of+ (Left e) -> return (Left e)+ (Right txt') -> runPreProcessors ps trust txt'++runPreProcessor :: (MonadIO m) => PreProcessor -> Trust -> Text -> m (Either Text Text)+runPreProcessor pproc trust txt =+ do let f = case pproc of+ Markdown -> markdown Nothing trust+ HsColour -> hscolour Nothing+ f txt++data Markup_001+ = Markup_001 { preProcessors_001 :: [PreProcessor]+ , markup_001 :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''Markup_001)++data Markup+ = Markup { preProcessors :: [PreProcessor]+ , markup :: Text+ , trust :: Trust+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''Markup)++instance Migrate Markup where+ type MigrateFrom Markup = Markup_001+ migrate (Markup_001 pp mu) = Markup pp mu Trusted++data PublishStatus+ = Draft+ | Revoked+ | Published+ | Scheduled+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PublishStatus)++publishStatusString :: PublishStatus -> String+publishStatusString Draft = "draft"+publishStatusString Revoked = "revoked"+publishStatusString Published = "published"+publishStatusString Scheduled = "scheduled"+++data PageKind+ = PlainPage+ | Post+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageKind)++data Page_001+ = Page_001 { pageId_001 :: PageId+ , pageTitle_001 :: Text+ , pageSrc_001 :: Markup+ , pageExcerpt_001 :: Maybe Markup+ , pageDate_001 :: Maybe UTCTime+ , pageStatus_001 :: PublishStatus+ , pageKind_001 :: PageKind+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''Page_001)++data Page_002+ = Page_002 { pageId_002 :: PageId+ , pageAuthor_002 :: UserId+ , pageTitle_002 :: Text+ , pageSrc_002 :: Markup+ , pageExcerpt_002 :: Maybe Markup+ , pageDate_002 :: UTCTime+ , pageUpdated_002 :: UTCTime+ , pageStatus_002 :: PublishStatus+ , pageKind_002 :: PageKind+ , pageUUID_002 :: UUID+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''Page_002)++instance Migrate Page_002 where+ type MigrateFrom Page_002 = Page_001+ migrate (Page_001 pi pt ps pe pd pst pk) =+ (Page_002 pi (UserId 1) pt ps pe (fromMaybe epoch pd) (fromMaybe epoch pd) pst pk $ generateNamed namespaceOID (map (fromIntegral . ord) (show pi ++ show ps)))+ where+ epoch = posixSecondsToUTCTime 0++newtype Slug = Slug { unSlug :: Text }+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''Slug)++instance PathInfo Slug where+ toPathSegments (Slug txt) = [txt]+ fromPathSegments = Slug <$> anySegment++-- NOTE: this instance will cause faulty behavior if the Maybe Slug is not at the end of the URL+instance PathInfo (Maybe Slug) where+ toPathSegments (Just slug) = toPathSegments slug+ fromPathSegments = optional $ fromPathSegments++slugify :: Text -> Slug+slugify txt = Slug $ Text.dropWhileEnd (=='-') $ Text.map (\c -> if isAlphaNum c then (toLower c) else '-') txt++toSlug :: Text -> Maybe Slug -> Slug+toSlug txt slug = fromMaybe (slugify txt) slug++data Page+ = Page { pageId :: PageId+ , pageAuthor :: UserId+ , pageTitle :: Text+ , pageSlug :: Maybe Slug+ , pageSrc :: Markup+ , pageExcerpt :: Maybe Markup+ , pageDate :: UTCTime+ , pageUpdated :: UTCTime+ , pageStatus :: PublishStatus+ , pageKind :: PageKind+ , pageUUID :: UUID+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 3 'extension ''Page)++instance Migrate Page where+ type MigrateFrom Page = Page_002+ migrate (Page_002 pi pa pt ps pe pd pu pst pk puu) =+ (Page pi pa pt Nothing ps pe pd pu pst pk puu)++instance Indexable Page where+ empty = ixSet [ ixFun ((:[]) . pageId)+ , ixFun ((:[]) . pageDate)+ , ixFun ((:[]) . pageKind)+ , ixFun ((:[]) . pageDate)+ , ixFun ((:[]) . pageStatus)+ ]++type Pages = IxSet Page++data FeedConfig = FeedConfig+ { feedUUID :: UUID -- ^ UUID which identifies this feed. Should probably never change+-- , feedCategory :: Set Text+ , feedTitle :: Text+ , feedLink :: Text+ , feedAuthorName :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''FeedConfig)++initialFeedConfig :: IO FeedConfig+initialFeedConfig =+ do uuid <- randomIO+ return $ FeedConfig { feedUUID = uuid+ , feedTitle = fromString "Untitled Feed"+ , feedLink = fromString ""+ , feedAuthorName = fromString "Anonymous"+ }
+ Clckwrks/Page/URL.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+module Clckwrks.Page.URL where++import Data.Data (Data, Typeable)+import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy)+import Clckwrks.Page.Acid (PageId(..))+import Clckwrks.Page.Types (Slug(..))+import Web.Routes.TH (derivePathInfo)++data PageAdminURL+ = EditPage PageId+ | PreviewPage PageId+ | Pages+ | NewPage+ | NewPost+ | EditFeedConfig+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''PageAdminURL)+$(derivePathInfo ''PageAdminURL)++data PageURL+ = ViewPage PageId+ | ViewPageSlug PageId Slug+ | Blog+ | AtomFeed+ | PageAdmin PageAdminURL+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''PageURL)+$(derivePathInfo ''PageURL)
+ Clckwrks/Page/Verbatim.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Clckwrks.Page.Verbatim+ ( verbatimText+ ) where++import qualified Data.Text as Text+import Language.Haskell.TH.Quote++verbatimText :: QuasiQuoter+verbatimText = QuasiQuoter+ { quoteExp = \s -> [| Text.pack s |]+ , quotePat = error "verbatim-text: quotePat not supported."+ , quoteType = error "verbatim-text: quotePat not supported."+ , quoteDec = error "verbatim-text: quotePat not supported."+ }+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ clckwrks-plugin-page.cabal view
@@ -0,0 +1,70 @@+name: clckwrks-plugin-page+version: 0.1.2+synopsis: support for CMS/Blogging in clckwrks+homepage: http://www.clckwrks.com/+license: BSD3+license-file: LICENSE+copyright: 2012, 2013 Jeremy Shaw, SeeReason Partners LLC+author: Jeremy Shaw+maintainer: jeremy@n-heptane.com+category: Clckwrks+build-type: Custom+cabal-version: >=1.8++source-repository head+ type: darcs+ subdir: clckwrks-plugin-page+ location: http://hub.darcs.net/stepcut/clckwrks++library+ build-tools:+ trhsx++ exposed-modules: Clckwrks.Page.Monad+ Clckwrks.Page.Route+ Clckwrks.Page.Types+ Clckwrks.Page.NavBarCallback+ Clckwrks.Page.Plugin+ Clckwrks.Page.PreProcess+ Clckwrks.Page.API+ Clckwrks.Page.Acid+ Clckwrks.Page.BlogPage+ Clckwrks.Page.Admin.EditFeedConfig+ Clckwrks.Page.Admin.EditPage+ Clckwrks.Page.Admin.NewPage+ Clckwrks.Page.Admin.Pages+ Clckwrks.Page.Admin.PreviewPage+ Clckwrks.Page.URL+ Clckwrks.Page.Atom+ other-modules:+ Clckwrks.Page.Verbatim+ build-depends: base == 4.6.*,+ aeson == 0.6.*,+ acid-state == 0.8.*,+ attoparsec == 0.10.*,+ clckwrks == 0.16.*,+ containers >= 0.4 && < 0.6,+ directory == 1.2.*,+ filepath == 1.3.*,+ happstack-authenticate == 0.10.*,+ happstack-hsp == 7.1.*,+ happstack-server >= 7.0 && < 7.2,+ hsp == 0.7.*,+ ixset == 1.0.*,+ mtl == 2.1.*,+ old-locale == 1.0.*,+ random == 1.0.*,+ reform == 0.1.*,+ reform-happstack == 0.1.*,+ reform-hsp == 0.1.*,+ safecopy == 0.8.*,+ tagsoup == 0.12.*,+ text == 0.11.*,+ time == 1.4.*,+ template-haskell >= 2.7 && <= 2.9,+ uuid == 1.2.*,+ utf8-string == 0.3.*,+ web-plugins == 0.2.*,+ web-routes == 0.27.*,+ web-routes-happstack == 0.23.*,+ web-routes-th == 0.22.*