Improve sessions handling (using new State instance of Controller)
Improve sessions handling (using new State instance of Controller)
Also fix a dumb bug :)
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 42d3702..9de0432 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -23,7 +23,7 @@ urlconf = "blog" // "new" --> newpost
login :: HttpAction
login = do
- loginPage "/blog/" "/login/"
+ loginPage "/blog" "/login"
renderToResponseM "login.html" []
testform :: HttpAction
diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs
index 18c41d0..08dfdec 100644
--- a/Framework/API/Sessions.hs
+++ b/Framework/API/Sessions.hs
@@ -2,6 +2,7 @@
module Framework.API.Sessions where
import Control.Monad.Reader.Class
+import Control.Monad.State.Class
import qualified Data.Map as M
import Framework.Types
@@ -20,12 +21,15 @@ sessionLookup name = do
-- | Set variable into session
sessionSet :: String -> String -> Controller ActionConfig r ()
sessionSet name value = do
- ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask
- liftIO $ sPush sessionsBackend sessionID $ M.insert name value sessionMap
+ ac <- get
+ let m' = M.insert name value $ sessionMap ac
+ liftIO $ sPush (sessionsBackend ac) (sessionID ac) m'
+ put $ ac {sessionMap = m'}
-- | Unset value in the session
sessionUnset :: String -> Controller ActionConfig r ()
sessionUnset name = do
- ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask
- liftIO $ sPush sessionsBackend sessionID $ M.delete name sessionMap
+ ac <- get
+ let m' = M.delete name $ sessionMap ac
+ put $ ac {sessionMap = m'}
diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs
index ef7804a..4f8ba1c 100644
--- a/Framework/Modules/Auth/Controllers.hs
+++ b/Framework/Modules/Auth/Controllers.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
module Framework.Modules.Auth.Controllers where
import Control.Monad.Reader.Class
@@ -19,7 +20,7 @@ checkAuth' :: String
-> String
-> Form
-> HttpAction
-checkAuth' target retry form = do
+checkAuth' !target retry form = do
rq <- asks request
errorIf 400 "Invalid request method" $ rqMethod rq /= POST
let model = formModel form
@@ -37,13 +38,12 @@ checkAuth' target retry form = do
let dbuser = head objs
dbpass = fromSql $ dbuser -:> "password"
if dbpass == (sha1 $ fromSql pass)
- then loginSuccessed name
+ then do
+ sessionSet "username" $ fromSql name
+ send "auth_ok" user
+ return $ redirect target
else loginFailed
where
- loginSuccessed name = do
- sessionSet "username" $ fromSql name
- send "auth_ok" user
- return $ redirect target
loginFailed = do
let values = tail $ urlencode $ map packParam vars
vars = formVars form "1" rq
@@ -73,10 +73,11 @@ loginPage target retry = do
else return ()
POST -> do
t <- sessionLookup "target"
- let target = if null t
- then target
- else t
- resp <- checkAuth target retry
+ sessionUnset "target"
+ let target' = if null t
+ then target
+ else t
+ resp <- checkAuth target' retry
returnNow resp
doLogout :: String