diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 3beec00..e2bdf72 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -72,33 +72,15 @@ allposts = do newpost :: HttpAction newpost = loginRequired $ do - rq <- asks request - let url = myUrl rq - case rqMethod rq of - GET -> do - (form,err) <- renderCreateForm postForm "1" [] url - renderToResponseM "newpost.html" [("form", C form), - ("invalid", C err)] - POST -> do - insertModel postModel postForm "1" [] - message "Пост успешно добавлен." - return $ redirect "/blog/" + (form,err) <- create postModel "/blog/" + renderToResponseM "newpost.html" [("form", C form), + ("invalid", C err)] editpost :: StrAction editpost sid = loginRequired $ do - rq <- asks request - let url = myUrl rq - pid = read sid - case rqMethod rq of - GET -> - do post <- getOneObject postModel pid - (form,err) <- renderEditForm post postForm "1" url - renderToResponseM "editpost.html" [("form", C form), - ("invalid", C err)] - POST -> - do updateModel postModel postForm "1" sid - message "Пост отредактирован." - return $ redirect "/blog/" + (form,err) <- update postModel (read sid) "/blog/" + renderToResponseM "editpost.html" [("form", C form), + ("invalid", C err)] onepost :: StrAction onepost sid = do diff --git a/Blog/Models.hs b/Blog/Models.hs index 4f90846..e583ebb 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -27,7 +27,8 @@ postModel = emptyModel { mCached = ["ncomments" ::: IntegerColumn], related = [("pid",[commentModel])], defaultOrdering = [Desceding "dt"], - perPage = Just 5 + perPage = Just 5, + showMe = getfield "title" } postid :: (TemplateOne a) => a -> String diff --git a/Blog/templates/posts2.html b/Blog/templates/posts2.html new file mode 100644 index 0000000..7a38c59 --- /dev/null +++ b/Blog/templates/posts2.html @@ -0,0 +1,23 @@ +<!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>Blog posts</title> + <meta name='author' content='Portnov'> + <link rel='stylesheet' type='text/css' href='/blog.css'/> + </head> + <body> + <h1>Blog posts</h1> + + {%for post in posts%} + <h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2> + <p><small>at {{postDate post}}</small></p> + <p>{{postmarkdown post}}</p> + {%for comment in children "pid" post%} + <p>{{commentBody comment}}</p> + {%endfor%} + {%endfor%} + + <p>{{pager}}</p> + + </body> +</html> diff --git a/Framework/API.hs b/Framework/API.hs index eac0559..7835553 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -22,6 +22,7 @@ module Framework.API module Framework.API.Storage, module Framework.API.SQL, module Framework.API.SQLUtils, + module Framework.API.CRUD, module Framework.API.Logger, module Framework.API.UserMessage, -- ** Specific modules @@ -51,6 +52,7 @@ import Framework.API.Sessions import Framework.API.Storage import Framework.API.SQL import Framework.API.SQLUtils +import Framework.API.CRUD import Framework.API.Logger import Framework.API.UserMessage diff --git a/Framework/API/CRUD.hs b/Framework/API/CRUD.hs new file mode 100644 index 0000000..cf9b85a --- /dev/null +++ b/Framework/API/CRUD.hs @@ -0,0 +1,50 @@ +module Framework.API.CRUD where + +import Control.Monad.Reader.Class +import Network.HTTP +import Text.Printf + +import Framework.Types +import Framework.Utils +import Framework.Controller +import Framework.Http.Response +import Framework.ORM.Types +import Framework.API.SQL +import Framework.API.SQLUtils +import Framework.API.UserMessage +import Framework.Forms.Types +import Framework.Forms.Rendering +import Framework.Forms.ModelForm +import Framework.GetText.Controller + +create' :: Model -> Form -> String -> AController (String,String) +create' model form target = do + rq <- asks request + let url = myUrl rq + case rqMethod rq of + GET -> renderCreateForm form "1" [] url + POST -> do + insertModel model form "1" [] + 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 + +update' :: Model -> Form -> Int -> String -> AController (String,String) +update' model form oid target = do + rq <- asks request + let url = myUrl rq + case rqMethod rq of + GET -> + do obj <- getOneObject model oid + renderEditForm obj form "1" url + POST -> + do updateModel model form "1" (show oid) + msg <- __ "%s updated." + message $ printf msg (capitalize $ mName model) + returnNow $ redirect target + +update :: Model -> Int -> String -> AController (String,String) +update model oid target = update' model (modelForm model) oid target diff --git a/Framework/Http/Vars.hs b/Framework/Http/Vars.hs index ae1824b..7f62917 100644 --- a/Framework/Http/Vars.hs +++ b/Framework/Http/Vars.hs @@ -14,6 +14,7 @@ import qualified Data.Map as M import Data.Maybe import Network.URI import Network.HTTP +import Data.List.Utils import Framework.Types import Framework.Utils @@ -86,6 +87,6 @@ httpAddGetVar :: HttpRequest -> String -- ^ Var value -> String httpAddGetVar rq name value = urlencode (map packParam pairs') - where pairs' = update name value pairs + where pairs' = addToAL pairs name value pairs = decodePairs (uriQuery $ rqURI rq) diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs index bb38bd5..0edcf60 100644 --- a/Framework/ORM/Models.hs +++ b/Framework/ORM/Models.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleContexts #-} -- | ADT for DB tables (data models). module Framework.ORM.Models - ((-:>), + ((-:>), getfield, getPK, isExternalField, foreignModel, foreignField, updateField, setCached, @@ -25,7 +25,8 @@ emptyModel = Model { mCached = [], related = [], defaultOrdering = [], - perPage = Nothing + perPage = Nothing, + showMe = showModel } -- | Default value of column type @@ -77,6 +78,9 @@ updateField [] name tp value = [FilledField name tp value] updateField (f:fs) name tp value | (fieldName f)==name = (FilledField name tp value):fs | otherwise = f:(updateField fs name tp value) +getfield :: String -> Model -> String +getfield name model = fromSql $ model -:> name + -- | Set given `cached` field in model setCached :: Model -> String -> ColumnType -> SqlValue -> Model setCached model name tp value = model { mCached = updateField (mCached model) name tp value } diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index fa4e5c8..7b8966b 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -2,6 +2,7 @@ module Framework.ORM.Types where import Database.HDBC (SqlValue(..)) +import Data.List import Framework.Types import Framework.Forms.HTMLTypes @@ -120,11 +121,16 @@ data Model = Model { mTable :: String, -- ^ DB table name mFields :: [ModelField], -- ^ List of model fields (DB table columns) mCached :: [ModelField], -- ^ Additional fields, which are no in DB - related :: [(String,[Model])], + related :: [(String,[Model])], -- ^ Assoc.list of related (children) models defaultOrdering :: [SQLOrder], -- ^ How to sort list of this models by default - perPage :: Maybe Int -- ^ Default paging + perPage :: Maybe Int, -- ^ Default paging + showMe :: Model -> String } - deriving (Show) + +showModel model = (mName model)++" ["++(mTable model)++"]: "++(intercalate ", " $ map show $ mFields model) + +instance Show Model where + show m = showMe m m instance Eq Model where m1 == m2 = (mName m1) == (mName m2) diff --git a/Framework/Utils.hs b/Framework/Utils.hs index ea50ea4..0e6c24f 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -149,10 +149,10 @@ lazySlurp fp ix len ------------------------------------------------------------------------------------------ -- | An opposite to lookup: update value in assosiative list -update :: (Eq a) => a -> t -> [(a, t)] -> [(a, t)] -update k v [] = [(k,v)] -update k v ((x,y):ps) | k==x = (k,v):ps - | otherwise = (x,y):(update k v ps) +-- update :: (Eq a) => a -> t -> [(a, t)] -> [(a, t)] +-- update k v [] = [(k,v)] +-- update k v ((x,y):ps) | k==x = (k,v):ps +-- | otherwise = (x,y):(update k v ps) days :: Int -> TimeDiff days n = TimeDiff 0 0 n 0 0 0 0 diff --git a/README.ru b/README.ru index bd25b87..124644c 100644 --- a/README.ru +++ b/README.ru @@ -226,6 +226,9 @@ controller = do * Генерация форм: приложение может определить функции, через которые будет проходить каждая форма (Form). Например, можно добавлять дополнительные поля итп. + * HTML Processors: HTML, генерируемый фреймворком (сейчас это только формы), + перед отправлением клиенту проходит через цепочку пользовательских + обработчиков. * Request Middlewares: это функции StaticConfig -> HttpRequest -> IO HttpRequest, через которые проходит каждый запрос прежде чем попасть в диспетчер URL. @@ -242,6 +245,15 @@ Extensions (пример см. в приложении Blog), оттуда их фреймворка. Там же определяется соответствие возможных сигналов и их обработчиков. +## Модули + +Фреймворк содержит некоторое количество модулей, которые, с точки зрения +архитектуры, являются не частью фреймворка, а частью приложения, но тем не +менее будут использоваться во многих приложениях, так что их имеет смысл +поставлять вместе с фреймворком. Сейчас это модули для простой парольной +аутентификации, для регистрации пользователей, для добавления простой текстовой +капчи в формы. + ## Интернационализация Для интернационализации используется gettext и его привязки к haskell - @@ -260,4 +272,8 @@ middleware использует их для инициализации gettext. языке (том, который выставлен в браузере как язык по умолчанию). Если перевода на этот язык нет, будет использован английский. +В модуле Framework.GetText.HTML есть функция translateHTML, которую можно +использовать в качестве HTML Processor-а. Она переводит текстовые фрагменты в +HTML - например, подписи в формах. + Сейчас фреймворк расчитан на использование кодировки UTF8.