Haskell で PostgreSQL のドライバを書いてみました。C を使わないでも出来ました。
参考にしたところ
- PostgreSQL 文書 / IV. クライアントインタフェース / 第 31章libpq - C ライブラリ
- PostgreSQLで作るLinuxデータベース（3）PostgreSQLをプログラムで操作する
- ファイヤープロジェクト/ PostgreSQL
環境は Windows です。
サーバは UTF8 でDBを作り、クライアントは SJIS
- postgresql.conf : client_encoding のコメントを外し修正。
# client_encoding = sql_ascii # actually, defaults to database
# encoding
client_encoding = 'SJIS' # actually, defaults to database
# encoding
- 確認
>echo "SHOW client_encoding;" |psql test client_encoding ----------------- SJIS (1 行)
- PgDrive.hs
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -- ghc --make PgDrive.hs -o pg -I/D/PostgreSQL/8.4/include -L/D/PostgreSQL/8.4/lib -lpq module Main where import Foreign.Ptr (Ptr) import Foreign.C.String (CString, withCString, peekCString) import Foreign.C.Types (CInt) import Cinnamon.Ucs (ucs4ToSjis, sjisToUcs4) import Data.List (intersperse) data PGconn = PGconn data PGresult = PGresult type PGconObj = (Ptr PGconn) type ResultObj = (Ptr PGresult) #define CONNECTION_OK 0 #define CONNECTION_BAD 1 #define PGRES_COMMAND_OK 1 #define PGRES_TUPLES_OK 2 main = do conn <- connectPgsql "host=localhost user=sirocco password=hogehoge dbname=test" sts <- pgStatus conn if sts then putStrLn "connect OK.\n" else putStr =<< pgErrorMessage conn -- FATAL: database "testt" does not exist -- INSERT let ins = ucs4ToSjis "INSERT INTO test VALUES (nextval('test_id_seq'),2,'ほげ','めも --')" res <- pgExec conn ins rSTS <- resultStatus res PGRES_COMMAND_OK if rSTS then putStrLn "insert OK.\n" else putStr =<< pgErrorMessage conn -- ERROR: syntax error at or near "VALUESS" -- LINE 1: INSERT INTO test VALUESS (nextval('test_id_seq'),2,'ほげ','... c_PQclear res -- SELECT let select = "SELECT * FROM test;" selRes <- pgExec conn select selSTS <- resultStatus selRes PGRES_TUPLES_OK if selSTS then putStrLn "select OK.\n" else putStr =<< pgErrorMessage conn getValueList selRes 0 3 [] >>= putStrLn.concat.intersperse " " -- => 1 1 hoge memo getValueList selRes 1 3 [] >>= putStrLn.concat.intersperse " " -- => 2 1 日本語 めも moemo -- getValueList selRes 2 3 [] >>= putStrLn.concat.intersperse " " -- => 3 2 ほげ めも -- c_PQclear selRes disConnect conn putStrLn "done." getValueList :: ResultObj -> CInt -> CInt -> [String] -> IO [String] getValueList res row 0 acc = pgGetValue res row 0 >>= \v -> return (v:acc) getValueList res row col acc = pgGetValue res row col >>= \v -> getValueList res row (col-1) (v:acc) -- 接続 connectPgsql :: String -> IO PGconObj connectPgsql con = withCString con c_PQconnectdb -- 接続結果 pgStatus :: PGconObj -> IO Bool pgStatus pgObj = c_PQstatus pgObj >>= return.(CONNECTION_OK ==) pgErrorMessage :: PGconObj -> IO String pgErrorMessage pgObj = c_PQerrorMessage pgObj >>= peekCString pgExec :: PGconObj -> String -> IO ResultObj pgExec pgObj sql = withCString sql (c_PQexec pgObj) -- pgExec 結果 resultStatus :: ResultObj -> CInt -> IO Bool resultStatus result ok = c_PQresultStatus result >>= return.(ok ==) pgGetValue result row column = c_PQgetvalue result row column >>= peekCString -- 切断 disConnect :: PGconObj -> IO () disConnect pgObj = c_PQfinish pgObj -- PostgreSQL のライブラリを呼ぶための定義 foreign import ccall unsafe "libpq-fe.h PQconnectdb" c_PQconnectdb :: CString -> IO PGconObj foreign import ccall unsafe "libpq-fe.h PQstatus" c_PQstatus :: PGconObj -> IO CInt foreign import ccall unsafe "libpq-fe.h PQerrorMessage" c_PQerrorMessage :: PGconObj -> IO CString foreign import ccall unsafe "libpq-fe.h PQexec" c_PQexec :: PGconObj -> CString -> IO ResultObj foreign import ccall unsafe "libpq-fe.h PQresultStatus" c_PQresultStatus :: ResultObj -> IO CInt foreign import ccall unsafe "libpq-fe.h PQgetvalue" c_PQgetvalue :: ResultObj -> CInt -> CInt -> IO CString foreign import ccall unsafe "libpq-fe.h PQclear" c_PQclear :: ResultObj -> IO () foreign import ccall unsafe "libpq-fe.h PQfinish" c_PQfinish :: PGconObj -> IO ()
