diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 82135c2..e2cdd84 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -2,23 +2,12 @@ import System.IO import Database.HDBC (SqlValue(..),fromSql) import qualified Data.Map as M -import Data.Maybe import Control.Monad(forM) -import Control.Monad.Reader.Class -import Network.HTTP -import Codec.Binary.UTF8.String -import Framework.Types -import Framework.Controller import Framework.API import Framework.SQL -import Framework.Http.Response -import Framework.Http.Vars -import Framework.TEngine.TemplateUtil -import Framework.Urls +import Framework.Http.Response(redirect) import Framework.Utils -import Framework.Forms.Validation -import Framework.Pager import Models diff --git a/Framework/API.hs b/Framework/API.hs index 1b12852..1b3e602 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -2,19 +2,37 @@ -- | Contains `userland` API. Wraps functions from many other modules. -- API functions get ActionConfig parameter, which contains all data about current job. module Framework.API - (getcookie, setcookie, + (-- * Cookies API + getcookie, setcookie, + -- * API of HTTP server serveStatic, serveHttp, + -- * Re-exported modules + -- ** System modules + module Control.Monad.Reader.Class, + module Network.HTTP, + -- ** Common modules + module Framework.Types, + module Framework.Controller, + -- ** API modules module Framework.API.Cache, module Framework.API.Sessions, module Framework.API.Storage, module Framework.API.SQL, module Framework.API.Logger, - module Framework.API.UserMessage + module Framework.API.UserMessage, + -- ** Specific modules + module Framework.TEngine.TemplateUtil, + module Framework.Forms.Validation, + module Framework.Pager, + module Framework.Http.Vars, + module Framework.Urls ) where +import Control.Monad.Reader.Class import Network.HTTP import Framework.Types +import Framework.Controller import qualified Framework.Http.Cookies as Cookies import Framework.Http.HTTPServer (serveStatic, serveHttp) @@ -25,15 +43,24 @@ import Framework.API.SQL import Framework.API.Logger import Framework.API.UserMessage +import Framework.TEngine.TemplateUtil +import Framework.Forms.Validation +import Framework.Pager +import Framework.Http.Vars +import Framework.Urls hiding (runURLConf) + ---------------------------------------------------------------------------------------------------------- -- * Cookies API --- FIXME: should this functions be monadic? -- | Get cookie value -getcookie :: ActionConfig -> String -> String -getcookie ac name = Cookies.getcookie (request ac) name +getcookie :: String -> AController String +getcookie name = do + rq <- asks request + return $ Cookies.getcookie rq name -- | Return HttpHeader, which sets specified cookie. -setcookie :: ActionConfig -> String -> String -> Header -setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value +setcookie :: String -> String -> AController Header +setcookie name value = do + expDate <- asks cookiesExp + return $ Cookies.setcookie expDate name value diff --git a/Framework/API/UserMessage.hs b/Framework/API/UserMessage.hs index a5b284f..1e777d3 100644 --- a/Framework/API/UserMessage.hs +++ b/Framework/API/UserMessage.hs @@ -1,14 +1,13 @@ module Framework.API.UserMessage where -import Control.Monad.Reader.Class - -import Framework.Types import Framework.Controller import Framework.API.Sessions +-- | Add a message for user to session message :: String -> AController () message msg = sessionSet "message" msg +-- | If there is `message` variable in session, then return X, else Y. ifMessage :: a -> a -> AController a ifMessage x y = do msg <- sessionLookup "message" diff --git a/Framework/Cache/Cache.hs b/Framework/Cache/Cache.hs index 581a8bc..ab21b3c 100644 --- a/Framework/Cache/Cache.hs +++ b/Framework/Cache/Cache.hs @@ -1,3 +1,4 @@ +-- | This module contains common cache functions module Framework.Cache.Cache where import Network.Memcache.Serializable (Serializable(..)) diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs index d926693..e5cdcff 100644 --- a/Framework/ContextProcessors.hs +++ b/Framework/ContextProcessors.hs @@ -1,13 +1,16 @@ -module Framework.ContextProcessors where +module Framework.ContextProcessors + (defaultProcessors) + where -import Control.Monad.Reader.Class - -import Framework.Types +import Framework.Types(TContainer(C)) import Framework.Controller import Framework.API.Sessions +-- | Default set of context processors +defaultProcessors :: [ContextProcessor] defaultProcessors = [addMessage] +-- | Add `message` variable from session to context addMessage :: ContextProcessor addMessage = do msg <- sessionLookup "message" diff --git a/Framework/Controller.hs b/Framework/Controller.hs index f82f3b7..0950610 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -1,13 +1,30 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +-- | Controller is a monad, superset of IO. +-- All application controllers are executed in this monad. +-- Controller type has three type parameters. First is type of configuration +-- for controller (usually it will be @ActionConfig@ or @StaticConfig@). Second and +-- third are types of possible results of controller. +-- +-- There are three possible ways to combine Controller actions. First, you can +-- execute actions one by one, just as in IO monad. Secondly, if you decode +-- that you already have a result, you can return that result with @returnNow@ +-- function -- all subsequent computations will not be executed. Third, you can +-- at any moment reject all the computation (in application controller, this +-- will mean `I do not want process this URL!'). module Framework.Controller - (Controller, AController, + (-- * Data types + Controller, AController, HttpController, StaticController, ContextProcessor, - liftC, returnNow, + -- * Controller-monad specific functions + liftC, + returnNow, reject, concatC, changeR, - internalError, reject, - assertC, errorIf, forceMaybe, - evalController + assertC, + evalController, + -- * Functions that are specific to application-level controllers + internalError, + errorIf, forceMaybe ) where import Control.Monad.Reader.Class @@ -15,6 +32,9 @@ import Control.Monad.Reader.Class import Framework.Types import Framework.Http.Response +--------------------------------------------------------------------------------------- +-- * Data types + -- | Controller may reject url, return a value for further processing, -- or return a value right now to avoid succeding computations data ControllerResult r a = Reject -- ^ `No, I wann't process this URL!' @@ -39,12 +59,6 @@ type ContextProcessor = Controller ActionConfig Context Context ------------------------------------------------------------------------------------------- --- | Convert any result to Maybe HttpResponse -anyResult :: ControllerResult a a -> Maybe a -anyResult Reject = Nothing -anyResult (RightNow r) = Just r -anyResult (Result r) = Just r - instance Monad (Controller s r) where -- return :: a -> Controller s a return v = Controller $ \_ -> return (Result v) @@ -62,6 +76,9 @@ instance MonadReader s (Controller s r) where ask = Controller $ \s -> return (Result s) local f m = Controller $ runController m . f +--------------------------------------------------------------------------------------------- +-- * Controller-monad specific functions + -- | Run all controllers in list in given environment, and concatenate results concatC :: [Controller b [a] [a]] -- ^ List of controllers -> Controller b r [a] @@ -100,6 +117,19 @@ assertC b = returnNow :: r -> Controller s r a returnNow v = Controller $ \_ -> return (RightNow v) +-- | Reject this computation +reject :: Controller s r a +reject = Controller $ \_ -> return Reject + +-- | Evaluate controller with given configuration +evalController :: Controller s a a -- ^ Controller + -> s -- ^ Configuration for controller + -> IO (Maybe a) +evalController m s = anyResult `fmap` (runController m s) + +----------------------------------------------------------------------------------------- +-- * Functions that are specific to application-level controllers + -- | Return HTTP 500 error with given message internalError :: String -> Controller s HttpResponse a internalError msg = returnNow $ response 500 [] msg @@ -123,14 +153,9 @@ forceMaybe msg x = Just v -> return v Nothing -> internalError msg --- | Reject this URL -reject :: Controller s r a -reject = Controller $ \_ -> return Reject - --- | Evaluate controller with given configuration -evalController :: Controller s a a -- ^ Controller - -> s -- ^ Configuration for controller - -> IO (Maybe a) -evalController m s = anyResult `fmap` (runController m s) - +-- | Convert any result to Maybe HttpResponse +anyResult :: ControllerResult a a -> Maybe a +anyResult Reject = Nothing +anyResult (RightNow r) = Just r +anyResult (Result r) = Just r diff --git a/Framework/Pager.hs b/Framework/Pager.hs index aeadcb6..8954e9f 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -12,7 +12,7 @@ import Framework.Forms.Types import Framework.Forms.HTML import Framework.Models import Framework.SQL -import Framework.API +import Framework.API.SQL import Framework.Types import Framework.Controller import Framework.Http.Vars diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index b681fb2..7f358a5 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -15,7 +15,8 @@ import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) import Framework.Types import Framework.Controller -import Framework.API +import Framework.API.Sessions +import Framework.API.Cache import Framework.Cache import Framework.ContextProcessors (defaultProcessors)