Simplifications
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)