Skip to content

Commit

Permalink
Adding non-functional ORM...
Browse files Browse the repository at this point in the history
  • Loading branch information
alsonk committed Nov 25, 2008
1 parent 5d7e217 commit 421e3c0
Show file tree
Hide file tree
Showing 3 changed files with 180 additions and 99 deletions.
27 changes: 15 additions & 12 deletions Turbinado/Database/ORM/Generator.hs
View file
@@ -1,38 +1,41 @@
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

combinePrimaryKeys :: [(TableName, [ColumnName])] -> TableColumns -> TableColumns
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
158 changes: 77 additions & 81 deletions Turbinado/Database/ORM/Output.hs
View file
Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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 $
Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -199,32 +208,19 @@ 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) $
words $
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;
-}
94 changes: 88 additions & 6 deletions Turbinado/Database/ORM/PostgreSQL.hs
View file
Expand Up @@ -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);
-}

0 comments on commit 421e3c0

Please sign in to comment.