clckwrks-plugin-page 0.1.8 → 0.2.0
raw patch · 13 files changed
+95/−72 lines, 13 filesdep ~acid-statedep ~clckwrksdep ~happstack-hspsetup-changed
Dependency ranges changed: acid-state, clckwrks, happstack-hsp, happstack-server, hsp, reform, reform-happstack, reform-hsp
Files
- Clckwrks/Page/API.hs +9/−7
- Clckwrks/Page/Admin/EditFeedConfig.hs +11/−8
- Clckwrks/Page/Admin/EditPage.hs +19/−17
- Clckwrks/Page/Admin/NewPage.hs +6/−2
- Clckwrks/Page/Admin/Pages.hs +8/−5
- Clckwrks/Page/Admin/PreviewPage.hs +6/−3
- Clckwrks/Page/Atom.hs +8/−6
- Clckwrks/Page/BlogPage.hs +5/−2
- Clckwrks/Page/Monad.hs +7/−6
- Clckwrks/Page/PreProcess.hs +3/−3
- Clckwrks/Page/Route.hs +1/−1
- Setup.hs +2/−2
- clckwrks-plugin-page.cabal +10/−10
Clckwrks/Page/API.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts, RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.API ( PageId(..) -- , getPage@@ -30,12 +30,14 @@ import Control.Applicative ((<$>)) import Control.Monad.State (get) import Control.Monad.Trans (MonadIO)-import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (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.XMLGenerator hiding (escape)+import HSP.XML (XML, cdata, fromStringLit) import HSP.Google.Analytics (analyticsAsync) import Text.HTML.TagSoup ( (~==), isTagCloseName, isTagOpenName, parseTags , renderTags, sections)@@ -64,7 +66,7 @@ do mrkup <- pageSrc <$> getPage markupToContent mrkup -}-getPagesSummary :: PageM [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)]+getPagesSummary :: PageM [(PageId, T.Text, Maybe Slug, UTCTime, UserId, PublishStatus)] getPagesSummary = query PagesSummary getPageMenu :: GenXML PageM@@ -85,7 +87,7 @@ (Just pge) -> extractExcerpt pge -getBlogTitle :: PageM Text+getBlogTitle :: PageM T.Text getBlogTitle = query GetBlogTitle extractExcerpt :: (MonadIO m, Functor m, Happstack m) =>@@ -100,7 +102,7 @@ case c of (TrustedHtml html) -> let tags = parseTags html- paragraphs = sections (~== "<p>") tags+ paragraphs = sections (~== ("<p>" :: String)) 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
Clckwrks/Page/Admin/EditFeedConfig.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.EditFeedConfig where import Clckwrks (ClckURL(Admin), AdminURL(Console), query, update)@@ -10,9 +10,11 @@ import Clckwrks.Page.URL (PageURL(..)) import Control.Applicative ((<$>), (<*), (<*>)) import Control.Monad.Reader (ask)-import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Text.Lazy (Text) import Happstack.Server (Response, seeOther, toResponse)-import HSP+import HSP.XML+import HSP.XMLGenerator import Text.Reform import Text.Reform.Happstack import Text.Reform.HSP.Text@@ -20,7 +22,7 @@ editFeedConfig :: PageURL -> PageM Response editFeedConfig here =- do feedConfig <- query $ GetFeedConfig+ do feedConfig <- query GetFeedConfig action <- showURL here template "edit feed config" () $ <%>@@ -39,17 +41,18 @@ fieldset $ ((,) <$> (divControlGroup (label' "Feed Title" ++> (divControls $ inputText feedTitle))) <*> (divControlGroup (label' "Default Author Name" ++> (divControls $ inputText feedAuthorName)))- <* (divControlGroup (divControls $ (inputSubmit (pack "Update") `setAttrs`[("class" := "btn")])))+ <* (divControlGroup (divControls $ (inputSubmit (T.pack "Update") `setAttrs`[("class" := "btn") :: Attr Text Text]))) ) `transformEither` toFeedConfig where- label' str = (label str `setAttrs` [("class":="control-label")])+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) 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 :: (T.Text, T.Text) -> Either PageFormError FeedConfig toFeedConfig (ttl, athr) = Right $ fc { feedTitle = ttl , feedAuthorName = athr }+
Clckwrks/Page/Admin/EditPage.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.EditPage ( editPage ) where@@ -12,12 +12,14 @@ 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.Text.Lazy (Text) import Data.Time.Clock (getCurrentTime)+import HSP.XML+import HSP.XMLGenerator 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)+import Text.Reform.HSP.Text (form, button, inputCheckbox, inputText, labelText, inputSubmit, select, textarea, fieldset, ol, li, setAttrs) data AfterSaveAction = EditSomeMore@@ -50,26 +52,26 @@ 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")])))+ <$> (divControlGroup (label' "Page Type" ++> (divControls $ select [(PlainPage, ("page" :: Text)), (Post, "post")] (== (pageKind page)))))+ <*> (divControlGroup (label' "Title" ++> (divControls $ inputText (pageTitle page) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge") :: Attr Text Text])))+ <*> (divControlGroup (label' "Slug (optional)" ++> (divControls $ inputText (maybe Text.empty unSlug $ pageSlug page) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge") :: Attr Text Text])))+ <*> (divControlGroup (divControls (inputCheckboxLabel ("Highlight Haskell code using HsColour" :: Text) hsColour)))+ <*> (divControlGroup (label' "Body" ++> (divControls $ textarea 80 25 (markup (pageSrc page)) `setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]))) <*> (divFormActions- ((,,) <$> (inputSubmit' (pack "Save"))- <*> (inputSubmit' (pack "Preview") `setAttrs` ("class" := "btn btn-info"))+ ((,,) <$> (inputSubmit' (Text.pack "Save"))+ <*> (inputSubmit' (Text.pack "Preview") `setAttrs` (("class" := "btn btn-info") :: Attr Text Text)) <*> newPublishStatus (pageStatus page))) ) `transformEitherM` toPage where- inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]+ inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn") :: Attr Text Text] inputCheckboxLabel lbl b = mapView (\xml -> [<label class="checkbox"><% xml %><% lbl %></label>]) (inputCheckbox b) - label' str = (label str `setAttrs` [("class":="control-label")])+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) - labelCB str = label str `setAttrs` [("class":="checkbox")]+ labelCB str = labelText str `setAttrs` [("class":="checkbox") :: Attr Text Text] -- 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>])@@ -77,11 +79,11 @@ 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")])+ newPublishStatus Published = fmap (const Draft) <$> (inputSubmit' (Text.pack "Unpublish") `setAttrs` [("class" := "btn btn-warning") :: Attr Text Text])+ newPublishStatus _ = fmap (const Published) <$> (inputSubmit' (Text.pack "Publish") `setAttrs` [("class" := "btn btn-success") :: Attr Text Text]) hsColour = HsColour `elem` (preProcessors $ pageSrc page) toPage :: (MonadIO m) =>- (PageKind, Text, Text, Bool, Text, (Maybe Text, Maybe Text, Maybe PublishStatus))+ (PageKind, Text.Text, Text.Text, Bool, Text.Text, (Maybe Text.Text, Maybe Text.Text, Maybe PublishStatus)) -> m (Either PageFormError (Page, AfterSaveAction)) toPage (kind, ttl, slug, haskell, bdy, (msave, mpreview, mpagestatus)) = do now <- liftIO $ getCurrentTime
Clckwrks/Page/Admin/NewPage.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.NewPage where import Clckwrks@@ -8,6 +9,9 @@ import Clckwrks.Admin.Template (template) import Data.UUID () -- instance Random UUID import Data.Time.Clock (getCurrentTime)+import Data.Text.Lazy (Text)+import HSP.XML+import HSP.XMLGenerator import System.Random (randomIO) newPage :: PageKind -> PageM Response@@ -29,7 +33,7 @@ now <- liftIO $ getCurrentTime muid <- getUserId case muid of- Nothing -> escape $ internalServerError $ toResponse "Clcwrks.Admin.NewPage.newPage was unable to obtain the current UserId"+ Nothing -> escape $ internalServerError $ toResponse ("Clcwrks.Admin.NewPage.newPage was unable to obtain the current UserId" :: Text) (Just uid) -> do page <- update (Acid.NewPage pageKind uid uuid now) seeOtherURL (PageAdmin $ EditPage (pageId page))
Clckwrks/Page/Admin/Pages.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.Pages where import Clckwrks (UserId)@@ -8,17 +9,19 @@ import Clckwrks.Page.Monad (PageM) import Clckwrks.Page.URL (PageAdminURL(..), PageURL(..)) import Clckwrks.Page.Types (PageId(..), PublishStatus(..), Slug(..), publishStatusString)-import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (Text) import Data.Time (UTCTime) import Happstack.Server (Response)-import HSP+import HSP.XML+import HSP.XMLGenerator pages :: PageM Response pages = do pages <- query PagesSummary template "Page List" () $ editList pages -editList :: [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)]+editList :: [(PageId, T.Text, Maybe Slug, UTCTime, UserId, PublishStatus)] -> GenChildList PageM editList [] = <%><p>There are currently no pages.</p></%> editList pgs =@@ -38,7 +41,7 @@ </table> </%> where- editPageTR :: (PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus) -> GenXML PageM+ editPageTR :: (PageId, T.Text, Maybe Slug, UTCTime, UserId, PublishStatus) -> GenXML PageM editPageTR (pid, ttl, _slug, updated, userId, published) = <tr> <td><% show $ unPageId pid %></td>
Clckwrks/Page/Admin/PreviewPage.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.PreviewPage ( previewPage ) where@@ -12,6 +12,8 @@ import Clckwrks.Unauthorized () import Control.Monad.State (get) import qualified Data.Set as Set+import Data.Text.Lazy (Text)+import HSP.XMLGenerator import Web.Plugins.Core (getTheme) previewPage :: PageId -> PageM Response@@ -31,5 +33,6 @@ (Just page) <- query (PageById pid) let ttl = pageTitle page bdy <- markupToContent (pageSrc page)+ addHeaderM "X-XSS-Protection" "0" clckT2PageT $ themeTemplate (plugins cs) ttl () bdy- else unauthorized (toResponse $ "Sorry, you need Administrator access to view this page.")+ else unauthorized (toResponse $ ("Sorry, you need Administrator access to view this page." :: Text))
Clckwrks/Page/Atom.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Atom where import Control.Monad.Trans (liftIO)@@ -11,16 +11,18 @@ import Clckwrks.Page.URL import qualified Data.ByteString.Lazy.UTF8 as UTF8 import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import Data.String (fromString)-import Data.Text (Text, pack) import qualified Data.Text as Text+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.Encoding as TL 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 HSP.XMLGenerator+import HSP.XML (XML, cdata, renderXML, fromStringLit) import System.Locale (defaultTimeLocale) import Web.Routes (showURL) @@ -92,4 +94,4 @@ 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)+ ok $ toResponseBS (fromString "application/atom+xml;charset=utf-8") ((UTF8.fromString $ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") <> (TL.encodeUtf8 $ renderXML xml))
Clckwrks/Page/BlogPage.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.BlogPage where import Clckwrks@@ -8,6 +8,9 @@ import Clckwrks.Page.Types import Clckwrks.Page.URL import Control.Monad.State (get)+import HSP.XML (XML, fromStringLit)+import HSP.XMLGenerator+import Data.Text.Lazy (Text) postsHTML :: XMLGenT PageM XML postsHTML =
Clckwrks/Page/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-} module Clckwrks.Page.Monad where import Control.Applicative ((<$>))@@ -21,7 +21,8 @@ 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 HSP.XMLGenerator+import HSP.XML import Text.Reform (CommonFormError, FormError(..)) import Web.Plugins.Core (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn) import Web.Routes (RouteT(..), showURL, withRouteT)@@ -95,15 +96,15 @@ getAcidState = pageState <$> ask -instance (IsName n) => EmbedAsAttr PageM (Attr n PageURL) where+instance (IsName n TL.Text) => EmbedAsAttr PageM (Attr n PageURL) where asAttr (n := u) = do url <- showURL u- asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict url)) -instance (IsName n) => EmbedAsAttr PageM (Attr n ClckURL) where+instance (IsName n TL.Text) => EmbedAsAttr PageM (Attr n ClckURL) where asAttr (n := url) = do showFn <- pageClckURL <$> ask- asAttr $ MkAttr (toName n, pAttrVal (T.unpack $ showFn url []))+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict $ showFn url [])) -- | convert 'Markup' to 'Content' that can be embedded. Generally by running the pre-processors needed.
Clckwrks/Page/PreProcess.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.PreProcess where import Control.Monad.Trans (MonadIO(..))@@ -18,7 +18,7 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as B import HSP-import HSP.HTML (renderAsHTML)+import HSP.HTML4 (renderAsHTML) import Web.Routes (showURL) -- TODO: move to reusable module@@ -84,7 +84,7 @@ case linkOnly of False -> do html <- unXMLGenT $ <a href=(clckShowURL (ViewPageSlug pid (toSlug ttl slug)) [])><% ttl %></a>- return $ B.fromString $ concat $ lines $ renderAsHTML html+ return $ B.fromString $ concat $ lines $ TL.unpack $ renderAsHTML html -- FIXME: don't pass through String to do this True -> return $ B.fromText $ clckShowURL (ViewPageSlug pid (toSlug ttl slug)) []
Clckwrks/Page/Route.hs view
@@ -25,7 +25,7 @@ import Happstack.Server ( Response, Happstack, escape, notFound, toResponse , ok, internalServerError )-import HSP (unXMLGenT)+import HSP.XMLGenerator (unXMLGenT) import Web.Routes.Happstack (seeOtherURL) import Web.Plugins.Core (getTheme)
Setup.hs view
@@ -5,9 +5,9 @@ import Distribution.Simple import Distribution.Simple.Program -trhsxProgram = simpleProgram "trhsx"+hsx2hsProgram = simpleProgram "hsx2hs" main :: IO () main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [trhsxProgram]+ hookedPrograms = [hsx2hsProgram] }
clckwrks-plugin-page.cabal view
@@ -1,5 +1,5 @@ name: clckwrks-plugin-page-version: 0.1.8+version: 0.2.0 synopsis: support for CMS/Blogging in clckwrks homepage: http://www.clckwrks.com/ license: BSD3@@ -18,7 +18,7 @@ library build-tools:- trhsx+ hsx2hs exposed-modules: Clckwrks.Page.Monad Clckwrks.Page.Route@@ -40,23 +40,23 @@ Clckwrks.Page.Verbatim build-depends: base >= 4.3 && < 4.7, aeson == 0.6.*,- acid-state == 0.8.*,+ acid-state == 0.11.*, attoparsec == 0.10.*,- clckwrks >= 0.16 && < 0.18,+ clckwrks >= 0.18 && < 0.19, containers >= 0.4 && < 0.6, directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4, happstack-authenticate == 0.10.*,- happstack-hsp == 7.1.*,- happstack-server >= 7.0 && < 7.2,- hsp == 0.7.*,+ happstack-hsp == 7.2.*,+ happstack-server >= 7.0 && < 7.4,+ hsp == 0.9.*, ixset == 1.0.*, mtl >= 2.0 && < 2.3, old-locale == 1.0.*, random == 1.0.*,- reform == 0.1.*,- reform-happstack == 0.1.*,- reform-hsp == 0.1.*,+ reform == 0.2.*,+ reform-happstack == 0.2.*,+ reform-hsp == 0.2.*, safecopy == 0.8.*, tagsoup == 0.12.*, text == 0.11.*,