{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Page.Acid ( module Clckwrks.Page.Types -- * state , PageState , initialPageState -- * events , NewPage(..) , PageById(..) , GetPageTitle(..) , IsPublishedPage(..) , PagesSummary(..) , UpdatePage(..) , AllPosts(..) , AllPublishedPages(..) , GetFeedConfig(..) , SetFeedConfig(..) , GetBlogTitle(..) , GetOldUACCT(..) , ClearOldUACCT(..) ) where 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 Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.State (get, modify, put) import Control.Monad.Trans (liftIO) import Data.Acid (AcidState, Query, Update, makeAcidic) import Data.Data (Data, Typeable) import Data.IxSet (Indexable, IxSet, (@=), Proxy(..), empty, fromList, getOne, ixSet, ixFun, insert, toList, toDescList, updateIx) import Data.Maybe (fromJust) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.String (fromString) import Data.Text (Text) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX(posixSecondsToUTCTime) import qualified Data.Text as Text import Data.UUID (UUID) import qualified Data.UUID as UUID import Happstack.Auth (UserId(..)) import HSP.Google.Analytics (UACCT) data PageState_001 = PageState_001 { nextPageId_001 :: PageId , pages_001 :: IxSet Page } deriving (Eq, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''PageState_001) data PageState_002 = PageState_002 { nextPageId_002 :: PageId , pages_002 :: IxSet Page , feedConfig_002 :: FeedConfig } deriving (Eq, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''PageState_002) instance Migrate PageState_002 where type MigrateFrom PageState_002 = PageState_001 migrate (PageState_001 npi pgs) = PageState_002 npi pgs (FeedConfig { feedUUID = fromJust $ UUID.fromString "fa6cf090-84d7-11e1-8001-0021cc712949" , feedTitle = fromString "Untitled Feed" , feedLink = fromString "" , feedAuthorName = fromString "Anonymous" }) data PageState = PageState { nextPageId :: PageId , pages :: IxSet Page , feedConfig :: FeedConfig , uacct :: Maybe UACCT } deriving (Eq, Read, Show, Data, Typeable) $(deriveSafeCopy 3 'extension ''PageState) instance Migrate PageState where type MigrateFrom PageState = PageState_002 migrate (PageState_002 npi pgs fc) = PageState npi pgs fc Nothing initialPageMarkup :: Text initialPageMarkup = [verbatimText|Congratulations! You are now running clckwrks! There are a few more steps you will want to take now. Create an Account ----------------- Go [here](/clck/auth/auth/create) and create an account for yourself. Give yourself Administrator permissions ------------------------------- After you create an account you will want to give yourself `Administrator` privileges. This can be done using the `clckwrks-cli` tool. *While the server is running* invoke `clckwrks-cli` and point it to the socket file: $ 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. Assuming you are `UserId 1` you can now give yourself admin access: % user add-role 1 Administrator You can run `help` for a list of other commands. Type `quit` to exit. Explore the Admin console ------------------------- Now you can explore the [Admin Console](/clck/admin/console). |] initialPageState :: IO PageState initialPageState = do fc <- initialFeedConfig return $ PageState { nextPageId = PageId 2 , pages = fromList [ Page { pageId = PageId 1 , pageAuthor = UserId 1 , pageTitle = "Welcome To clckwrks!" , pageSlug = Just $ slugify "Welcome to clckwrks" , pageSrc = Markup { preProcessors = [ Markdown ] , trust = Trusted , markup = initialPageMarkup } , pageExcerpt = Nothing , pageDate = posixSecondsToUTCTime 1334089928 , pageUpdated = posixSecondsToUTCTime 1334089928 , pageStatus = Published , pageKind = PlainPage , pageUUID = fromJust $ UUID.fromString "c306fe3a-8346-11e1-8001-0021cc712949" } ] , feedConfig = fc , uacct = Nothing } pageById :: PageId -> Query PageState (Maybe Page) pageById pid = do pgs <- pages <$> ask return $ getOne $ pgs @= pid -- | get the 'pageTitle' for 'PageId' getPageTitle :: PageId -> Query PageState (Maybe (Text, Maybe Slug)) getPageTitle pid = do mPage <- pageById pid case mPage of Nothing -> return $ Nothing (Just page) -> return $ Just (pageTitle page, pageSlug page) -- | check if the 'PageId' corresponds to a published 'PageId' isPublishedPage :: PageId -> Query PageState Bool isPublishedPage pid = do pgs <- pages <$> ask case getOne $ pgs @= pid of Nothing -> return False (Just page) -> return $ pageStatus page == Published pagesSummary :: Query PageState [(PageId, Text, Maybe Slug, UTCTime, UserId, PublishStatus)] pagesSummary = do pgs <- pages <$> ask return $ map (\page -> (pageId page, pageTitle page, pageSlug page, pageUpdated page, pageAuthor page, pageStatus page)) (toList pgs) updatePage :: Page -> Update PageState (Maybe String) updatePage page = do ps@PageState{..} <- get case getOne $ pages @= (pageId page) of Nothing -> return $ Just $ "updatePage: Invalid PageId " ++ show (unPageId $ pageId page) (Just _) -> do put $ ps { pages = updateIx (pageId page) page pages } return Nothing newPage :: PageKind -> UserId -> UUID -> UTCTime -> Update PageState Page newPage pk uid uuid now = do ps@PageState{..} <- get let page = Page { pageId = nextPageId , pageAuthor = uid , pageTitle = "Untitled" , pageSlug = Nothing , pageSrc = Markup { preProcessors = [ Markdown ] , trust = Trusted , markup = Text.empty } , pageExcerpt = Nothing , pageDate = now , pageUpdated = now , pageStatus = Draft , pageKind = pk , pageUUID = uuid } put $ ps { nextPageId = PageId $ succ $ unPageId nextPageId , pages = insert page pages } return page getFeedConfig :: Query PageState FeedConfig getFeedConfig = do PageState{..} <- ask return feedConfig getBlogTitle :: Query PageState Text getBlogTitle = do PageState{..} <- ask return (feedTitle feedConfig) setFeedConfig :: FeedConfig -> Update PageState () setFeedConfig fc = do ps <- get put $ ps { feedConfig = fc } -- | get all 'Published' posts, sorted reverse cronological allPosts :: Query PageState [Page] allPosts = do pgs <- pages <$> ask return $ toDescList (Proxy :: Proxy UTCTime) (pgs @= Post @= Published) -- | get all 'Published' pages, sorted in no particular order allPublishedPages :: Query PageState [Page] allPublishedPages = do pgs <- pages <$> ask return $ toList (pgs @= PlainPage @= Published) -- | get the 'UACCT' for Google Analytics -- -- DEPRECATED: moved to clckwrks / 'CoreState' getOldUACCT :: Query PageState (Maybe UACCT) getOldUACCT = uacct <$> ask -- | zero out the UACCT code in 'PageState'. It belongs in 'CoreState' -- now. clearOldUACCT :: Update PageState () clearOldUACCT = modify $ \ps -> ps { uacct = Nothing } $(makeAcidic ''PageState [ 'newPage , 'pageById , 'getPageTitle , 'isPublishedPage , 'pagesSummary , 'updatePage , 'allPosts , 'allPublishedPages , 'getFeedConfig , 'setFeedConfig , 'getBlogTitle , 'getOldUACCT , 'clearOldUACCT ])