diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 3b1e619..100c756 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -17,22 +17,28 @@ urlconf = "blog" // "new" --> newpost
<|> "blog" --> allposts
<|> "login" --> login
<|> "logout" --> (doLogout "/blog/")
- <|> "auth" --> (checkAuth "/blog/" "/login/")
<|> "form" --> testform
<|> "i18n" --> i18ntest
<|> RawFunction serveStatic
login :: HttpAction
login = do
- methodOnly GET
rq <- asks request
- already <- sessionLookup "username"
- if not $ null already
- then returnNow $ redirect "/blog/"
- else return ()
- (loginhtml,err) <- showLoginForm "/auth/"
- renderToResponseM "login.html" [("form", C loginhtml),
- ("invalid", C err)]
+ 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/"
testform :: HttpAction
testform = do
diff --git a/Blog/Settings.hs b/Blog/Settings.hs
index 78bb421..c079179 100644
--- a/Blog/Settings.hs
+++ b/Blog/Settings.hs
@@ -9,20 +9,29 @@ 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 :: ExcHandler
+-- 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 :: ExcHandler
+controllerExcHandler :: ControllerExcHandler
-- controllerExcHandler rq code msg = return ()
-controllerExcHandler rq code msg = requestExcHandler rq code msg
+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]
diff --git a/Blog/templates/403.html b/Blog/templates/403.html
new file mode 100644
index 0000000..22b4058
--- /dev/null
+++ b/Blog/templates/403.html
@@ -0,0 +1,13 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="ru">
+ <head>
+ <title>{{error}}</title>
+ <meta name='author' content='Portnov'>
+ </head>
+ <body>
+
+ <h1>{{error}}</h1>
+ <p>Sorry, authentitication required.</p>
+
+ </body>
+</html>
diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html
index d9bdb0d..fc0c7b2 100644
--- a/Blog/templates/blogposts.html
+++ b/Blog/templates/blogposts.html
@@ -33,7 +33,9 @@
Добавить комментарий
{%endif%}
</a></p>
+ {%if username%}
<p><small><a href="/blog/edit/{{postid post}}">Edit</a></small></p>
+ {%endif%}
<hr>
{%endfor%}
diff --git a/Framework/Controller.hs b/Framework/Controller.hs
index 3eaa0a0..f313cbe 100644
--- a/Framework/Controller.hs
+++ b/Framework/Controller.hs
@@ -16,7 +16,7 @@ module Framework.Controller
Controller, AController,
HttpController, StaticController,
ContextProcessor,
- ExcHandler,
+ RequestExcHandler, ControllerExcHandler,
-- * Controller-monad specific functions
MonadIO (..),
returnNow, reject,
@@ -56,7 +56,8 @@ type AController a = Controller ActionConfig HttpResponse a
type ContextProcessor = Controller ActionConfig Context Context
-type ExcHandler = HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse ()
+type RequestExcHandler = HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse ()
+type ControllerExcHandler = HttpRequest -> Int -> String -> AController ()
-------------------------------------------------------------------------------------------
diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs
index 7b81e13..85be647 100644
--- a/Framework/Exceptions.hs
+++ b/Framework/Exceptions.hs
@@ -18,10 +18,17 @@ import Framework.Http.Response
import Settings (requestExcHandler, controllerExcHandler)
-raiseAny :: ExcHandler -> HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse a
-raiseAny handler rq code msg = do
+raiseStatic :: HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse a
+raiseStatic rq code msg = do
ps <- ask
- handler rq code msg
+ requestExcHandler rq code msg
+ liftIO $ writeLog (errChan ps) rq $ (show code)++" "++msg
+ returnNow $ response code [] msg
+
+raiseAction :: HttpRequest -> Int -> String -> AController a
+raiseAction rq code msg = do
+ ps <- asks httpParams
+ controllerExcHandler rq code msg
liftIO $ writeLog (errChan ps) rq $ (show code)++" "++msg
returnNow $ response code [] msg
@@ -31,9 +38,9 @@ raiseC :: Int -- ^ HTTP error code
-> AController a
raiseC code msg = do
rq <- asks request
- ps <- asks httpParams
- let handler = raiseAny controllerExcHandler rq code msg
- val <- liftIO $ evalRightNow handler ps
+ ac <- ask
+ let handler = raiseAction rq code msg
+ val <- liftIO $ evalController handler ac
case val of
Just resp -> returnNow resp
Nothing -> returnNow $ response 500 [] "Impossible: Exception handler returned Nothing!"
@@ -45,7 +52,7 @@ raiseIO :: StaticConfig -- ^ Static (global) config
-> String -- ^ Message
-> IO HttpResponse
raiseIO ps rq code msg = do
- val <- evalController (raiseAny requestExcHandler rq code msg) ps
+ val <- evalController (raiseStatic rq code msg) ps
case val of
Just resp -> return resp
Nothing -> return $ response 500 [] "Impossible: Exception handler returned Nothing!"
diff --git a/Framework/Modules/Auth/Utils.hs b/Framework/Modules/Auth/Utils.hs
new file mode 100644
index 0000000..fd37150
--- /dev/null
+++ b/Framework/Modules/Auth/Utils.hs
@@ -0,0 +1,11 @@
+module Framework.Modules.Auth.Utils where
+
+import Framework.API
+
+loginRequired :: AController a
+ -> AController a
+loginRequired action = do
+ username <- sessionLookup "username"
+ if null username
+ then raiseC 403 "Forbidden"
+ else action