diff --git a/Clckwrks/Page/API.hs b/Clckwrks/Page/API.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/API.hs @@ -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 + [] ->
No pages found.
+ _ -> + +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 (~== "

") 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 diff --git a/Clckwrks/Page/Acid.hs b/Clckwrks/Page/Acid.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Acid.hs @@ -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 + ]) diff --git a/Clckwrks/Page/Admin/EditFeedConfig.hs b/Clckwrks/Page/Admin/EditFeedConfig.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Admin/EditFeedConfig.hs @@ -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 -> [

<% xml %>
]) + divControlGroup = mapView (\xml -> [
<% xml %>
]) + divControls = mapView (\xml -> [
<% xml %>
]) + + toFeedConfig :: (Text, Text) -> Either PageFormError FeedConfig + toFeedConfig (ttl, athr) = + Right $ fc { feedTitle = ttl + , feedAuthorName = athr + } diff --git a/Clckwrks/Page/Admin/EditPage.hs b/Clckwrks/Page/Admin/EditPage.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Admin/EditPage.hs @@ -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 -> []) + (inputCheckbox b) + + label' str = (label str `setAttrs` [("class":="control-label")]) + + labelCB str = label str `setAttrs` [("class":="checkbox")] +-- divInline = mapView (\xml -> [
<% xml %>
]) + divFormActions = mapView (\xml -> [
<% xml %>
]) + divHorizontal = mapView (\xml -> [
<% xml %>
]) + divControlGroup = mapView (\xml -> [
<% xml %>
]) + divControls = mapView (\xml -> [
<% xml %>
]) + + 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 + ) diff --git a/Clckwrks/Page/Admin/NewPage.hs b/Clckwrks/Page/Admin/NewPage.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Admin/NewPage.hs @@ -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" () $ + <%> +
+ +
+
+ +
+ + + <|> + 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)) diff --git a/Clckwrks/Page/Admin/Pages.hs b/Clckwrks/Page/Admin/Pages.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Admin/Pages.hs @@ -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 [] = <%>

There are currently no pages.

+editList pgs = + <%> + + + + + + + + + + + <% mapM editPageTR pgs %> + +
Page IdTitleLast UpdatedStatus
+ + where + editPageTR :: (PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus) -> GenXML PageM + editPageTR (pid, ttl, _slug, updated, userId, published) = + + <% show $ unPageId pid %> + <% ttl %> + <% updated %> + <% publishStatusString published %> + diff --git a/Clckwrks/Page/Admin/PreviewPage.hs b/Clckwrks/Page/Admin/PreviewPage.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Admin/PreviewPage.hs @@ -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.") diff --git a/Clckwrks/Page/Atom.hs b/Clckwrks/Page/Atom.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Atom.hs @@ -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 $ + <% feedTitle %> + + + + <% feedAuthorName %> + + <% atomDate $ mostRecentUpdate pages %> + <% "urn:uuid:" ++ toString feedUUID %> + <% mapM entry pages %> + + +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 $ + <% pageTitle %> + + <% "urn:uuid:" ++ toString pageUUID %> + <% author %> + <% atomDate pageUpdated %> + <% atomContent pageSrc %> + + 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 -> + + <% n %> + + +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 $ <% txt %> + (TrustedHtml html) -> + unXMLGenT $ <% html %> + +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 $ "\n" ++ renderXML xml) diff --git a/Clckwrks/Page/BlogPage.hs b/Clckwrks/Page/BlogPage.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/BlogPage.hs @@ -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 +
    + <% mapM postHTML posts %> +
+ +postHTML :: Page -> XMLGenT PageM XML +postHTML Page{..} = +
  • +

    <% pageTitle %>

    + <% pageDate %> + <% (markupToContent pageSrc) :: PageM Content %> +

    permalink

    +
    • + +blog :: PageM Response +blog = + do ttl <- getBlogTitle + cs <- get + + bdy <- unXMLGenT $ +
    + <% postsHTML %> +
    + + clckT2PageT $ themeTemplate (plugins cs) ttl () bdy diff --git a/Clckwrks/Page/Monad.hs b/Clckwrks/Page/Monad.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Monad.hs @@ -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 } +-} diff --git a/Clckwrks/Page/NavBarCallback.hs b/Clckwrks/Page/NavBarCallback.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/NavBarCallback.hs @@ -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)) diff --git a/Clckwrks/Page/Plugin.hs b/Clckwrks/Page/Plugin.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Plugin.hs @@ -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 + diff --git a/Clckwrks/Page/PreProcess.hs b/Clckwrks/Page/PreProcess.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/PreProcess.hs @@ -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 $ <% ttl %> + return $ B.fromString $ concat $ lines $ renderAsHTML html diff --git a/Clckwrks/Page/Route.hs b/Clckwrks/Page/Route.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Route.hs @@ -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 diff --git a/Clckwrks/Page/Types.hs b/Clckwrks/Page/Types.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Types.hs @@ -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" + } diff --git a/Clckwrks/Page/URL.hs b/Clckwrks/Page/URL.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/URL.hs @@ -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) diff --git a/Clckwrks/Page/Verbatim.hs b/Clckwrks/Page/Verbatim.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Page/Verbatim.hs @@ -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." + } + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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] + } diff --git a/clckwrks-plugin-page.cabal b/clckwrks-plugin-page.cabal new file mode 100644 --- /dev/null +++ b/clckwrks-plugin-page.cabal @@ -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.*