Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Adding non-functional ORM...

  • Loading branch information...
commit 421e3c0f01fc1471581629071698a017fc993c0e 1 parent 5d7e217
alsonk authored
View
27 Turbinado/Database/ORM/Generator.hs
@@ -1,30 +1,30 @@
module Turbinado.Database.ORM.Generator where
-
import qualified Data.Map as M
+import Config.Master
-type ConnectionString = String
type TableName = String
type ColumnName = String
type Column = (SqlColDesc, DependentKeys, Boolean) -- Boolean == isPrimaryKey
-type DependentKeys = [(TableName, ColumnName)] -- all columns which are targets of foreign keys
+type DependentKeys = [((ColumnName, (TableName, ColumnName))] -- all columns which are targets of foreign keys
type TableColumn = (TableName, ColumnName)
type TableColumns = M.Map TableColumn Column
generateModels :: FilePath -> IO ()
-generateModels cs fp = do conn <- openDBConnection
+generateModels cs fp = do conn <- databaseConnection
ts <- Database.HDBC.getTables conn
ds <- zip ts $ mapM (describeTable conn) ts
let tcs = combineTablesColumns ts ds
- pks <- getPrimaryKeys conn t
- let tcs' = combinePrimaryKeys tcs pks
+ -- TODO: Pull in indices
+ pks <- getPrimaryKeys conn ts
+ let tcs' = combinePrimaryKeys pks tcs
fks <- getForeignKeys t
- let tcs'' = foldl
+ let tcs'' = combineForeignKeys fks tcs'
-combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> TableColumn
+combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> TableColumns
combineTablesColumsn ts cs =
M.fromList $ zipWith (\t (c, d) -> ((t,c), (d, [], False)) ) ts cs
@@ -32,7 +32,10 @@ combinePrimaryKeys :: [(TableName, [ColumnName])] -> TableColumns -> TableColumn
combinePrimaryKeys pks tcs =
foldl (\tcs (t, cs) -> foldl (\c -> M.adjust (\(d,k,_) -> (d, k, True)) (t, c) ) tcs cs) tcs pks
-addDependentKey :: (TableColumn, TableColumn) -> TableColumns -> TableColumns
-addDependentKey (parTable, parColumn), ((depTable, depColumn)) t =
- let c@(d, k, i) = M.lookup (parTable, parColumn) t in
- M.insert (parTable, parColumn) (d, k `union` (depTable, depColumn), i)
+combineForeignKeys :: [(TableColumn, TableColumn)] -> TableColumns -> TableColumns
+combineForeignKeys fks tcs = foldl (\tcs' fk -> combineForeignKey fk tcs') tcs fks
+
+combineForeignKey :: (TableColumn, TableColumn) -> TableColumns -> TableColumns
+combineForeignKey (parTable, parColumn), ((depTable, depColumn)) tcs =
+ let c@(d, k, i) = M.lookup (parTable, parColumn) tcs in
+ M.insert (parTable, parColumn) (d, k `union` (parColumn, (depTable, depColumn)), i) t
View
158 Turbinado/Database/ORM/Output.hs
@@ -6,6 +6,8 @@ import Data.List
import Database.HDBC
import System.Directory
+-- TODO: This file needs to be completely torn up and generalized.
+
type TableName = String
type ParentName = String
type TypeName = String
@@ -18,13 +20,15 @@ data TableSpec = TableSpec {
columnDescriptions :: [(String, SqlColDesc)]
}
-generateModels conn parentName =
- do writeFile "Bases/ModelBase.hs" generateModelBase
+generateModels conn path parentName =
+ do writeFile (joinPath [path, "Bases/ModelBase.hs"]) generateModelBase
mapM (\t -> let typeName = (capitalizeName t)
fullName = typeName ++ "Model" in
do desc <- describeTable conn t
- writeFile ("Bases/" ++ fullName ++ "Base.hs") (generateModel parentName typeName (TableSpec t (getPrimaryKeysFromDesc desc) desc))
- doesFileExist (fullName ++ ".hs") >>= (\e -> when (not e) (writeFile (fullName++".hs") (generateModelFile parentName typeName) ) ) )
+ writeFile (joinPath [path, "Bases/", fullName ++ "Base.hs"]) (generateModel parentName typeName (TableSpec t (getPrimaryKeysFromDesc desc) desc))
+ e <- doesFileExist (joinPath [path, fullName ++ ".hs"])
+ when (not e) (writeFile (joinPath [path, fullName++".hs"]) (generateModelFile parentName typeName) )
+ )
=<< (getTables conn)
getPrimaryKeysFromDesc:: [(String, SqlColDesc)] -> (PrimaryKeyColumnNames, PrimaryKeyTypeNames)
@@ -33,6 +37,64 @@ getPrimaryKeysFromDesc desc =
where worker (c,t) [] = (c,t)
worker (c,t) (d:ds) = worker (if ((colIsPrimaryKey $ snd d) == True) then (c++[fst d], t++[getHaskellTypeString $ colType $ snd d]) else (c,t)) ds
+
+{-------------------------------------------------------------------------}
+columnToFieldLabel :: (String, SqlColDesc) -> String
+columnToFieldLabel (name, desc) =
+ " " ++ partiallyCapitalizeName name ++ " :: " ++
+ (if ((colNullable desc) == Just True) then "Maybe " else "") ++
+ getHaskellTypeString (colType desc)
+
+{-------------------------------------------------------------------------}
+generateFindByPrimaryKey :: TypeName -> TableSpec -> [String]
+generateFindByPrimaryKey typeName tspec =
+ case (length $ fst $ primaryKey tspec) of
+ 0 -> [""]
+ _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (snd $ primaryKey tspec)) ++ ") " ++ " where"
+ ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length $ fst $ primaryKey tspec)]) ++ ") = do"
+ ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (" ++ generatePrimaryKeyWhere (fst $ primaryKey tspec) ++ "++ \")\") []"
+ ," case res of"
+ ," [] -> throwDyn $ SqlError"
+ ," {seState = \"\","
+ ," seNativeError = (-1),"
+ ," seErrorMsg = \"No record found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
+ ," }"
+ ," r:[] -> return $ " ++ (generateConstructor typeName tspec)
+ ," _ -> throwDyn $ SqlError"
+ ," {seState = \"\","
+ ," seNativeError = (-1),"
+ ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
+ ," }"
+ ]
+
+generateFinders :: TypeName -> TableSpec -> [String]
+generateFinders typeName tspec =
+ ["instance HasFinders " ++ typeName ++ " where"
+ ," findAll conn = do"
+ ," res <- quickQuery' conn \"SELECT * FROM " ++ tableName tspec ++ "\" []"
+ ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
+ ," findAllBy conn ss sp = do"
+ ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
+ ," findOneBy conn ss sp = do"
+ ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," return $ (\\r -> " ++ generateConstructor typeName tspec ++ ") (head res)"
+ ]
+
+{-----------------------------------------------------------------------}
+generatePrimaryKeyWhere cnames =
+ unwords $
+ intersperse "++ \" AND \" ++ \"" $
+ map (\(c,i) -> c ++ " = \" ++ (show pk" ++ (show i) ++ ")") (zip cnames [1..])
+
+generateConstructor typeName tspec =
+ typeName ++ " " ++ (unwords $
+ map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((length $ columnDescriptions tspec)-1)])
+
+---------------------------------------------------------------------------
+-- File templates --
+---------------------------------------------------------------------------
+
generateModelFile parentName modelName =
let fullName = (if (length parentName > 0) then parentName ++ "." else "") ++ modelName ++ "Model"
in unlines $
@@ -108,64 +170,11 @@ generateModel parentName typeName tspec =
] ++
generateFindByPrimaryKey typeName tspec ++
generateFinders typeName tspec
-
-{-------------------------------------------------------------------------}
-columnToFieldLabel :: (String, SqlColDesc) -> String
-columnToFieldLabel (name, desc) =
- " " ++ partiallyCapitalizeName name ++ " :: " ++
- (if ((colNullable desc) == Just True) then "Maybe " else "") ++
- getHaskellTypeString (colType desc)
-
-{-------------------------------------------------------------------------}
-generateFindByPrimaryKey :: TypeName -> TableSpec -> [String]
-generateFindByPrimaryKey typeName tspec =
- case (length $ fst $ primaryKey tspec) of
- 0 -> [""]
- _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (snd $ primaryKey tspec)) ++ ") " ++ " where"
- ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length $ fst $ primaryKey tspec)]) ++ ") = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (" ++ generatePrimaryKeyWhere (fst $ primaryKey tspec) ++ "++ \")\") []"
- ," case res of"
- ," [] -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"No record found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
- ," }"
- ," r:[] -> return $ " ++ (generateConstructor typeName tspec)
- ," _ -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
- ," }"
- ]
-
-generateFinders :: TypeName -> TableSpec -> [String]
-generateFinders typeName tspec =
- ["instance HasFinders " ++ typeName ++ " where"
- ," findAll conn = do"
- ," res <- quickQuery' conn \"SELECT * FROM " ++ tableName tspec ++ "\" []"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
- ," findAllBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") \") sp"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
- ," findOneBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
- ," return $ (\\r -> " ++ generateConstructor typeName tspec ++ ") (head res)"
- ]
-
-{-----------------------------------------------------------------------}
-generatePrimaryKeyWhere cnames =
- unwords $
- intersperse "++ \" AND \" ++ \"" $
- map (\(c,i) -> c ++ " = \" ++ (show pk" ++ (show i) ++ ")") (zip cnames [1..])
-
-generateConstructor typeName tspec =
- typeName ++ " " ++ (unwords $
- map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((length $ columnDescriptions tspec)-1)])
-
-
-{-------------------------------------------------------------------------
- - Utility functions -
- -------------------------------------------------------------------------}
+
+
+---------------------------------------------------------------------------
+-- Utility functions --
+---------------------------------------------------------------------------
addCommas (s:[]) = [s]
addCommas (s:ss) = (s ++ ",") : (addCommas ss)
@@ -199,8 +208,9 @@ class TableType a where
find :: (IConnection conn) => conn -> Int -> a
findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
-{- Converts "column_name" to "ColumnName"
- -}
+--
+-- Converts "column_name" to "ColumnName" (for types)
+--
capitalizeName colname =
concat $
map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
@@ -208,23 +218,9 @@ capitalizeName colname =
map (\c -> if (c=='_') then ' ' else c) colname
+--
+-- Converts "column_name" to "columnName" (for functions)
+--
partiallyCapitalizeName colname =
(\(s:ss) -> (Data.Char.toLower s) : ss) $
capitalizeName colname
-
-{- If a column ends with "_id" then it's a foreign key
- -}
-isForeignKey colname =
- drop (length colname - 3) colname == "_id"
-
-
-{-
-PostgreSQL query to get Primary Keys:
-SELECT pg_attribute.attname
- FROM pg_class
- JOIN pg_namespace ON pg_namespace.oid=pg_class.relnamespace AND pg_namespace.nspname NOT LIKE 'pg_%' AND pg_class.relname like 'abba%'
- JOIN pg_attribute ON pg_attribute.attrelid=pg_class.oid AND pg_attribute.attisdropped='f'
- JOIN pg_index ON pg_index.indrelid=pg_class.oid AND pg_index.indisprimary='t' AND ( pg_index.indkey[0]=pg_attribute.attnum OR pg_inde
-x.indkey[1]=pg_attribute.attnum OR pg_index.indkey[2]=pg_attribute.attnum OR pg_index.indkey[3]=pg_attribute.attnum OR pg_index.indkey[4]=pg_attribute.attnum OR pg_index.indkey[5]=pg_attribute.attnum OR pg_index.indkey[6]=pg_attribute.attnum OR pg_index.indkey[7]=pg_attribute.attnum OR pg_index.indkey[8]=pg_attribute.attnum OR pg_index.indkey[9]=pg_attribute.attnum )
- ORDER BY pg_namespace.nspname, pg_class.relname,pg_attribute.attname;
--}
View
94 Turbinado/Database/ORM/PostgreSQL.hs
@@ -2,20 +2,102 @@ module Turbinado.Database.ORM.PostgreSQL where
import Database.HDBC
-getPrimaryKeys :: IConnection conn => conn -> String -> [String]
-getPrimaryKeys conn t = quickQuery conn (concatenate [
+getPrimaryKeys :: IConnection conn => conn -> [String] -> IO [String, [String]]
+getPrimaryKeys conn ts = mapM (\t -> getPrimaryKey conn t >>= \pks -> return (t, pks) ) ts
+
+getPrimaryKey :: IConnection conn => conn -> String -> IO [String]
+getPrimaryKey conn t = quickQuery conn (concatenate [
" SELECT ins.tablename, ins.indexname, i.indkey, a.*"
," FROM pg_indexes ins "
," INNER JOIN pg_class c ON ins.indexname = c.relname "
," INNER JOIN pg_index i ON c.oid = i.indexrelid "
," INNER JOIN pg_attribute a ON c.oid = a.attrelid "
- ," WHERE ins.tablename = '" ++ t ++ "' AND contype = 'f';"]) []
+ ," WHERE ins.tablename = ? AND contype = 'f';"]) [toSql t]
-getForeignKeys :: IConnection conn => conn -> String -> [String]
-getForeignKeys conn t = quickQuery conn (concatenate [
+getAllForeignKeys :: IConnection conn => conn -> [String] -> IO [(String, String), (String, String)]
+getAllForeignKeys conn ts = mapM (\t -> getForeignKeys conn t) ts
+
+getForeignKeys_ :: IConnection conn => conn -> String -> IO [((String, String), (String, String))]
+getForeignKeys_ conn t = quickQuery conn (concatenate [
" SELECT ins.tablename, ins.indexname, i.indkey, a.*"
," FROM pg_indexes ins "
," INNER JOIN pg_class c ON ins.indexname = c.relname "
," INNER JOIN pg_index i ON c.oid = i.indexrelid "
," INNER JOIN pg_attribute a ON c.oid = a.attrelid "
- ," WHERE ins.tablename = '" ++ t ++ "';"]) []
+ ," WHERE ins.tablename = ?;"]) [toSql t]
+
+
+{-
+
+INDEX COLUMNS
+
+ select n.nspname as schema_name,
+ ct.relname as table_name,
+ ci.relname as index_name,
+ a.attname as column_name,
+ s.i as column_position,
+ n2.nspname as opclass_schema,
+ o.opcname as opclass_name,
+ pg_get_indexdef(ci.oid,s.i,true) as definition
+ from pg_index x
+ join pg_class ct on (ct.oid = x.indrelid)
+ join pg_class ci on (ci.oid = x.indexrelid)
+ join pg_namespace n on (n.oid = ct.relnamespace)
+ join _pg_sv_keypositions() s(i) on (s.i <= x.indnatts)
+ join pg_opclass o on (o.oid = x.indclass[i-1])
+ join pg_namespace n2 on (n2.oid = o.opcnamespace)
+ left join pg_attribute a on (a.attrelid = ct.oid
+ and a.attnum = x.indkey[i-1])
+ where _pg_sv_table_accessible(n.oid,ct.oid)
+ and ct.relkind = 'r' and ci.relkind = 'i';
+
+PRIMARY KEY
+
+ select n.nspname as schema_name,
+ c.relname as table_name,
+ con.conname as constraint_name,
+ con.contype = 'p' as is_primary_key,
+ a.attname as column_name,
+ s.i as column_position,
+ c.oid as table_oid
+ from pg_constraint con
+ join pg_namespace n on (n.oid = con.connamespace)
+ join pg_class c on (c.oid = con.conrelid)
+ join _pg_sv_keypositions() s(i)
+ on (s.i <= array_upper(con.conkey,1))
+ join pg_attribute a on (a.attrelid = c.oid
+ and a.attnum = con.conkey[i])
+ where con.conrelid != 0
+ and con.contype in ('p','u')
+ and _pg_sv_table_accessible(n.oid,c.oid);
+
+
+FOREIGN KEYS
+
+ select n1.nspname as foreign_key_schema_name,
+ c1.relname as foreign_key_table_name,
+ k1.conname as foreign_key_constraint_name,
+ c1.oid as foreign_key_table_oid,
+ a1.attname as foreign_key_column,
+ s.i as column_position,
+ n2.nspname as key_schema_name,
+ c2.relname as key_table_name,
+ c2.oid as key_table_oid,
+ a2.attname as key_column
+ from pg_constraint k1
+ join pg_namespace n1 on (n1.oid = k1.connamespace)
+ join pg_class c1 on (c1.oid = k1.conrelid)
+ join pg_class c2 on (c2.oid = k1.confrelid)
+ join pg_namespace n2 on (n2.oid = c2.relnamespace)
+ join _pg_sv_keypositions() s(i)
+ on (s.i <= array_upper(k1.conkey,1))
+ join pg_attribute a1
+ on (a1.attrelid = c1.oid and a1.attnum = k1.conkey[s.i])
+ join pg_attribute a2
+ on (a2.attrelid = c2.oid and a2.attnum = k1.confkey[s.i])
+ where k1.conrelid != 0
+ and k1.confrelid != 0
+ and k1.contype = 'f'
+ and _pg_sv_table_accessible(n1.oid,c1.oid);
+
+-}
Please sign in to comment.
Something went wrong with that request. Please try again.