diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 8325043..221f739 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -32,8 +32,8 @@ allposts = do let getvars = _GET rq key = "allposts" ++ (getString' getvars "page" "1") tryReturnFromCache key - (posts,pagerHtml) <- pager 5 (countChildren postModel commentModel "dt") [] postModel - lastComments <- querySQL' ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel + (posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel + lastComments <- querySQL' ((table commentModel) `order` [Desceding "dt"] `limit` (0,10)) [] commentModel renderToResponseP key "blogposts.html" [("posts", C posts), ("comments", C lastComments), ("pager", C pagerHtml)] @@ -87,7 +87,7 @@ onepost sid = do case rqMethod rq of GET -> do post <- getOneObject postModel pid - comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 $ fromIntegral pid] commentModel + comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?")) [SqlInt32 $ fromIntegral pid] commentModel renderToResponseM "onepost.html" [("post", C post), ("comments", C comments), ("form", C form)] diff --git a/Blog/Models.hs b/Blog/Models.hs index c3e159b..fb3e388 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -12,17 +12,19 @@ import Framework.Storage import Framework.Forms.Types import Framework.Forms.HTML import Framework.Forms.Validation -import Framework.Models +import Framework.ORM import Framework.Markdown -postModel = Model { +postModel = emptyModel { mName = "post", mTable = "posts", mFields = ["id" ::: PrimaryKey, "dt" ::: CurrentDateColumn, "title" ::: StringColumn, "body" ::: StringColumn], - mCached = ["ncomments" ::: IntegerColumn] + mCached = ["ncomments" ::: IntegerColumn], + defaultOrdering = [Desceding "dt"], + perPage = Just 5 } @@ -47,7 +49,7 @@ addNComments post n = setCached postModel "ncomments" IntegerColumn n ------------------------------------------------------------------------------- -commentModel = Model { +commentModel = emptyModel { mName = "comment", mTable = "comments", mFields = ["id" ::: PrimaryKey, @@ -55,7 +57,8 @@ commentModel = Model { "dt" ::: CurrentDateColumn, "author" ::: StringColumn, "body" ::: StringColumn ], - mCached = [] + mCached = [], + defaultOrdering = [Asceding "dt"] } commentId = show.(transformInt 1 id) diff --git a/Framework/API.hs b/Framework/API.hs index 02679c4..e6e8b95 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -27,7 +27,7 @@ module Framework.API module Framework.Pager, module Framework.Http.Vars, module Framework.Urls, - module Framework.SQL, + module Framework.ORM, module Framework.Http.Response ) where @@ -52,7 +52,7 @@ import Framework.Forms.Validation import Framework.Pager import Framework.Http.Vars import Framework.Urls hiding (runURLConf) -import Framework.SQL +import Framework.ORM import Framework.Http.Response ---------------------------------------------------------------------------------------------------------- diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs index b387545..d4a5f4e 100644 --- a/Framework/API/SQL.hs +++ b/Framework/API/SQL.hs @@ -8,8 +8,7 @@ import Framework.Types import Framework.Controller import Framework.Exceptions import qualified Framework.Storage as Storage -import Framework.SQL -import Framework.Models +import Framework.ORM import Framework.Forms.Types import Framework.Forms.Validation diff --git a/Framework/API/Storage.hs b/Framework/API/Storage.hs index 136e3e9..eea3bab 100644 --- a/Framework/API/Storage.hs +++ b/Framework/API/Storage.hs @@ -5,7 +5,7 @@ import qualified Database.HDBC as HDBC import Framework.Types import Framework.Controller -import Framework.Models +import Framework.ORM.Types import qualified Framework.Storage as Storage ---------------------------------------------------------------------------------------------------------- diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index 67ddd24..3f77cbc 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -11,7 +11,7 @@ module Framework.Forms.Types import Network.HTTP import Framework.Types -import Framework.Models +import Framework.ORM -- | Form plugin transforms a Form type FormsPlugins = [Form -> Form] diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index f4b6867..42f8191 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -24,7 +24,7 @@ import Framework.Types import Framework.Utils import Framework.Controller import Framework.API.Sessions -import Framework.Models +import Framework.ORM import Framework.Http.Response (redirectG) import Framework.Http.Vars diff --git a/Framework/Models.hs b/Framework/Models.hs deleted file mode 100644 index c16d1dd..0000000 --- a/Framework/Models.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleContexts #-} --- | ADT for DB tables (data models). -module Framework.Models - (ColumnType (..), - Model (..), - ModelField (..), - (-:>), - getPK, isExternalField, - foreignModel, foreignField, - updateField, setCached, - record, record', - fieldName, fieldType, fieldValue - ) where - -import Data.List -import qualified Data.Convertible.Base as CD -import Database.HDBC (SqlValue(..), fromSql) - -import Framework.Types - --- | Type of DB table column -data ColumnType = IntegerColumn - | PrimaryKey - | ForeignKey Model String -- ^ Foreign key <parent model> <link field in parent model> - | StringColumn - | BoolColumn - | CurrentDateColumn - deriving (Show,Eq) - --- | Default value of column type -defaultValue :: ColumnType -> SqlValue -defaultValue PrimaryKey = SqlInt32 0 -defaultValue IntegerColumn = SqlInt32 0 -defaultValue (ForeignKey _ _) = SqlInt32 0 -defaultValue StringColumn = SqlString "" -defaultValue BoolColumn = SqlBool False -defaultValue CurrentDateColumn = SqlString "current_timestamp" - --- | DB model (table) itself -data Model = Model { - mName :: String, -- ^ Model name - mTable :: String, -- ^ DB table name - mFields :: [ModelField], -- ^ List of model fields (DB table columns) - mCached :: [ModelField] -- ^ Additional fields, which are no in DB - } - deriving (Eq,Show) - -getPK :: Model -> Maybe String -getPK model = getPK' $ mFields model - where - getPK' [] = Nothing - getPK' (x:xs) | fieldType x == PrimaryKey = Just $ fieldName x - | otherwise = getPK' xs - --- | 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 - --- | Check if this field is PrimaryKey, ForeignKey or CurrentDate -isExternalField :: ModelField -> Bool -isExternalField f = case fieldType f of - PrimaryKey -> True - CurrentDateColumn -> True - ForeignKey _ _ -> True - _ -> False - --- | Field for Model -data ModelField = String ::: ColumnType - | FilledField String ColumnType SqlValue - deriving (Eq,Show) - --- | Get specific field from model -(-:>) :: Model -> String -> SqlValue -model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname - -lookupField :: [ModelField] -> String -> SqlValue -lookupField [] name = error $ "field name "++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 } - --- | 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 - combine _ [] = [] - combine [] _ = [] - combine flds@(f@(name:::tp):fs) vals@(x:xs) = - if isExternalField f - 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 - filledFields = combine (mFields m) lst - combine _ [] = [] - combine [] lst = combine' (mCached m) lst - combine ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine fs xs) - 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 - showO = show - intField n x = fieldValue' $ nthTypeField [IntegerColumn,PrimaryKey] x n - stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n - boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n diff --git a/Framework/ORM.hs b/Framework/ORM.hs new file mode 100644 index 0000000..7afcca7 --- /dev/null +++ b/Framework/ORM.hs @@ -0,0 +1,12 @@ +module Framework.ORM + ( + module Framework.ORM.Types, + module Framework.ORM.Models, + module Framework.ORM.SQL + ) where + + +import Framework.ORM.Types +import Framework.ORM.Models +import Framework.ORM.SQL + diff --git a/Framework/ORM/Models.hs b/Framework/ORM/Models.hs new file mode 100644 index 0000000..fc435a9 --- /dev/null +++ b/Framework/ORM/Models.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleContexts #-} +-- | ADT for DB tables (data models). +module Framework.ORM.Models + ((-:>), + getPK, isExternalField, + foreignModel, foreignField, + updateField, setCached, + record, record', + fieldName, fieldType, fieldValue, + emptyModel + ) where + +import Data.List +import qualified Data.Convertible.Base as CD +import Database.HDBC (SqlValue(..), fromSql) + +import Framework.Types +import Framework.ORM.Types + +emptyModel = Model { + mName = "default", + mTable = "default", + mFields = [], + mCached = [], + defaultOrdering = [], + perPage = Nothing + } + +-- | Default value of column type +defaultValue :: ColumnType -> SqlValue +defaultValue PrimaryKey = SqlInt32 0 +defaultValue IntegerColumn = SqlInt32 0 +defaultValue (ForeignKey _ _) = SqlInt32 0 +defaultValue StringColumn = SqlString "" +defaultValue BoolColumn = SqlBool False +defaultValue CurrentDateColumn = SqlString "current_timestamp" + +getPK :: Model -> Maybe String +getPK model = getPK' $ mFields model + where + getPK' [] = Nothing + getPK' (x:xs) | fieldType x == PrimaryKey = Just $ fieldName x + | otherwise = getPK' xs + +-- | 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 + +-- | Check if this field is PrimaryKey, ForeignKey or CurrentDate +isExternalField :: ModelField -> Bool +isExternalField f = case fieldType f of + PrimaryKey -> True + CurrentDateColumn -> True + ForeignKey _ _ -> True + _ -> False + +-- | Get specific field from model +(-:>) :: Model -> String -> SqlValue +model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname + +lookupField :: [ModelField] -> String -> SqlValue +lookupField [] name = error $ "field name "++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 } + +-- | 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 + combine _ [] = [] + combine [] _ = [] + combine flds@(f@(name:::tp):fs) vals@(x:xs) = + if isExternalField f + 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 + filledFields = combine (mFields m) lst + combine _ [] = [] + combine [] lst = combine' (mCached m) lst + combine ((name:::tp):fs) (x:xs) = (FilledField name tp x):(combine fs xs) + 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 + showO = show + intField n x = fieldValue' $ nthTypeField [IntegerColumn,PrimaryKey] x n + stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n + boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs new file mode 100644 index 0000000..b321459 --- /dev/null +++ b/Framework/ORM/SQL.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleContexts,NoMonomorphismRestriction, TypeSynonymInstances, PatternGuards #-} +-- | EDSL for SQL, and SQL generation from Models descriptions +module Framework.ORM.SQL + (sql, + table, select, onlyFields, + sgroup, order, + restrict, + limit, + countChildren, + insertM,updateM, +-- insertQ, updateQ, + aggregate, count + ) where + +import Debug.Trace + +import Data.List +import Database.HDBC +import qualified Data.Convertible.Base as CD + +import Framework.ORM.Types +import Framework.ORM.Models + +-- | Get name of field +fieldname (QField n) = n +fieldname (QFn _ n) = n + +-- sql q = let s = sql' q +-- in trace s s + +-- | Generate SQL query from its Query description +sql :: Query -> String +sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other + where other = wpart++gpart++opart++lpart + tlist | TableList ts <- tables = commas ts + | TableJoin ts <- tables = sqlJoin ts + wpart | whre == NoCondition = "" + | TableList _ <- tables = " WHERE "++(sqlFragment whre) + | TableJoin _ <- tables = " ON "++(sqlFragment whre) + opart | null order = "" + | otherwise = " ORDER BY "++(sqlList order) + gpart | null group = "" + | otherwise = " GROUP BY "++(commas group) + lpart | Just (x,y) <- ls = " OFFSET "++(show x)++" LIMIT "++(show y) + | otherwise = "" +sql (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")" +sql (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart + 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 + +-- | Simple query -- SELECT * FROM tablename +table :: Model -> Query +table m = Query allFields (TableList [mTable m]) NoCondition (defaultOrdering m) [] Nothing + +-- | Generate INSERT query for given model +insertM :: Model -> Query +insertM m = InsertQuery (mTable m) (map fieldName insfields) temps + where insfields = filter notid $ mFields m + notid s = not ("id" == (fieldName s)) + temps = map (\f -> if (fieldType f)==CurrentDateColumn + then "current_timestamp" + else "?") insfields + +-- | Generate UPDATE query for the model +updateM :: Model -> SQLCondition -> Query +updateM m cond = UpdateQuery (mTable m) (map fieldName updfields) temps cond + where updfields = filter normal $ mFields m + normal s = (not ("id" `isSuffixOf` (fieldName s))) && ((fieldType s)/=CurrentDateColumn) + 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 + fkey [] = error $ "No foreign key in model "++(mName m) + +-- | SELECT all items in table and, for each item, count it's subitems +countChildren :: Model -> Model -> Query +countChildren m c = (flip aggregate "count") $ setFields fs $ ((table m) `joinT` childTable) + `restrict` ((childTable++"."++childId) :==: parentField) + `sgroup` (parentField++", "++ordField) + where childTable = mTable c + fkey = getForeignKey c + parentId = foreignField $ fieldType fkey + childId = fieldName fkey + parentField = mTable m ++"."++ parentId + fs = parent++child + parent = map (\f -> if "id" `isSuffixOf` (fieldName f) + then QField $ (mTable m)++"."++(fieldName f) + else if (fieldName f)==ord + then QField $ (mTable m)++"."++(fieldName f) + else QFn "max" $ (mTable m)++"."++(fieldName f)) $ mFields m + child = [QField childTable] + ordField = (mTable m)++"."++ord + ord = if null $ defaultOrdering m + then "dt" + else case head $ defaultOrdering m of + Asceding x -> x + Desceding x -> x + +setFields :: [SQLField] -> Query -> Query +setFields fs q = q { qFields = fs } + +joinT :: Query -> String -> Query +joinT q@(Query {qTables = tables}) tbl | TableList ts <- tables = q { qTables = TableJoin (ts++[tbl]) } + | TableJoin ts <- tables = q { qTables = TableJoin (ts++[tbl]) } + +-- | 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) +restrict :: Query -> SQLCondition -> Query +restrict q@(Query {qWhere=NoCondition}) cond = q {qWhere=cond} +restrict q cond = q {qWhere = (qWhere q) :&: cond} + +-- | Sort items in query (add ORDER BY part) +order :: Query -> [SQLOrder] -> Query +order q ord = q {qOrder = ord} + +-- | Group items in query (add GROUP BY part) +sgroup :: Query -> String -> Query +sgroup q grp = q {qGroup = (qGroup q)++[grp]} + +-- | Limit query (add OFFSET ... LIMIT ... part) +limit :: Query -> (Int,Int) -> Query +limit q pair = q {qLimits = Just pair} diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs new file mode 100644 index 0000000..369c411 --- /dev/null +++ b/Framework/ORM/Types.hs @@ -0,0 +1,111 @@ +module Framework.ORM.Types where + +import Database.HDBC (SqlValue(..), fromSql) + +---------------------------------------------------------------------------------- +-- * SQL query ADT + +-- | List of tables: simple list or Join +data Tables = TableList [SQLTable] | TableJoin [SQLTable] + deriving (Eq,Show) + +-- | ADT for SQL Query +data Query = Query -- SELECT query + { + qFields :: [SQLField], -- ^ Fields to select + qTables :: Tables, -- + qWhere :: SQLCondition, -- ^ Conditions (WHERE part) + qOrder :: [SQLOrder], -- ^ ORDER BY part + qGroup :: [String], -- ^ GROUP BY part + qLimits :: Maybe (Int,Int) -- ^ OFFSET ... LIMIT part + } + | InsertQuery -- INSERT query + { + iTable :: String, -- ^ Table + iFields :: [String], -- ^ Fields list + iValues :: [String] -- ^ Values + } + | UpdateQuery -- UPDATE query + { + uTable :: String, -- ^ Table + uFields :: [String], -- ^ Fields + uValues :: [String], -- ^ Values + uWhere :: SQLCondition -- ^ Condition (WHERE part) + } + deriving (Eq,Show) + +data SQLField = QField String -- ^ Just a named field + | QFn String String -- ^ Some function of field, e.g. count(id) + deriving (Eq,Show) + +type SQLTable = String + +-- | ADT for SQL conditions +data SQLCondition = + NoCondition + | Selector :==: Selector + | Selector :/=: Selector + | Selector :>: Selector + | Selector :<: Selector + | SQLCondition :&: SQLCondition + | SQLCondition :|: SQLCondition + deriving (Eq,Show) + +type Selector = String + +data SQLOrder = Asceding String | Desceding String + deriving (Eq,Show) + +class SQLFragment s where + sqlFragment :: s -> String + +instance SQLFragment SQLCondition where + sqlFragment NoCondition = "" + sqlFragment (x :==: y) = sqlLift "=" x y + sqlFragment (x :/=: y) = sqlLift "!=" x y + sqlFragment (x :>: y) = sqlLift ">" x y + sqlFragment (x :<: y) = sqlLift "<" x y + sqlFragment (x :&: y) = "("++(sqlFPair " AND " x y)++")" + sqlFragment (x :|: y) = "("++(sqlFPair " OR " x y)++")" + +sqlFPair :: (SQLFragment f) => String -> f -> f -> String +sqlFPair op x y = (sqlFragment x)++op++(sqlFragment y) + +sqlLift op x y = x++op++y + +instance SQLFragment SQLField where + sqlFragment (QField n) = n + sqlFragment (QFn fn f) = fn++"("++f++")" + +instance SQLFragment SQLOrder where + sqlFragment (Asceding o) = o++" ASC" + sqlFragment (Desceding o) = o++" DESC" + +--------------------------------------------------------------------------------------------------------- +-- * Data model ADT + +-- | Type of DB table column +data ColumnType = IntegerColumn + | PrimaryKey + | ForeignKey Model String -- ^ Foreign key <parent model> <link field in parent model> + | StringColumn + | BoolColumn + | CurrentDateColumn + deriving (Show,Eq) + +-- | DB model (table) itself +data Model = Model { + mName :: String, -- ^ Model name + mTable :: String, -- ^ DB table name + mFields :: [ModelField], -- ^ List of model fields (DB table columns) + mCached :: [ModelField], -- ^ Additional fields, which are no in DB + defaultOrdering :: [SQLOrder], -- ^ How to sort list of this models by default + perPage :: Maybe Int -- ^ Default paging + } + deriving (Eq,Show) + +-- | Field for Model +data ModelField = String ::: ColumnType + | FilledField String ColumnType SqlValue + deriving (Eq,Show) + diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 8954e9f..8b7ccb6 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -10,8 +10,8 @@ import Network.HTTP import Framework.Forms.Types import Framework.Forms.HTML -import Framework.Models -import Framework.SQL +import Framework.ORM.Types +import Framework.ORM.SQL import Framework.API.SQL import Framework.Types import Framework.Controller @@ -21,8 +21,7 @@ import Framework.Http.Vars type Pager = HttpRequest -> Int -> Int -> String -- | Simple pager -pager :: Int -- ^ Number of items per page - -> Query -- ^ Query itself +pager :: Query -- ^ Query itself -> [SqlValue] -- ^ Query parameters -> Model -- ^ Model to return -> AController ([Model], String) -- ^ (List of models, pager HTML) @@ -30,25 +29,31 @@ pager = genericPager genpager -- | Generic pager function genericPager :: Pager -- ^ Pager HTML generator function - -> Int -- ^ Number of items per page -> Query -- ^ DB query -> [SqlValue] -- ^ DB query parameters -> Model -- ^ Model of result -> AController ([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 - let itemCount :: Int - itemCount = fromSql $ head (head countRes) - if itemCount < perpage - then do items <- querySQL' q params model - return (items, "") - else do - rq <- asks request - let page = read $ httpGetVar' rq "page" "1" - let first = (page-1)*perpage - let pages = (itemCount `div` perpage)+1 - items <- querySQL' (q `limit` (first,perpage)) params model - return (items, pg rq pages page) +genericPager pg q params model = do + let pp = perPage model + case pp of + Nothing -> returnAll + Just perpage -> do + countRes <- queryListSQL' (count q) params + let itemCount :: Int + itemCount = fromSql $ head (head countRes) + if itemCount < perpage + then returnAll + else do + rq <- asks request + let page = read $ httpGetVar' rq "page" "1" + let first = (page-1)*perpage + let pages = (itemCount `div` perpage)+1 + items <- querySQL' (q `limit` (first,perpage)) params model + return (items, pg rq pages page) + where + returnAll = do + items <- querySQL' q params model + return (items, "") -- | Simple pager HTML generator genpager :: Pager diff --git a/Framework/SQL.hs b/Framework/SQL.hs deleted file mode 100644 index fa5f0d1..0000000 --- a/Framework/SQL.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleContexts,NoMonomorphismRestriction, TypeSynonymInstances, PatternGuards #-} --- | EDSL for SQL, and SQL generation from Models descriptions -module Framework.SQL - (sql, - Query, - Selector, - SQLOrder (..), - SQLCondition (..), - table, select, onlyFields, - sgroup, order, - restrict, - limit, - countChildren, - insertM,updateM, --- insertQ, updateQ, - aggregate, count - ) where - -import Debug.Trace - -import Data.List -import Database.HDBC -import qualified Data.Convertible.Base as CD - -import Framework.Models - --- | List of tables: simple list or Join -data Tables = TableList [SQLTable] | TableJoin [SQLTable] - deriving (Eq,Show) - --- | ADT for SQL Query -data Query = Query -- SELECT query - { - qFields :: [SQLField], -- ^ Fields to select - qTables :: Tables, -- - qWhere :: SQLCondition, -- ^ Conditions (WHERE part) - qOrder :: [SQLOrder], -- ^ ORDER BY part - qGroup :: [String], -- ^ GROUP BY part - qLimits :: Maybe (Int,Int) -- ^ OFFSET ... LIMIT part - } - | InsertQuery -- INSERT query - { - iTable :: String, -- ^ Table - iFields :: [String], -- ^ Fields list - iValues :: [String] -- ^ Values - } - | UpdateQuery -- UPDATE query - { - uTable :: String, -- ^ Table - uFields :: [String], -- ^ Fields - uValues :: [String], -- ^ Values - uWhere :: SQLCondition -- ^ Condition (WHERE part) - } - deriving (Eq,Show) - -data SQLField = QField String -- ^ Just a named field - | QFn String String -- ^ Some function of field, e.g. count(id) - deriving (Eq,Show) - --- | Get name of field -fieldname (QField n) = n -fieldname (QFn _ n) = n - -type SQLTable = String - --- | ADT for SQL conditions -data SQLCondition = - NoCondition - | Selector :==: Selector - | Selector :/=: Selector - | Selector :>: Selector - | Selector :<: Selector - | SQLCondition :&: SQLCondition - | SQLCondition :|: SQLCondition - deriving (Eq,Show) - -type Selector = String - -data SQLOrder = Asceding String | Desceding String - deriving (Eq,Show) - -class SQLFragment s where - sqlFragment :: s -> String - -instance SQLFragment SQLCondition where - sqlFragment NoCondition = "" - sqlFragment (x :==: y) = sqlLift "=" x y - sqlFragment (x :/=: y) = sqlLift "!=" x y - sqlFragment (x :>: y) = sqlLift ">" x y - sqlFragment (x :<: y) = sqlLift "<" x y - sqlFragment (x :&: y) = "("++(sqlFPair " AND " x y)++")" - sqlFragment (x :|: y) = "("++(sqlFPair " OR " x y)++")" - -sqlFPair :: (SQLFragment f) => String -> f -> f -> String -sqlFPair op x y = (sqlFragment x)++op++(sqlFragment y) - -sqlLift op x y = x++op++y - -instance SQLFragment SQLField where - sqlFragment (QField n) = n - sqlFragment (QFn fn f) = fn++"("++f++")" - -instance SQLFragment SQLOrder where - sqlFragment (Asceding o) = o++" ASC" - sqlFragment (Desceding o) = o++" DESC" - --- sql q = let s = sql' q --- in trace s s - --- | Generate SQL query from its Query description -sql :: Query -> String -sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other - where other = wpart++gpart++opart++lpart - tlist | TableList ts <- tables = commas ts - | TableJoin ts <- tables = sqlJoin ts - wpart | whre == NoCondition = "" - | TableList _ <- tables = " WHERE "++(sqlFragment whre) - | TableJoin _ <- tables = " ON "++(sqlFragment whre) - opart | null order = "" - | otherwise = " ORDER BY "++(sqlList order) - gpart | null group = "" - | otherwise = " GROUP BY "++(commas group) - lpart | Just (x,y) <- ls = " OFFSET "++(show x)++" LIMIT "++(show y) - | otherwise = "" -sql (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")" -sql (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart - 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 { --- mName = "object", --- mTable = "objects", --- mFields = [ "id" ::: IntegerColumn, --- "dt" ::: CurrentDateColumn, --- "name" ::: StringColumn, --- "value" ::: StringColumn ], --- mCached = [] --- } --- --- sub = Model { --- mName = "child", --- mTable = "children", --- mFields = [ "id" ::: IntegerColumn, --- "pid" ::: ForeignKey object "id", --- "body" ::: StringColumn ], --- mCached = [] --- } - --- | Simple query -- SELECT * FROM tablename -table :: Model -> Query -table m = tableR (mTable m) - --- | Generate INSERT query for given model -insertM :: Model -> Query -insertM m = InsertQuery (mTable m) (map fieldName insfields) temps - where insfields = filter notid $ mFields m - notid s = not ("id" == (fieldName s)) - temps = map (\f -> if (fieldType f)==CurrentDateColumn - then "current_timestamp" - else "?") insfields - --- | Generate UPDATE query for the model -updateM :: Model -> SQLCondition -> Query -updateM m cond = UpdateQuery (mTable m) (map fieldName updfields) temps cond - where updfields = filter normal $ mFields m - normal s = (not ("id" `isSuffixOf` (fieldName s))) && ((fieldType s)/=CurrentDateColumn) - 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 - fkey [] = error $ "No foreign key in model "++(mName m) - --- | SELECT all items in table and, for each item, count it's subitems -countChildren :: Model -> Model -> String -> Query -countChildren m c ord = (flip aggregate "count") $ setFields fs $ ((table m) `joinT` childTable) - `restrict` ((childTable++"."++childId) :==: parentField) - `sgroup` (parentField++", "++ordField) `order` (Asceding ordField) - where childTable = mTable c - fkey = getForeignKey c - parentId = foreignField $ fieldType fkey - childId = fieldName fkey - parentField = mTable m ++"."++ parentId - ordField = (mTable m)++"."++ord - fs = parent++child - parent = map (\f -> if "id" `isSuffixOf` (fieldName f) - then QField $ (mTable m)++"."++(fieldName f) - else if (fieldName f)==ord - then QField $ (mTable m)++"."++(fieldName f) - else QFn "max" $ (mTable m)++"."++(fieldName f)) $ mFields m - child = [QField childTable] - -setFields :: [SQLField] -> Query -> Query -setFields fs q = q { qFields = fs } - -joinT :: Query -> String -> Query -joinT q@(Query {qTables = tables}) tbl | TableList ts <- tables = q { qTables = TableJoin (ts++[tbl]) } - | TableJoin ts <- tables = q { qTables = TableJoin (ts++[tbl]) } - --- | 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) -restrict :: Query -> SQLCondition -> Query -restrict q@(Query {qWhere=NoCondition}) cond = q {qWhere=cond} -restrict q cond = q {qWhere = (qWhere q) :&: cond} - --- | Sort items in query (add ORDER BY part) -order :: Query -> SQLOrder -> Query -order q ord = q {qOrder = (qOrder q)++[ord]} - --- | Group items in query (add GROUP BY part) -sgroup :: Query -> String -> Query -sgroup q grp = q {qGroup = (qGroup q)++[grp]} - --- | Limit query (add OFFSET ... LIMIT ... part) -limit :: Query -> (Int,Int) -> Query -limit q pair = q {qLimits = Just pair} diff --git a/Framework/Storage.hs b/Framework/Storage.hs index 1ee6bc1..30e86f6 100644 --- a/Framework/Storage.hs +++ b/Framework/Storage.hs @@ -16,7 +16,7 @@ import qualified Database.HDBC.PostgreSQL as PostgreSQL import qualified Database.HDBC as D import Framework.Types -import Framework.Models +import Framework.ORM import Framework.Pool -- | Connect to DB