{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Page.Admin.EditPage ( editPage ) where import Control.Applicative ((<$>), (<*>), (<*)) import Clckwrks import Clckwrks.Admin.Template (template) 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 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.Happstack (reform) import Text.Reform.HSP.Text (form, button, inputCheckbox, inputText, labelText, inputSubmit, select, textarea, fieldset, ol, li, setAttrs) data AfterSaveAction = EditSomeMore | VisitPage | ShowPreview editPage :: PageURL -> PageId -> PageM Response editPage here pid = do mPage <- query $ PageById pid case mPage of Nothing -> notFound $ toResponse $ "Page not found: " ++ show (unPageId pid) (Just page) -> do action <- showURL here template "edit page" () $ <%> <% reform (form action) "ep" updatePage Nothing (pageFormlet page) %> %> where updatePage :: (Page, AfterSaveAction) -> PageM Response updatePage (page, afterSaveAction) = do update (UpdatePage page) case afterSaveAction of EditSomeMore -> seeOtherURL (PageAdmin $ EditPage (pageId page)) VisitPage -> seeOtherURL (ViewPageSlug (pageId page) (toSlug (pageTitle page) (pageSlug page))) ShowPreview -> seeOtherURL (PageAdmin $ PreviewPage (pageId page)) pageFormlet :: Page -> PageForm (Page, AfterSaveAction) pageFormlet page = divHorizontal $ (fieldset $ (,,,,,) <$> (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' (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") :: Attr Text Text] inputCheckboxLabel lbl b = mapView (\xml -> []) (inputCheckbox b) label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) labelCB str = labelText str `setAttrs` [("class":="checkbox") :: Attr Text Text] -- divInline = mapView (\xml -> [