[initial import of a new CMS Jeremy Shaw **20111106052905 Ignore-this: 31505a5eae8aff6e97055c678fa05c69 ] addfile ./Acid.hs hunk ./Acid.hs 1 +module Acid where + +import Control.Exception (bracket) +import Data.Acid (AcidState, openAcidStateFrom, createCheckpointAndClose) +import Data.Maybe (fromMaybe) +import Page.Acid (PageState , initialPageState) +import Happstack.Auth.Core.Auth (AuthState , initialAuthState) +import Happstack.Auth.Core.Profile (ProfileState , initialProfileState) +import System.FilePath (()) + +data Acid = Acid + { acidAuth :: AcidState AuthState + , acidProfile :: AcidState ProfileState + , acidPage :: AcidState PageState + } + +class GetAcidState st where + getAcidState :: Acid -> AcidState st + +instance GetAcidState AuthState where + getAcidState = acidAuth + +instance GetAcidState ProfileState where + getAcidState = acidProfile + +instance GetAcidState PageState where + getAcidState = acidPage + + +withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a +withAcid mBasePath f = + let basePath = fromMaybe "_state" mBasePath in + bracket (openAcidStateFrom (basePath "auth") initialAuthState) (createCheckpointAndClose) $ \auth -> + bracket (openAcidStateFrom (basePath "profile") initialProfileState) (createCheckpointAndClose) $ \profile -> + bracket (openAcidStateFrom (basePath "page") initialPageState) (createCheckpointAndClose) $ \page -> + f (Acid auth profile page) adddir ./Admin addfile ./Admin/Console.hs hunk ./Admin/Console.hs 1 +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Admin.Console where + +import Admin.URL +import Admin.Template +import CMS +import Data.Text (Text) +import Page.Acid + +consolePage :: CMS Response +consolePage = + do pages <- query PagesSummary + template "Administration" () $ editList pages + +editList :: [(PageId, Text)] -> XMLGenT CMS XML +editList [] =

There are currently no pages.

+editList pgs = +

+ <% mapM editPageLI pgs %> + + where + editPageLI :: (PageId, Text) -> XMLGenT CMS XML + editPageLI (pid, ttl) = + <% ttl %> addfile ./Admin/Route.hs hunk ./Admin/Route.hs 1 +module Admin.Route where + +import Admin.Console +import Admin.URL +import CMS + +routeAdmin :: AdminURL -> CMS Response +routeAdmin url = + case url of + Console -> consolePage + (EditPage pid) -> notFound (toResponse ()) addfile ./Admin/Template.hs hunk ./Admin/Template.hs 1 +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Admin.Template where + +import CMS + +template :: + ( EmbedAsChild CMS headers + , EmbedAsChild CMS body + ) => String -> headers -> body -> CMS Response +template title headers body = + toResponse <$> (unXMLGenT $ + + + <% title %> + <% headers %> + + + <% body %> + + ) addfile ./Admin/URL.hs hunk ./Admin/URL.hs 1 +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +module Admin.URL where hunk ./Admin/URL.hs 4 +import Data.Data +import Page.Types +import Web.Routes +import Web.Routes.TH + +data AdminURL + = Console + | EditPage PageId + deriving (Eq, Ord, Read, Show, Data, Typeable) + +$(derivePathInfo ''AdminURL) addfile ./CMS.hs hunk ./CMS.hs 1 +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} +module CMS + ( module Acid + , module Control.Applicative + , module Control.Monad + , module Control.Monad.Trans + , module CMSMonad + , module CMSURL + , module Page.API + , module HSP + , module HSP.ServerPartT + , module Happstack.Server + ) where + +import Acid +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import CMSMonad +import CMSURL +import Page.API +import HSP hiding (Request, escape) +import HSP.ServerPartT +import Happstack.Server +import Happstack.Server.HSP.HTML +import Web.Routes +import Web.Routes.XMLGenT () +import Web.Routes.Happstack addfile ./CMSMonad.hs hunk ./CMSMonad.hs 1 +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-} +module CMSMonad + ( CMS(..) + , CMSState(..) + , setCurrentPage + , query + , update + ) where + +import Acid +import Control.Applicative +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans +import CMSURL (CMSURL(..)) +import Data.Acid (AcidState, EventState, EventResult, QueryEvent, UpdateEvent, query', update') +import Page.Acid +import Data.ByteString.Lazy as LB (ByteString) +import Data.ByteString.Lazy.UTF8 as LB (toString) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Data.Time.Clock (UTCTime) +import Data.Time.Format (formatTime) + +import HSP hiding (Request, escape) +import HSP.ServerPartT +import qualified HSX.XMLGenerator as HSX +import Happstack.Server +import System.Locale (defaultTimeLocale) +import Web.Routes +import Web.Routes.XMLGenT () +import Web.Routes.Happstack + +data CMSState + = CMSState { acidState :: Acid + , currentPage :: PageId + } + +newtype CMS a = CMS { unCMS :: RouteT CMSURL (ServerPartT (StateT CMSState IO)) a } + deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, Happstack, ServerMonad, HasRqData, FilterMonad Response, WebMonad Response, MonadState CMSState) + +instance MonadRoute CMS where + type URL CMS = CMSURL + askRouteFn = CMS $ askRouteFn + + + +query :: forall event. (QueryEvent event, GetAcidState (EventState event)) => event -> CMS (EventResult event) +query event = + do as <- (getAcidState . acidState) <$> get + query' (as :: AcidState (EventState event)) event + +update :: forall event. (UpdateEvent event, GetAcidState (EventState event)) => event -> CMS (EventResult event) +update event = + do as <- (getAcidState . acidState) <$> get + update' (as :: AcidState (EventState event)) event + + + +-- | update the 'currentPage' field of 'CMSState' +setCurrentPage :: PageId -> CMS () +setCurrentPage pid = + modify $ \s -> s { currentPage = pid } + + +-- * XMLGen / XMLGenerator instances for CMS + +instance HSX.XMLGen CMS where + type HSX.XML CMS = XML + newtype HSX.Child CMS = CMSChild { unCMSChild :: XML } + newtype HSX.Attribute CMS = FAttr { unFAttr :: Attribute } + genElement n attrs children = + do attribs <- map unFAttr <$> asAttr attrs + childer <- flattenCDATA . map (unCMSChild) <$> asChild children + HSX.XMLGenT $ return (Element + (toName n) + attribs + childer + ) + xmlToChild = CMSChild + pcdataToChild = HSX.xmlToChild . pcdata + +flattenCDATA :: [XML] -> [XML] +flattenCDATA cxml = + case flP cxml [] of + [] -> [] + [CDATA _ ""] -> [] + xs -> xs + where + flP :: [XML] -> [XML] -> [XML] + flP [] bs = reverse bs + flP [x] bs = reverse (x:bs) + flP (x:y:xs) bs = case (x,y) of + (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs + _ -> flP (y:xs) (x:bs) + +instance IsAttrValue CMS T.Text where + toAttrValue = toAttrValue . T.unpack + +instance IsAttrValue CMS TL.Text where + toAttrValue = toAttrValue . TL.unpack +{- +instance EmbedAsChild CMS (Block t) where + asChild b = asChild $ + + +instance IsAttrValue CMS (HJScript (Exp t)) where + toAttrValue script = toAttrValue $ evaluateHJScript script + +instance IsAttrValue CMS (Block t) where + toAttrValue block = return . attrVal $ "javascript:" ++ show block + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n (HJScript (Exp a))) where + asAttr (n := script) = return . (:[]) . FAttr $ MkAttr (toName n, attrVal $ show $ evaluateHJScript script) +-} +instance HSX.EmbedAsAttr CMS Attribute where + asAttr = return . (:[]) . FAttr + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n String) where + asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n Char) where + asAttr (n := c) = asAttr (n := [c]) + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n Bool) where + asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") + asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n Int) where + asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n Integer) where + asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) + +instance (IsName n) => HSX.EmbedAsAttr CMS (Attr n CMSURL) where + asAttr (n := u) = + do url <- showURL u + asAttr $ MkAttr (toName n, pAttrVal (T.unpack url)) +{- +instance HSX.EmbedAsAttr CMS (Attr String AuthURL) where + asAttr (n := u) = + do url <- showURL (W_Auth u) + asAttr $ MkAttr (toName n, pAttrVal url) +-} + +instance (IsName n) => (EmbedAsAttr CMS (Attr n TL.Text)) where + asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a) + +instance (IsName n) => (EmbedAsAttr CMS (Attr n T.Text)) where + asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a) + +instance EmbedAsChild CMS Char where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata . (:[]) + +instance EmbedAsChild CMS String where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata + +instance EmbedAsChild CMS Int where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata . show + +instance EmbedAsChild CMS Integer where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata . show + +instance EmbedAsChild CMS Double where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata . show + +instance EmbedAsChild CMS Float where + asChild = XMLGenT . return . (:[]) . CMSChild . pcdata . show + +instance EmbedAsChild CMS TL.Text where + asChild = asChild . TL.unpack + +instance EmbedAsChild CMS T.Text where + asChild = asChild . T.unpack + +instance (EmbedAsChild CMS a) => EmbedAsChild CMS (CMS a) where + asChild c = + do a <- XMLGenT c + asChild a + +instance (EmbedAsChild CMS a) => EmbedAsChild CMS (IO a) where + asChild c = + do a <- XMLGenT (liftIO c) + asChild a + +{- +instance EmbedAsChild CMS TextHtml where + asChild = XMLGenT . return . (:[]) . CMSChild . cdata . T.unpack . unTextHtml + +instance EmbedAsChild CMS FbXML where + asChild = XMLGenT . return . (:[]) . CMSChild +-} +instance EmbedAsChild CMS XML where + asChild = XMLGenT . return . (:[]) . CMSChild + +instance EmbedAsChild CMS () where + asChild () = return [] + +instance EmbedAsChild CMS UTCTime where + asChild = asChild . formatTime defaultTimeLocale "%a, %F @ %r" + +instance AppendChild CMS XML where + appAll xml children = do + chs <- children + case xml of + CDATA _ _ -> return xml + Element n as cs -> return $ Element n as (cs ++ (map unCMSChild chs)) + +instance SetAttr CMS XML where + setAll xml hats = do + attrs <- hats + case xml of + CDATA _ _ -> return xml + Element n as cs -> return $ Element n (foldr (:) as (map unFAttr attrs)) cs + +instance XMLGenerator CMS addfile ./CMSURL.hs hunk ./CMSURL.hs 1 +{-# LANGUAGE TemplateHaskell #-} +module CMSURL where hunk ./CMSURL.hs 4 +import Control.Applicative ((<$>)) +import Page.Acid (PageId(..)) +import Admin.URL +import Web.Routes +import Web.Routes.TH + + +data CMSURL + = Page PageId + | Admin AdminURL + deriving (Eq, Ord, Read, Show) + +$(derivePathInfo ''CMSURL) addfile ./Main.hs hunk ./Main.hs 1 +module Main where + +import Acid +import Admin.Route (routeAdmin) +import Control.Applicative +import Control.Monad.State +import Control.Monad.Trans +import CMS +import qualified Data.Text as Text +import Happstack.Server +import Happstack.Plugins.Plugins +import HSP +import HSP.ServerPartT +import Happstack.Server.HSP.HTML +import Web.Routes +import Web.Routes.Happstack + +main :: IO () +main = + do ph <- initPlugins + withAcid Nothing $ \acid -> + do let cmsState = CMSState { acidState = acid + , currentPage = PageId 0 + } + putStrLn "starting..." + simpleHTTP nullConf (handlers ph cmsState) + +handlers :: PluginHandle -> CMSState -> ServerPart Response +handlers ph cmsState = + msum + [ dir "favicon.ico" $ notFound (toResponse ()) + , implSite (Text.pack "http://localhost:8000") (Text.pack "") (cms ph cmsState) + ] + +route :: PluginHandle -> CMSURL -> CMS Response +route ph url = + case url of + (Page pid) -> + do setCurrentPage pid + withSymbol ph "Page.hs" "page" page + (Admin adminURL) -> + routeAdmin adminURL + +cms :: PluginHandle -> CMSState -> Site CMSURL (ServerPart Response) +cms ph cmsState = setDefault (Page $ PageId 1) $ mkSitePI route' + where + route' f u = + mapServerPartT (\m -> evalStateT m cmsState) $ unRouteT (unCMS $ route ph u) f + +withSymbol :: (MonadIO m) => PluginHandle -> FilePath -> String -> (a -> m b) -> m b +withSymbol ph fp sym f = + do r <- liftIO $ func ph fp sym + case r of + (Left e) -> error (unlines e) + (Right a) -> f a + +page :: XMLGenT CMS XML -> CMS Response +page (XMLGenT part) = toResponse <$> part adddir ./Page addfile ./Page.hs hunk ./Page.hs 1 +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +<% +module Page where +import CMS +import Data.Time.Clock + +page :: XMLGenT CMS XML + +%> + + + + <% getPageTitle %> + + +

<% getPageTitle %>

<% getPageText %>

<% getCurrentTime %>

+ + addfile ./Page/API.hs hunk ./Page/API.hs 1 +{-# LANGUAGE RecordWildCards #-} +module Page.API + ( PageId(..) + , getPage + , getPageTitle + , getPageText + ) where hunk ./Page/API.hs 9 +import Acid +import Control.Applicative +import Control.Monad.State +import Control.Monad.Trans (MonadIO) +import CMSMonad +import Data.Text +import Happstack.Server +import Page.Acid + +getPage :: CMS Page +getPage = + do CMSState{..} <- get + mPage <- query (PageById currentPage) + case mPage of + Nothing -> escape $ internalServerError $ toResponse ("getPage: invalid PageId " ++ show (unPageId currentPage)) + (Just p) -> return p + +getPageTitle :: CMS Text +getPageTitle = pageTitle <$> getPage + +getPageText :: CMS Text +getPageText = (toText . pageSrc) <$> getPage addfile ./Page/Acid.hs hunk ./Page/Acid.hs 1 +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards #-} +module Page.Acid + ( module Page.Types + -- * state + , PageState + , initialPageState + -- * events + , PageById(..) + , PagesSummary(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) +import Data.Acid (AcidState, Query, makeAcidic) +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable, IxSet, (@=), empty, fromList, getOne, ixSet, ixFun, toList) +import Data.SafeCopy +import Data.Text (Text, pack) +import Page.Types + +data PageState = PageState + { nextPageId :: PageId + , pages :: Pages + } + deriving (Eq, Read, Show, Data, Typeable) +$(deriveSafeCopy 1 'base ''PageState) + +initialPageState :: PageState +initialPageState = + PageState { nextPageId = PageId 2 + , pages = fromList [ Page { pageId = PageId 1 + , pageTitle = pack "This title rocks!" + , pageSrc = Markdown $ pack "This is the body!" + } + ] + } + +pageById :: PageId -> Query PageState (Maybe Page) +pageById pid = + do pgs <- pages <$> ask + return $ getOne $ pgs @= pid + +pagesSummary :: Query PageState [(PageId, Text)] +pagesSummary = + do pgs <- pages <$> ask + return $ map (\page -> (pageId page, pageTitle page)) (toList pgs) + +$(makeAcidic ''PageState + [ 'pageById + , 'pagesSummary + ]) addfile ./Page/Types.hs hunk ./Page/Types.hs 1 +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +module Page.Types where + +import Control.Applicative ((<$>)) +import Data.Data +import Data.IxSet +import Data.SafeCopy +import Data.Text +import Web.Routes + +instance PathInfo PageId where + toPathSegments (PageId i) = toPathSegments i + fromPathSegments = PageId <$> fromPathSegments + + +newtype PageId = PageId { unPageId :: Integer } + deriving (Eq, Ord, Show, Read, Data, Typeable) +$(deriveSafeCopy 1 'base ''PageId) + +data PageSrc + = Markdown { toText :: Text } + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 1 'base ''PageSrc) + + +data Page + = Page { pageId :: PageId + , pageTitle :: Text + , pageSrc :: PageSrc + } + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 1 'base ''Page) + +instance Indexable Page where + empty = ixSet [ ixFun ((:[]) . pageId) + ] + +type Pages = IxSet Page addfile ./cms.cabal