{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies, OverloadedStrings #-} module Clckwrks.Page.Types where 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) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Char (ord, toLower, isAlphaNum) import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe) import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as Text import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.UUID (UUID) import Data.UUID.V5 (generateNamed, namespaceOID) import Web.Routes (PathInfo(..), anySegment) import System.Random (randomIO) -- $(deriveSafeCopy 0 'base ''UUID) 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) instance ToJSON PageId where toJSON (PageId i) = toJSON i 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 2 'extension ''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) runPreProcessors (p:ps) trust txt = do e <- runPreProcessor p trust txt case e of (Left e) -> return (Left e) (Right txt') -> runPreProcessors ps trust txt' runPreProcessor :: (MonadIO m) => PreProcessor -> Trust -> Text -> m (Either Text Text) runPreProcessor pproc trust txt = do let f = case pproc of Markdown -> markdown Nothing trust HsColour -> hscolour Nothing Pandoc -> pandoc Nothing trust f txt data Markup_001 = Markup_001 { preProcessors_001 :: [PreProcessor] , markup_001 :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''Markup_001) data Markup = Markup { preProcessors :: [PreProcessor] , markup :: Text , trust :: Trust } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''Markup) instance Migrate Markup where type MigrateFrom Markup = Markup_001 migrate (Markup_001 pp mu) = Markup pp mu Trusted data PublishStatus = Draft | Revoked | Published | Scheduled deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''PublishStatus) publishStatusString :: PublishStatus -> String publishStatusString Draft = "draft" publishStatusString Revoked = "revoked" publishStatusString Published = "published" publishStatusString Scheduled = "scheduled" data PageKind = PlainPage | Post deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''PageKind) data Page_001 = Page_001 { pageId_001 :: PageId , pageTitle_001 :: Text , pageSrc_001 :: Markup , pageExcerpt_001 :: Maybe Markup , pageDate_001 :: Maybe UTCTime , pageStatus_001 :: PublishStatus , pageKind_001 :: PageKind } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''Page_001) data Page_002 = Page_002 { pageId_002 :: PageId , pageAuthor_002 :: UserId , pageTitle_002 :: Text , pageSrc_002 :: Markup , pageExcerpt_002 :: Maybe Markup , pageDate_002 :: UTCTime , pageUpdated_002 :: UTCTime , pageStatus_002 :: PublishStatus , pageKind_002 :: PageKind , pageUUID_002 :: UUID } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''Page_002) instance Migrate Page_002 where type MigrateFrom Page_002 = Page_001 migrate (Page_001 pi pt ps pe pd pst pk) = (Page_002 pi (UserId 1) pt ps pe (fromMaybe epoch pd) (fromMaybe epoch pd) pst pk $ generateNamed namespaceOID (map (fromIntegral . ord) (show pi ++ show ps))) where epoch = posixSecondsToUTCTime 0 newtype Slug = Slug { unSlug :: Text } deriving (Eq, Ord, Data, Typeable, Read, Show) $(deriveSafeCopy 0 'base ''Slug) instance PathInfo Slug where toPathSegments (Slug txt) = [txt] fromPathSegments = Slug <$> anySegment -- NOTE: this instance will cause faulty behavior if the Maybe Slug is not at the end of the URL instance PathInfo (Maybe Slug) where toPathSegments (Just slug) = toPathSegments slug fromPathSegments = optional $ fromPathSegments slugify :: Text -> Slug slugify txt = Slug $ Text.dropWhileEnd (=='-') $ Text.map (\c -> if isAlphaNum c then (toLower c) else '-') txt 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 , pageThemeStyleId :: ThemeStyleId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(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_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) , ixFun ((:[]) . pageDate) , ixFun ((:[]) . pageKind) , ixFun ((:[]) . pageDate) , ixFun ((:[]) . pageStatus) ] type Pages = IxSet Page data FeedConfig = FeedConfig { feedUUID :: UUID -- ^ UUID which identifies this feed. Should probably never change -- , feedCategory :: Set Text , feedTitle :: Text , feedLink :: Text , feedAuthorName :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 0 'base ''FeedConfig) initialFeedConfig :: IO FeedConfig initialFeedConfig = do uuid <- randomIO return $ FeedConfig { feedUUID = uuid , feedTitle = fromString "Untitled Feed" , feedLink = fromString "" , feedAuthorName = fromString "Anonymous" }