diff --git a/Clckwrks/Page/API.hs b/Clckwrks/Page/API.hs --- a/Clckwrks/Page/API.hs +++ b/Clckwrks/Page/API.hs @@ -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{..} = diff --git a/Clckwrks/Page/Acid.hs b/Clckwrks/Page/Acid.hs --- a/Clckwrks/Page/Acid.hs +++ b/Clckwrks/Page/Acid.hs @@ -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 } 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 @@ -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 } 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 @@ -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" diff --git a/Clckwrks/Page/Atom.hs b/Clckwrks/Page/Atom.hs --- a/Clckwrks/Page/Atom.hs +++ b/Clckwrks/Page/Atom.hs @@ -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| diff --git a/Clckwrks/Page/Monad.hs b/Clckwrks/Page/Monad.hs --- a/Clckwrks/Page/Monad.hs +++ b/Clckwrks/Page/Monad.hs @@ -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 diff --git a/Clckwrks/Page/Plugin.hs b/Clckwrks/Page/Plugin.hs --- a/Clckwrks/Page/Plugin.hs +++ b/Clckwrks/Page/Plugin.hs @@ -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 diff --git a/Clckwrks/Page/Route.hs b/Clckwrks/Page/Route.hs --- a/Clckwrks/Page/Route.hs +++ b/Clckwrks/Page/Route.hs @@ -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 diff --git a/Clckwrks/Page/Types.hs b/Clckwrks/Page/Types.hs --- a/Clckwrks/Page/Types.hs +++ b/Clckwrks/Page/Types.hs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/clckwrks-plugin-page.cabal b/clckwrks-plugin-page.cabal --- a/clckwrks-plugin-page.cabal +++ b/clckwrks-plugin-page.cabal @@ -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.*