diff --git a/Framework/CacheTypes.hs b/Framework/CacheTypes.hs index 72c6d06..9ad115e 100644 --- a/Framework/CacheTypes.hs +++ b/Framework/CacheTypes.hs @@ -4,11 +4,16 @@ module Framework.CacheTypes where import Network.Memcache.Serializable (Serializable(..)) class CacheBackend b where - cinit :: String -> IO b -- ^ Init cache backend - cget :: (Serializable v) => b -> String -> IO (Maybe v) -- ^ Get data from cache - cput :: (Serializable v) => b -> String -> v -> IO Bool -- ^ Put data to cache - cunset :: b -> String -> IO Bool -- ^ Unset data - cfree :: b -> IO () -- ^ Free backend + -- | Init cache backend + cinit :: String -> IO b + -- | Get data from cache + cget :: (Serializable v) => b -> String -> IO (Maybe v) + -- | Put data to cache + cput :: (Serializable v) => b -> String -> v -> IO Bool + -- | Unset data + cunset :: b -> String -> IO Bool + -- | Free backend + cfree :: b -> IO () -- | Type to incapsulate connection to any cache backend. data CacheConnection = forall b. (CacheBackend b) => CConnection b diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index 78316e8..ac2f5f5 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -13,15 +13,22 @@ import Framework.Urls import Framework.Utils import Framework.Types -tag :: String -> [FormVar] -> HTML -> HTMLTag +-- | Create HTML tag +tag :: String -- ^ Tag name + -> [FormVar] -- ^ Tag attributes + -> HTML -- ^ Tag contents + -> HTMLTag tag name attrs content = Tag name attrs content True +-- | Same, but do not allow tag to collapse (<tag></tag> --> <tag/>) tagE :: String -> [FormVar] -> HTML -> HTMLTag tagE name attrs content = Tag name attrs content False +-- | Render HTML toHtml :: HTML -> String toHtml html = concat $ map tagToHtml html +-- | Render one HTML tag tagToHtml :: HTMLTag -> String tagToHtml (Text text) = text tagToHtml (Tag name attrs value coll) = "<"++name++(concat $ map htmlAttr attrs)++content++">" @@ -32,12 +39,20 @@ tagToHtml (Tag name attrs value coll) = "<"++name++(concat $ map htmlAttr attrs) then ">\n"++(toHtml value)++"\n</"++name else ">"++(toHtml value)++"</"++name -hiddenField :: String -> String -> HTMLTag +-- | Create hidden form field +hiddenField :: String -- ^ Input name + -> String -- ^ Input value + -> HTMLTag hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] [] -mangleName :: String -> String -> String -> String +-- | Mangle form input name +mangleName :: String -- ^ Form name + -> String -- ^ Form ID + -> String -- ^ Field name + -> String mangleName formname fid name = formname++fid++"-"++name +-- | Render HTML Form formToHtml :: HTMLForm -> String formToHtml form = tagToHtml $ tag "form" ["method" =: "POST","action" =: (formAction form), "id" =: tagid] $ [tag "table" [] $ (visibleFields form) ++ (hiddenFields form) ++ [fidfield, namefield, submit]] @@ -62,18 +77,21 @@ formrow fname fid def cls (Field name label widget _) = tag "tr" attrs [tag "td" else label itemname = mangleName fname fid name +-- | Form's submit button submit :: HTMLTag submit = tag "tr" [] [tag "td" [] [], tag "td" [] [tag "input" ["type" =: "submit"] []]] +-- | Render field=value htmlAttr :: FormVar -> String htmlAttr (name := value) | httpEmpty value = "" | otherwise = " "++name++"='"++(httpShow value)++"'" -createform :: Form - -> String - -> [(String,String)] - -> String +-- | Create HTMLForm from Form description +createform :: Form -- ^ Form description + -> String -- ^ Form ID + -> [(String,String)] -- ^ Hidden fields values + -> String -- ^ Form target URL -> HTMLForm createform form fid pairs action = HTMLForm vFields hFields name fid action where vFields = map (formrow name fid "" "") (fFields form) @@ -81,8 +99,6 @@ createform form fid pairs action = HTMLForm vFields hFields name fid action name = formName form mangle (n,v) = (mangleName name fid n, v) -emptyTags = ["textarea"] - data Inputbox = Inputbox { ibWidth :: HttpBox } inputbox = Inputbox (HB (Nothing::Maybe Int)) diff --git a/Framework/Http/Cookies.hs b/Framework/Http/Cookies.hs index 0839485..1733072 100644 --- a/Framework/Http/Cookies.hs +++ b/Framework/Http/Cookies.hs @@ -8,12 +8,16 @@ import Network.Shed.Httpd import Framework.Types import Framework.Utils --- import Framework.Urls -setcookie :: String -> String -> String -> HttpHeader +setcookie :: String -- ^ Expiration date + -> String -- ^ Cookie name + -> String -- ^ Cookie value + -> HttpHeader setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) -getcookie :: Request -> String -> String +getcookie :: Request -- ^ HTTP request + -> String -- ^ Cookie name + -> String getcookie rq name = maybe "" id $ lookup name cc where cc = allcookies rq diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs index 9892d27..a04404d 100644 --- a/Framework/Http/Response.hs +++ b/Framework/Http/Response.hs @@ -1,3 +1,4 @@ +-- | Utility functions to form HTTP response module Framework.Http.Response (response, ok, redirect, redirectG, redirectP, @@ -15,27 +16,38 @@ url ? pairs = url++(urlencode pairs) ------------------------------------------------------------------------------------------------------- -- * Make a Response --- -response :: Int -> [HttpHeader] -> String -> Httpd.Response +-- | Generic response +response :: Int -- ^ HTTP status code + -> [HttpHeader] -- ^ HTTP headers + -> String -- ^ Response body + -> Httpd.Response response code pairs body = Httpd.Response code (map repackHeader $ filter notEmptyHeader pairs) body where notEmptyHeader (_:=v) = not $ httpEmpty v +-- | HTTP 200 OK response with given body (text/html) ok :: String -> Httpd.Response ok body = response 200 ["Content-Type" =: mime] body where mime = "text/html" +-- | HTTP 302 redirect response with given text redirect :: String -> Httpd.Response redirect url = response 302 ["Location" =: url] "" +-- | HTTP 301 redirect response with given text redirectP :: String -> Httpd.Response redirectP url = response 301 ["Location" =: url] "" -redirectG :: String -> [UrlParam] -> Httpd.Response +-- | Generic 302 redirect +redirectG :: String -- ^ Response body + -> [UrlParam] -- ^ Parameters for URL + -> Httpd.Response redirectG url pairs = redirect $ url ? pairs +-- | Add HTTP header to response (<+>) :: Httpd.Response -> HttpHeader -> Httpd.Response (Httpd.Response c hdrs b) <+> hdr = Httpd.Response c (hdrs++[repackHeader hdr]) b +-- | Add list of HTTP headers to response (<++>) :: Httpd.Response -> [HttpHeader] -> Httpd.Response (Httpd.Response c old b) <++> new = Httpd.Response c (old++(map repackHeader new)) b diff --git a/Framework/Http/SessionTypes.hs b/Framework/Http/SessionTypes.hs index 8ea7583..7f6200c 100644 --- a/Framework/Http/SessionTypes.hs +++ b/Framework/Http/SessionTypes.hs @@ -6,6 +6,7 @@ import qualified Data.Map as M type SessionID = String type SessionMap = M.Map String String +-- | Session data data Session = NewSession SessionID | ExistingSession SessionID SessionMap deriving (Show) @@ -16,6 +17,7 @@ class SessionBackend b where spush :: b -> SessionID -> SessionMap -> IO () sfree :: b -> IO () +-- | Container type for any sessions backend connection data SessionsConnection = forall b. (SessionBackend b) => SConnection b instance Show SessionsConnection where diff --git a/Framework/Http/Sessions.hs b/Framework/Http/Sessions.hs index fe90b29..b9f2c30 100644 --- a/Framework/Http/Sessions.hs +++ b/Framework/Http/Sessions.hs @@ -52,18 +52,25 @@ instance SessionBackend FilesBackend where sfree _ = return () -initSessions :: String -> String -> IO SessionsConnection +-- | Init sessions backend +initSessions :: String -- ^ Backend name (currently only `files`) + -> String -- ^ Config of backend (path where to store sessions files) + -> IO SessionsConnection initSessions "files" s = SConnection `fmap` (sinit s :: IO FilesBackend) +-- | Fetch session data from backend sFetch :: SessionsConnection -> SessionID -> IO SessionMap sFetch (SConnection b) sid = sfetch b sid +-- | Push session data to backend sPush :: SessionsConnection -> SessionID -> SessionMap -> IO () sPush (SConnection b) sid mm = spush b sid mm +-- | Free sessions backend sFree :: SessionsConnection -> IO () sFree (SConnection b) = sfree b +-- | Acquire session (create new or use existing SessionID) session :: SessionsConnection -> Request -> IO Session session (SConnection b) rq = if null sid @@ -73,5 +80,8 @@ session (SConnection b) rq = return $ ExistingSession sid mm where sid = getcookie rq "SessionID" -sessionCookie :: String -> String -> HttpHeader +-- | Form SessionID cookie header +sessionCookie :: String -- ^ Cookie expiration date + -> SessionID -- ^ Session ID + -> HttpHeader sessionCookie exp sid = setcookie exp "SessionID" sid diff --git a/Framework/Models.hs b/Framework/Models.hs index dc5c1cb..11e3c78 100644 --- a/Framework/Models.hs +++ b/Framework/Models.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleContexts #-} +-- | ADT for DB tables (data models). module Framework.Models - (ColumnType (..), -- $doc + (ColumnType (..), Model (..), ModelField (..), (-:>), @@ -16,9 +17,6 @@ import Database.HDBC (SqlValue(..), fromSql) import Framework.Types --- $doc --- ADT for DB tables (data models). - -- | Type of DB table column data ColumnType = IntegerColumn | ForeignKey Model String @@ -45,7 +43,12 @@ data Model = Model { } deriving (Eq,Show) +-- | Connected model for foreign key +foreignModel :: ColumnType -> Model foreignModel (ForeignKey m _) = m + +-- | Connected foreign field for foreign key +foreignField :: ColumnType -> String foreignField (ForeignKey _ f) = f -- | Field for Model @@ -54,19 +57,29 @@ data ModelField = String ::: ColumnType deriving (Eq,Show) -- | Get specific field from model +(-:>) :: Model -> String -> SqlValue model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname +lookupField :: [ModelField] -> String -> SqlValue lookupField [] _ = error "field name not found by lookupField!" lookupField (f:fs) name | (fieldName f)==name = fieldValue f | otherwise = lookupField fs name +-- | Set one field value +updateField :: [ModelField] -> String -> ColumnType -> SqlValue -> [ModelField] 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) +-- | 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 } -record :: Model -> [SqlValue] -> Model +-- | Fill fields in "Model" from ["SqlValue"] +-- Do not fill `id` and current date fields +record :: Model -- ^ Empty model (with unfilled fields) + -> [SqlValue] -- ^ List of values + -> Model -- ^ Model with filled fields record m lst = m { mFields = filledFields } where filledFields = combine (mFields m) lst @@ -77,6 +90,7 @@ record m lst = m { mFields = filledFields } then (FilledField name tp (defaultValue tp)):(combine fs vals) else (FilledField name tp x):(combine fs xs) +-- | Same as "record", but fill all fields record' :: Model -> [SqlValue] -> Model record' m lst = m { mFields = filledFields } where @@ -87,19 +101,28 @@ record' m lst = m { mFields = filledFields } combine' [] _ = [] combine' ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine' fs xs) +-- | Get name of field +fieldName :: ModelField -> String fieldName (n:::_) = n fieldName (FilledField n _ _) = n +-- | Get type of field +fieldType :: ModelField -> ColumnType fieldType (_:::tp) = tp fieldType (FilledField _ tp _) = tp +-- | Get value of field +fieldValue :: ModelField -> SqlValue fieldValue (_:::tp) = defaultValue tp fieldValue (FilledField _ _ v) = v +fieldValue' :: (CD.Convertible SqlValue a) => ModelField -> a fieldValue' f = fromSql $ fieldValue f +isTypeOf :: [ColumnType] -> ModelField -> Bool isTypeOf tps field = (fieldType field) `elem` tps +nthTypeField :: [ColumnType] -> Model -> Int -> ModelField nthTypeField tps x n = (filter (isTypeOf tps) ((mFields x)++(mCached x)))!!(n-1) instance TemplateOne Model where diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 5f80374..6e7c319 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} - -- $doc +-- | Functions to break query results into pages. module Framework.Pager (pager ) where @@ -15,13 +15,12 @@ import Framework.API import Framework.Urls import Framework.Types --- $doc --- Functions to break query results into pages. -- | Represents pager HTML generator type Pager = Request -> Int -> Int -> String -- | Simple pager +pager :: ActionConfig-> Int-> Query-> [SqlValue]-> Model-> IO ([Model], String) pager = genericPager genpager -- | Generic pager function diff --git a/Framework/SQL.hs b/Framework/SQL.hs index 2a53493..a05037f 100644 --- a/Framework/SQL.hs +++ b/Framework/SQL.hs @@ -122,27 +122,40 @@ sql (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpa where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre) eqs = commas $ zipWith (\n v -> n++"="++v) fields values +commas :: [String] -> String commas = concat . intersperse ", " + +sqlList :: (SQLFragment a) => [a] -> [Char] sqlList = commas.map sqlFragment + +sqlJoin :: [String] -> String sqlJoin = concat . (intersperse " LEFT JOIN ") -- | Get some aggregate function of query +aggregate :: Query -> String -> Query aggregate q fn = q {qFields=(onlyLast (liftF fn) (qFields q))} -- | Apply function only to last item of list +onlyLast :: (b -> b) -> [b] -> [b] onlyLast f lst = (init lst)++[(f $ last lst)] -- | Apply function to SQLField +liftF :: String -> SQLField -> SQLField liftF fn (QField name) = QFn fn name liftF fn (QFn _ name) = QFn fn name -- | Get `count` function of query +count :: Query -> Query count q@(Query flds tbls conds ordr grp lim) | TableJoin lst <- tbls = Query [liftF "count" $ head flds] (TableList [head lst]) NoCondition [] [] Nothing | otherwise = aggregate q "count" +allFields :: [SQLField] allFields = [QField "*"] +tableR :: SQLTable -> Query tableR t = Query allFields (TableList [t]) NoCondition [] [] Nothing + +tablesR :: [SQLTable] -> Query tablesR ts = Query allFields (TableList ts) NoCondition [] [] Nothing -- object = Model { @@ -185,6 +198,7 @@ updateM m cond = UpdateQuery (mTable m) (map fieldName updfields) temps cond temps = replicate (length updfields) "?" -- | Get foreign key of the model +getForeignKey :: Model -> ModelField getForeignKey m = fkey (mFields m) where fkey (f:fs) | ForeignKey _ _ <- fieldType f = f | otherwise = fkey fs diff --git a/Framework/Urls.hs b/Framework/Urls.hs index ff1c8a9..c5ffecd 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +-- | URL dispatcher module Framework.Urls where import Debug.Trace @@ -17,18 +18,22 @@ import qualified Framework.Http.Sessions as Sessions import Framework.Http.Response ((<+>)) type URLParts = [String] +-- | Function which get one String argument and (maybe) returns Response type StrAction = ActionConfig -> String -> Maybe (IO Response) +-- | Function which get many String arguments and (maybe) returns Response type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO Response) +-- | Function which just returns Response type HttpAction = ActionConfig -> IO Response -data URLConf = Action HttpAction - | OneOf URLConf URLConf - | Function StrAction - | Prefix String URLConf - | Regexp String URLConf - | RegexpFun String StrAction - | ManyRegexpFun URLParts URLParts ManyStrAction - | After URLConf URLConf +-- | URL dispatcher config +data URLConf = Action HttpAction -- ^ Simple answer, not depending on URL + | OneOf URLConf URLConf -- ^ Try to dispatch URL with first URLConf, if error then try second + | Function StrAction -- ^ Answer depends on last URL part (`basename`) + | Prefix String URLConf -- ^ URLConf is executed only when URL starts with given prefix + | Regexp String URLConf -- ^ URLConf is executed only when current part of URL matches regexp + | RegexpFun String StrAction -- ^ Same, but answer depends on URL part + | ManyRegexpFun URLParts URLParts ManyStrAction -- ^ Answer depends on many URL parts (which should match regexps) + | After URLConf URLConf -- ^ Execute first URLConf, then second. instance Show URLConf where show (Action _) = "Some action" @@ -40,6 +45,8 @@ instance Show URLConf where show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function" show (After u v) = (show u)++", then "++(show v) +-- | Split URL into parts: +-- /usr/local/bin --> [usr,local,bin] urlSplit :: URI -> URLParts urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash) where url = uriPath uri @@ -47,10 +54,16 @@ urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash) -- then "" -- else "/" +-- | Join URL parts into URL urlJoin :: URLParts -> String urlJoin us = concat $ intersperse "/" us -runURLConf :: StaticConfig -> Request -> String -> URLConf -> IO Response +-- | Main dispatcher function +runURLConf :: StaticConfig -- ^ Static (global) config + -> Request -- ^ HTTP request + -> String -- ^ URL itself + -> URLConf -- ^ Dispatcher configuration + -> IO Response runURLConf ps rq s conf = let murl = parseURIReference s in case murl of Nothing -> error "Couldn't parse URL!" @@ -87,9 +100,11 @@ runURLConf' (After c d) (x:xs) ac = case runURLConf' c [x] ac of Just act -> Just (maybe act (act>>) (runURLConf' d xs ac)) runURLConf' cc xs ac = error $ unlines ["URLConf error",show cc,show xs,show ac] +-- | If current part of URL is equal to given string, then call given function (-->) :: String -> HttpAction -> URLConf s --> act = Prefix s (Action act) +-- | If current part of URL is equal to given string, then work with given URLConf (//) :: String -> URLConf -> URLConf (//) = Prefix infixr 7 // @@ -122,27 +137,44 @@ infixr 6 >=> ------------------------------------------------------------------------------------------------ -- -httpGetVar :: Request -> String -> Maybe String +-- | Get HTTP GET var value +httpGetVar :: Request -- ^ HTTP Request + -> String -- ^ Var name + -> Maybe String httpGetVar rq name = lookup name pairs where pairs = queryToArguments $ uriQuery $ reqURI rq -httpGetVar' :: Request -> String -> String -> String +-- | Same, but with default value +httpGetVar' :: Request + -> String -- ^ Var name + -> String -- ^ Default value + -> String httpGetVar' rq name def = maybe def id $ lookup name pairs where pairs = queryToArguments $ uriQuery $ reqURI rq +-- | Get HTTP POST var value httpPostVar :: Request -> String -> Maybe String httpPostVar rq name = lookup name pairs where pairs = decodePairs (reqBody rq) -httpPostVar' :: Request -> String -> String -> String +-- | Same, but with default value +httpPostVar' :: Request + -> String -- ^ Var name + -> String -- ^ Default value + -> String httpPostVar' rq name def = maybe def id $ lookup name pairs where pairs = decodePairs (reqBody rq) -httpAddGetVar :: Request -> String -> String -> String +-- | Add GET var to given Request and return resulting URL +httpAddGetVar :: Request + -> String -- ^ Var name + -> String -- ^ Var value + -> String httpAddGetVar rq name value = urlencode (map packHeader pairs') where pairs' = update name value pairs pairs = decodePairs (uriQuery $ reqURI rq) +-- | Get URL from Request myUrl :: Request -> String myUrl rq = uriPath $ reqURI rq