diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,2 +1,4 @@ +2010-1-29 + 1.8.1: uses updated exception handling of hsql-1.8.1; refactorings 2009-9-6 1.7.1: Fix to make it run on GHC 6.10. diff --git a/DB/HSQL/SQLite3/Functions.hsc b/DB/HSQL/SQLite3/Functions.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/SQLite3/Functions.hsc @@ -0,0 +1,46 @@ +module DB.HSQL.SQLite3.Functions where + +import Foreign(Ptr,FunPtr) +import Foreign.C(CString,CInt) + +#include +#include + +type SQLite3 = Ptr () + +foreign import ccall + sqlite3_open :: CString -> (Ptr SQLite3) -> IO Int + +foreign import ccall + sqlite3_errmsg :: SQLite3 -> IO CString + +foreign import ccall + sqlite3_close :: SQLite3 -> IO () + +foreign import ccall + sqlite3_exec :: SQLite3 -> CString -> FunPtr () -> Ptr () -> Ptr CString -> IO CInt + +foreign import ccall + sqlite3_get_table :: SQLite3 -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CInt -> Ptr CString -> IO CInt + +foreign import ccall + sqlite3_free_table :: Ptr CString -> IO () + +foreign import ccall + sqlite3_free :: CString -> IO () + +-- | +foreign import ccall "strlen" + strlen :: CString -> IO CInt + +-- | +sqliteOk:: Int +sqliteOk = #const SQLITE_OK + +oRdOnly = #const O_RDONLY + +oWrOnly = #const O_WRONLY + +oRdWr = #const O_RDWR + +oAppend = #const O_APPEND diff --git a/Database/HSQL/SQLite3.hs b/Database/HSQL/SQLite3.hs new file mode 100644 --- /dev/null +++ b/Database/HSQL/SQLite3.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| Module : Database.HSQL.SQLite3 + Copyright : (c) Krasimir Angelov 2005 + License : BSD-style + + Maintainer : kr.angelov@gmail.com + Stability : provisional + Portability : portable + + The module provides interface to SQLite3 +-} +module Database.HSQL.SQLite3(connect + ,module Database.HSQL) where + +import Foreign(Ptr,alloca,peek,nullPtr,peekElemOff,nullFunPtr) +import Foreign.C(CString,CInt,peekCString,withCString) +import System.IO(IOMode(..)) +import Control.Monad(when) +import Control.Exception(throw) +import Control.Concurrent.MVar(newMVar,modifyMVar,readMVar) + +import Database.HSQL +import Database.HSQL.Types(Connection(..),Statement(..)) + +import DB.HSQL.SQLite3.Functions + +------------------------------------------------------------------------------ +-- Connect +------------------------------------------------------------------------------ +-- | +connect :: FilePath -> IOMode -> IO Connection +connect fpath mode = + alloca $ \psqlite -> + withCString fpath $ \pFPath -> do + res <- sqlite3_open pFPath psqlite + sqlite <- peek psqlite + when (res /= sqliteOk) $ do + pMsg <- sqlite3_errmsg sqlite + msg <- peekCString pMsg + throw SqlError { seState = "C" + , seNativeError = 0 + , seErrorMsg = msg } + refFalse <- newMVar False + let connection + = Connection { connDisconnect = sqlite3_close sqlite + , connClosed = refFalse + , connExecute = sqlite3Execute sqlite + , connQuery = sqlite3Query connection sqlite + , connTables = sqlite3Tables connection sqlite + , connDescribe = + sqlite3Describe connection sqlite + , connBeginTransaction = + sqlite3Execute sqlite "BEGIN TRANSACTION" + , connCommitTransaction = + sqlite3Execute sqlite "COMMIT TRANSACTION" + , connRollbackTransaction = + sqlite3Execute sqlite "ROLLBACK TRANSACTION" } + return connection + where oflags1 = case mode of + ReadMode -> oRdOnly + WriteMode -> oWrOnly + ReadWriteMode -> oRdWr + AppendMode -> oAppend + +-- | +sqlite3Tables :: Connection -> SQLite3 -> IO [String] +sqlite3Tables connection sqlite = do + stmt <- sqlite3Query connection sqlite "SELECT tbl_name FROM sqlite_master" + collectRows (\stmt -> getFieldValue stmt "tbl_name") stmt + +-- | +sqlite3Describe :: Connection -> SQLite3 -> String -> IO [FieldDef] +sqlite3Describe connection sqlite table = do + stmt <- sqlite3Query connection sqlite ("pragma table_info("++table++")") + collectRows getRow stmt + +-- | +sqlite3Query :: Connection -> SQLite3 -> String -> IO Statement +sqlite3Query connection sqlite query = do + withCString query $ \pQuery -> do + alloca $ \ppResult -> do + alloca $ \pnRow -> do + alloca $ \pnColumn -> do + alloca $ \ppMsg -> do + res <- sqlite3_get_table sqlite pQuery ppResult pnRow pnColumn ppMsg + handleSqlResult res ppMsg + pResult <- peek ppResult + rows <- fmap fromIntegral (peek pnRow) + columns <- fmap fromIntegral (peek pnColumn) + defs <- getFieldDefs pResult 0 columns + refFalse <- newMVar False + refIndex <- newMVar 0 + return Statement { stmtConn = connection + , stmtClose = sqlite3_free_table pResult + , stmtFetch = sqlite3Fetch refIndex rows + , stmtGetCol = getColValue pResult refIndex columns rows + , stmtFields = defs + , stmtClosed = refFalse } + +-- | +getRow stmt = do + name <- getFieldValue stmt "name" + notnull <- getFieldValue stmt "notnull" + return (name, SqlText, notnull=="0") + +-- | +getFieldDefs :: Ptr CString -> Int -> Int -> IO [FieldDef] +getFieldDefs pResult index count + | index >= count = return [] + | otherwise = do + name <- peekElemOff pResult index >>= peekCString + defs <- getFieldDefs pResult (index+1) count + return ((name,SqlText,True):defs) + +-- | +sqlite3Fetch tupleIndex countTuples = + modifyMVar tupleIndex + (\index -> return (index+1,index < countTuples)) + +-- | +getColValue pResult refIndex columns rows colNumber fieldDef f = do + index <- readMVar refIndex + when (index > rows) (throw SqlNoData) + pStr <- peekElemOff pResult (columns*index+colNumber) + if pStr == nullPtr + then f fieldDef pStr 0 + else do strLen <- strlen pStr + f fieldDef pStr (fromIntegral strLen) + +-- | +sqlite3Execute :: SQLite3 -> String -> IO () +sqlite3Execute sqlite query = + withCString query $ \pQuery -> do + alloca $ \ppMsg -> do + res <- sqlite3_exec sqlite pQuery nullFunPtr nullPtr ppMsg + handleSqlResult res ppMsg + + +------------------------------------------------------------------------------ +-- routines for handling exceptions +------------------------------------------------------------------------------ +-- | +handleSqlResult :: CInt -> Ptr CString -> IO () +handleSqlResult res ppMsg + | fromIntegral res == sqliteOk = return () + | otherwise = do + pMsg <- peek ppMsg + msg <- peekCString pMsg + sqlite3_free pMsg + throw (SqlError "E" (fromIntegral res) msg) diff --git a/Database/HSQL/SQLite3.hsc b/Database/HSQL/SQLite3.hsc deleted file mode 100644 --- a/Database/HSQL/SQLite3.hsc +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------- -{-| Module : Database.HSQL.SQLite3 - Copyright : (c) Krasimir Angelov 2005 - License : BSD-style - - Maintainer : kr.angelov@gmail.com - Stability : provisional - Portability : portable - - The module provides interface to SQLite3 --} ------------------------------------------------------------------------------- -module Database.HSQL.SQLite3(connect - ,module Database.HSQL) where - -import Database.HSQL -import Database.HSQL.Types -import Foreign -import Foreign.C -import System.IO -import Control.Monad(when) -import Control.OldException(throwDyn) -import Control.Concurrent.MVar - -#include -#include - -type SQLite3 = Ptr () - -foreign import ccall sqlite3_open :: CString -> (Ptr SQLite3) -> IO Int -foreign import ccall sqlite3_errmsg :: SQLite3 -> IO CString -foreign import ccall sqlite3_close :: SQLite3 -> IO () -foreign import ccall sqlite3_exec :: SQLite3 -> CString -> FunPtr () -> Ptr () -> Ptr CString -> IO CInt -foreign import ccall sqlite3_get_table :: SQLite3 -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CInt -> Ptr CString -> IO CInt -foreign import ccall sqlite3_free_table :: Ptr CString -> IO () -foreign import ccall sqlite3_free :: CString -> IO () - -foreign import ccall "strlen" strlen :: CString -> IO CInt - ------------------------------------------------------------------------------- --- routines for handling exceptions ------------------------------------------------------------------------------- - -handleSqlResult :: CInt -> Ptr CString -> IO () -handleSqlResult res ppMsg - | res == (#const SQLITE_OK) = return () - | otherwise = do - pMsg <- peek ppMsg - msg <- peekCString pMsg - sqlite3_free pMsg - throwDyn (SqlError "E" (fromIntegral res) msg) - ------------------------------------------------------------------------------- --- Connect ------------------------------------------------------------------------------- - -connect :: FilePath -> IOMode -> IO Connection -connect fpath mode = - alloca $ \psqlite -> - withCString fpath $ \pFPath -> do - res <- sqlite3_open pFPath psqlite - sqlite <- peek psqlite - when (res /= (#const SQLITE_OK)) $ do - pMsg <- sqlite3_errmsg sqlite - msg <- peekCString pMsg - throwDyn (SqlError - { seState = "C" - , seNativeError = 0 - , seErrorMsg = msg - }) - refFalse <- newMVar False - let connection = Connection - { connDisconnect = sqlite3_close sqlite - , connClosed = refFalse - , connExecute = execute sqlite - , connQuery = query connection sqlite - , connTables = tables connection sqlite - , connDescribe = describe connection sqlite - , connBeginTransaction = execute sqlite "BEGIN TRANSACTION" - , connCommitTransaction = execute sqlite "COMMIT TRANSACTION" - , connRollbackTransaction = execute sqlite "ROLLBACK TRANSACTION" - } - return connection - where - oflags1 = case mode of - ReadMode -> (#const O_RDONLY) - WriteMode -> (#const O_WRONLY) - ReadWriteMode -> (#const O_RDWR) - AppendMode -> (#const O_APPEND) - - execute :: SQLite3 -> String -> IO () - execute sqlite query = - withCString query $ \pQuery -> do - alloca $ \ppMsg -> do - res <- sqlite3_exec sqlite pQuery nullFunPtr nullPtr ppMsg - handleSqlResult res ppMsg - - query :: Connection -> SQLite3 -> String -> IO Statement - query connection sqlite query = do - withCString query $ \pQuery -> do - alloca $ \ppResult -> do - alloca $ \pnRow -> do - alloca $ \pnColumn -> do - alloca $ \ppMsg -> do - res <- sqlite3_get_table sqlite pQuery ppResult pnRow pnColumn ppMsg - handleSqlResult res ppMsg - pResult <- peek ppResult - rows <- fmap fromIntegral (peek pnRow) - columns <- fmap fromIntegral (peek pnColumn) - defs <- getFieldDefs pResult 0 columns - refFalse <- newMVar False - refIndex <- newMVar 0 - return (Statement - { stmtConn = connection - , stmtClose = sqlite3_free_table pResult - , stmtFetch = fetch refIndex rows - , stmtGetCol = getColValue pResult refIndex columns rows - , stmtFields = defs - , stmtClosed = refFalse - }) - where - getFieldDefs :: Ptr CString -> Int -> Int -> IO [FieldDef] - getFieldDefs pResult index count - | index >= count = return [] - | otherwise = do - name <- peekElemOff pResult index >>= peekCString - defs <- getFieldDefs pResult (index+1) count - return ((name,SqlText,True):defs) - - tables :: Connection -> SQLite3 -> IO [String] - tables connection sqlite = do - stmt <- query connection sqlite "select tbl_name from sqlite_master" - collectRows (\stmt -> getFieldValue stmt "tbl_name") stmt - - describe :: Connection -> SQLite3 -> String -> IO [FieldDef] - describe connection sqlite table = do - stmt <- query connection sqlite ("pragma table_info("++table++")") - collectRows getRow stmt - where - getRow stmt = do - name <- getFieldValue stmt "name" - notnull <- getFieldValue stmt "notnull" - return (name, SqlText, notnull=="0") - - fetch tupleIndex countTuples = - modifyMVar tupleIndex (\index -> return (index+1,index < countTuples)) - - getColValue pResult refIndex columns rows colNumber fieldDef f = do - index <- readMVar refIndex - when (index > rows) (throwDyn SqlNoData) - pStr <- peekElemOff pResult (columns*index+colNumber) - if pStr == nullPtr - then f fieldDef pStr 0 - else do strLen <- strlen pStr - f fieldDef pStr (fromIntegral strLen) diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,7 +2,7 @@ \begin{code} import Control.Monad(when) -import Control.OldException(try) +import Control.Exception(SomeException,try) import System.Directory(removeFile,findExecutable) import System.Exit(ExitCode(ExitSuccess) ,exitWith) import System.IO(hClose, hGetContents, hPutStr, stderr) @@ -24,7 +24,7 @@ where preConf:: [String] -> ConfigFlags -> IO HookedBuildInfo preConf args flags = do - try (removeFile "SQLite3.buildinfo") + try (removeFile "SQLite3.buildinfo"):: IO (Either SomeException ()) return emptyHookedBuildInfo postConf:: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () diff --git a/hsql-sqlite3.cabal b/hsql-sqlite3.cabal --- a/hsql-sqlite3.cabal +++ b/hsql-sqlite3.cabal @@ -1,5 +1,5 @@ Name: hsql-sqlite3 -Version: 1.7.1 +Version: 1.8.1 Synopsis: SQLite3 driver for HSQL. License: BSD3 License-File: LICENSE @@ -8,8 +8,10 @@ Category: Database Description: A Haskell Interface to SQLite 3 via libsqlite3 in the standard library path. -Exposed-modules: Database.HSQL.SQLite3 -build-depends: base >= 4 && < 5, hsql >= 1.7 +Exposed-modules: + Database.HSQL.SQLite3 + DB.HSQL.SQLite3.Functions +build-depends: base >= 4 && < 5, hsql >= 1.8 Extensions: ForeignFunctionInterface, CPP Build-type: Simple Extra-libraries: sqlite3