clckwrks 0.20.2 → 0.21.0
raw patch · 3 files changed
+89/−30 lines, 3 files
Files
- Clckwrks/Monad.hs +87/−28
- Clckwrks/Route.hs +1/−1
- clckwrks.cabal +1/−1
Clckwrks/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-} module Clckwrks.Monad ( Clck , ClckPlugins@@ -13,7 +13,10 @@ , TLSSettings(..) , AttributeType(..) , Theme(..)+ , ThemeStyle(..)+ , ThemeStyleId(..) , ThemeName+ , getThemeStyles , themeTemplate , calcBaseURI , calcTLSBaseURI@@ -72,10 +75,11 @@ import Data.Acid.Advanced (query', update') import Data.Attoparsec.Text.Lazy (Parser, parseOnly, char, asciiCI, try, takeWhile, takeWhile1) import qualified Data.HashMap.Lazy as HashMap+ import qualified Data.List as List import qualified Data.Map as Map import Data.Monoid ((<>), mappend, mconcat)-import qualified Data.Text as Text+ import Data.Traversable (sequenceA) import qualified Data.Vector as Vector import Data.ByteString.Lazy as LB (ByteString)@@ -83,10 +87,12 @@ import Data.Data (Data, Typeable) import Data.Map (Map) import Data.Maybe (fromJust)-import Data.SafeCopy (SafeCopy(..))+import Data.SafeCopy (SafeCopy(..), deriveSafeCopy, base) import Data.Set (Set) import qualified Data.Set as Set+import Data.Sequence (Seq) import qualified Data.Text as T+import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder, fromText) import qualified Data.Text.Lazy.Builder as B@@ -117,53 +123,73 @@ import Web.Routes.Happstack (seeOtherURL) -- imported so that instances are scope even though we do not use them here import Web.Routes.XMLGenT () -- imported so that instances are scope even though we do not use them here -data ClckPluginsSt = ClckPluginsSt- { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text]- , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]- }+------------------------------------------------------------------------------+-- Theme+------------------------------------------------------------------------------ -initialClckPluginsSt :: ClckPluginsSt-initialClckPluginsSt = ClckPluginsSt- { cpsPreProcessors = []- , cpsNavBarLinks = []- }+type ThemeName = T.Text --- | ClckPlugins------ newtype Plugins theme m hook config st-type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+newtype ThemeStyleId = ThemeStyleId { unThemeStyleId :: Int }+ deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy) -type ThemeName = T.Text+data ThemeStyle = ThemeStyle+ { themeStyleName :: T.Text+ , themeStyleDescription :: T.Text+ , themeStylePreview :: Maybe FilePath+ , themeStyleTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>+ T.Text+ -> headers+ -> body+ -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ } data Theme = Theme { themeName :: ThemeName- , _themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers- , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>- T.Text- -> headers- -> body- -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML--- , themeBlog :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ , themeStyles :: [ThemeStyle] , themeDataDir :: IO FilePath } - themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body ) => ClckPlugins+ -> ThemeStyleId -> T.Text -> headers -> body -> ClckT ClckURL (ServerPartT IO) Response-themeTemplate plugins ttl hdrs bdy =+themeTemplate plugins tsid ttl hdrs bdy = do mTheme <- getTheme plugins case mTheme of Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: T.Text)- (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme ttl hdrs bdy)+ (Just theme) ->+ case lookupThemeStyle tsid (themeStyles theme) of+ Nothing -> escape $ internalServerError $ toResponse $ ("The current theme does not seem to contain any theme styles." :: T.Text)+ (Just themeStyle) ->+ fmap toResponse $ unXMLGenT $ ((themeStyleTemplate themeStyle) ttl hdrs bdy) +lookupThemeStyle :: ThemeStyleId -> [a] -> Maybe a+lookupThemeStyle _ [] = Nothing+lookupThemeStyle (ThemeStyleId 0) (t:_) = Just t+lookupThemeStyle (ThemeStyleId n) (t':ts) = lookupThemeStyle' (n - 1) ts+ where+ lookupThemeStyle' _ [] = Just t'+ lookupThemeStyle' 0 (t:ts) = Just t+ lookupThemeStyle' n (_:ts) = lookupThemeStyle' (n - 1) ts +getThemeStyles :: (MonadIO m) => ClckPlugins -> m [(ThemeStyleId, ThemeStyle)]+getThemeStyles plugins =+ do mTheme <- getTheme plugins+ case mTheme of+ Nothing -> return []+ (Just theme) -> return $ zip (map ThemeStyleId [0..]) (themeStyles theme) +------------------------------------------------------------------------------+-- ClckwrksConfig+------------------------------------------------------------------------------++ data TLSSettings = TLSSettings { clckTLSPort :: Int , clckTLSCert :: FilePath@@ -197,15 +223,24 @@ (Just tlsSettings) -> Just $ Text.pack $ "https://" ++ (clckHostname c) ++ if ((clckPort c /= 443) && (clckHidePort c == False)) then (':' : show (clckTLSPort tlsSettings)) else "" +------------------------------------------------------------------------------+-- ClckState+------------------------------------------------------------------------------++ data ClckState = ClckState { acidState :: Acid , uniqueId :: TVar Integer -- only unique for this request , adminMenus :: [(T.Text, [(Set Role, T.Text, T.Text)])]- , enableAnalytics :: Bool -- ^ enable Google Analytics+ , enableAnalytics :: Bool -- ^ enable Google Analytics , plugins :: ClckPlugins , requestInit :: ServerPart () -- ^ an action which gets called at the beginning of each request } +------------------------------------------------------------------------------+-- ClckT+------------------------------------------------------------------------------+ newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a } deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState) @@ -268,6 +303,30 @@ -- | ClckForm - type for reform forms type ClckFormT error m = Form m [Input] error [XMLGenT m XML] () type ClckForm url = Form (ClckT url (ServerPartT IO)) [Input] ClckFormError [XMLGenT (ClckT url (ServerPartT IO)) XML] ()++++------------------------------------------------------------------------------+-- ClckPlugins / ClckPluginsSt+------------------------------------------------------------------------------++data ClckPluginsSt = ClckPluginsSt+ { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text]+ , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]+ }++initialClckPluginsSt :: ClckPluginsSt+initialClckPluginsSt = ClckPluginsSt+ { cpsPreProcessors = []+ , cpsNavBarLinks = []+ }+++-- | ClckPlugins+--+-- newtype Plugins theme m hook config st+type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+ setUnique :: (Functor m, MonadIO m) => Integer -> ClckT url m () setUnique i =
Clckwrks/Route.hs view
@@ -83,7 +83,7 @@ u <- showURL $ Profile CreateNewProfileData showClckURL <- askRouteFn cs <- get- let template' ttl hdr bdy = withRouteClckT (const showClckURL) $ themeTemplate (plugins cs) (pack ttl) hdr bdy+ let template' ttl hdr bdy = withRouteClckT (const showClckURL) $ themeTemplate (plugins cs) (ThemeStyleId 0) (pack ttl) hdr bdy withAbs $ nestURL Auth $ handleAuthProfile acidAuth acidProfile template' Nothing Nothing u apURL case clckTLS cc of Nothing -> go
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.20.2+Version: 0.21.0 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS