diff --git a/Clckwrks/Page/Acid.hs b/Clckwrks/Page/Acid.hs --- a/Clckwrks/Page/Acid.hs +++ b/Clckwrks/Page/Acid.hs @@ -23,6 +23,7 @@ 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 Clckwrks.Monad (ThemeStyleId(..)) import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.State (get, modify, put) @@ -128,6 +129,7 @@ , pageStatus = Published , pageKind = PlainPage , pageUUID = fromJust $ UUID.fromString "c306fe3a-8346-11e1-8001-0021cc712949" + , pageThemeStyleId = ThemeStyleId 0 } ] , feedConfig = fc @@ -187,6 +189,7 @@ , pageStatus = Draft , pageKind = pk , pageUUID = uuid + , pageThemeStyleId = ThemeStyleId 0 } put $ ps { nextPageId = PageId $ succ $ unPageId nextPageId , pages = insert page pages 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 @@ -5,19 +5,20 @@ ) where import Control.Applicative ((<$>), (<*>), (<*)) -import Clckwrks +import Clckwrks hiding (transform) import Clckwrks.Admin.Template (template) -import Clckwrks.Page.Monad (PageM, PageForm, PageFormError) +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 Control.Monad.State (get) import Data.Maybe (isJust, maybe) 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 ((<++), (++>), mapView, transformEitherM, transform, decimal) import Text.Reform.Happstack (reform) import Text.Reform.HSP.Text (form, button, inputCheckbox, inputText, labelText, inputSubmit, select, textarea, fieldset, ol, li, setAttrs) @@ -33,9 +34,10 @@ Nothing -> notFound $ toResponse $ "Page not found: " ++ show (unPageId pid) (Just page) -> do action <- showURL here + styles <- getThemeStyles =<< plugins <$> get template "edit page" () $ <%> - <% reform (form action) "ep" updatePage Nothing (pageFormlet page) %> + <% reform (form action) "ep" updatePage Nothing (pageFormlet styles page) %> where updatePage :: (Page, AfterSaveAction) -> PageM Response @@ -47,12 +49,15 @@ ShowPreview -> seeOtherURL (PageAdmin $ PreviewPage (pageId page)) -pageFormlet :: Page -> PageForm (Page, AfterSaveAction) -pageFormlet page = +pageFormlet :: [(ThemeStyleId, ThemeStyle)] -> Page -> PageForm (Page, AfterSaveAction) +pageFormlet styles' page = + let styles = map (\(i, ts) -> (i, themeStyleName ts)) styles' in divHorizontal $ (fieldset $ - (,,,,,) + (,,,,,,) <$> (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' "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))) @@ -83,9 +88,9 @@ 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, Text.Text, Bool, Text.Text, (Maybe Text.Text, Maybe Text.Text, Maybe PublishStatus)) + (PageKind, ThemeStyleId, 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)) = + toPage (kind, style, ttl, slug, haskell, bdy, (msave, mpreview, mpagestatus)) = do now <- liftIO $ getCurrentTime return $ Right $ ( Page { pageId = pageId page @@ -104,6 +109,7 @@ Nothing -> pageStatus page , pageKind = kind , pageUUID = pageUUID page + , pageThemeStyleId = style } , if isJust mpreview then ShowPreview 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 @@ -34,5 +34,5 @@ let ttl = pageTitle page bdy <- markupToContent (pageSrc page) addHeaderM "X-XSS-Protection" "0" - clckT2PageT $ themeTemplate (plugins cs) ttl () bdy + clckT2PageT $ themeTemplate (plugins cs) (pageThemeStyleId page) ttl () bdy else unauthorized (toResponse $ ("Sorry, you need Administrator access to view this page." :: Text)) diff --git a/Clckwrks/Page/BlogPage.hs b/Clckwrks/Page/BlogPage.hs --- a/Clckwrks/Page/BlogPage.hs +++ b/Clckwrks/Page/BlogPage.hs @@ -38,4 +38,4 @@ <% postsHTML %> - clckT2PageT $ themeTemplate (plugins cs) ttl () bdy + clckT2PageT $ themeTemplate (plugins cs) (ThemeStyleId 0) ttl () bdy diff --git a/Clckwrks/Page/Monad.hs b/Clckwrks/Page/Monad.hs --- a/Clckwrks/Page/Monad.hs +++ b/Clckwrks/Page/Monad.hs @@ -77,6 +77,7 @@ data PageFormError = PageCFE (CommonFormError [Input]) + | PageErrorInternal deriving Show instance FormError PageFormError where diff --git a/Clckwrks/Page/Route.hs b/Clckwrks/Page/Route.hs --- a/Clckwrks/Page/Route.hs +++ b/Clckwrks/Page/Route.hs @@ -73,7 +73,7 @@ (Just page) <- query (PageById pid) let ttl = pageTitle page bdy <- markupToContent (pageSrc page) - clckT2PageT $ themeTemplate (plugins cs) ttl () bdy + clckT2PageT $ themeTemplate (plugins cs) (pageThemeStyleId page) ttl () bdy else do notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid)) (Blog) -> blog diff --git a/Clckwrks/Page/Types.hs b/Clckwrks/Page/Types.hs --- a/Clckwrks/Page/Types.hs +++ b/Clckwrks/Page/Types.hs @@ -3,6 +3,7 @@ import Clckwrks.Markup.HsColour (hscolour) import Clckwrks.Markup.Markdown (markdown) +import Clckwrks.Monad (ThemeStyleId(..)) import Clckwrks.Types (Trust(..)) import Control.Applicative ((<$>), optional) import Control.Monad.Trans (MonadIO(liftIO)) @@ -155,26 +156,51 @@ toSlug :: Text -> Maybe Slug -> Slug toSlug txt slug = fromMaybe (slugify txt) slug + + +data Page_3 = Page_3 + { pageId_3 :: PageId + , pageAuthor_3 :: UserId + , pageTitle_3 :: Text + , pageSlug_3 :: Maybe Slug + , pageSrc_3 :: Markup + , pageExcerpt_3 :: Maybe Markup + , pageDate_3 :: UTCTime + , pageUpdated_3 :: UTCTime + , pageStatus_3 :: PublishStatus + , pageKind_3 :: PageKind + , pageUUID_3 :: UUID + } + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 3 'extension ''Page_3) + +instance Migrate Page_3 where + type MigrateFrom Page_3 = Page_002 + migrate (Page_002 pi pa pt ps pe pd pu pst pk puu) = + (Page_3 pi pa pt Nothing ps pe pd pu pst pk puu) + 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 + = 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 + , pageThemeStyleId :: ThemeStyleId } deriving (Eq, Ord, Read, Show, Data, Typeable) -$(deriveSafeCopy 3 'extension ''Page) +$(deriveSafeCopy 4 'extension ''Page) +-- migration added for clckwrks-plugin-page-0.3.0 on 2013-12-26 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) + type MigrateFrom Page = Page_3 + migrate (Page_3 pi pa pt psl ps pe pd pu pst pk puu) = + (Page pi pa pt psl ps pe pd pu pst pk puu (ThemeStyleId 0)) instance Indexable Page where empty = ixSet [ ixFun ((:[]) . pageId) 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.2.6 +version: 0.3.0 synopsis: support for CMS/Blogging in clckwrks homepage: http://www.clckwrks.com/ license: BSD3 @@ -42,7 +42,7 @@ aeson == 0.6.*, acid-state == 0.12.*, attoparsec == 0.10.*, - clckwrks >= 0.18 && < 0.21, + clckwrks >= 0.21 && < 0.22, containers >= 0.4 && < 0.6, directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4,