Simplifications.
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 238b5ec..0d2878a 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -32,14 +32,8 @@ login = do
registration :: HttpAction
registration = do
- rq <- asks request
- case rqMethod rq of
- GET -> do
- (form,err) <- showRegistrationForm "/register"
- return $ renderToResponse "register.html" [("form", C form),
- ("invalid", C err)]
- POST -> do
- doRegister "/blog"
+ registrationPage "/blog"
+ renderToResponseM "register.html" []
testform :: HttpAction
testform = do
diff --git a/Blog/Extensions/Context.hs b/Blog/Extensions/Context.hs
index e616538..4af1367 100644
--- a/Blog/Extensions/Context.hs
+++ b/Blog/Extensions/Context.hs
@@ -3,7 +3,8 @@ module Extensions.Context where
import Framework.Controller
import Framework.Modules.Auth.Context
+import Framework.Modules.Registration.Context
-- | Application set of context processors
contextProcessors :: [ContextProcessor]
-contextProcessors = [addLoginForm "/login"]
+contextProcessors = [addLoginForm "/login", addRegistrationForm "/register"]
diff --git a/Framework/Modules/Auth/Context.hs b/Framework/Modules/Auth/Context.hs
index dd52bc7..78dd8ff 100644
--- a/Framework/Modules/Auth/Context.hs
+++ b/Framework/Modules/Auth/Context.hs
@@ -10,10 +10,6 @@ import Framework.Utils
import Framework.Modules.Auth.ShowForm
-normal url = if last url == '/'
- then init url
- else url
-
-- | Context processor; Add login form to login page
addLoginForm :: String -- ^ URL of auth-checking controller
-> ContextProcessor
diff --git a/Framework/Modules/Registration/Context.hs b/Framework/Modules/Registration/Context.hs
new file mode 100644
index 0000000..7a251f4
--- /dev/null
+++ b/Framework/Modules/Registration/Context.hs
@@ -0,0 +1,19 @@
+module Framework.Modules.Registration.Context where
+
+import Control.Monad.Reader.Class
+
+import Framework.Types
+import Framework.Controller
+import Framework.Utils
+
+import Framework.Modules.Registration.Forms
+
+-- | Context processor; Add login registration to login page
+addRegistrationForm :: String -- ^ target URL
+ -> ContextProcessor
+addRegistrationForm target = do
+ url <- asks (myUrl.request)
+ if normal url == (normal target)
+ then do (html,err) <- showRegistrationForm target
+ return [("form", C html), ("invalid", C err)]
+ else return []
diff --git a/Framework/Modules/Registration/Forms.hs b/Framework/Modules/Registration/Forms.hs
index 6a4b2f2..ba71775 100644
--- a/Framework/Modules/Registration/Forms.hs
+++ b/Framework/Modules/Registration/Forms.hs
@@ -7,7 +7,6 @@ import Network.HTTP
import Framework.Types
import Framework.Controller
-import Framework.Exceptions
import Framework.ORM
import Framework.Signals
import Framework.Forms.Types
@@ -18,7 +17,7 @@ import Framework.Http.Vars
import Framework.Http.Response
import Framework.API.SQL
import Framework.API.Storage
-import Framework.API.SQLUtils
+import Framework.API.Sessions
import Framework.Modules.Auth.Models
import Framework.Modules.SHA1
@@ -56,10 +55,10 @@ showRegistrationForm' form target = retryForm form "1" [] target
showRegistrationForm :: String-> Controller ActionConfig r (String, String)
showRegistrationForm target = showRegistrationForm' registrationForm target
-doRegister' :: Form -> String -> AController a
+doRegister' :: Form -> String -> HttpController
doRegister' form target = do
rq <- asks request
- methodOnly POST
+-- methodOnly POST
let model = formModel form
(d,_) = getForm form rq $ formName form
case d of
@@ -70,8 +69,23 @@ doRegister' form target = do
pass' = SqlString $ sha1 $ fromSql pass
queryListSQL (insertM model) $ [name,pass']
commit
- returnNow $ redirect target
+ return $ redirect target
Left e -> returnInvalidForm form "1" e
-doRegister :: String -> AController a
+doRegister :: String -> HttpController
doRegister = doRegister' registrationForm
+
+registrationPage' form target = do
+ rq <- asks request
+ case rqMethod rq of
+ GET -> do
+ registered <- sessionLookup "username"
+ if null registered
+ then return ()
+ else returnNow $ redirect target
+ POST -> do
+ resp <- doRegister' form target
+ returnNow resp
+
+registrationPage = registrationPage' registrationForm
+
diff --git a/Framework/Utils.hs b/Framework/Utils.hs
index cefe570..d1556d7 100644
--- a/Framework/Utils.hs
+++ b/Framework/Utils.hs
@@ -150,3 +150,8 @@ f `o` g = \x -> f x >>= g
ioPipe fs x = foldr o return $ ap fs [x]
ioPipe' fs = foldr o return fs
+
+normal url = if last url == '/'
+ then init url
+ else url
+