module Graphics.UI.WXCore.Db
(
dbWithConnection, dbConnect, dbDisconnect
, dbWithDirectConnection, dbConnectDirect
, dbQuery, dbQuery_
, dbExecute, dbTransaction
, DbRow(..)
, dbRowGetString, dbRowGetStringMb
, dbRowGetBool, dbRowGetBoolMb
, dbRowGetInt, dbRowGetIntMb
, dbRowGetDouble, dbRowGetDoubleMb
, dbRowGetInteger, dbRowGetIntegerMb
, dbRowGetClockTime, dbRowGetClockTimeMb
, DbValue( dbValueRead, toSqlValue )
, dbRowGetValue, dbRowGetValueMb
, dbRowGetColumnInfo, dbRowGetColumnInfos
, DataSourceName, dbGetDataSources
, dbGetDataSourceInfo, dbGetDataSourceTableInfo
, TableName, ColumnName, ColumnIndex
, DbInfo(..), TableInfo(..), ColumnInfo(..)
, dbGetInfo, dbGetTableInfo, dbGetTableColumnInfos, dbGetColumnInfos
, Dbms(..), dbGetDbms
, DbError(..)
, catchDbError, raiseDbError
, dbHandleExn, dbCheckExn, dbRaiseExn
, dbGetErrorMessages
, dbGetDbStatus, DbStatus(..)
, DbType(..), SqlType(..)
, toSqlTableName, toSqlColumnName
, toSqlString, toSqlTime, toSqlDate, toSqlTimeStamp
, dbStringRead, dbGetDataNull, toSqlType, fromSqlType
) where
import Graphics.UI.WXCore.WxcTypes
import Graphics.UI.WXCore.WxcDefs
import Graphics.UI.WXCore.WxcClasses
import Graphics.UI.WXCore.Types
import System.IO.Error( catch, ioError, isUserError, ioeGetErrorString)
import Data.List( isPrefixOf )
import Data.Char( isDigit )
import Foreign
import Foreign.Ptr
import Foreign.C.String
import Foreign.Marshal.Array
import System.Time
withValidObject :: (Object a -> IO ()) -> Object a -> IO ()
withValidObject f p
= if (objectIsNull p) then return () else f p
dbQuery :: Db a -> String -> (DbRow a -> IO b) -> IO [b]
dbQuery db select action
= do dbExecute db select
infos <- dbGetColumnInfos db
walkRows (DbRow db infos) []
where
walkRows row acc
= do ok <- dbGetNext db
if (not ok)
then return (reverse acc)
else do x <- action row
walkRows row (x:acc)
dbQuery_ :: Db a -> String -> (DbRow a -> IO b) -> IO ()
dbQuery_ db select action
= do dbHandleExn db $ dbExecSql db select
infos <- dbGetColumnInfos db
walkRows (DbRow db infos)
where
walkRows row
= do ok <- dbGetNext db
if (not ok)
then return ()
else do action row
walkRows row
dbExecute :: Db a -> String -> IO ()
dbExecute db sql
= dbHandleExn db $ dbExecSql db sql
dbTransaction :: Db a -> IO b -> IO b
dbTransaction db io
= do x <- io
dbHandleExn db (dbCommitTrans db)
return x
data DbRow a = DbRow (Db a) [ColumnInfo]
dbRowGetColumnInfos :: DbRow a -> [ColumnInfo]
dbRowGetColumnInfos (DbRow db columnInfos)
= columnInfos
dbRowGetColumnInfo :: DbRow a -> ColumnName -> IO ColumnInfo
dbRowGetColumnInfo (DbRow db columnInfos) name
= case lookup name (zip (map columnName columnInfos) columnInfos) of
Just info -> return info
Nothing -> if (all isDigit name)
then case lookup (read name) (zip (map columnIndex columnInfos) columnInfos) of
Just info -> return info
Nothing -> err
else err
where
err = raiseDbInvalidColumnName db (name ++ " in " ++ (show (map columnName columnInfos)))
dbRowGetValueMb :: DbValue b => DbRow a -> ColumnName -> IO (Maybe b)
dbRowGetValueMb row@(DbRow db columnInfos) name
= do info <- dbRowGetColumnInfo row name
dbValueRead db info
dbRowGetValue :: DbValue b => DbRow a -> ColumnName -> IO b
dbRowGetValue row@(DbRow db columnInfos) columnName
= do mbValue <- dbRowGetValueMb row columnName
case mbValue of
Just x -> return x
Nothing -> raiseDbFetchNull db
class DbValue a where
dbValueRead :: Db b -> ColumnInfo -> IO (Maybe a)
toSqlValue :: a -> String
instance DbValue Bool where
dbValueRead db columnInfo
= alloca $ \pint ->
do isNull <- dbGetDataNull db $ dbGetDataInt db (columnIndex columnInfo) pint
if isNull
then return Nothing
else do i <- peek pint
return (Just (i/=0))
toSqlValue b
= if b then "TRUE" else "FALSE"
instance DbValue Int where
dbValueRead db columnInfo
= alloca $ \pint ->
do isNull <- dbGetDataNull db $ dbGetDataInt db (columnIndex columnInfo) pint
if isNull
then return Nothing
else do i <- peek pint
return (Just (fromCInt i))
toSqlValue i
= show i
instance DbValue Double where
dbValueRead db columnInfo
= alloca $ \pdouble ->
do isNull <- dbGetDataNull db $ dbGetDataDouble db (columnIndex columnInfo) pdouble
if isNull
then return Nothing
else do d <- peek pdouble
return (Just d)
toSqlValue d
= show d
instance DbValue Integer where
dbValueRead db columnInfo
= do mbS <- dbStringRead db columnInfo
case mbS of
Nothing -> return Nothing
Just s -> case parse s of
Just i -> return (Just i)
Nothing -> raiseDbTypeMismatch db
where
parse s
= let (val,xs) = span isDigit s
in case xs of
('.':frac) | all isDigit frac
-> Just (read (val ++ adjust (columnDecimalDigits columnInfo) frac))
other -> Nothing
toSqlValue i
= show i
instance DbValue ClockTime where
dbValueRead db columnInfo
= alloca $ \pfraction ->
alloca $ \psecs ->
do poke pfraction (toCInt 0)
isNull <- dbGetDataNull db $
case columnSqlType columnInfo of
SqlDate -> dbGetDataDate db (columnIndex columnInfo) psecs
SqlTime -> dbGetDataTime db (columnIndex columnInfo) psecs
other -> dbGetDataTimeStamp db (columnIndex columnInfo) psecs pfraction
if (isNull)
then return Nothing
else do secs <- peek psecs
fraction <- peek pfraction
return (Just (TOD (fromIntegral secs) (fromIntegral fraction * 1000)))
toSqlValue ctime
= toSqlTimeStamp ctime
dbRowGetBool :: DbRow a -> ColumnName -> IO Bool
dbRowGetBool = dbRowGetValue
dbRowGetBoolMb :: DbRow a -> ColumnName -> IO (Maybe Bool)
dbRowGetBoolMb = dbRowGetValueMb
dbRowGetInt :: DbRow a -> ColumnName -> IO Int
dbRowGetInt = dbRowGetValue
dbRowGetIntMb :: DbRow a -> ColumnName -> IO (Maybe Int)
dbRowGetIntMb = dbRowGetValueMb
dbRowGetDouble :: DbRow a -> ColumnName -> IO Double
dbRowGetDouble = dbRowGetValue
dbRowGetDoubleMb :: DbRow a -> ColumnName -> IO (Maybe Double)
dbRowGetDoubleMb = dbRowGetValueMb
dbRowGetInteger :: DbRow a -> ColumnName -> IO Integer
dbRowGetInteger = dbRowGetValue
dbRowGetIntegerMb :: DbRow a -> ColumnName -> IO (Maybe Integer)
dbRowGetIntegerMb = dbRowGetValueMb
dbRowGetClockTime :: DbRow a -> ColumnName -> IO ClockTime
dbRowGetClockTime = dbRowGetValue
dbRowGetClockTimeMb :: DbRow a -> ColumnName -> IO (Maybe ClockTime)
dbRowGetClockTimeMb = dbRowGetValueMb
dbRowGetString :: DbRow a -> ColumnName -> IO String
dbRowGetString row name
= do mbStr <- dbRowGetStringMb row name
return (maybe "" id mbStr)
dbRowGetStringMb :: DbRow a -> ColumnName -> IO (Maybe String)
dbRowGetStringMb row@(DbRow db columnInfos) name
= do info <- dbRowGetColumnInfo row name
dbStringRead db info
dbStringRead :: Db a -> ColumnInfo -> IO (Maybe String)
dbStringRead db info
= alloca $ \pbuf ->
alloca $ \plen ->
do dbHandleExn db $ dbGetDataBinary db (columnIndex info) True pbuf plen
len <- peek plen
if (fromCInt len == wxSQL_NULL_DATA)
then do buf <- peek pbuf
wxcFree buf
return Nothing
else do buf <- peek pbuf
s <- peekCStringLen (buf,fromCInt len)
wxcFree buf
return (Just s)
toSqlString :: String -> String
toSqlString s
= "'" ++ concatMap quote s ++ "'"
where
quote '\'' = "''"
quote c = [c]
toSqlDate :: ClockTime -> String
toSqlDate ctime
= "'" ++ show (ctYear t) ++ "-" ++ show (ctMonth t) ++ "-" ++ show (ctDay t) ++ "'"
where
t = toUTCTime ctime
toSqlTimeStamp :: ClockTime -> String
toSqlTimeStamp ctime
= "'" ++ show (ctYear t) ++ "-" ++ show (ctMonth t) ++ "-" ++ show (ctDay t)
++ " " ++ show (ctHour t) ++ ":" ++ show (ctMin t) ++ ":" ++ show (ctSec t) ++ "'"
where
t = toUTCTime ctime
toSqlTime :: ClockTime -> String
toSqlTime ctime
= "'" ++ show (ctHour t) ++ ":" ++ show (ctMin t) ++ ":" ++ show (ctSec t) ++ "'"
where
t = toUTCTime ctime
dbGetDataNull :: Db a -> (Ptr CInt -> IO Bool) -> IO Bool
dbGetDataNull db getData
= alloca $ \pused ->
do dbHandleExn db $ getData pused
used <- peek pused
return (fromCInt used == wxSQL_NULL_DATA)
dbWithConnection :: DataSourceName -> String -> String -> (Db () -> IO b) -> IO b
dbWithConnection name userid password f
= bracket (dbConnect name userid password)
(dbDisconnect)
(f)
dbWithDirectConnection :: DataSourceName -> String -> String -> (Db () -> IO b) -> IO b
dbWithDirectConnection name userid password f
= bracket (dbConnectDirect name userid password)
(\db -> do{ dbClose db; dbDelete db } )
(f)
dbConnect :: DataSourceName -> String -> String -> IO (Db ())
dbConnect name userId password
= bracket (dbConnectInfCreate nullHENV name userId password "" "" "" )
(dbConnectInfDelete)
(\connectInf ->
do db <- dbGetConnection connectInf True
if objectIsNull db
then dbConnectDirect name userId password
else do opened <- dbIsOpen db
if (not opened)
then do dbFreeConnection db
dbConnectDirect name userId password
else return db)
dbConnectDirect :: DataSourceName -> String -> String -> IO (Db ())
dbConnectDirect dataSource userId password
= bracket (dbConnectInfCreate nullHENV dataSource userId password "" "" "")
(dbConnectInfDelete)
(\connectInf ->
do henv <- dbConnectInfGetHenv connectInf
db <- dbCreate henv True
if (objectIsNull db)
then raiseDbConnect dataSource
else do opened <- dbOpen db dataSource userId password
if (not opened)
then finalize (dbDelete db)
(dbRaiseExn db)
else return db)
dbDisconnect :: Db a -> IO ()
dbDisconnect db
= do freed <- dbFreeConnection db
if (freed)
then return ()
else do dbClose db
dbDelete db
type DataSourceName = String
type TableName = String
type ColumnName = String
type ColumnIndex = Int
data DbInfo
= DbInfo { dbCatalog :: String
, dbSchema :: String
, dbTables :: [TableInfo]
}
data TableInfo
= TableInfo{ tableName :: TableName
, tableType :: String
, tableRemarks :: String
, tableColumns :: [ColumnInfo]
}
data ColumnInfo
= ColumnInfo{ columnName :: ColumnName
, columnIndex :: ColumnIndex
, columnSize :: Int
, columnNullable :: Bool
, columnType :: DbType
, columnSqlType :: SqlType
, columnTypeName :: String
, columnRemarks :: String
, columnDecimalDigits :: Int
, columnNumPrecRadix :: Int
, columnForeignKey :: Int
, columnPrimaryKey :: Int
, columnForeignKeyTableName :: TableName
, columnPrimaryKeyTableNames :: [TableName]
}
dbGetDataSourceInfo :: DataSourceName -> String -> String -> IO DbInfo
dbGetDataSourceInfo dataSource userId password
= dbWithConnection dataSource userId password dbGetInfo
dbGetDataSourceTableInfo :: DataSourceName -> TableName -> String -> String -> IO TableInfo
dbGetDataSourceTableInfo dataSource tableName userId password
= dbWithConnection dataSource userId password (\db -> dbGetTableInfo db tableName)
dbGetTableInfo :: Db a -> TableName -> IO TableInfo
dbGetTableInfo db name
= do info <- dbGetInfo db
case lookup name (zip (map tableName (dbTables info)) (dbTables info)) of
Nothing -> raiseDbInvalidTableName db name
Just tinfo -> return tinfo
dbGetInfo :: Db a -> IO DbInfo
dbGetInfo db
= bracket (dbGetCatalog db "")
(withValidObject dbInfDelete)
(\dbInf ->do catalog <- dbInfGetCatalogName dbInf
schema <- dbInfGetSchemaName dbInf
numTables<- dbInfGetNumTables dbInf
tables <- mapM (\idx -> do tableInf <- dbInfGetTableInf dbInf (idx1)
dbTableInfGetInfo tableInf db)
[1..numTables]
return (DbInfo catalog schema tables))
dbTableInfGetInfo :: DbTableInf a -> Db b -> IO TableInfo
dbTableInfGetInfo tableInf db
= do tableName <- dbTableInfGetTableName tableInf
tableType <- dbTableInfGetTableType tableInf
remarks <- dbTableInfGetTableRemarks tableInf
numCols <- dbTableInfGetNumCols tableInf
columns <- dbGetTableColumnInfos db tableName
return (TableInfo tableName tableType remarks columns)
dbGetColumnInfos :: Db a -> IO [ColumnInfo]
dbGetColumnInfos db
= alloca $ \pcnumCols ->
bracket (dbGetResultColumns db pcnumCols)
(withValidObject dbColInfArrayDelete)
(\colInfs -> do cnumCols <- peek pcnumCols
let numCols = fromCInt cnumCols
mapM (\idx -> do colInf <- dbColInfArrayGetColInf colInfs (idx1)
dbColInfGetInfo colInf idx)
[1..numCols])
dbGetTableColumnInfos :: Db a -> TableName -> IO [ColumnInfo]
dbGetTableColumnInfos db tableName
| null tableName = dbGetColumnInfos db
| otherwise =
alloca $ \pcnumCols ->
bracket (dbGetColumns db tableName pcnumCols "")
(withValidObject dbColInfArrayDelete)
(\colInfs -> do cnumCols <- peek pcnumCols
let numCols = fromCInt cnumCols
mapM (\idx -> do colInf <- dbColInfArrayGetColInf colInfs (idx1)
dbColInfGetInfo colInf idx)
[1..numCols])
dbColInfGetInfo :: DbColInf a -> ColumnIndex -> IO ColumnInfo
dbColInfGetInfo info idx
= do columnName <- dbColInfGetColName info
columnSize <- dbColInfGetColumnSize info
nullable <- dbColInfIsNullable info
tp <- dbColInfGetDbDataType info
sqltp <- dbColInfGetSqlDataType info
tpname <- dbColInfGetTypeName info
remarks <- dbColInfGetRemarks info
decdigits <- dbColInfGetDecimalDigits info
numprecrad <- dbColInfGetNumPrecRadix info
fk <- dbColInfGetFkCol info
fkname <- dbColInfGetFkTableName info
pk <- dbColInfGetPkCol info
pkname <- dbColInfGetPkTableName info
return (ColumnInfo columnName idx columnSize nullable (toEnum tp) (toSqlType sqltp) tpname remarks
decdigits numprecrad fk pk fkname (parseTables pkname) )
where
parseTables [] = []
parseTables ('[':xs) = let (name,ys) = span (/=']') xs
in name : parseTables ys
parseTables (']':xs) = parseTables xs
parseTables (' ':xs) = parseTables xs
parseTables xs = [xs]
dbGetDataSources :: IO [(DataSourceName,String)]
dbGetDataSources
= do connectInf <- dbConnectInfCreate nullHENV "" "" "" "" "" ""
henv <- dbConnectInfGetHenv connectInf
xs <- loop henv True
dbConnectInfDelete connectInf
return xs
where
loop henv isFirst
= do mbSrc <- dbGetDataSourceEx henv isFirst
case mbSrc of
Nothing -> return []
Just x -> do xs <- loop henv False
return (x:xs)
dbGetDataSourceEx :: HENV () -> Bool -> IO (Maybe (String,String))
dbGetDataSourceEx henv isFirst
= allocaArray (dsnLen+1) $ \cdsn ->
allocaArray (descLen+1) $ \cdesc ->
do pokeArray0 0 cdsn []
pokeArray0 0 cdesc []
ok <- dbGetDataSource henv (castPtr cdsn) dsnLen (castPtr cdesc) descLen
(if isFirst then wxSQL_FETCH_FIRST else wxSQL_FETCH_NEXT)
if not ok
then return Nothing
else do dsn <- peekCWString cdsn
desc <- peekCWString cdesc
return (Just (dsn,desc))
where
dsnLen = 255
descLen = 1024
dbGetDataSourceName :: Db a -> IO DataSourceName
dbGetDataSourceName db
= dbGetDatasourceName db
data Dbms
= DbmsORACLE
| DbmsSYBASE_ASA
| DbmsSYBASE_ASE
| DbmsMS_SQL_SERVER
| DbmsMY_SQL
| DbmsPOSTGRES
| DbmsACCESS
| DbmsDBASE
| DbmsINFORMIX
| DbmsVIRTUOSO
| DbmsDB2
| DbmsINTERBASE
| DbmsPERVASIVE_SQL
| DbmsXBASE_SEQUITER
| DbmsUNIDENTIFIED
deriving (Eq,Enum,Show)
dbGetDbms :: Db a -> IO Dbms
dbGetDbms db
= do i <- dbDbms db
if (i==0 || i > fromEnum DbmsUNIDENTIFIED)
then return DbmsUNIDENTIFIED
else return (toEnum (i1))
data DbError
= DbError { dbErrorMsg :: String
, dbDataSource :: DataSourceName
, dbErrorCode :: DbStatus
, dbNativeCode :: Int
, dbSqlState :: String
}
deriving (Read,Show)
dbHandleExn :: Db a -> IO Bool -> IO ()
dbHandleExn db io
= do ok <- io
if ok
then return ()
else dbRaiseExn db
dbCheckExn :: Db a -> IO ()
dbCheckExn db
= do status <- dbGetDbStatus db
if (status == DB_SUCCESS)
then return ()
else dbRaiseExn db
dbRaiseExn :: Db a -> IO b
dbRaiseExn db
= do errorMsg <- dbGetErrorMessage db 0
errorCode <- dbGetDbStatus db
nativeCode<- dbGetNativeError db
dataSource<- dbGetDataSourceName db
raiseDbError (DbError (extractMessage errorMsg) dataSource errorCode nativeCode (extractSqlState errorMsg))
where
extractSqlState msg
| isPrefixOf sqlStatePrefix msg = takeWhile (/='\n') (drop (length sqlStatePrefix) msg)
| otherwise = ""
where
sqlStatePrefix = "SQL State = "
extractMessage msg
= dropTillPrefix "Error Message = " msg
dropTillPrefix prefix msg
= walk msg
where
walk s | null s = msg
| isPrefixOf prefix s = drop (length prefix) s
| otherwise = walk (tail s)
dbGetErrorMessages :: Db a -> IO [String]
dbGetErrorMessages db
= do n <- dbGetNumErrorMessages db
mapM (\idx -> dbGetErrorMessage db (idx1)) [1..n]
raiseDbTypeMismatch :: Db a -> IO b
raiseDbTypeMismatch db
= do dataSource <- dbGetDataSourceName db
raiseDbError (DbError "Type mismatch" dataSource DB_ERR_TYPE_MISMATCH 0 "" )
raiseDbFetchNull :: Db a -> IO b
raiseDbFetchNull db
= do dataSource <- dbGetDataSourceName db
raiseDbError (DbError "Unexpected NULL value" dataSource DB_ERR_FETCH_NULL 0 "")
raiseDbInvalidColumnName :: Db a -> ColumnName -> IO b
raiseDbInvalidColumnName db name
= do dataSource <- dbGetDataSourceName db
raiseDbError (DbError ("Invalid column name/index (" ++ name ++ ")") dataSource DB_ERR_INVALID_COLUMN_NAME 0 "")
raiseDbInvalidTableName :: Db a -> ColumnName -> IO b
raiseDbInvalidTableName db name
= do dataSource <- dbGetDataSourceName db
raiseDbError (DbError ("Invalid table name (" ++ name ++ ")") dataSource DB_ERR_INVALID_TABLE_NAME 0 "")
raiseDbConnect :: DataSourceName -> IO a
raiseDbConnect name
= raiseDbError (DbError ("Unable to establish a connection to the '" ++ name ++ "' database")
name DB_ERR_CONNECT 0 "")
raiseDbError :: DbError -> IO a
raiseDbError err
= ioError (userError (dbErrorPrefix ++ show err))
catchDbError :: IO a -> (DbError -> IO a) -> IO a
catchDbError io handler
= catch io $ \err ->
let errmsg = ioeGetErrorString err
in if (isUserError err && isPrefixOf dbErrorPrefix errmsg)
then handler (read (drop (length dbErrorPrefix) errmsg))
else ioError err
dbErrorPrefix
= "Database error: "
data DbStatus
= DB_FAILURE
| DB_SUCCESS
| DB_ERR_NOT_IN_USE
| DB_ERR_GENERAL_WARNING
| DB_ERR_DISCONNECT_ERROR
| DB_ERR_DATA_TRUNCATED
| DB_ERR_PRIV_NOT_REVOKED
| DB_ERR_INVALID_CONN_STR_ATTR
| DB_ERR_ERROR_IN_ROW
| DB_ERR_OPTION_VALUE_CHANGED
| DB_ERR_NO_ROWS_UPD_OR_DEL
| DB_ERR_MULTI_ROWS_UPD_OR_DEL
| DB_ERR_WRONG_NO_OF_PARAMS
| DB_ERR_DATA_TYPE_ATTR_VIOL
| DB_ERR_UNABLE_TO_CONNECT
| DB_ERR_CONNECTION_IN_USE
| DB_ERR_CONNECTION_NOT_OPEN
| DB_ERR_REJECTED_CONNECTION
| DB_ERR_CONN_FAIL_IN_TRANS
| DB_ERR_COMM_LINK_FAILURE
| DB_ERR_INSERT_VALUE_LIST_MISMATCH
| DB_ERR_DERIVED_TABLE_MISMATCH
| DB_ERR_STRING_RIGHT_TRUNC
| DB_ERR_NUMERIC_VALUE_OUT_OF_RNG
| DB_ERR_ERROR_IN_ASSIGNMENT
| DB_ERR_DATETIME_FLD_OVERFLOW
| DB_ERR_DIVIDE_BY_ZERO
| DB_ERR_STR_DATA_LENGTH_MISMATCH
| DB_ERR_INTEGRITY_CONSTRAINT_VIOL
| DB_ERR_INVALID_CURSOR_STATE
| DB_ERR_INVALID_TRANS_STATE
| DB_ERR_INVALID_AUTH_SPEC
| DB_ERR_INVALID_CURSOR_NAME
| DB_ERR_SYNTAX_ERROR_OR_ACCESS_VIOL
| DB_ERR_DUPLICATE_CURSOR_NAME
| DB_ERR_SERIALIZATION_FAILURE
| DB_ERR_SYNTAX_ERROR_OR_ACCESS_VIOL2
| DB_ERR_OPERATION_ABORTED
| DB_ERR_UNSUPPORTED_FUNCTION
| DB_ERR_NO_DATA_SOURCE
| DB_ERR_DRIVER_LOAD_ERROR
| DB_ERR_SQLALLOCENV_FAILED
| DB_ERR_SQLALLOCCONNECT_FAILED
| DB_ERR_SQLSETCONNECTOPTION_FAILED
| DB_ERR_NO_DATA_SOURCE_DLG_PROHIB
| DB_ERR_DIALOG_FAILED
| DB_ERR_UNABLE_TO_LOAD_TRANSLATION_DLL
| DB_ERR_DATA_SOURCE_NAME_TOO_LONG
| DB_ERR_DRIVER_NAME_TOO_LONG
| DB_ERR_DRIVER_KEYWORD_SYNTAX_ERROR
| DB_ERR_TRACE_FILE_ERROR
| DB_ERR_TABLE_OR_VIEW_ALREADY_EXISTS
| DB_ERR_TABLE_NOT_FOUND
| DB_ERR_INDEX_ALREADY_EXISTS
| DB_ERR_INDEX_NOT_FOUND
| DB_ERR_COLUMN_ALREADY_EXISTS
| DB_ERR_COLUMN_NOT_FOUND
| DB_ERR_NO_DEFAULT_FOR_COLUMN
| DB_ERR_GENERAL_ERROR
| DB_ERR_MEMORY_ALLOCATION_FAILURE
| DB_ERR_INVALID_COLUMN_NUMBER
| DB_ERR_PROGRAM_TYPE_OUT_OF_RANGE
| DB_ERR_SQL_DATA_TYPE_OUT_OF_RANGE
| DB_ERR_OPERATION_CANCELLED
| DB_ERR_INVALID_ARGUMENT_VALUE
| DB_ERR_FUNCTION_SEQUENCE_ERROR
| DB_ERR_OPERATION_INVALID_AT_THIS_TIME
| DB_ERR_INVALID_TRANS_OPERATION_CODE
| DB_ERR_NO_CURSOR_NAME_AVAIL
| DB_ERR_INVALID_STR_OR_BUF_LEN
| DB_ERR_DESCRIPTOR_TYPE_OUT_OF_RANGE
| DB_ERR_OPTION_TYPE_OUT_OF_RANGE
| DB_ERR_INVALID_PARAM_NO
| DB_ERR_INVALID_SCALE_VALUE
| DB_ERR_FUNCTION_TYPE_OUT_OF_RANGE
| DB_ERR_INF_TYPE_OUT_OF_RANGE
| DB_ERR_COLUMN_TYPE_OUT_OF_RANGE
| DB_ERR_SCOPE_TYPE_OUT_OF_RANGE
| DB_ERR_NULLABLE_TYPE_OUT_OF_RANGE
| DB_ERR_UNIQUENESS_OPTION_TYPE_OUT_OF_RANGE
| DB_ERR_ACCURACY_OPTION_TYPE_OUT_OF_RANGE
| DB_ERR_DIRECTION_OPTION_OUT_OF_RANGE
| DB_ERR_INVALID_PRECISION_VALUE
| DB_ERR_INVALID_PARAM_TYPE
| DB_ERR_FETCH_TYPE_OUT_OF_RANGE
| DB_ERR_ROW_VALUE_OUT_OF_RANGE
| DB_ERR_CONCURRENCY_OPTION_OUT_OF_RANGE
| DB_ERR_INVALID_CURSOR_POSITION
| DB_ERR_INVALID_DRIVER_COMPLETION
| DB_ERR_INVALID_BOOKMARK_VALUE
| DB_ERR_DRIVER_NOT_CAPABLE
| DB_ERR_TIMEOUT_EXPIRED
| DB_ERR_FETCH_NULL
| DB_ERR_INVALID_TABLE_NAME
| DB_ERR_INVALID_COLUMN_NAME
| DB_ERR_TYPE_MISMATCH
| DB_ERR_CONNECT
deriving (Read,Show,Eq,Enum)
dbGetDbStatus :: Db a -> IO DbStatus
dbGetDbStatus db
= do i <- dbGetStatus db
if (i < 0 || i >= fromEnum DB_ERR_CONNECT)
then return DB_FAILURE
else return (toEnum i)
data DbType
= DbUnknown
| DbVarChar
| DbInteger
| DbFloat
| DbDate
| DbBlob
deriving (Show,Eq,Enum)
data SqlType
= SqlChar
| SqlNumeric
| SqlDecimal
| SqlInteger
| SqlSmallInt
| SqlFloat
| SqlReal
| SqlDouble
| SqlDate
| SqlTime
| SqlTimeStamp
| SqlVarChar
| SqlBit
| SqlBinary
| SqlVarBinary
| SqlBigInt
| SqlTinyInt
| SqlUnknown Int
deriving (Show,Eq)
instance Enum SqlType where
toEnum i
= case i of
1 -> SqlChar
2 -> SqlNumeric
3 -> SqlDecimal
4 -> SqlInteger
5 -> SqlSmallInt
6 -> SqlFloat
7 -> SqlReal
8 -> SqlDouble
9 -> SqlDate
10 -> SqlTime
11 -> SqlTimeStamp
12 -> SqlVarChar
13 -> SqlBit
14 -> SqlBinary
15 -> SqlVarBinary
16 -> SqlBigInt
17 -> SqlTinyInt
_ -> SqlUnknown i
fromEnum tp
= case tp of
SqlChar -> 1
SqlNumeric -> 2
SqlDecimal -> 3
SqlInteger -> 4
SqlSmallInt -> 5
SqlFloat -> 6
SqlReal -> 7
SqlDouble -> 8
SqlDate -> 9
SqlTime -> 10
SqlTimeStamp -> 11
SqlVarChar -> 12
SqlBit -> 13
SqlBinary -> 14
SqlVarBinary -> 15
SqlBigInt -> 16
SqlTinyInt -> 17
SqlUnknown i -> i
toSqlType :: Int -> SqlType
toSqlType i
= unsafePerformIO $
do tp <- dbSqlTypeToStandardSqlType i
return (toEnum tp)
fromSqlType :: SqlType -> Int
fromSqlType tp
= unsafePerformIO (dbStandardSqlTypeToSqlType (fromEnum tp))
toSqlTableName :: Db a -> TableName -> TableName
toSqlTableName db name
= unsafePerformIO $ dbSQLTableName db name
toSqlColumnName :: Db a -> ColumnName -> ColumnName
toSqlColumnName db name
= unsafePerformIO $ dbSQLColumnName db name
instance Show DbInfo where
show info = unlines (showDbInfo info)
showDbInfo :: DbInfo -> [String]
showDbInfo info
= ["catalog: " ++ dbCatalog info
,"schema : " ++ dbSchema info
,"tables : "
] ++
numbered (map showTableInfo (dbTables info))
instance Show TableInfo where
show info = unlines (showTableInfo info)
showTableInfo :: TableInfo -> [String]
showTableInfo info
= ["name : " ++ tableName info
,"type : " ++ tableType info
,"remarks: " ++ tableRemarks info
,"columns: "
] ++ showColumnInfos (tableColumns info)
instance Show ColumnInfo where
show info = unlines (showColumnInfo info)
showList infos = showString (unlines (showColumnInfos infos))
showColumnInfos infos
= numbered (map showColumnInfo infos)
showColumnInfo info
= ["name : " ++ columnName info
,"index : " ++ show (columnIndex info)
,"type : " ++ columnTypeName info
,"size : " ++ show (columnSize info)
,"sqltp : " ++ show (columnSqlType info)
,"type id: " ++ show (columnType info)
,"digits : " ++ show (columnDecimalDigits info)
,"prec : " ++ show (columnNumPrecRadix info)
,"remarks: " ++ columnRemarks info
,"pkey : " ++ show (columnPrimaryKey info)
,"ptables: " ++ show (columnPrimaryKeyTableNames info)
,"fkey : " ++ show (columnForeignKey info)
,"ftable : " ++ columnForeignKeyTableName info
]
numbered xss
= concat [shift (" " ++ adjust 3 (show i ++ ":")) xs | (i,xs) <- zip [1..] xss]
where
shift prefix []
= []
shift prefix (x:xs)
= [prefix ++ x] ++ map (replicate (length prefix) ' ' ++) xs
adjust :: Int -> String -> String
adjust n s | length s < n = s ++ replicate (n length s) ' '
| otherwise = s