diff --git a/Blog/Blog.hs b/Blog/Blog.hs index fd4fd77..bfbfeb3 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -1,6 +1,6 @@ import System.IO -import Database.HDBC (SqlValue(..)) +import Database.HDBC (SqlValue(..),toSql) import Framework.API import Framework.Utils @@ -12,12 +12,12 @@ import Framework.Modules.Registration.Forms import Models hiding (__) urlconf :: URLConf -urlconf = "blog" // "new" --> newpost - <|> "blog" // "post" // number ~> onepost - <|> "blog" // "edit" // number ~> editpost - <|> "blog" // "del" // number ~> delpost - <|> "blog2" --> allposts2 +urlconf = "blog" // ( "new" --> newpost + <|> "post"//number ~> onepost + <|> "edit"//number ~> editpost + <|> "del"//number ~> delpost) <|> "blog" --> allposts + <|> "blog2" --> allposts2 <|> "login" --> login <|> "logout" --> (doLogout "/blog/") <|> "register" --> registration @@ -47,7 +47,7 @@ testform = do i18ntest :: HttpAction i18ntest = do text <- __ "Hello world!" - return $ renderToResponse "i18ntest.html" [("text", C text)] + renderToResponseM "i18ntest.html" [("text", C text)] allposts2 = do methodOnly GET @@ -60,8 +60,7 @@ allposts :: HttpAction allposts = do methodOnly GET rq <- asks request - let getvars = _GET rq - key = "allposts" ++ (getString' getvars "page" "1") + let key = "allposts" ++ (httpGetVar' rq "page" "1") tryReturnFromCache key (posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel lastComments <- querySQL' ((table commentModel) `order` [Desceding "dt"] `limit` (0,10)) [] commentModel @@ -73,13 +72,14 @@ allposts = do newpost :: HttpAction newpost = loginRequired $ do - (form,err) <- create postModel "/blog/" + (form,err) <- create postModel [] "/blog/" renderToResponseM "newpost.html" [("form", C form), ("invalid", C err)] delpost sid = loginRequired $ do + post <- getOneObject postModel (read sid) delete postModel (read sid) "/blog/" - renderToResponseM "delconfirm.html" [] + renderToResponseM "delconfirm.html" [("object", C post)] editpost :: StrAction editpost sid = loginRequired $ do @@ -87,24 +87,17 @@ editpost sid = loginRequired $ do renderToResponseM "editpost.html" [("form", C form), ("invalid", C err)] -onepost :: StrAction onepost sid = do rq <- asks request let url = myUrl rq pid = read sid - (form,err) <- renderCreateForm commentForm "1" [] url - case rqMethod rq of - GET -> do - post <- getOneObject postModel pid - comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?")) [SqlInt32 $ fromIntegral pid] commentModel - renderToResponseM "onepost.html" [("post", C post), - ("comments", C comments), - ("form", C form), - ("invalid", C err)] - POST -> do - insertModel commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] - message "Комментарий добавлен." - return $ redirect url + (form,err) <- create commentModel [toSql pid] url + post <- getOneObject postModel pid + comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?")) [toSql pid] commentModel + renderToResponseM "onepost.html" [("post", C post), + ("comments", C comments), + ("form", C form), + ("invalid", C err)] main :: IO () main = serveHttp "blog.conf" urlconf diff --git a/Framework/API/CRUD.hs b/Framework/API/CRUD.hs index 57316d0..52847d9 100644 --- a/Framework/API/CRUD.hs +++ b/Framework/API/CRUD.hs @@ -1,6 +1,7 @@ module Framework.API.CRUD where import Control.Monad.Reader.Class +import Database.HDBC import Network.HTTP import Text.Printf @@ -19,20 +20,20 @@ import Framework.Forms.ModelForm import Framework.GetText.Controller import Framework.TEngine.TemplateUtil -create' :: Model -> Form -> String -> AController (String,String) -create' model form target = do +create' :: Model -> Form -> [SqlValue] -> String -> AController (String,String) +create' model form params target = do rq <- asks request let url = myUrl rq case rqMethod rq of GET -> renderCreateForm form "1" [] url POST -> do - insertModel model form "1" [] + insertModel model form "1" params msg <- __ "%s created." message $ printf msg (capitalize $ mName model) returnNow $ redirect target -create :: Model -> String -> AController (String,String) -create model target = create' model (modelForm model) target +create :: Model -> [SqlValue] -> String -> AController (String,String) +create model params target = create' model (modelForm model) params target update' :: Model -> Form -> Int -> String -> AController (String,String) update' model form oid target = do diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 34bb95b..a417a9d 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -135,7 +135,7 @@ evalController :: Controller s a a -- ^ Controller -> s -- ^ Configuration for controller -> IO (Maybe a) evalController m s = do - (res, _) <- (runController m s) + (res, _) <- runController m s return $ anyResult res where -- | Convert any result to Maybe HttpResponse diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs index 767e912..208a88f 100644 --- a/Framework/Exceptions.hs +++ b/Framework/Exceptions.hs @@ -4,7 +4,7 @@ module Framework.Exceptions -- * Functions that are specific to application-level controllers internalError, errorIf, - methodOnly, + methodOnly, ifMethod, forceMaybe ) where @@ -80,6 +80,13 @@ methodOnly meth = do rq <- asks request errorIf 400 "Invalid request method" $ rqMethod rq /= meth +ifMethod :: RequestMethod -> a -> AController a -> AController a +ifMethod meth def ctr = do + rq <- asks request + if rqMethod rq == meth + then ctr + else return def + -- | If value is supplied, return it. Otherwise, raise HTTP 500 error. forceMaybe :: String -- ^ Error message -> Maybe a -- ^ Maybe value diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index c0997cc..bcac58c 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -71,7 +71,7 @@ formrow :: String -- ^ Form name -> FormField -- ^ Field -> HTMLTag formrow fname fid def err (Field name label widget _) = - tag "tr" attrs [tag "td" [] [Text itemlabel], wd] + tag "tr" attrs [tag "td" [] [Translatable itemlabel], wd] where attrs = if null err then [] else ["class" := "error"] diff --git a/Framework/Forms/HTMLTypes.hs b/Framework/Forms/HTMLTypes.hs index a9b1ec9..8f190f3 100644 --- a/Framework/Forms/HTMLTypes.hs +++ b/Framework/Forms/HTMLTypes.hs @@ -10,6 +10,7 @@ data HTMLTag = Tag { mayCollapse :: Bool -- ^ May we collapse <tag></tag> to <tag/> ? } | Text String + | Translatable String type HTML = [HTMLTag] diff --git a/Framework/GetText/HTML.hs b/Framework/GetText/HTML.hs index d812b69..1c31f4e 100644 --- a/Framework/GetText/HTML.hs +++ b/Framework/GetText/HTML.hs @@ -15,6 +15,7 @@ translateTag :: HTMLTag-> AController HTMLTag translateTag (Tag n a lst m) = do lst' <- translateHTML lst return $ Tag n a lst' m -translateTag (Text t) = do +translateTag (Text t) = return $ Text t +translateTag (Translatable t) = do t' <- if null t then return "" else C.__ t return $ Text t' diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index 22c4445..fda0d42 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -22,11 +22,10 @@ import qualified Extensions.Middlewares as Settings (requestMiddlewares, respons type RequestMiddleware = StaticConfig -> HttpRequest -> IO HttpRequest type ResponseMiddleware = StaticConfig -> HttpResponse -> IO HttpResponse -addEncoding :: (Monad m) => t -> Response a -> m (Response a) -addEncoding _ resp = return $ - case lookupHeader HdrContentType (rspHeaders resp) of - Nothing -> replaceHeader HdrContentType ("text/html; charset="++enc) resp - Just ctype -> insertHeader HdrContentType (ctype++"; charset="++enc) resp +addEncoding _ resp = + return $ case lookupHeader HdrContentType (rspHeaders resp) of + Nothing -> replaceHeader HdrContentType ("text/html; charset="++enc) resp + Just ctype -> insertHeader HdrContentType (ctype++"; charset="++enc) resp where enc = case lookupHeader (HdrCustom "X-UserCharset") (rspHeaders resp) of Just x -> tail x Nothing -> "UTF-8"