■ [Haskell] HSQLを使ってMySQLに接続

HSQL-1.7を使ってMySQL 5.0.24に接続してみるテスト。

module Main where

import IO
import qualified Database.HSQL as DB
import qualified Database.HSQL.MySQL as MySQL

host     = "localhost"
db       = "test"
user     = "root"
password = "password"

main :: IO ()
main = process `DB.catchSql` print
    where
        process = bracket (MySQL.connect host db user password) DB.disconnect proc
        proc conn = do init conn
                       q conn
        init conn = DB.execute conn "set names utf8"
        q conn = bracket (DB.query conn "select * from test")
                         DB.closeStatement
                         (DB.forEachRow' p)
        p stmt = mapM_ (printColumn stmt) $ first $ unzip3 $ DB.getFieldsTypes stmt
         where
             first (x, _, _) = x
             printColumn stmt name = do v <- DB.getFieldValue stmt name
                                        putStrLn $ v ++ " (" ++ (show $ length v) ++ ")"

/etc/my.cnfを読まないので、日本語を使うためにはSET NAMESで文字コードを指定する必要があります。

/etc/my.cnfを読み込むようにするパッチはこれ。

diff -ur HSQL.orig/MySQL/Database/HSQL/MySQL.hsc HSQL/MySQL/Database/HSQL/MySQL.hsc
--- HSQL.orig/MySQL/Database/HSQL/MySQL.hsc	2005-12-12 16:27:28.000000000 -0500
+++ HSQL/MySQL/Database/HSQL/MySQL.hsc	2006-08-16 10:26:03.000000000 -0400
@@ -43,6 +43,7 @@
 #endif

 foreign import #{CALLCONV} "HsMySQL.h mysql_init" mysql_init :: MYSQL -> IO MYSQL
+foreign import #{CALLCONV} "HsMySQL.h mysql_options" mysql_options :: MYSQL -> CInt -> CString -> IO CInt
 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
@@ -81,6 +82,7 @@
         -> IO Connection
 connect server database user authentication = do
 	pMYSQL <- mysql_init nullPtr
+	withCString "hsql" $ mysql_options pMYSQL (#const MYSQL_READ_DEFAULT_GROUP)
 	pServer <- newCString server
 	pDatabase <- newCString database
 	pUser <- newCString user