Haskell で MS-Access、SQL server のテーブルを読む

接続文字列
    # http://oshiete1.goo.ne.jp/qa5196452.html
    # SQL Serverの場合、一般的に使われているのが、
    #・Microsoft OLE DB Provider for ODBC(MSDASQL)
    #・Microsoft OLE DB Provider for SQL Server(SQLOLEDB) 〜最も一般的
    #・Microsoft SQL Server Native Client(SQLNCLI)        〜SQL Server 2005対応
    #・Microsoft SQL Server Native Client 10.0(SQLNCLI10) 〜SQL Server 2008対応
    # SQLNCLI.1
    # SQLOLEDB.1

import System.Win32.Com 
import System.Win32.Com.Automation 

sqlconn = "Provider=SQLOLEDB.1;Password=passwd;User ID=userName;Initial Catalog=DBname;Data Source=tcp:192.168.1.123,1433"

mdbconn = "DRIVER={Microsoft Access Driver (*.mdb)};Dbq=C:\\Users\\uname\\Documents\\hoge.mdb ;Pwd=password"

createConnection :: String -> IO (IDispatch a) 
createConnection dsn = do 
  c <- createObject "ADODB.Connection" 
  openConnection dsn c 
  return c 
    where
      openConnection :: String -> IDispatch a -> IO () 
      openConnection dsn = method0 "Open" [inString dsn] 

adOpenStatic     = inInt 3
adLockOptimistic = inInt 3
adCmdText        = inInt 1  

createRecordset :: (Variant a1) => a1 -> String -> IO (IDispatch a)
createRecordset cn sql = do 
  rs <- createObject "ADODB.Recordset" 
  openRecordset cn sql rs
  return rs 

-- http://msdn.microsoft.com/ja-jp/library/cc364218(v=MSDN.10).aspx
openRecordset :: (Variant a) => a -> String -> IDispatch i -> IO ()
openRecordset cn sql =
    method0 "Open" [inString sql, inVariant cn, adOpenStatic, 
                    adLockOptimistic, adCmdText]

closeObject :: IDispatch a -> IO () 
closeObject =  method0 "Close" [] 

fields :: IDispatch i -> IO (IDispatch a) 
fields = propertyGet_0 "Fields" 

moveFirst :: IDispatch i -> IO () 
moveFirst = method_0_0 "MoveFirst" 

moveNext :: IDispatch i -> IO () 
moveNext = method_0_0 "MoveNext" 

eofORbof :: IDispatch i -> IO Bool
eofORbof rs = do
    eof <- propertyGet_0 "EOF" rs
    bof <- propertyGet_0 "BOF" rs
    return (eof || bof)

items :: IDispatch i -> [String] -> Int -> IO [String]
items fls xs 0 = do
  x <- function1 "Item" [inInt 0] outString fls
  return (x:xs)

items fls xs n = do
  x <- function1 "Item" [inInt n] outString fls
  items fls (x:xs) (n-1)

readLine :: IDispatch d -> [String] -> Int -> IO [String]
readLine rs xs n = do
    fls <- propertyGet_0 "Fields" rs
    items fls xs n

fieldsCount :: (Variant b) => IDispatch d -> IO b
fieldsCount rs = do 
    field <- propertyGet_0 "Fields" rs
    propertyGet_0 "Count" field

allLines :: IDispatch i -> [[String]] -> Int -> IO [[String]]
allLines rs xs len = do
    eb <- eofORbof rs 
    if eb then return xs
          else do line <- readLine rs [] len
                  e <- eofORbof rs
                  if e then return (line:xs)
                       else do moveNext rs
                               allLines rs (line:xs) len

dbRead :: String -> String -> IO [[String]]
dbRead constr sqlstr = coRun $ do
    con <- createConnection constr
    rs  <- execute con sqlstr
    cnt <- fieldsCount rs
    all <- allLines rs [] (cnt-1)
    closeObject rs
    closeObject con
    return $reverse all
    where
        execute :: IDispatch i -> String -> IO (IDispatch a) 
        execute connection sqlStatement = 
                function_1_1 "Execute" sqlStatement connection 

rsRead constr sqlstr = coRun $ do
    con <- createConnection constr
    rs  <- createRecordset con sqlstr
    cnt <- fieldsCount rs
    all <- allLines rs [] (cnt-1)
    closeObject rs
    closeObject con
    return $reverse all

*Main> dbRead  mdbconn "SELECT count(*) FROM  table"
[["100"]]

*Main> dbRead  sqlconn "SELECT count(*) FROM  table"
[["201"]]

*Main> dbRead  mdbconn "SELECT * FROM table"
[["0","0","","99"],["0","0","","98"],["0","0","","97"]・・・