[htoolkit-cvs] HSQL/MSI/Database/HSQL MSI.hsc,NONE,1.1

[<kr_...@us...>]

Update of /cvsroot/htoolkit/HSQL/MSI/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23805/MSI/Database/HSQL

Added Files:
	MSI.hsc 
Log Message:
Added MSI driver


--- NEW FILE: MSI.hsc ---
{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------------------
{-| Module      :  Database.HSQL.MSI
    Copyright   :  (c) Krasimir Angelov 2005
    License     :  BSD-style

    Maintainer  :  kr....@gm...
    Stability   :  provisional
    Portability :  portable

    The module provides interface to Microsoft Installer Database
-}
-----------------------------------------------------------------------------------------

module Database.HSQL.MSI(connect, module Database.HSQL) where

import Control.Concurrent.MVar
import Control.Exception (throwDyn)
import Control.Monad
import Data.Char (isUpper, toLower)
import Data.IORef
import Data.Word
import Foreign
import Foreign.C
import Database.HSQL
import Database.HSQL.Types

#include <windows.h>

type MSIHANDLE = CInt

connect :: String -> String -> IO Connection
connect source dest =
  withCString source $ \csource ->
  withCString dest   $ \cdest   ->
  alloca             $ \phandle -> do
    msiOpenDatabase csource cdest phandle >>= checkResult 0
    hDatabase <- peek phandle
    refFalse <- newMVar False
    let connection = (Connection
    			{ connDisconnect = disconnect hDatabase
    			, connExecute    = execute hDatabase
    			, connQuery      = query connection hDatabase
    			, connTables     = tables connection hDatabase
    			, connDescribe   = describe connection hDatabase
    			, connBeginTransaction = beginTransaction hDatabase
    			, connCommitTransaction = commitTransaction hDatabase
    			, connRollbackTransaction = rollbackTransaction hDatabase
    			, connClosed     = refFalse
    			})
    return connection
  where
    disconnect :: MSIHANDLE -> IO ()
    disconnect hDatabase = do
      msiDatabaseCommit hDatabase >>= checkResult hDatabase
      msiCloseHandle hDatabase >>= checkResult hDatabase

    execute :: MSIHANDLE -> String -> IO ()
    execute hDatabase query =
      withCString query $ \cquery  ->
      alloca            $ \phandle -> do
        msiDatabaseOpenView hDatabase cquery phandle >>= checkResult hDatabase
        hView <- peek phandle
        msiViewExecute hView 0 >>= checkResult hDatabase
        msiCloseHandle hView >>= checkResult hDatabase

    query :: Connection -> MSIHANDLE -> String -> IO Statement
    query connection hDatabase query =
      withCString query $ \cquery  ->
      alloca            $ \phandle -> do
        msiDatabaseOpenView hDatabase cquery phandle >>= checkResult hDatabase
        hView <- peek phandle
        msiViewExecute hView 0 >>= checkResult hDatabase
        fields <- getFields hView
        refFalse <- newMVar False
        refRecord <- newIORef 0
        let statement = Statement
       			    { stmtConn   = connection
    			    , stmtClose  = closeStatement hView refRecord
    			    , stmtFetch  = fetch hView refRecord
    			    , stmtGetCol = getColValue refRecord
    			    , stmtFields = fields
    			    , stmtClosed = refFalse
    			    }
        return statement
      where
        getFields hView = 
          alloca $ \phNamesRecord ->
          alloca $ \phTypesRecord -> do
            msiViewGetColumnInfo hView 0 phNamesRecord >>= checkResult hView
            msiViewGetColumnInfo hView 1 phTypesRecord >>= checkResult hView
            hNamesRecord <- peek phNamesRecord
            hTypesRecord <- peek phTypesRecord
            count <- msiRecordGetFieldCount hNamesRecord
            loop 1 count hNamesRecord hTypesRecord

        loop n count hNamesRecord hTypesRecord
          | n > count = return []
          | otherwise = 
              allocaBytes 1024 $ \buffer ->
              alloca           $ \plen -> do
                poke plen 1024
                msiRecordGetString hNamesRecord n buffer plen >>= checkResult hNamesRecord
                name <- peekCString buffer
                poke plen 1024
                msiRecordGetString hTypesRecord n buffer plen >>= checkResult hTypesRecord
                typ <- peekCString buffer
                fieldDefs <- loop (n+1) count hNamesRecord hTypesRecord
                return (mkFieldDef name typ : fieldDefs)
        
        mkFieldDef name (c:cs) = (name, sqlType, isUpper c)
          where
            width   = read cs
            sqlType = case toLower c of
                        's' -> case width of
                                 0 -> SqlText
                                 n -> SqlVarChar n
                        'l' -> case width of
			         0 -> SqlText
                                 n -> SqlVarChar n
                        'i' -> case width of
                                 2 -> SqlInteger
                                 4 -> SqlBigInt
                        'v' -> case width of
			         0 -> SqlBLOB

    tables :: Connection -> MSIHANDLE -> IO [String]
    tables connection hDatabase = undefined

    describe :: Connection -> MSIHANDLE -> String -> IO [FieldDef]
    describe connection hDatabase tableName = undefined
    
    beginTransaction hDatabase = throwDyn SqlUnsupportedOperation
    commitTransaction hDatabase = throwDyn SqlUnsupportedOperation
    rollbackTransaction hDatabase = throwDyn SqlUnsupportedOperation
    
    fetch :: MSIHANDLE -> IORef MSIHANDLE -> IO Bool
    fetch hView refRecord = do
      hRecord <- readIORef refRecord
      unless (hRecord == 0) $
        (msiCloseHandle hRecord >>= checkResult hRecord)
      alloca $ \phRecord -> do
        res <- msiViewFetch hView phRecord
        if res == 259
          then do writeIORef refRecord 0
                  return False
          else do checkResult hView res
                  hRecord <- peek phRecord
                  writeIORef refRecord hRecord
                  return True

    getColValue :: IORef MSIHANDLE -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
    getColValue refRecord colNumber (name,sqlType,nullable) f =
      allocaBytes 1024 $ \buffer ->
      alloca           $ \plen -> do
        poke plen 1024
        hRecord <- readIORef refRecord
        msiRecordGetString hRecord (fromIntegral colNumber+1) buffer plen >>= checkResult hRecord
        len <- peek plen
        f sqlType buffer (fromIntegral len)

    closeStatement :: MSIHANDLE -> IORef MSIHANDLE -> IO ()
    closeStatement hView refRecord = do
      msiCloseHandle hView >>= checkResult 0
      hRecord <- readIORef refRecord
      unless (hRecord == 0) $
        (msiCloseHandle hRecord >>= checkResult 0)

foreign import stdcall "MsiOpenDatabaseA" msiOpenDatabase :: CString -> CString -> Ptr MSIHANDLE -> IO Word32
foreign import stdcall "MsiDatabaseCommit" msiDatabaseCommit :: MSIHANDLE -> IO Word32
foreign import stdcall "MsiCloseHandle"  msiCloseHandle :: MSIHANDLE -> IO Word32
foreign import stdcall "MsiDatabaseOpenViewA" msiDatabaseOpenView :: MSIHANDLE -> CString -> Ptr MSIHANDLE -> IO Word32
foreign import stdcall "MsiViewExecute" msiViewExecute :: MSIHANDLE -> MSIHANDLE -> IO Word32
foreign import stdcall "MsiGetLastErrorRecord" msiGetLastErrorRecord :: IO MSIHANDLE
foreign import stdcall "MsiFormatRecordA" msiFormatRecord :: MSIHANDLE -> MSIHANDLE -> CString -> Ptr CInt -> IO Word32
foreign import stdcall "MsiViewGetColumnInfo" msiViewGetColumnInfo :: MSIHANDLE -> CInt -> Ptr MSIHANDLE -> IO Word32
foreign import stdcall "MsiRecordGetFieldCount" msiRecordGetFieldCount :: MSIHANDLE -> IO Word32
foreign import stdcall "MsiRecordGetStringA" msiRecordGetString :: MSIHANDLE -> Word32 -> CString -> Ptr Word32 -> IO Word32
foreign import stdcall "MsiViewFetch" msiViewFetch :: MSIHANDLE -> Ptr MSIHANDLE -> IO Word32
foreign import stdcall "FormatMessageA" formatMessage :: Word32 -> Ptr () -> Word32 -> Word32 -> CString -> Word32 -> Ptr () -> IO Word32

checkResult :: MSIHANDLE -> Word32 -> IO ()
checkResult hDatabase err
  | err == 0  = return ()
  | otherwise = do
      hRecord <- msiGetLastErrorRecord
      msg <- allocaBytes 1024 $ \cmsg -> do
                formatMessage (#const FORMAT_MESSAGE_FROM_SYSTEM) nullPtr err 0 cmsg 1024 nullPtr
                peekCString cmsg
      msiCloseHandle hRecord
      throwDyn (SqlError "" (fromIntegral err) msg)