diff --git a/Clckwrks/Page/API.hs b/Clckwrks/Page/API.hs --- a/Clckwrks/Page/API.hs +++ b/Clckwrks/Page/API.hs @@ -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 (~== "

") tags + paragraphs = sections (~== ("

" :: 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 diff --git a/Clckwrks/Page/Admin/EditFeedConfig.hs b/Clckwrks/Page/Admin/EditFeedConfig.hs --- a/Clckwrks/Page/Admin/EditFeedConfig.hs +++ b/Clckwrks/Page/Admin/EditFeedConfig.hs @@ -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 -> [

<% xml %>
]) divControlGroup = mapView (\xml -> [
<% xml %>
]) divControls = mapView (\xml -> [
<% xml %>
]) - toFeedConfig :: (Text, Text) -> Either PageFormError FeedConfig + toFeedConfig :: (T.Text, T.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 --- a/Clckwrks/Page/Admin/EditPage.hs +++ b/Clckwrks/Page/Admin/EditPage.hs @@ -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 -> []) (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 -> [
<% xml %>
]) divFormActions = mapView (\xml -> [
<% xml %>
]) divHorizontal = mapView (\xml -> [
<% xml %>
]) @@ -77,11 +79,11 @@ 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")]) + 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 diff --git a/Clckwrks/Page/Admin/NewPage.hs b/Clckwrks/Page/Admin/NewPage.hs --- a/Clckwrks/Page/Admin/NewPage.hs +++ b/Clckwrks/Page/Admin/NewPage.hs @@ -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)) diff --git a/Clckwrks/Page/Admin/Pages.hs b/Clckwrks/Page/Admin/Pages.hs --- a/Clckwrks/Page/Admin/Pages.hs +++ b/Clckwrks/Page/Admin/Pages.hs @@ -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 [] = <%>

There are currently no pages.

editList pgs = @@ -38,7 +41,7 @@ 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) = <% show $ unPageId pid %> diff --git a/Clckwrks/Page/Admin/PreviewPage.hs b/Clckwrks/Page/Admin/PreviewPage.hs --- a/Clckwrks/Page/Admin/PreviewPage.hs +++ b/Clckwrks/Page/Admin/PreviewPage.hs @@ -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)) diff --git a/Clckwrks/Page/Atom.hs b/Clckwrks/Page/Atom.hs --- a/Clckwrks/Page/Atom.hs +++ b/Clckwrks/Page/Atom.hs @@ -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 $ "\n" ++ renderXML xml) + ok $ toResponseBS (fromString "application/atom+xml;charset=utf-8") ((UTF8.fromString $ "\n") <> (TL.encodeUtf8 $ renderXML xml)) diff --git a/Clckwrks/Page/BlogPage.hs b/Clckwrks/Page/BlogPage.hs --- a/Clckwrks/Page/BlogPage.hs +++ b/Clckwrks/Page/BlogPage.hs @@ -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 = diff --git a/Clckwrks/Page/Monad.hs b/Clckwrks/Page/Monad.hs --- a/Clckwrks/Page/Monad.hs +++ b/Clckwrks/Page/Monad.hs @@ -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. diff --git a/Clckwrks/Page/PreProcess.hs b/Clckwrks/Page/PreProcess.hs --- a/Clckwrks/Page/PreProcess.hs +++ b/Clckwrks/Page/PreProcess.hs @@ -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 $ <% ttl %> - 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)) [] diff --git a/Clckwrks/Page/Route.hs b/Clckwrks/Page/Route.hs --- a/Clckwrks/Page/Route.hs +++ b/Clckwrks/Page/Route.hs @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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] } diff --git a/clckwrks-plugin-page.cabal b/clckwrks-plugin-page.cabal --- a/clckwrks-plugin-page.cabal +++ b/clckwrks-plugin-page.cabal @@ -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.*,