Update driver interface to get composite primary key infos.

This commit is contained in:
Kei Hibino 2013-06-27 14:48:31 +09:00
parent 30933282bc
commit d5cd188143
4 changed files with 39 additions and 29 deletions

View File

@ -21,8 +21,8 @@ module Database.HDBC.Query.TH (
defineTableFromDB defineTableFromDB
) where ) where
import Data.Maybe (listToMaybe, maybeToList) import Data.Maybe (listToMaybe, isJust, catMaybes)
import Data.List (elemIndex) import qualified Data.Map as Map
import Database.HDBC (IConnection, SqlValue) import Database.HDBC (IConnection, SqlValue)
@ -78,15 +78,24 @@ defineTableFromDB connect drv scm tbl derives = do
withConnectionIO connect withConnectionIO connect
(\conn -> do (\conn -> do
(cols, notNullIdxs) <- getFields drv conn scm tbl (cols, notNullIdxs) <- getFields drv conn scm tbl
mayPrimaryKey <- getPrimaryKey drv conn scm tbl primCols <- getPrimaryKey drv conn scm tbl
mayPrimaryIdx <- case mayPrimaryKey of let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ]
Just key -> case elemIndex key $ map fst cols of lookup' k = do
Nothing -> do putLog $ "defineTableFromDB: fail to find index of pkey - " ++ key ++ ". Something wrong!!" case Map.lookup k colIxMap of
Just i -> return $ Just i
Nothing -> do
putLog $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!"
return Nothing return Nothing
Just ix -> return $ Just ix
Nothing -> return Nothing
return (cols, notNullIdxs, mayPrimaryIdx) )
(cols, notNullIdxs, mayPrimaryIdx) <- runIO getDBinfo primaryIxs <- case primCols of
defineTableDefault scm tbl cols derives (maybeToList mayPrimaryIdx) (listToMaybe notNullIdxs) _:_ -> do
founds <- mapM lookup' primCols
if all isJust founds
then return $ catMaybes founds
else return []
[] -> return []
return (cols, notNullIdxs, primaryIxs) )
(cols, notNullIdxs, primaryIxs) <- runIO getDBinfo
defineTableDefault scm tbl cols derives primaryIxs (listToMaybe notNullIdxs)

View File

@ -41,12 +41,12 @@ data Driver conn =
, getPrimaryKey :: conn -- Connection to query system catalog , getPrimaryKey :: conn -- Connection to query system catalog
-> String -- Schema name string -> String -- Schema name string
-> String -- Table name string -> String -- Table name string
-> IO (Maybe String) -- Action to get primary key column name -> IO ([String]) -- Action to get column names of primary key
} }
-- | Empty definition of 'Driver' -- | Empty definition of 'Driver'
emptyDriver :: IConnection conn => Driver conn emptyDriver :: IConnection conn => Driver conn
emptyDriver = Driver [] (\_ _ _ _ -> return ([],[])) (\_ _ _ -> return Nothing) emptyDriver = Driver [] (\_ _ _ _ -> return ([],[])) (\_ _ _ -> return [])
-- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'. -- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'.
getFields :: IConnection conn => Driver conn -> conn -> String -> String -> IO ([(String, TypeQ)], [Int]) getFields :: IConnection conn => Driver conn -> conn -> String -> String -> IO ([(String, TypeQ)], [Int])

View File

@ -27,7 +27,7 @@ import qualified Language.Haskell.TH.Lib.Extra as TH
import Database.HDBC (IConnection, SqlValue) import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery', listToUnique) import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable () import Database.HDBC.Record.Persistable ()
import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined) import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined)
@ -60,16 +60,15 @@ getPrimaryKey' :: IConnection conn
=> conn => conn
-> String -> String
-> String -> String
-> IO (Maybe String) -> IO [String]
getPrimaryKey' conn scm' tbl' = do getPrimaryKey' conn scm' tbl' = do
let tbl = map toUpper tbl' let tbl = map toUpper tbl'
scm = map toUpper scm' scm = map toUpper scm'
mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL primCols <- runQuery' conn (scm, tbl) primaryKeyQuerySQL
>>= listToUnique let primaryKeyCols = normalizeColumn `fmap` primCols
let mayPrimaryKey = normalizeColumn `fmap` mayPrim putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
putLog $ "getPrimaryKey: primary key = " ++ show mayPrimaryKey
return mayPrimaryKey return primaryKeyCols
getFields' :: IConnection conn getFields' :: IConnection conn
=> TypeMap => TypeMap

View File

@ -28,7 +28,7 @@ import Database.HDBC (IConnection, SqlValue)
import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined) import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined)
import qualified Database.Relational.Query.Table as Table import qualified Database.Relational.Query.Table as Table
import Database.HDBC.Record.Query (runQuery', listToUnique) import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable () import Database.HDBC.Record.Persistable ()
import Database.Relational.Schema.PostgreSQL import Database.Relational.Schema.PostgreSQL
@ -60,13 +60,15 @@ getPrimaryKey' :: IConnection conn
=> conn => conn
-> String -> String
-> String -> String
-> IO (Maybe String) -> IO [String]
getPrimaryKey' conn scm' tbl' = do getPrimaryKey' conn scm' tbl' = do
let scm = map toLower scm' let scm = map toLower scm'
tbl = map toLower tbl' tbl = map toLower tbl'
mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL primCols <- runQuery' conn (scm, tbl) primaryKeyQuerySQL
>>= listToUnique let primaryKeyCols = normalizeColumn `fmap` primCols
return $ normalizeColumn `fmap` mayPrim putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
return primaryKeyCols
getFields' :: IConnection conn getFields' :: IConnection conn
=> TypeMap => TypeMap