Improve sessions handling (using new State instance of Controller)

portnov [2009-07-14 07:32:33]
Improve sessions handling (using new State instance of Controller)

Also fix a dumb bug :)
Filename
Blog/Blog.hs
Framework/API/Sessions.hs
Framework/Modules/Auth/Controllers.hs
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
ViewGit