diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 6be99ef..f4e0c07 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -2,7 +2,8 @@ import System.IO import Database.HDBC (SqlValue(..),fromSql) import qualified Data.Map as M -import Control.Monad +import Data.Maybe +import Control.Monad(forM) import Control.Monad.Reader.Class import Network.HTTP import Codec.Binary.UTF8.String @@ -17,12 +18,9 @@ import Framework.TEngine.TemplateUtil import Framework.Urls import Framework.Utils import Framework.Forms.Validation -import Framework.Models import Framework.Pager -import Framework.Cache import Models -import Plugins messagecodes = [("1","Пост успешно добавлен."), ("2","Комментарий добавлен."), @@ -53,8 +51,9 @@ allposts = do tryReturnFromCache key (posts,pagerHtml) <- pager 5 (countChildren postModel commentModel "dt") [] postModel lastComments <- querySQL' ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel - let code = getString' getvars "code" "" - let message = maybe "" id $ lookup code messagecodes + code <- sessionLookup "code" + sessionUnset "code" + let message = fromMaybe "" $ lookup code messagecodes let html = render "blogposts.html" $ M.fromList [("posts", C posts), ("comments", C lastComments), @@ -79,11 +78,12 @@ newpost = do GET -> do (form,err) <- retryForm postForm "1" [] url return $ renderToResponse "newpost.html" [("form", C form), - ("invalid", C err)] + ("invalid", C err)] POST -> do insertModel allForms postModel postForm "1" [] invalidatePostsCache - return $ redirectG "/blog/" ["code" := "1"] + sessionSet "code" "1" + return $ redirect "/blog/" editpost :: StrAction editpost sid = do @@ -99,7 +99,8 @@ editpost sid = do POST -> do updateModel allForms postModel postForm "1" sid invalidatePostsCache - return $ redirectG "/blog/" ["code" := "3"] + sessionSet "code" "3" + return $ redirect "/blog/" onepost :: StrAction onepost sid = do @@ -111,8 +112,9 @@ onepost sid = do GET -> do post <- getOneObject postModel pid comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 $ fromIntegral pid] commentModel - let code = httpGetVar' rq "code" "" - let message = maybe "" id $ lookup code messagecodes + code <- sessionLookup "code" + sessionUnset "code" + let message = fromMaybe "" $ lookup code messagecodes return $ renderToResponse "onepost.html" [("post", C post), ("comments", C comments), ("message", C message), @@ -120,6 +122,7 @@ onepost sid = do POST -> do insertModel allForms commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] invalidatePostsCache - return $ redirectG url ["code" := "2"] + sessionSet "code" "2" + return $ redirect url main = serveHttp "blog.conf" urlconf diff --git a/Framework/API/Cache.hs b/Framework/API/Cache.hs index d8d794c..c2389ba 100644 --- a/Framework/API/Cache.hs +++ b/Framework/API/Cache.hs @@ -12,7 +12,7 @@ import Framework.Http.Response -- | Get a value from cache cacheGet :: String -- ^ Key - -> Controller ActionConfig (Maybe String) + -> AController (Maybe String) cacheGet key = do cb <- asks cacheBackend liftC $ cGet cb key @@ -20,7 +20,7 @@ cacheGet key = do -- | Put a value to cache cachePut :: String -- ^ Key -> String -- ^ Value - -> Controller ActionConfig Bool + -> AController Bool cachePut key value = do cb <- asks cacheBackend liftC $ {-do @@ -29,14 +29,14 @@ cachePut key value = do -- | Unset key in cache cacheUnset :: String -- ^ Key - -> Controller ActionConfig Bool + -> AController Bool cacheUnset key = do cb <- asks cacheBackend liftC $ cUnset cb key -- | If named item is in cache, return its value. Otherwise, do nothing. tryReturnFromCache :: String -- ^ Key - -> Controller ActionConfig () + -> AController () tryReturnFromCache key = do c <- cacheGet key case c of diff --git a/Framework/API/Logger.hs b/Framework/API/Logger.hs index 648b153..b865abc 100644 --- a/Framework/API/Logger.hs +++ b/Framework/API/Logger.hs @@ -11,7 +11,7 @@ import qualified Framework.Logger as Logger -- | Write a message to access log accessLog :: String -- ^ Log message - -> Controller ActionConfig () + -> AController () accessLog msg = do chan <- asks (logChan.httpParams) rq <- asks request @@ -19,7 +19,7 @@ accessLog msg = do -- | Write a message to errors log errorLog :: String -- ^ Log message - -> Controller ActionConfig () + -> AController () errorLog msg = do chan <- asks (errChan.httpParams) rq <- asks request diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index a775b2a..4627355 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -18,32 +18,32 @@ import Framework.API.Storage -- * Storage/SQL API -- | Same as "queryList", but gets Query instead of plain SQL -queryListSQL :: Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryListSQL :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryListSQL q params = do conn <- asks dbconnection liftC $ Storage.query conn (sql q) params -- | Same, but strict. -queryListSQL' :: Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryListSQL' :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]] queryListSQL' q params = do conn <- asks dbconnection liftC $ Storage.query' conn (sql q) params -- | Same as "query", but gets Query object instead of plain SQL -querySQL :: Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model] +querySQL :: Query -> [HDBC.SqlValue] -> Model -> AController [Model] querySQL q params model = do conn <- asks dbconnection liftC $ Storage.queryR conn (sql q) params model -- | Same, but strict. -querySQL' :: Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model] +querySQL' :: Query -> [HDBC.SqlValue] -> Model -> AController [Model] querySQL' q params model = do conn <- asks dbconnection liftC $ Storage.queryR' conn (sql q) params model -- | Get an object from DB specified by Model and object ID. -- Fail if count(such objects)=!1. -getOneObject :: Model -> Int -> Controller ActionConfig Model +getOneObject :: Model -> Int -> AController Model getOneObject model oid = do idf <- forceMaybe "Could not find primary key!" $ getPK model objs <- querySQL' ((table model) `restrict` (idf :==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model @@ -55,7 +55,7 @@ insertModel :: M.Map String Form -- ^ Map of all forms -> Form -> String -- ^ Form ID -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form) - -> Controller ActionConfig () + -> AController () insertModel mm model form fid params = do rq <- asks request let (d,_) = getForm mm rq (formName form) @@ -73,7 +73,7 @@ updateModel :: M.Map String Form -- ^ Map of all forms -> Form -> String -- ^ Form ID -> String -- ^ Object ID - -> Controller ActionConfig () + -> AController () updateModel mm model form fid oid = do rq <- asks request idf <- forceMaybe "Could not find PK!" $ getPK model diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index 1074cb8..a2aa346 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -12,13 +12,20 @@ import Framework.Http.Sessions -- * Sessions API -- | Get variable from session -sessionLookup :: String -> Controller ActionConfig String +sessionLookup :: String -> AController String sessionLookup name = do mm <- asks sessionMap return $ maybe "" id $ M.lookup name mm -- | Set variable into session -sessionSet :: String -> String -> Controller ActionConfig () +sessionSet :: String -> String -> AController () sessionSet name value = do ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask liftC $ sPush sessionsBackend sessionID $ M.insert name value sessionMap + +-- | Unset value in the session +sessionUnset :: String -> AController () +sessionUnset name = do + ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask + liftC $ sPush sessionsBackend sessionID $ M.delete name sessionMap + diff --git a/Framework/API/Storage.hs b/Framework/API/Storage.hs index c065f90..130cd42 100644 --- a/Framework/API/Storage.hs +++ b/Framework/API/Storage.hs @@ -27,7 +27,7 @@ queryList' sql params = do query :: String -- ^ SQL -> [HDBC.SqlValue] -- ^ SQL parameters -> Model -- ^ Model of query results - -> Controller ActionConfig [Model] + -> AController [Model] query sql params model = do conn <- asks dbconnection liftC $ Storage.queryR conn sql params model @@ -36,12 +36,12 @@ query sql params model = do query' :: String -- ^ SQL -> [HDBC.SqlValue] -- ^ SQL parameters -> Model -- ^ Model of query results - -> Controller ActionConfig [Model] + -> AController [Model] query' sql params model = do conn <- asks dbconnection liftC $ Storage.queryR' conn sql params model -commit :: Controller ActionConfig () +commit :: AController () commit = do conn <- asks dbconnection liftC $ Storage.commit conn diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 5a4c8e1..0744098 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Framework.Controller - (Controller, + (Controller, AController, HttpController, StaticController, liftC, returnNow, internalError, rejectUrl, @@ -28,6 +28,8 @@ newtype Controller s a = Controller { type HttpController = Controller ActionConfig HttpResponse -- | Type of application-level controllers, that use StaticConfig type StaticController = Controller StaticConfig HttpResponse +-- | Most common type of controllers +type AController a = Controller ActionConfig a -- | Convert any result to Maybe HttpResponse anyResult :: ControllerResult HttpResponse -> Maybe HttpResponse diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 5531b4e..0edd24d 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -72,7 +72,7 @@ retryForm :: Form -- ^ A form -> String -- ^ Form ID -> [(String,String)] -- ^ Hidden values -> String -- ^ Target URL - -> Controller ActionConfig (String, String) -- ^ (Form HTML, error message) + -> AController (String, String) -- ^ (Form HTML, error message) retryForm form fid pairs action = do filled <- sessionLookup "filled" rq <- asks request @@ -89,7 +89,7 @@ retryEditForm :: Form -- ^ A form -> [(String,String)] -- ^ Default values -> [(String,String)] -- ^ Hidden values -> String -- ^ Target URL - -> Controller ActionConfig (String, String) -- ^ (Form HTML, error message) + -> AController (String, String) -- ^ (Form HTML, error message) retryEditForm form fid defvals hidden action = do filled <- sessionLookup "filled" rq <- asks request @@ -105,7 +105,7 @@ editModelForm :: Model -> Form -> String -- ^ Form ID -> String -- ^ Target URL - -> Controller ActionConfig (String, String) + -> AController (String, String) editModelForm model form fid action = retryEditForm form fid (zip fields values) [] action where fields = map fieldName $ filter (not . isExternalField) $ mFields model values = map (D.fromSql.(model -:>)) fields @@ -113,7 +113,7 @@ editModelForm model form fid action = retryEditForm form fid (zip fields values) returnInvalidForm :: Form -> String -- ^ Form ID -> [String] -- ^ List of erroneus filled fields - -> Controller ActionConfig a + -> AController a returnInvalidForm form fid errs = do rq <- asks request let values = tail $ urlencode $ map packParam vars diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs index 9c26d03..986142e 100644 --- a/Framework/Http/Httpd.hs +++ b/Framework/Http/Httpd.hs @@ -48,6 +48,8 @@ import qualified Data.Char as Char import qualified Data.ByteString.Lazy.Char8 as L import Numeric (showHex) +import Foreign.C.UTF8 (lengthUTF8) + import Framework.Types import Framework.Logger @@ -58,6 +60,9 @@ showRC (a,b,c) = x:y:z:[] y = Char.intToDigit b z = Char.intToDigit c +addContentLength body = {-# SCC "addContentLength" #-} + ([mkHeader HdrContentLength (show $ lengthUTF8 body)], body) + {- | This server transfers documents as one parcel, using the content-length header. -} @@ -66,9 +71,7 @@ initServer :: StaticConfig -> (HttpRequest -> IO HttpResponse) -- ^ The functionality of the Sever -> IO Server -- ^ A token for the Server -initServer = - initServerMain - (\body -> ([mkHeader HdrContentLength (show $ length $ encodeString body)], body)) +initServer = initServerMain addContentLength {- | This server transfers documents in chunked mode diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 4a68ffe..aeadcb6 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -25,7 +25,7 @@ pager :: Int -- ^ Number of items per page -> Query -- ^ Query itself -> [SqlValue] -- ^ Query parameters -> Model -- ^ Model to return - -> Controller ActionConfig ([Model], String) -- ^ (List of models, pager HTML) + -> AController ([Model], String) -- ^ (List of models, pager HTML) pager = genericPager genpager -- | Generic pager function @@ -34,7 +34,7 @@ genericPager :: Pager -- ^ Pager HTML generator fu -> Query -- ^ DB query -> [SqlValue] -- ^ DB query parameters -> Model -- ^ Model of result - -> Controller ActionConfig ([Model], String) -- ^ Returns list of items on current page and HTML for pager + -> AController ([Model], String) -- ^ Returns list of items on current page and HTML for pager genericPager pg perpage q params model = do countRes <- queryListSQL' (count q) params let itemCount :: Int