clckwrks-plugin-page 0.3.10 → 0.4.3.26
raw patch · 11 files changed
Files
- Clckwrks/Page/API.hs +2/−1
- Clckwrks/Page/Acid.hs +3/−3
- Clckwrks/Page/Admin/EditPage.hs +9/−6
- Clckwrks/Page/Admin/PreviewPage.hs +1/−1
- Clckwrks/Page/Atom.hs +9/−6
- Clckwrks/Page/Monad.hs +7/−5
- Clckwrks/Page/Plugin.hs +9/−9
- Clckwrks/Page/Route.hs +1/−1
- Clckwrks/Page/Types.hs +14/−2
- Setup.hs +1/−6
- clckwrks-plugin-page.cabal +29/−25
Clckwrks/Page/API.hs view
@@ -28,6 +28,7 @@ import Clckwrks.Page.URL ( PageURL(ViewPageSlug)) import Clckwrks.URL (ClckURL(..)) import Control.Applicative ((<$>))+import Control.Monad.Fail (MonadFail) import Control.Monad.State (get) import Control.Monad.Trans (MonadIO) import qualified Data.Text as T@@ -90,7 +91,7 @@ getBlogTitle :: PageM T.Text getBlogTitle = query GetBlogTitle -extractExcerpt :: (MonadIO m, Functor m, Happstack m) =>+extractExcerpt :: (MonadIO m, MonadFail m, Functor m, Happstack m) => Page -> ClckT url m Content extractExcerpt Page{..} =
Clckwrks/Page/Acid.hs view
@@ -96,7 +96,7 @@ $ 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. +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: @@ -119,7 +119,7 @@ , pageAuthor = UserId 1 , pageTitle = "Welcome To clckwrks!" , pageSlug = Just $ slugify "Welcome to clckwrks"- , pageSrc = Markup { preProcessors = [ Markdown ]+ , pageSrc = Markup { preProcessors = [ Pandoc ] , trust = Trusted , markup = initialPageMarkup }@@ -179,7 +179,7 @@ , pageAuthor = uid , pageTitle = "Untitled" , pageSlug = Nothing- , pageSrc = Markup { preProcessors = [ Markdown ]+ , pageSrc = Markup { preProcessors = [ Pandoc ] , trust = Trusted , markup = Text.empty }
Clckwrks/Page/Admin/EditPage.hs view
@@ -57,10 +57,10 @@ (,,,,,,) <$> (divControlGroup (label' "Page Type" ++> (divControls $ select [(PlainPage, ("page" :: Text)), (Post, "post")] (== (pageKind page))))) -- <*> (divControlGroup (label' "Theme Style" ++> (divControls $ ThemeStyleId <$> (select styles (const True)) `transform` (decimal (const PageErrorInternal)))))- <*> (divControlGroup (label' "Theme Style" ++> (divControls $ select styles (== (fst $ head styles)))))+ <*> (divControlGroup (label' "Theme Style" ++> (divControls $ select styles (== (pageThemeStyleId 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' "Markdown processor" ++> (divControls $ select [(Pandoc, "Pandoc"), (Markdown, "markdown perl script (legacy)" :: Text), (HsColour, "markdown perl script + hscolour (legacy)")] (\p -> p `elem` (preProcessors $ pageSrc page)))) <*> (divControlGroup (label' "Body" ++> (divControls $ textarea 80 25 (markup (pageSrc page)) `setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]))) <*> (divFormActions ((,,) <$> (inputSubmit' (Text.pack "Save"))@@ -90,18 +90,21 @@ newPublishStatus :: PublishStatus -> PageForm (Maybe PublishStatus) 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, ThemeStyleId, Text.Text, Text.Text, Bool, Text.Text, (Maybe Text.Text, Maybe Text.Text, Maybe PublishStatus))+ (PageKind, ThemeStyleId, Text.Text, Text.Text, PreProcessor, Text.Text, (Maybe Text.Text, Maybe Text.Text, Maybe PublishStatus)) -> m (Either PageFormError (Page, AfterSaveAction))- toPage (kind, style, ttl, slug, haskell, bdy, (msave, mpreview, mpagestatus)) =+ toPage (kind, style, ttl, slug, markup, 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 ]+ , pageSrc = Markup { preProcessors =+ case markup of+ Markdown -> [ Markdown ]+ HsColour -> [ Markdown, HsColour ]+ Pandoc -> [ Pandoc ] , trust = Trusted , markup = bdy }
Clckwrks/Page/Admin/PreviewPage.hs view
@@ -30,7 +30,7 @@ (Just uid) -> query $ HasRole uid (Set.singleton Administrator) if authorized then do cs <- get- (Just page) <- query (PageById pid)+ ~(Just page) <- query (PageById pid) let ttl = pageTitle page bdy <- markupToContent (pageSrc page) addHeaderM "X-XSS-Protection" "0"
Clckwrks/Page/Atom.hs view
@@ -1,13 +1,15 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Page.Atom where -import Control.Monad.Trans (liftIO)+import Control.Monad.Trans (lift, liftIO)+import Clckwrks.Authenticate.API (Username(..), getUsername) import Clckwrks.Monad (Clck, Content(..), query, withAbs) import Clckwrks.Page.Acid-import Clckwrks.Page.Monad (PageM, markupToContent)+import Clckwrks.Page.Monad (PageM, markupToContent, clckT2PageT) import Clckwrks.Page.Types import Clckwrks.ProfileData.Acid import Clckwrks.Page.URL+import Control.Monad.Fail (MonadFail(fail)) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.String (fromString)@@ -18,11 +20,12 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (formatTime) import Data.UUID (toString)-import Happstack.Server (Happstack, Response, ok, toResponseBS)+import Happstack.Server (Happstack, Response, ok, ServerPartT, toResponseBS) import HSP.XMLGenerator import HSP.XML (XML, cdata, renderXML, fromStringLit) import Language.Haskell.HSX.QQ (hsx) import Data.Time.Locale.Compat (defaultTimeLocale)+import Prelude hiding (fail) import Web.Routes (showURL) atom :: FeedConfig -- ^ feed configuration@@ -65,10 +68,10 @@ where author :: XMLGenT PageM XML author =- do mu <- query $ UsernameForId pageAuthor+ do mu <- lift $ clckT2PageT ((getUsername pageAuthor) :: Clck () (Maybe Username)) case mu of Nothing -> return $ cdata ""- (Just n)+ (Just (Username n)) | Text.null n -> return $ cdata "" | otherwise -> [hsx|
Clckwrks/Page/Monad.hs view
@@ -3,6 +3,7 @@ import Control.Applicative ((<$>)) import Control.Monad (foldM)+import Control.Monad.Fail (MonadFail(fail)) import Control.Monad.Reader (MonadReader(ask,local), ReaderT(runReaderT)) import Control.Monad.State (StateT, put, get, modify) import Control.Monad.Trans (MonadIO(liftIO))@@ -23,6 +24,7 @@ import Happstack.Server (Happstack, Input, ServerPartT) import HSP.XMLGenerator import HSP.XML+import Prelude hiding (fail) import Text.Reform (CommonFormError, FormError(..)) import Web.Plugins.Core (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn) import Web.Routes (RouteT(..), showURL, withRouteT)@@ -62,12 +64,12 @@ where flattenURL _ = \u p -> showClckURL u p -clckT2PageT :: (Functor m, MonadIO m, Typeable url1) =>+clckT2PageT :: (Functor m, MonadIO m, MonadFail m, Typeable url1) => ClckT url1 m a -> PageT m a clckT2PageT m = do p <- plugins <$> get- (Just clckShowFn) <- getPluginRouteFn p (pluginName clckPlugin)+ ~(Just clckShowFn) <- getPluginRouteFn p (pluginName clckPlugin) flattenURLClckT clckShowFn $ mapClckT addReaderT m where addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)@@ -110,14 +112,14 @@ -- | 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) =>+markupToContent :: (Functor m, MonadIO m, MonadFail 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)+ ~(Just clckRouteFn) <- getPluginRouteFn (plugins clckState) (pluginName clckPlugin)+ (markup', clckState') <- 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
Clckwrks/Page/Plugin.hs view
@@ -26,7 +26,7 @@ import Happstack.Server (ServerPartT, Response, notFound, toResponse) import System.Directory (createDirectoryIfMissing) import System.FilePath ((</>))-import Web.Routes (toPathInfo, parseSegments, withRouteT, fromPathSegments)+import Web.Routes (toPathSegments, parseSegments, withRouteT, fromPathSegments) import Web.Plugins.Core (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, addPostHook, initPlugin, getConfig, getPluginRouteFn) pageHandler :: (PageURL -> [(Text, Maybe Text)] -> Text)@@ -46,8 +46,8 @@ pageInit :: ClckPlugins -> IO (Maybe Text) pageInit plugins =- do (Just pageShowFn) <- getPluginRouteFn plugins (pluginName pagePlugin)- (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ 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@@ -72,7 +72,7 @@ addPageAdminMenu :: ClckT url IO () addPageAdminMenu = do p <- plugins <$> get- (Just pageShowURL) <- getPluginRouteFn p (pluginName pagePlugin)+ ~(Just pageShowURL) <- getPluginRouteFn p (pluginName pagePlugin) let newPageURL = pageShowURL (PageAdmin NewPage) [] pagesURL = pageShowURL (PageAdmin Pages) [] feedConfigURL = pageShowURL (PageAdmin EditFeedConfig) []@@ -96,11 +96,11 @@ 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+ { pluginName = "page"+ , pluginInit = pageInit+ , pluginDepends = ["clck"]+ , pluginToPathSegments = toPathSegments+ , pluginPostHook = addPageAdminMenu } plugin :: ClckPlugins -- ^ plugins
Clckwrks/Page/Route.hs view
@@ -70,7 +70,7 @@ do published <- query (IsPublishedPage pid) if published then do cs <- get- (Just page) <- query (PageById pid)+ ~(Just page) <- query (PageById pid) let ttl = pageTitle page bdy <- markupToContent (pageSrc page) clckT2PageT $ themeTemplate (plugins cs) (pageThemeStyleId page) ttl () bdy
Clckwrks/Page/Types.hs view
@@ -4,6 +4,7 @@ import Clckwrks (UserId(..)) import Clckwrks.Markup.HsColour (hscolour) import Clckwrks.Markup.Markdown (markdown)+import Clckwrks.Markup.Pandoc (pandoc) import Clckwrks.Monad (ThemeStyleId(..)) import Clckwrks.Types (Trust(..)) import Control.Applicative ((<$>), optional)@@ -40,13 +41,23 @@ instance FromJSON PageId where parseJSON n = PageId <$> parseJSON n +data PreProcessor_1+ = HsColour_1+ | Markdown_1+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PreProcessor_1)+ data PreProcessor = HsColour | Markdown+ | Pandoc deriving (Eq, Ord, Read, Show, Data, Typeable)-$(deriveSafeCopy 1 'base ''PreProcessor)+$(deriveSafeCopy 2 'extension ''PreProcessor) --- $(deriveJSON id ''PreProcessor)+instance Migrate PreProcessor where+ type MigrateFrom PreProcessor = PreProcessor_1+ migrate HsColour_1 = HsColour+ migrate Markdown_1 = Markdown runPreProcessors :: (MonadIO m) => [PreProcessor] -> Trust -> Text -> m (Either Text Text) runPreProcessors [] _ txt = return (Right txt)@@ -61,6 +72,7 @@ do let f = case pproc of Markdown -> markdown Nothing trust HsColour -> hscolour Nothing+ Pandoc -> pandoc Nothing trust f txt data Markup_001
Setup.hs view
@@ -3,11 +3,6 @@ module Main where import Distribution.Simple-import Distribution.Simple.Program -hsx2hsProgram = simpleProgram "hsx2hs"- main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [hsx2hsProgram]- }+main = defaultMain
clckwrks-plugin-page.cabal view
@@ -1,6 +1,9 @@ name: clckwrks-plugin-page-version: 0.3.10+version: 0.4.3.26 synopsis: support for CMS/Blogging in clckwrks+description: This provides two similar concepts Pages and Posts. Both allow+ you to create page content by editting pages in the browser. A Post+ is simply a page which is displayed in the blog. homepage: http://www.clckwrks.com/ license: BSD3 license-file: LICENSE@@ -8,17 +11,17 @@ author: Jeremy Shaw maintainer: jeremy@n-heptane.com category: Clckwrks-build-type: Custom-cabal-version: >=1.8+build-type: Simple+cabal-version: 1.18+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2 source-repository head type: git location: git://github.com/clckwrks/clckwrks-plugin-page.git library- build-tools:- hsx2hs-+ default-language: Haskell2010+ build-tool-depends: hsx2hs:hsx2hs exposed-modules: Clckwrks.Page.Monad Clckwrks.Page.Route Clckwrks.Page.Types@@ -37,33 +40,34 @@ Clckwrks.Page.Atom other-modules: Clckwrks.Page.Verbatim- build-depends: base >= 4.3 && < 4.9,- aeson >= 0.6 && < 0.9,- acid-state == 0.12.*,- attoparsec >= 0.10 && < 0.14,- clckwrks >= 0.21 && < 0.24,- containers >= 0.4 && < 0.6,- directory >= 1.1 && < 1.3,+ build-depends: base >= 4.3 && < 4.17,+ acid-state >= 0.12 && < 0.17,+ aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.6) || (>= 2.0 && < 2.1),+ attoparsec >= 0.10 && < 0.15,+ clckwrks >= 0.25 && < 0.29,+ containers >= 0.4 && < 0.7,+ directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5,- happstack-hsp >= 7.2 && < 7.4,- happstack-server >= 7.0 && < 7.5,+ happstack-hsp >= 7.2 && < 7.5,+ happstack-server >= 7.0 && < 7.8, hsp >= 0.9 && < 0.11,- hsx2hs >= 0.13 && < 0.14,- ixset == 1.0.*,+ hsx2hs >= 0.13 && < 0.15,+ ixset >= 1.0 && < 1.2, mtl >= 2.0 && < 2.3, old-locale == 1.0.*,- random >= 1.0 && < 1.2,- reform == 0.2.*,+ random >= 1.0 && < 1.3,+ reform >= 0.2 && < 0.4, reform-happstack == 0.2.*, reform-hsp == 0.2.*,- safecopy == 0.8.*,- tagsoup == 0.13.*,- text >= 0.11 && < 1.3,- time >= 1.4 && < 1.6,+ safecopy >= 0.8,+ tagsoup >= 0.13 && < 0.15,+ text >= 0.11 && < 2.1,+ time >= 1.4 && < 1.14, time-locale-compat >= 0.1 && < 0.2,- template-haskell >= 2.7 && <= 2.11,+ template-haskell >= 2.7 && <= 2.19, uuid >= 1.2 && <= 1.4,- web-plugins == 0.2.*,+ uuid-orphans >= 1.2 && < 1.5,+ web-plugins >= 0.4 && < 0.5, web-routes == 0.27.*, web-routes-happstack == 0.23.*, web-routes-th == 0.22.*