clckwrks 0.19.3 → 0.20.0
raw patch · 6 files changed
+126/−27 lines, 6 files
Files
- Clckwrks/Acid.hs +56/−8
- Clckwrks/Admin/EditSettings.hs +56/−12
- Clckwrks/Admin/Template.hs +4/−3
- Clckwrks/ProfileData/Route.hs +4/−1
- Clckwrks/Server.hs +5/−2
- clckwrks.cabal +1/−1
Clckwrks/Acid.hs view
@@ -9,13 +9,13 @@ import Control.Exception (bracket, catch, throw) import Control.Concurrent (killThread, forkIO) import Control.Monad.Reader (ask)-import Control.Monad.State (modify)+import Control.Monad.State (modify, put) import Data.Acid (AcidState, Query, Update, createArchive, makeAcidic) import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose) import Data.Acid.Remote (acidServer, skipAuthenticationCheck) import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe)-import Data.SafeCopy (base, deriveSafeCopy)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Text (Text) import Happstack.Auth.Core.Auth (AuthState , initialAuthState) import Happstack.Auth.Core.Profile (ProfileState , initialProfileState)@@ -29,17 +29,36 @@ -- | 'CoreState' holds some values that are required by the core -- itself, or which are useful enough to be shared with numerous -- plugins/themes.+data CoreState_v0 = CoreState_v0+ { coreUACCT_v0 :: Maybe UACCT -- ^ Google Account UAACT+ , coreRootRedirect_v0 :: Maybe Text+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 0 'base ''CoreState_v0)++-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes. data CoreState = CoreState- { coreUACCT :: Maybe UACCT -- ^ Google Account UAACT- , coreRootRedirect :: Maybe Text+ { coreSiteName :: Maybe Text+ , coreUACCT :: Maybe UACCT -- ^ Google Account UAACT+ , coreRootRedirect :: Maybe Text+ , coreLoginRedirect :: Maybe Text+ } deriving (Eq, Data, Typeable, Show)-$(deriveSafeCopy 0 'base ''CoreState)+$(deriveSafeCopy 1 'extension ''CoreState) +instance Migrate CoreState where+ type MigrateFrom CoreState = CoreState_v0+ migrate (CoreState_v0 ua rr) = CoreState Nothing ua rr Nothing+ initialCoreState :: CoreState initialCoreState = CoreState- { coreUACCT = Nothing- , coreRootRedirect = Nothing+ { coreSiteName = Nothing+ , coreUACCT = Nothing+ , coreRootRedirect = Nothing+ , coreLoginRedirect = Nothing } -- | get the 'UACCT' for Google Analytics@@ -58,11 +77,41 @@ setRootRedirect :: Maybe Text -> Update CoreState () setRootRedirect path = modify $ \cs -> cs { coreRootRedirect = path } +-- | get the path that we should redirect to after login+getLoginRedirect :: Query CoreState (Maybe Text)+getLoginRedirect = coreLoginRedirect <$> ask++-- | set the path that we should redirect to after login+setLoginRedirect :: Maybe Text -> Update CoreState ()+setLoginRedirect path = modify $ \cs -> cs { coreLoginRedirect = path }++-- | get the site name+getSiteName :: Query CoreState (Maybe Text)+getSiteName = coreSiteName <$> ask++-- | set the site name+setSiteName :: Maybe Text -> Update CoreState ()+setSiteName name = modify $ \cs -> cs { coreSiteName = name }++-- | get the entire 'CoreState'+getCoreState :: Query CoreState CoreState+getCoreState = ask++-- | set the entire 'CoreState'+setCoreState :: CoreState -> Update CoreState ()+setCoreState = put+ $(makeAcidic ''CoreState [ 'getUACCT , 'setUACCT , 'getRootRedirect , 'setRootRedirect+ , 'getLoginRedirect+ , 'setLoginRedirect+ , 'getSiteName+ , 'setSiteName+ , 'getCoreState+ , 'setCoreState ]) data Acid = Acid@@ -92,4 +141,3 @@ createArchiveCheckpointAndClose acid = do createArchive acid createCheckpointAndClose acid-
Clckwrks/Admin/EditSettings.hs view
@@ -5,33 +5,78 @@ import Clckwrks import Clckwrks.Acid (GetUACCT(..), SetUACCT(..)) import Clckwrks.Admin.Template (template)-import Data.Text.Lazy (Text)+import Data.Maybe (fromMaybe)+-- import Data.Text.Lazy (Text, pack, unpack)+-- import qualified Data.Text.Lazy as TL++import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+ -- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..)) import HSP.Google.Analytics (UACCT(..)) import HSP.XMLGenerator import HSP.XML (fromStringLit) import Text.Reform import Text.Reform.Happstack-import Text.Reform.HSP.String+import Text.Reform.HSP.Text editSettings :: ClckURL -> Clck ClckURL Response editSettings here =- do muacct <- query $ GetUACCT+ do coreState <- query $ GetCoreState action <- showURL here template "Edit Settings" () $ <%>- <% reform (form action) "ss" updateSettings Nothing (editSettingsForm muacct) %>+ <% reform (form action) "ss" updateSettings Nothing (editSettingsForm coreState) %> </%> where- updateSettings :: Maybe UACCT -> Clck ClckURL Response- updateSettings muacct =- do update (SetUACCT muacct)- seeOtherURL (Admin Console)+ updateSettings :: CoreState -> Clck ClckURL Response+ updateSettings coreState =+ do update (SetCoreState coreState)+ seeOtherURL here -editSettingsForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)-editSettingsForm muacct =+editSettingsForm :: CoreState -> ClckForm ClckURL CoreState+editSettingsForm CoreState{..} = divHorizontal $ fieldset $+ (CoreState <$>+ (divControlGroup $+ (labelText "site name" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty coreSiteName)) `transformEither` toNothing)))++ <*> (divControlGroup $+ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (unUACCT coreUACCT)) `transformEither` toMUACCT))++ <*> (divControlGroup $+ (labelText "/ redirects to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty coreRootRedirect)) `transformEither` toNothing))++ <*> (divControlGroup $+ (labelText "after login redirect to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++>+ (divControls (inputText (fromMaybe mempty coreLoginRedirect)) `transformEither` toNothing))+ <*+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text])+ where+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])++ unUACCT (Just (UACCT str)) = pack str+ unUACCT Nothing = mempty++ toMUACCT :: T.Text -> Either ClckFormError (Maybe UACCT)+ toMUACCT str | T.null str = Right $ Nothing+ toMUACCT str = Right $ Just (UACCT $ T.unpack str)++ toNothing :: a -> Either ClckFormError (Maybe a)+ toNothing a = Right $ Just a+++{-+editUACCTForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)+editUACCTForm muacct =+ divHorizontal $+ fieldset $ (divControlGroup $ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*@@ -46,5 +91,4 @@ toMUACCT :: String -> Either ClckFormError (Maybe UACCT) toMUACCT [] = Right $ Nothing toMUACCT str = Right $ Just (UACCT str)--+-}
Clckwrks/Admin/Template.hs view
@@ -4,7 +4,7 @@ import Clckwrks import Control.Monad.State (get)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, fromMaybe) import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Set (Set)@@ -18,7 +18,8 @@ , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response-template title headers body =+template title headers body = do+ siteName <- (fromMaybe "Your Site") <$> query GetSiteName toResponse <$> (unXMLGenT $ <html> <head>@@ -36,7 +37,7 @@ <div class="navbar"> <div class="navbar-inner"> <div class="container-fluid">- <a href="/" class="brand">Back to Your Site</a>+ <a href="/" class="brand">Back to <% siteName %></a> </div> </div> </div>
Clckwrks/ProfileData/Route.hs view
@@ -23,7 +23,10 @@ , roles = singleton Visitor } update (NewProfileData profileData)- seeOtherURL EditProfileData+ mRedirect <- query GetLoginRedirect+ case mRedirect of+ Nothing -> seeOtherURL EditProfileData+ (Just url) -> seeOther url (toResponse ()) EditProfileData -> do editProfileDataPage url EditProfileDataFor u ->
Clckwrks/Server.hs view
@@ -14,9 +14,10 @@ import Control.Concurrent (forkIO, killThread) import Control.Concurrent.STM (atomically, newTVar) import Control.Monad.State (get, evalStateT)+import Data.Acid.Advanced (query') import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, fromMaybe) import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text)@@ -81,7 +82,9 @@ [ jsHandlers cc , dir "favicon.ico" $ notFound (toResponse ()) , dir "static" $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing []- , nullDir >> seeOther ("/page/view-page/1" :: String) (toResponse ()) -- FIXME: get redirect location from database+ , do nullDir+ mRR <- query' (acidCore . acidState $ clckState) GetRootRedirect+ seeOther (fromMaybe ("/page/view-page/1") mRR) (toResponse ()) -- FIXME: get redirect location from database , clckSite cc clckState ]
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.19.3+Version: 0.20.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