mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2025-01-08 06:19:33 +03:00
Update driver interface to get composite primary key infos.
This commit is contained in:
parent
30933282bc
commit
d5cd188143
@ -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)
|
||||||
|
@ -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])
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user