diff --git a/Clckwrks/Acid.hs b/Clckwrks/Acid.hs
--- a/Clckwrks/Acid.hs
+++ b/Clckwrks/Acid.hs
@@ -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
-
diff --git a/Clckwrks/Admin/EditSettings.hs b/Clckwrks/Admin/EditSettings.hs
--- a/Clckwrks/Admin/EditSettings.hs
+++ b/Clckwrks/Admin/EditSettings.hs
@@ -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 -> [<% xml %>
])
+ divControlGroup = mapView (\xml -> [<% xml %>
])
+ divControls = mapView (\xml -> [<% xml %>
])
+
+ 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)
-
-
+-}
diff --git a/Clckwrks/Admin/Template.hs b/Clckwrks/Admin/Template.hs
--- a/Clckwrks/Admin/Template.hs
+++ b/Clckwrks/Admin/Template.hs
@@ -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 $
@@ -36,7 +37,7 @@
diff --git a/Clckwrks/ProfileData/Route.hs b/Clckwrks/ProfileData/Route.hs
--- a/Clckwrks/ProfileData/Route.hs
+++ b/Clckwrks/ProfileData/Route.hs
@@ -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 ->
diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs
--- a/Clckwrks/Server.hs
+++ b/Clckwrks/Server.hs
@@ -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
]
diff --git a/clckwrks.cabal b/clckwrks.cabal
--- a/clckwrks.cabal
+++ b/clckwrks.cabal
@@ -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