hsql-mysql (empty) → 1.7
raw patch · 4 files changed
+354/−0 lines, 4 filesdep +basedep +hsqlbuild-type:Customsetup-changed
Dependencies added: base, hsql
Files
- Database/HSQL/HsMySQL.h +16/−0
- Database/HSQL/MySQL.hsc +223/−0
- Setup.lhs +104/−0
- hsql-mysql.cabal +11/−0
+ Database/HSQL/HsMySQL.h view
@@ -0,0 +1,16 @@+#ifndef HsMySQL+#define HsMySQL++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif++#include <mysql.h>++#ifdef CLIENT_MULTI_STATEMENTS+#define MYSQL_DEFAULT_CONNECT_FLAGS CLIENT_MULTI_STATEMENTS+#else+#define MYSQL_DEFAULT_CONNECT_FLAGS 0+#endif++#endif
+ Database/HSQL/MySQL.hsc view
@@ -0,0 +1,223 @@+-----------------------------------------------------------------------------------------+{-| 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)
+ Setup.lhs view
@@ -0,0 +1,104 @@+#!/usr/bin/runghc++\begin{code}+import Data.Maybe(fromMaybe)+import Distribution.PackageDescription+import Distribution.Setup+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils(rawSystemVerbose)+import System.Info+import System.Exit+import System.Directory+import System.Process(runInteractiveProcess, waitForProcess)+import System.IO(hClose, hGetContents, hPutStr, stderr)+import Control.Monad(when)+import Control.Exception(try)++main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf}+ where+ preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo+ preConf args flags = do+ try (removeFile "MySQL.buildinfo")+ return emptyHookedBuildInfo+ postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode+ postConf args flags _ localbuildinfo = do+ mb_bi <- mysqlConfigBuildInfo (configVerbose flags)+ let default_binfo | os == "mingw32" = emptyBuildInfo{extraLibs=["libmySQL"], ccOptions=["-Dmingw32_HOST_OS"]}+ | otherwise = emptyBuildInfo{extraLibs=["mysqlclient"]}+ writeHookedBuildInfo "MySQL.buildinfo" (Just (fromMaybe default_binfo mb_bi),[])+ return ExitSuccess+\end{code}++The following code is derived from Distribution.Simple.Configure+\begin{code}+findProgram+ :: String -- ^ program name+ -> Maybe FilePath -- ^ optional explicit path+ -> IO (Maybe FilePath)+findProgram name Nothing = do+ mb_path <- findExecutable name+ case mb_path of+ Nothing -> message ("No " ++ name ++ " found")+ Just path -> message ("Using " ++ name ++ ": " ++ path)+ return mb_path+findProgram name (Just path) = do+ message ("Using " ++ name ++ ": " ++ path)+ return (Just path)++rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String+rawSystemGrabOutput verbose path args = do+ when (verbose > 0) $+ putStrLn (path ++ concatMap (' ':) args)+ (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing+ exitCode <- waitForProcess pid+ if exitCode /= ExitSuccess+ then do errMsg <- hGetContents err+ hPutStr stderr errMsg+ exitWith exitCode+ else return ()+ hClose inp+ hClose err+ hGetContents out++message :: String -> IO ()+message s = putStrLn $ "configure: " ++ s+\end{code}++Populate BuildInfo using pkg-config tool.+\begin{code}+mysqlConfigBuildInfo :: Int -> IO (Maybe BuildInfo)+mysqlConfigBuildInfo verbose = do+ mb_mysql_config_path <- findProgram "mysql_config" Nothing+ case mb_mysql_config_path of+ Just mysql_config_path -> do+ message ("configuring mysqlclient library") + res <- rawSystemGrabOutput verbose mysql_config_path ["--libs"]+ let (lib_dirs,libs,ld_opts) = splitLibsFlags (words res)+ res <- rawSystemGrabOutput verbose mysql_config_path ["--include"]+ let (inc_dirs,cc_opts) = splitCFlags (words res)+ let bi = emptyBuildInfo{extraLibDirs=lib_dirs, extraLibs=libs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}+ return (Just bi)+ Nothing -> do+ message ("The package will be built using default settings for mysqlclient library")+ return Nothing+ where+ splitLibsFlags [] = ([],[],[])+ splitLibsFlags (arg:args) =+ case arg of+ ('-':'L':lib_dir) -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args+ in (lib_dir:lib_dirs,libs,ld_opts)+ ('-':'l':lib) -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args+ in (lib_dirs,lib:libs,ld_opts)+ ld_opt -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args+ in (lib_dirs,libs,ld_opt:ld_opts)++ splitCFlags [] = ([],[])+ splitCFlags (arg:args) =+ case arg of+ ('-':'I':inc_dir) -> let (inc_dirs,c_opts) = splitCFlags args+ in (inc_dir:inc_dirs,c_opts)+ c_opt -> let (inc_dirs,c_opts) = splitCFlags args+ in (inc_dirs,c_opt:c_opts)++\end{code}
+ hsql-mysql.cabal view
@@ -0,0 +1,11 @@+name: hsql-mysql+version: 1.7+license: BSD3+author: Krasimir Angelov <kr.angelov@gmail.com>+category: Database+description: MySQL driver for HSQL.+exposed-modules: Database.HSQL.MySQL+build-depends: base, hsql+extensions: ForeignFunctionInterface, CPP+cc-options: -IDatabase/HSQL+extra-source-files: Database/HSQL/HsMySQL.h