diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index e24e347..fdeb3df 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-} module Framework.API.Sessions where -import Control.Monad.Reader.Class +-- This module is single that `knows` that Controller is a MonadState also. import Control.Monad.State.Class import qualified Data.Map as M @@ -15,7 +15,7 @@ import Framework.Http.Sessions -- | Get variable from session sessionLookup :: String -> Controller ActionConfig r String sessionLookup name = do - mm <- asks sessionMap + mm <- gets sessionMap return $ maybe "" id $ M.lookup name mm -- | Set variable into session diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs index 28780d5..603b7e8 100644 --- a/Framework/ContextProcessors.hs +++ b/Framework/ContextProcessors.hs @@ -1,3 +1,4 @@ +-- | Context processors are Controllers, that return Context. That contexts are added to context passed with renderToResponseM. module Framework.ContextProcessors (contextProcessors) where @@ -25,11 +26,13 @@ addMessage = do msg <- sessionTake "message" return [("message", C msg)] +-- | Add `myurl` variable -- current URL addMyUrl :: ContextProcessor addMyUrl = do rq <- asks request return [("myurl", C $ myUrl rq)] +-- | Adds `page` variable from HTTP GET addHttpVars :: ContextProcessor addHttpVars = do page <- asks (_GET' "page" "1") diff --git a/Framework/Controller.hs b/Framework/Controller.hs index a417a9d..04238f5 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -20,7 +20,7 @@ module Framework.Controller -- * Controller-monad specific functions MonadIO (..), returnNow, reject, - concatC, changeR, + concatC, changeR, changeS, assertC, evalController ) where @@ -115,6 +115,12 @@ changeR m = do RightNow _ -> reject Result x -> return x +-- | Run a controller in changed environment +changeS :: (s -> s1) -> Controller s1 r a -> Controller s r a +changeS f m = Controller $ \s -> do + (res,_) <- runController m (f s) + return (res, s) + -- | Assert that condition is satisfied. Otherwise, reject URL. assertC :: Bool -> Controller s r () assertC b = diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs index 208a88f..a245fc8 100644 --- a/Framework/Exceptions.hs +++ b/Framework/Exceptions.hs @@ -74,13 +74,18 @@ errorIf code msg b = then returnNow $ response code [] msg else return () +-- | Accept only given HTTP method, otherwise raise HTTP 400 error methodOnly :: RequestMethod -> AController () methodOnly meth = do rq <- asks request errorIf 400 "Invalid request method" $ rqMethod rq /= meth -ifMethod :: RequestMethod -> a -> AController a -> AController a +-- | Run a controller only if given HTTP method, otherwise return default value +ifMethod :: RequestMethod -- + -> a -- ^ Default value + -> AController a -- ^ Run this + -> AController a ifMethod meth def ctr = do rq <- asks request if rqMethod rq == meth diff --git a/Framework/Logger.hs b/Framework/Logger.hs index 1de56be..156e788 100644 --- a/Framework/Logger.hs +++ b/Framework/Logger.hs @@ -22,6 +22,7 @@ currentTime = do ctime <- toCalendarTime time return $ formatCalendarTime defaultTimeLocale "%c" ctime +-- | Format log message. formatMsg :: LogItem -> String formatMsg item = printf "%s: %s" (logTime item) (logMessage item) @@ -44,10 +45,10 @@ runLogWriter aLog eLog afile efile = do forkIO $ flushLog eLog efile forkIO $ flushLog aLog afile +-- | Flush content of @Log@ to given @Handle@. flushLog :: Log -> Handle -> IO () flushLog chan hndl = do - items <- getChanContents chan + items <- getChanContents chan -- Get lazy list of log items (block if chan is empty) forM_ items $ \item -> do --- putStrLn $ formatMsg item hPutStrLn hndl $ formatMsg item hFlush hndl diff --git a/Framework/Pool.hs b/Framework/Pool.hs index 327c3a2..9242be1 100644 --- a/Framework/Pool.hs +++ b/Framework/Pool.hs @@ -1,4 +1,10 @@ {-# LANGUAGE TypeSynonymInstances #-} +-- | This module describes an abstract pool of any `connections` (to DB, cache backend or anything). One will create a pool with +-- pool <- emptyPool 20 +-- (that opens 20 connections), and then +-- (idx, pool) <- acquire someConfig connectFunction -- Get open connection or create a new one +-- doSomethingWith conn +-- free pool idx conn -- Free a connection, so it may be used again by other threads module Framework.Pool (Pool, MPool, emptyPool, @@ -74,7 +80,7 @@ garbageCollector mpool f = do action threadDelay ms every ms action - collect = modifyMVar_ mpool (mapM $ freeGarbage) + collect = modifyMVar_ mpool (mapM freeGarbage) freeGarbage (Free res) = do f res return NotConnected diff --git a/Framework/SignalTypes.hs b/Framework/SignalTypes.hs index 3fdcc52..fc489f6 100644 --- a/Framework/SignalTypes.hs +++ b/Framework/SignalTypes.hs @@ -1,3 +1,4 @@ +-- | This module was separated from Signals, to avoid circular dependency Signals -> Extensions.Handlers -> Signals module Framework.SignalTypes where import Framework.Controller @@ -5,5 +6,6 @@ import Framework.ORM.Types type Signal = String +-- | Currently, only @Model@s can be passed with signals. type SignalHandler = Signal -> Model -> AController () diff --git a/Framework/Signals.hs b/Framework/Signals.hs index 5a58789..6996ef8 100644 --- a/Framework/Signals.hs +++ b/Framework/Signals.hs @@ -13,9 +13,11 @@ import Framework.SignalTypes import Extensions.Signals (connectSignals) +-- | Map of all signal handlers signals :: M.Map Signal [SignalHandler] signals = defaultSignals `M.union` connectSignals +-- | Default signal handlers defaultSignals :: M.Map Signal [SignalHandler] defaultSignals = M.fromList [] diff --git a/Framework/Types.hs b/Framework/Types.hs index dfb462d..e2aa27a 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -130,6 +130,7 @@ class TemplateOne a where -- | Get assoc.list of related models getRelated :: a -> [(String,[a])] getRelated _ = [] + -- | Get number of items to put on one page getPerPage :: a -> Int getPerPage _ = 20 @@ -213,18 +214,23 @@ type BFunction = forall a. (TemplateItem a) => a -> Bool type Context = [(String,TContainer)] ------------------------------------------------------------------------------------------- +-- | Claims a fact that values of type @f@ can be `applied` to value of type +-- @a@, resulting value of type @b@ class Applicable f a b where app :: Int -> f -> a -> b +-- | Same as `app 1' apply :: (Applicable f a b) => f -> a -> b apply = app 1 +-- | Simplest instance of this class instance Applicable (a -> b) a b where app _ f x = f x instance Applicable (a -> b) [a] [b] where app _ f lst = map f lst +-- | @TContainer@ can have fields of such types class FieldType a where _field :: Int -> TContainer -> a fzero :: a @@ -242,6 +248,7 @@ instance Applicable (String -> a) TContainer a where instance Applicable (Bool -> a) TContainer a where app n f (C x) = f (boolField n x) +-- Next three instances allow to `apply` a function to two @TContainer@'s instance Applicable (a -> b) TContainer b => Applicable (String -> a -> b) TContainer (TContainer -> b) where app n op (C x) = \y -> app n (op (stringField n x)) y @@ -251,6 +258,7 @@ instance Applicable (a -> b) TContainer b => Applicable (Int -> a -> b) TContain instance Applicable (a -> b) TContainer b => Applicable (Bool -> a -> b) TContainer (TContainer -> b) where app n op (C x) = \y -> app n (op (boolField n x)) y +-- Next three instances allow to `apply` a function to `simple` value and @TContainer@ instance (TemplateOne a, FieldType a) => Applicable (String -> a -> b) a (TContainer -> b) where app n op x = \y -> app n (op (_field n $ C x)) ((_field n y)::a) @@ -281,7 +289,10 @@ instance FieldType Bool where _field n x = app n idBool x fzero = False -field :: FieldType a => Int -> Maybe TContainer -> a +-- | Get a field from TContainer +field :: FieldType a => Int -- ^ Number of the field + -> Maybe TContainer + -> a -- ^ Type of field determined by return type field n (Just x) = _field n x field n Nothing = fzero diff --git a/README.ru b/README.ru index 124644c..577e407 100644 --- a/README.ru +++ b/README.ru @@ -25,9 +25,9 @@ web-приложений на Haskell. ## Общие замечания об архитектуре Архитектура фреймворка в общих чертах соответствует MVC. Модели описывают -таблицы в БД (но могут иметь дополнительные поля, не хранящиеся в БД). В -качестве слоя View выступает система шаблонов TEngine. Контроллеры занимаются -выбором нужных данных и передачей этих данных в шаблоны. +таблицы в БД (но могут иметь дополнительные поля, не хранящиеся в БД; или вовсе +не иметь связи с БД). В качестве слоя View выступает система шаблонов TEngine. +Контроллеры занимаются выбором нужных данных и передачей этих данных в шаблоны. Приложение обычно будет импортировать из фреймворка модули Framework.API и Framework.Utils. Модуль API ре-экспортирует интерфейсы некоторых внутренних @@ -109,7 +109,7 @@ UsingWidget. (часть else, как обычно, необязательна) -{%for var in list%} +{%for var in list%} --- вариант: {%for var in function list%} ... {%endfor%} (внутри цикла появляется дополнительная переменная {{it}}, содержащая номер @@ -129,14 +129,16 @@ UsingWidget. Однако в контроллерах удобнее использовать функции семейства renderToResponse*. Они возвращают не HTML, а сразу готовый HttpResponse. -Функции, применяемые к переменным в шаблонах, должны иметь полиморфный тип -(TemplateOne a) => a -> String (для функций, применяемых в теге if -- -соответственно, a -> Bool). Эти функции для моделей можно определять с помощью -функций transformInt, transformString, transformBool. Они принимают номер поля -данного типа (IntegerColumn,StringColumn, BoolColumn соответственно) в модели, -и функцию, обрабатывающую значение этого типа, а возвращают функцию, подходящую -для использования в шаблонах. Примеры для функций-аксессоров см. в модуле -Models приложения Blog. +Функции, применяемые к переменным в шаблонах, должны иметь тип Maybe TContainer +-> String (для функций, применяемых в теге if -- соответственно, Maybe +TContainer -> Bool). Эти функции для моделей можно определять с помощью функций +field, app, apply. Функция field принимает номер поля и возвращает функцию, +возвращающюю поле объекта соответствующего типа под данным номером. Функция app +принимает номер поля и функцию, обрабатывающую значение этого поля, а +возвращает функцию, возвращающую обработанное значение данного поля. Например, +app 2 (map toUpper) -- это функция, возвращающая второе поле подходящего типа +объекта, преобразованное в верхний регистр. apply -- это то же самое, что app +1. Примеры для функций-аксессоров см. в модуле Models приложения Blog. В модуле Framework.TEngine.TemplateFuncs определены некоторые часто используемые функции для использования в шаблонах. diff --git a/TODO b/TODO index 7e633b7..ab77eaa 100644 --- a/TODO +++ b/TODO @@ -3,7 +3,8 @@ TODO * [PARTIALLY DONE] Удобные средства расширения форм (в т.ч. и для использования в Form processors); * Больше виджетов для форм; * Средства создания "мастеров"; - * (?) Автоматические CRUD-контроллеры; + * (?) Более удобный paginator; + * [PARTIALLY DONE] Автоматические CRUD-контроллеры; * Человеческая обработка завершения программы; * Все параметры, которые сейчас hard-coded, брать из конфига; * [PARTIALLY DONE] Полу-автоматическая интернационализация с помощью какого-л. Middleware;