diff --git a/Blog/Extensions/Context.hs b/Blog/Extensions/Context.hs new file mode 100644 index 0000000..e616538 --- /dev/null +++ b/Blog/Extensions/Context.hs @@ -0,0 +1,9 @@ +module Extensions.Context where + +import Framework.Controller + +import Framework.Modules.Auth.Context + +-- | Application set of context processors +contextProcessors :: [ContextProcessor] +contextProcessors = [addLoginForm "/login"] diff --git a/Blog/Extensions/FormProcessors.hs b/Blog/Extensions/FormProcessors.hs new file mode 100644 index 0000000..e03d528 --- /dev/null +++ b/Blog/Extensions/FormProcessors.hs @@ -0,0 +1,11 @@ +module Extensions.FormProcessors where + +import Framework.Forms.Types + +-- | These functions may modify each Form. +formProcessors :: [Form -> Form] +formProcessors = [simple] + +simple :: Form -> Form +simple = id + diff --git a/Blog/Extensions/Handlers.hs b/Blog/Extensions/Handlers.hs new file mode 100644 index 0000000..0b7c058 --- /dev/null +++ b/Blog/Extensions/Handlers.hs @@ -0,0 +1,25 @@ +module Extensions.Handlers where + +import Network.HTTP +import Network.URI + +import Framework.Types +import Framework.Controller +import Framework.TEngine.TemplateUtil + +import Framework.Modules.Auth.Handlers + +-- | 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 = do + handle403 "/login/" rq code msg + requestExcHandler rq code msg diff --git a/Blog/Extensions/Middlewares.hs b/Blog/Extensions/Middlewares.hs new file mode 100644 index 0000000..4f85566 --- /dev/null +++ b/Blog/Extensions/Middlewares.hs @@ -0,0 +1,5 @@ +module Extensions.Middlewares where + +requestMiddlewares = [] +responseMiddlewares = [] + diff --git a/Blog/Extensions/Signals.hs b/Blog/Extensions/Signals.hs new file mode 100644 index 0000000..2e8838c --- /dev/null +++ b/Blog/Extensions/Signals.hs @@ -0,0 +1,13 @@ +module Extensions.Signals where + +import qualified Data.Map as M + +import Framework.SignalTypes + +import Invalidation +connectSignals :: M.Map Signal [SignalHandler] +connectSignals = M.fromList [ + ("pre_insert", [invalidatePostsCache]), + ("auth_ok", [invalidatePostsCache]), + ("logout", [invalidatePostsCache]), + ("pre_update", [invalidatePostsCache]) ] diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs index 85be647..767e912 100644 --- a/Framework/Exceptions.hs +++ b/Framework/Exceptions.hs @@ -16,7 +16,7 @@ import Framework.Controller import Framework.Logger import Framework.Http.Response -import Settings (requestExcHandler, controllerExcHandler) +import Extensions.Handlers (requestExcHandler, controllerExcHandler) raiseStatic :: HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse a raiseStatic rq code msg = do diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index e95e23a..00e858d 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -30,7 +30,7 @@ import Framework.Http.Vars import Framework.Forms.Types import Framework.Forms.HTML -import Settings (formProcessors) +import Extensions.FormProcessors (formProcessors) -- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and -- fill with previous values diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index b30e31f..5ef21a3 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -18,7 +18,7 @@ import Framework.Types import Framework.GetText import Framework.Config -import qualified Settings (requestMiddlewares, responseMiddlewares) +import qualified Extensions.Middlewares as Settings (requestMiddlewares, responseMiddlewares) type RequestMiddleware = StaticConfig -> HttpRequest -> IO HttpRequest type ResponseMiddleware = StaticConfig -> HttpResponse -> IO HttpResponse diff --git a/Framework/Modules/Auth/Context.hs b/Framework/Modules/Auth/Context.hs new file mode 100644 index 0000000..dd52bc7 --- /dev/null +++ b/Framework/Modules/Auth/Context.hs @@ -0,0 +1,25 @@ +module Framework.Modules.Auth.Context where + +import Debug.Trace + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +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 +addLoginForm target = do + url <- asks (myUrl.request) + if normal url == (normal target) + then do (loginhtml,err) <- showLoginForm target + return [("form", C loginhtml), ("invalid", C err)] + else return [] diff --git a/Framework/Modules/Auth/Handlers.hs b/Framework/Modules/Auth/Handlers.hs new file mode 100644 index 0000000..d8ef738 --- /dev/null +++ b/Framework/Modules/Auth/Handlers.hs @@ -0,0 +1,22 @@ +module Framework.Modules.Auth.Handlers where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import Framework.Utils +import Framework.API.UserMessage +import Framework.API.Sessions +import Framework.Http.Response + +-- | Controller exceptions handler; Handle only 403 error; redirect to login page, after which user will be redirected here. +handle403 :: String -- ^ URL of login page + -> ControllerExcHandler +handle403 target rq code msg = do + rq <- asks request + if code==403 + then do message $ msg ++ ": Authenitication required" + sessionSet "target" $ myUrl rq + returnNow $ redirect target + else return () + diff --git a/Framework/Modules/Auth/ShowForm.hs b/Framework/Modules/Auth/ShowForm.hs new file mode 100644 index 0000000..9a46183 --- /dev/null +++ b/Framework/Modules/Auth/ShowForm.hs @@ -0,0 +1,20 @@ +module Framework.Modules.Auth.ShowForm where + +import Framework.Types +import Framework.Controller +import Framework.Forms.Types +import Framework.Forms.Validation + +import Framework.Modules.Auth.Models + + +-- | Wraps @retryForm@ for login form +showLoginForm' :: String -- ^ Form target (URL of auth-checking controller) + -> Form -- ^ Login form + -> Controller ActionConfig r (String,String) -- ^ (Form HTML, errors) +showLoginForm' target form = retryForm form "1" [] target + +-- | Same as @showLoginForm'@, but with default login form +showLoginForm :: String -- ^ Form target + -> Controller ActionConfig r (String,String) +showLoginForm target = showLoginForm' target defaultLoginForm diff --git a/Framework/Signals.hs b/Framework/Signals.hs index 205dbcd..32fcda5 100644 --- a/Framework/Signals.hs +++ b/Framework/Signals.hs @@ -11,7 +11,7 @@ import Framework.Controller import Framework.ORM.Types import Framework.SignalTypes -import Settings (connectSignals) +import Extensions.Signals (connectSignals) signals :: M.Map Signal [SignalHandler] signals = defaultSignals `M.union` connectSignals diff --git a/Framework/Urls.hs b/Framework/Urls.hs index ab421e3..fce3a14 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -176,9 +176,3 @@ infixr 6 <|> -- (>=>) = After -- infixr 6 >=> ------------------------------------------------------------------------------------------------- --- --- | Get URL from Request -myUrl :: HttpRequest -> String -myUrl rq = uriPath $ rqURI rq - diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 86c5ec9..274322e 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -139,3 +139,8 @@ expirationDate = do ctime <- toCalendarTime (addDays 14 time) -- FIXME: get number of days from config! return $ formatCalendarTime defaultTimeLocale "%c" ctime +------------------------------------------------------------------------------------------------ +-- +-- | Get URL from Request +myUrl :: HttpRequest -> String +myUrl rq = uriPath $ rqURI rq