Simplifications.

Portnov [2009-07-16 05:52:23]
Simplifications.
Filename
Blog/Blog.hs
Blog/Extensions/Context.hs
Framework/Modules/Auth/Context.hs
Framework/Modules/Registration/Context.hs
Framework/Modules/Registration/Forms.hs
Framework/Utils.hs
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
+
ViewGit