Simplifications

portnov [2009-07-14 04:30:33]
Simplifications
Filename
Blog/Blog.hs
Blog/Context.hs
Blog/Settings.hs
Framework/ContextProcessors.hs
Framework/Forms/Validation.hs
Framework/Modules/Auth/Controllers.hs
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 100c756..42d3702 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -23,22 +23,8 @@ urlconf = "blog" // "new" --> newpost

 login :: HttpAction
 login = do
-    rq <- asks request
-    case rqMethod rq of
-      GET -> do
-            already <- sessionLookup "username"
-            if not $ null already
-              then returnNow $ redirect "/blog/"
-              else return ()
-            (loginhtml,err) <- showLoginForm "/login/"
-            renderToResponseM "login.html" [("form", C loginhtml),
-                                            ("invalid", C err)]
-      POST -> do
-            t <- sessionLookup "target"
-            let target = if null t
-                           then "/blog/"
-                           else t
-            checkAuth target "/login/"
+    loginPage "/blog/" "/login/"
+    renderToResponseM "login.html" []

 testform :: HttpAction
 testform = do
diff --git a/Blog/Context.hs b/Blog/Context.hs
deleted file mode 100644
index 439cd06..0000000
--- a/Blog/Context.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Context where
-
-import Framework.Controller
-
--- | Application set of context processors
-contextProcessors :: [ContextProcessor]
-contextProcessors = []
diff --git a/Blog/Settings.hs b/Blog/Settings.hs
deleted file mode 100644
index c079179..0000000
--- a/Blog/Settings.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-module Settings where
-
-import Network.HTTP
-import Network.URI
-import qualified Data.Map as M
-
-import Framework.Types
-import Framework.SignalTypes
-import Framework.Controller
-import Framework.TEngine.TemplateUtil
-import Framework.Forms.Types
-import Framework.API.UserMessage
-import Framework.API.Sessions
-import Framework.Http.Response
-
-import Invalidation
-
--- | Handle request exception. Should end with returnNow. If it is just @return ()@, built-in handler will work.
--- requestExcHandler :: RequestExcHandler
-requestExcHandler :: HttpRequest -> Int -> String -> Controller s HttpResponse a
-requestExcHandler rq code msg = do
-    returnNow $ renderToResponse (show code++".html") [("error", C msg),
-                                                       ("request", C $ show rq),
-                                                       ("url", C $ uriPath $ rqURI rq)]
-
--- | Handle controller exception. See notes for requestExcHandler.
-controllerExcHandler :: ControllerExcHandler
--- controllerExcHandler rq code msg = return ()
-controllerExcHandler rq code msg =
-    case code of
-      403 -> do message $ msg ++ ": Authenitication required"
-                sessionSet "target" $ uriPath $ rqURI rq
-                returnNow $ redirect "/login/"
-      _   -> requestExcHandler rq code msg
-
--- | These functions may modify each Form.
-formProcessors :: [Form -> Form]
-formProcessors = [simple]
-
-simple :: Form -> Form
-simple = id
-
-requestMiddlewares = []
-responseMiddlewares = []
-
-connectSignals :: M.Map Signal [SignalHandler]
-connectSignals = M.fromList [
-    ("pre_insert", [invalidatePostsCache]),
-    ("auth_ok", [invalidatePostsCache]),
-    ("logout", [invalidatePostsCache]),
-    ("pre_update", [invalidatePostsCache]) ]
diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs
index b6bfc69..fb4e905 100644
--- a/Framework/ContextProcessors.hs
+++ b/Framework/ContextProcessors.hs
@@ -6,7 +6,7 @@ import Framework.Types(TContainer(C))
 import Framework.Controller
 import Framework.API.Sessions

-import qualified Context (contextProcessors)
+import qualified Extensions.Context as Context (contextProcessors)

 -- | Default set of context processors
 defaultProcessors ::  [ContextProcessor]
diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs
index 00e858d..fd1c83c 100644
--- a/Framework/Forms/Validation.hs
+++ b/Framework/Forms/Validation.hs
@@ -71,7 +71,7 @@ retryForm :: Form                  -- ^ A form
           -> String                -- ^ Form ID
           -> [(String,String)]     -- ^ Hidden values
           -> String                -- ^ Target URL
-          -> AController (String, String)   -- ^ (Form HTML, error message)
+          -> Controller ActionConfig r (String, String)   -- ^ (Form HTML, error message)
 retryForm form fid pairs action = do
     filled <- sessionLookup "filled"
     rq <- asks request
diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs
index 76a424e..ef7804a 100644
--- a/Framework/Modules/Auth/Controllers.hs
+++ b/Framework/Modules/Auth/Controllers.hs
@@ -55,6 +55,30 @@ checkAuth' target retry form = do

       Left e -> returnInvalidForm form "1" e

+checkAuth :: String
+          -> String
+          -> HttpAction
+checkAuth target retry = checkAuth' target retry defaultLoginForm
+
+loginPage :: String
+          -> String
+          -> AController ()
+loginPage target retry = do
+    rq <- asks request
+    case rqMethod rq of
+      GET -> do
+            already <- sessionLookup "username"
+            if not $ null already
+              then returnNow $ redirect target
+              else return ()
+      POST -> do
+            t <- sessionLookup "target"
+            let target = if null t
+                           then target
+                           else t
+            resp <- checkAuth target retry
+            returnNow resp
+
 doLogout :: String
          -> HttpAction
 doLogout target = do
@@ -64,11 +88,6 @@ doLogout target = do
     sessionUnset "username"
     return $ redirect target

-checkAuth :: String
-          -> String
-          -> HttpAction
-checkAuth target retry = checkAuth' target retry defaultLoginForm
-
 showLoginForm' :: String
                -> Form
                -> AController (String,String)
ViewGit