diff --git a/Framework/API/Cache.hs b/Framework/API/Cache.hs index c129b82..d8d794c 100644 --- a/Framework/API/Cache.hs +++ b/Framework/API/Cache.hs @@ -10,24 +10,33 @@ import Framework.Http.Response ---------------------------------------------------------------------------------------------------------- -- * Cache API -cacheGet :: String -> Controller ActionConfig (Maybe String) +-- | Get a value from cache +cacheGet :: String -- ^ Key + -> Controller ActionConfig (Maybe String) cacheGet key = do cb <- asks cacheBackend liftC $ cGet cb key -cachePut :: String -> String -> Controller ActionConfig Bool +-- | Put a value to cache +cachePut :: String -- ^ Key + -> String -- ^ Value + -> Controller ActionConfig Bool cachePut key value = do cb <- asks cacheBackend liftC $ {-do print $ length value -} cPut cb key value -cacheUnset :: String -> Controller ActionConfig Bool +-- | Unset key in cache +cacheUnset :: String -- ^ Key + -> Controller ActionConfig Bool cacheUnset key = do cb <- asks cacheBackend liftC $ cUnset cb key -tryReturnFromCache :: String -> Controller ActionConfig () +-- | If named item is in cache, return its value. Otherwise, do nothing. +tryReturnFromCache :: String -- ^ Key + -> Controller ActionConfig () tryReturnFromCache key = do c <- cacheGet key case c of diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 31f648b..5a4c8e1 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -1,21 +1,35 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -module Framework.Controller where +module Framework.Controller + (Controller, + HttpController, StaticController, + liftC, returnNow, + internalError, rejectUrl, + assertC, errorIf, forceMaybe, + evalController + ) where import Control.Monad.Reader.Class import Framework.Types import Framework.Http.Response -data ControllerResult a = RejectUrl - | RightNow HttpResponse - | Result a +-- | Controller may reject url, return a value for further processing, +-- or return a value right now to avoid succeding computations +data ControllerResult a = RejectUrl -- ^ `No, I wann't process this URL!' + | RightNow HttpResponse -- ^ `Return this response and do not see what is writen below!' + | Result a -- ^ `I return this value; use it in following computations.' +-- | Controller itself newtype Controller s a = Controller { - runController :: s -> IO (ControllerResult a) } + runController :: s -> IO (ControllerResult a) + } +-- | Type of application-level controllers type HttpController = Controller ActionConfig HttpResponse +-- | Type of application-level controllers, that use StaticConfig type StaticController = Controller StaticConfig HttpResponse +-- | Convert any result to Maybe HttpResponse anyResult :: ControllerResult HttpResponse -> Maybe HttpResponse anyResult RejectUrl = Nothing anyResult (RightNow r) = Just r @@ -38,37 +52,52 @@ instance MonadReader s (Controller s) where ask = Controller $ \s -> return (Result s) local f m = Controller $ runController m . f +-- | `Lift' an IO action into Controller liftC :: IO a -> Controller s a liftC act = Controller $ \_ -> Result `fmap` act +-- | Assert that condition is satisfied. Otherwise, reject URL. assertC :: Bool -> Controller s () assertC b = if b then return () else rejectUrl +-- | Return given value and do not evaluate following computations returnNow :: HttpResponse -> Controller s a returnNow v = Controller $ \_ -> return (RightNow v) +-- | Return HTTP 500 error with given message internalError :: String -> Controller s a internalError msg = returnNow $ response 500 [] msg -errorIf :: Int -> String -> Bool -> Controller s () +-- | Return HTTP error with given code, if condition is satisfied +errorIf :: Int -- ^ HTTP status code + -> String -- ^ Error message + -> Bool -- ^ Value of condition + -> Controller s () errorIf code msg b = if b then returnNow $ response code [] msg else return () -forceMaybe :: String -> Maybe a -> Controller s a +-- | If value is supplied, return it. Otherwise, raise HTTP 500 error. +forceMaybe :: String -- ^ Error message + -> Maybe a -- ^ Maybe value + -> Controller s a -- forceMaybe msg x = case x of Just v -> return v Nothing -> internalError msg +-- | Reject this URL rejectUrl :: Controller s a rejectUrl = Controller $ \_ -> return RejectUrl -evalController :: Controller s HttpResponse -> s -> IO (Maybe HttpResponse) +-- | Evaluate controller with given configuration +evalController :: Controller s HttpResponse -- ^ Controller + -> s -- ^ Configuration for controller + -> IO (Maybe HttpResponse) evalController m s = anyResult `fmap` (runController m s) diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index f5c67b5..323e895 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -99,10 +99,13 @@ createform form fid pairs action = HTMLForm vFields hFields name fid action name = formName form mangle (n,v) = (mangleName name fid n, v) +-- | Inputbox widget data Inputbox = Inputbox { ibWidth :: Maybe Int } +-- | Default input box inputbox = Inputbox Nothing data Textarea = Textarea { tbCols :: Maybe Int, tbRows :: Maybe Int } +-- | Default textarea textarea = Textarea (Just 60) (Just 15) instance Widget Inputbox where diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index c4d5b3b..67ddd24 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -13,6 +13,7 @@ import Network.HTTP import Framework.Types import Framework.Models +-- | Form plugin transforms a Form type FormsPlugins = [Form -> Form] -- $doc @@ -36,7 +37,7 @@ data HTMLTag = Tag { tagName :: String, tagAttrs :: [FormVar], tagContent :: HTML, - mayCollapse :: Bool + mayCollapse :: Bool -- ^ May we collapse <tag></tag> to <tag/> ? } | Text String @@ -47,7 +48,9 @@ data HTMLForm = HTMLForm { formId :: String, formAction :: String } +-- | Form validator takes request and returns either list of erroneus filled field or filled Model type FormValidator = HttpRequest -> Either [String] Model +-- | Field validator takes field value and returns either error message or validated value type FieldValidator = String -> Either String String data FormField = forall w. (Widget w) => Field { diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 047301f..5531b4e 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -63,6 +63,7 @@ refillForm :: [String] -- ^ List of erroneus filled fields names -> HTMLForm refillForm = refillFormG mangleName +-- | Same as refillForm, but do not mangle fields names refillFormU :: [String]-> Form-> String-> [(String, String)]-> [(String, String)]-> String-> HTMLForm refillFormU = refillFormG (\x y z -> z) @@ -149,20 +150,30 @@ defValidate form fid rq = vars :: [String] vars = formVarsValues form fid rq -formVarsValues :: Form -> String -> HttpRequest -> [String] +-- | List of all form fields values in request +formVarsValues :: Form + -> String -- ^ Form ID + -> HttpRequest + -> [String] formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) -formVarsNames :: Form -> String -> [String] +-- | List of all (mangled) form fields names +formVarsNames :: Form + -> String -- ^ Form ID + -> [String] formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFields form +-- | Combination of formVarsNames and formVarsValues formVars :: Form -> String -> HttpRequest -> [(String,String)] formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) +-- | Check that field is not empty notEmpty :: String -> FieldValidator notEmpty msg s = if null s then Left msg else Right s +-- | Do not validate at all, consider all values are valid. noValidate :: FieldValidator noValidate s = Right s diff --git a/Framework/Models.hs b/Framework/Models.hs index 3086872..c16d1dd 100644 --- a/Framework/Models.hs +++ b/Framework/Models.hs @@ -21,7 +21,7 @@ import Framework.Types -- | Type of DB table column data ColumnType = IntegerColumn | PrimaryKey - | ForeignKey Model String + | ForeignKey Model String -- ^ Foreign key <parent model> <link field in parent model> | StringColumn | BoolColumn | CurrentDateColumn @@ -60,6 +60,8 @@ foreignModel (ForeignKey m _) = m foreignField :: ColumnType -> String foreignField (ForeignKey _ f) = f +-- | Check if this field is PrimaryKey, ForeignKey or CurrentDate +isExternalField :: ModelField -> Bool isExternalField f = case fieldType f of PrimaryKey -> True CurrentDateColumn -> True diff --git a/Framework/Pager.hs b/Framework/Pager.hs index ae5a297..b2e17b0 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -21,7 +21,11 @@ import Framework.Http.Vars type Pager = HttpRequest -> Int -> Int -> String -- | Simple pager -pager :: Int-> Query-> [SqlValue]-> Model-> Controller ActionConfig ([Model], String) +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) pager = genericPager genpager -- | Generic pager function @@ -33,7 +37,6 @@ genericPager :: Pager -- ^ Pager HTML generator fu -> Controller ActionConfig ([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 - rq <- asks request let itemCount :: Int itemCount = fromSql $ head (head countRes) if itemCount < perpage @@ -44,6 +47,7 @@ genericPager pg perpage q params model = do let first = (page-1)*perpage let pages = (itemCount `div` perpage)+1 items <- querySQL' (q `limit` (first,perpage)) params model + rq <- asks request return (items, pg rq pages page) -- | Simple pager HTML generator diff --git a/Framework/Pool.hs b/Framework/Pool.hs index 7728a32..58177e3 100644 --- a/Framework/Pool.hs +++ b/Framework/Pool.hs @@ -11,7 +11,9 @@ import Control.Concurrent.MVar data PoolItem a = NotConnected | Busy a | Free a +-- | Pool itself type Pool a = [PoolItem a] +-- | Mutable pool type MPool a = MVar (Pool a) instance Show (MPool a) where @@ -59,11 +61,12 @@ freeAll mpool f = withMVar mpool (mapM_ $ free' f) free' f (Busy res) = f res free' f (Free res) = f res -garbageCollector :: MPool a - -> (a -> IO ()) +-- | Run GC thread, which closes unused connections +garbageCollector :: MPool a -- ^ Pool + -> (a -> IO ()) -- ^ Connection close function -> IO () garbageCollector mpool f = do - forkIO $ every 10000000 $ collect mpool + forkIO $ every 10000000 collect return () where every ms action = do @@ -71,7 +74,7 @@ garbageCollector mpool f = do action threadDelay ms every ms action - collect var = modifyMVar_ var (mapM $ freeGarbage) + collect = modifyMVar_ mpool (mapM $ freeGarbage) freeGarbage (Free res) = do f res return NotConnected diff --git a/Framework/SQL.hs b/Framework/SQL.hs index 7ce3bf7..fa5f0d1 100644 --- a/Framework/SQL.hs +++ b/Framework/SQL.hs @@ -238,7 +238,11 @@ joinT q@(Query {qTables = tables}) tbl | TableList ts <- tables = q { qTables = -- | Select only given fields from the table/query select :: Query -> [String] -> Query select q fs = q {qFields= (map QField fs)} +-- | Alias for select +onlyFields :: Query -> [String] -> Query onlyFields = select + +selectF :: Query -> [SQLField] -> Query selectF q fs = q{qFields=fs} -- | Restrict query (add the WHERE part)