?prevdifflink? - Blame
-----------------------------------------------------------------------------------------
{-| Module : Database.HSQL.MySQL
Copyright : (c) Krasimir Angelov 2003
License : BSD-style
Maintainer : ka2_mail@yahoo.com
Stability : provisional
Portability : portable
The module provides interface to MySQL database
-}
-----------------------------------------------------------------------------------------
module Database.HSQL.MySQL(connect, module Database.HSQL) where
import Database.HSQL
import Database.HSQL.Types
import Data.Dynamic
import Data.Bits
import Data.Char
import Foreign
import Foreign.C
import Control.Monad(when,unless)
import Control.Exception (throwDyn, finally)
import Control.Concurrent.MVar
import System.Time
import System.IO.Unsafe
import Text.ParserCombinators.ReadP
import Text.Read
#include <HsMySQL.h>
type MYSQL = Ptr ()
type MYSQL_RES = Ptr ()
type MYSQL_FIELD = Ptr ()
type MYSQL_ROW = Ptr CString
type MYSQL_LENGTHS = Ptr CULong
#ifdef mingw32_HOST_OS
#let CALLCONV = "stdcall"
#else
#let CALLCONV = "ccall"
#endif
foreign import #{CALLCONV} "HsMySQL.h mysql_init" mysql_init :: MYSQL -> IO MYSQL
foreign import #{CALLCONV} "HsMySQL.h mysql_real_connect" mysql_real_connect :: MYSQL -> CString -> CString -> CString -> CString -> CInt -> CString -> CInt -> IO MYSQL
foreign import #{CALLCONV} "HsMySQL.h mysql_close" mysql_close :: MYSQL -> IO ()
foreign import #{CALLCONV} "HsMySQL.h mysql_errno" mysql_errno :: MYSQL -> IO CInt
foreign import #{CALLCONV} "HsMySQL.h mysql_error" mysql_error :: MYSQL -> IO CString
foreign import #{CALLCONV} "HsMySQL.h mysql_query" mysql_query :: MYSQL -> CString -> IO CInt
foreign import #{CALLCONV} "HsMySQL.h mysql_use_result" mysql_use_result :: MYSQL -> IO MYSQL_RES
foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_field" mysql_fetch_field :: MYSQL_RES -> IO MYSQL_FIELD
foreign import #{CALLCONV} "HsMySQL.h mysql_free_result" mysql_free_result :: MYSQL_RES -> IO ()
foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_row" mysql_fetch_row :: MYSQL_RES -> IO MYSQL_ROW
foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_lengths" mysql_fetch_lengths :: MYSQL_RES -> IO MYSQL_LENGTHS
foreign import #{CALLCONV} "HsMySQL.h mysql_list_tables" mysql_list_tables :: MYSQL -> CString -> IO MYSQL_RES
foreign import #{CALLCONV} "HsMySQL.h mysql_list_fields" mysql_list_fields :: MYSQL -> CString -> CString -> IO MYSQL_RES
foreign import #{CALLCONV} "HsMySQL.h mysql_next_result" mysql_next_result :: MYSQL -> IO CInt
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------
handleSqlError :: MYSQL -> IO a
handleSqlError pMYSQL = do
errno <- mysql_errno pMYSQL
errMsg <- mysql_error pMYSQL >>= peekCString
throwDyn (SqlError "" (fromIntegral errno) errMsg)
-----------------------------------------------------------------------------------------
-- Connect/Disconnect
-----------------------------------------------------------------------------------------
-- | Makes a new connection to the database server.
connect :: String -- ^ Server name
-> String -- ^ Database name
-> String -- ^ User identifier
-> String -- ^ Authentication string (password)
-> IO Connection
connect server database user authentication = do
pMYSQL <- mysql_init nullPtr
pServer <- newCString server
pDatabase <- newCString database
pUser <- newCString user
pAuthentication <- newCString authentication
res <- mysql_real_connect pMYSQL pServer pUser pAuthentication pDatabase 0 nullPtr (#const MYSQL_DEFAULT_CONNECT_FLAGS)
free pServer
free pDatabase
free pUser
free pAuthentication
when (res == nullPtr) (handleSqlError pMYSQL)
refFalse <- newMVar False
let connection = Connection
{ connDisconnect = mysql_close pMYSQL
, connExecute = execute pMYSQL
, connQuery = query connection pMYSQL
, connTables = tables connection pMYSQL
, connDescribe = describe connection pMYSQL
, connBeginTransaction = execute pMYSQL "begin"
, connCommitTransaction = execute pMYSQL "commit"
, connRollbackTransaction = execute pMYSQL "rollback"
, connClosed = refFalse
}
return connection
where
execute :: MYSQL -> String -> IO ()
execute pMYSQL query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
withStatement :: Connection -> MYSQL -> MYSQL_RES -> IO Statement
withStatement conn pMYSQL pRes = do
currRow <- newMVar (nullPtr, nullPtr)
refFalse <- newMVar False
if (pRes == nullPtr)
then do
errno <- mysql_errno pMYSQL
when (errno /= 0) (handleSqlError pMYSQL)
return (Statement
{ stmtConn = conn
, stmtClose = return ()
, stmtFetch = fetch pRes currRow
, stmtGetCol = getColValue currRow
, stmtFields = []
, stmtClosed = refFalse
})
else do
fieldDefs <- getFieldDefs pRes
return (Statement
{ stmtConn = conn
, stmtClose = mysql_free_result pRes
, stmtFetch = fetch pRes currRow
, stmtGetCol = getColValue currRow
, stmtFields = fieldDefs
, stmtClosed = refFalse
})
where
getFieldDefs pRes = do
pField <- mysql_fetch_field pRes
if pField == nullPtr
then return []
else do
name <- (#peek MYSQL_FIELD, name) pField >>= peekCString
dataType <- (#peek MYSQL_FIELD, type) pField
columnSize <- (#peek MYSQL_FIELD, length) pField
flags <- (#peek MYSQL_FIELD, flags) pField
decimalDigits <- (#peek MYSQL_FIELD, decimals) pField
let sqlType = mkSqlType dataType columnSize decimalDigits
defs <- getFieldDefs pRes
return ((name,sqlType,((flags :: Int) .&. (#const NOT_NULL_FLAG)) == 0):defs)
mkSqlType :: Int -> Int -> Int -> SqlType
mkSqlType (#const FIELD_TYPE_STRING) size _ = SqlChar size
mkSqlType (#const FIELD_TYPE_VAR_STRING) size _ = SqlVarChar size
mkSqlType (#const FIELD_TYPE_DECIMAL) size prec = SqlNumeric size prec
mkSqlType (#const FIELD_TYPE_SHORT) _ _ = SqlSmallInt
mkSqlType (#const FIELD_TYPE_INT24) _ _ = SqlMedInt
mkSqlType (#const FIELD_TYPE_LONG) _ _ = SqlInteger
mkSqlType (#const FIELD_TYPE_FLOAT) _ _ = SqlReal
mkSqlType (#const FIELD_TYPE_DOUBLE) _ _ = SqlDouble
mkSqlType (#const FIELD_TYPE_TINY) _ _ = SqlTinyInt
mkSqlType (#const FIELD_TYPE_LONGLONG) _ _ = SqlBigInt
mkSqlType (#const FIELD_TYPE_DATE) _ _ = SqlDate
mkSqlType (#const FIELD_TYPE_TIME) _ _ = SqlTime
mkSqlType (#const FIELD_TYPE_TIMESTAMP) _ _ = SqlTimeStamp
mkSqlType (#const FIELD_TYPE_DATETIME) _ _ = SqlDateTime
mkSqlType (#const FIELD_TYPE_YEAR) _ _ = SqlYear
mkSqlType (#const FIELD_TYPE_BLOB) _ _ = SqlBLOB
mkSqlType (#const FIELD_TYPE_SET) _ _ = SqlSET
mkSqlType (#const FIELD_TYPE_ENUM) _ _ = SqlENUM
mkSqlType tp _ _ = SqlUnknown tp
query :: Connection -> MYSQL -> String -> IO Statement
query conn pMYSQL query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
pRes <- getFirstResult pMYSQL
withStatement conn pMYSQL pRes
where
getFirstResult :: MYSQL -> IO MYSQL_RES
getFirstResult pMYSQL = do
pRes <- mysql_use_result pMYSQL
if pRes == nullPtr
then do
res <- mysql_next_result pMYSQL
if res == 0
then getFirstResult pMYSQL
else return nullPtr
else return pRes
fetch :: MYSQL_RES -> MVar (MYSQL_ROW, MYSQL_LENGTHS) -> IO Bool
fetch pRes currRow
| pRes == nullPtr = return False
| otherwise = modifyMVar currRow $ \(pRow, pLengths) -> do
pRow <- mysql_fetch_row pRes
pLengths <- mysql_fetch_lengths pRes
return ((pRow, pLengths), pRow /= nullPtr)
getColValue :: MVar (MYSQL_ROW, MYSQL_LENGTHS) -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
getColValue currRow colNumber fieldDef f = do
(row, lengths) <- readMVar currRow
pValue <- peekElemOff row colNumber
len <- fmap fromIntegral (peekElemOff lengths colNumber)
f fieldDef pValue len
tables :: Connection -> MYSQL -> IO [String]
tables conn pMYSQL = do
pRes <- mysql_list_tables pMYSQL nullPtr
stmt <- withStatement conn pMYSQL pRes
-- SQLTables returns:
-- Column name # Type
-- Tables_in_xx 0 VARCHAR
collectRows (\stmt -> do
mb_v <- stmtGetCol stmt 0 ("Tables", SqlVarChar 0, False) fromSqlCStringLen
return (case mb_v of { Nothing -> ""; Just a -> a })) stmt
describe :: Connection -> MYSQL -> String -> IO [FieldDef]
describe conn pMYSQL table = do
pRes <- withCString table (\table -> mysql_list_fields pMYSQL table nullPtr)
stmt <- withStatement conn pMYSQL pRes
return (getFieldsTypes stmt)
|