├── CHANGELOG.md ├── Database └── HDBC │ ├── Sqlite3.hs │ └── Sqlite3 │ ├── Connection.hs │ ├── ConnectionImpl.hs │ ├── Consts.hsc │ ├── Statement.hsc │ ├── Types.hs │ └── Utils.hsc ├── HDBC-sqlite3.cabal ├── LICENSE ├── Makefile ├── README.txt ├── Setup.hs ├── hdbc-sqlite3-helper.c ├── hdbc-sqlite3-helper.h └── testsrc ├── SpecificDB.hs ├── SpecificDBTests.hs ├── TestMisc.hs ├── TestSbasics.hs ├── TestTime.hs ├── TestUtils.hs ├── Testbasics.hs ├── Tests.hs └── runtests.hs /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | # Changelog 3 | 4 | #### 2.3.3.1 5 | 6 | * Compatibility with GHC 7.10. 7 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Database.HDBC.Sqlite3 3 | Copyright : Copyright (C) 2005-2011 John Goerzen 4 | License : BSD3 5 | 6 | Maintainer : John Goerzen 7 | Stability : provisional 8 | Portability: portable 9 | 10 | HDBC driver interface for Sqlite 3.x. 11 | 12 | Written by John Goerzen, jgoerzen\@complete.org 13 | -} 14 | 15 | module Database.HDBC.Sqlite3 16 | ( 17 | -- * Sqlite3 Basics 18 | connectSqlite3, connectSqlite3Raw, Connection(), setBusyTimeout, 19 | -- * Sqlite3 Error Consts 20 | module Database.HDBC.Sqlite3.Consts 21 | ) 22 | 23 | where 24 | 25 | import Database.HDBC.Sqlite3.Connection(connectSqlite3, connectSqlite3Raw, Connection()) 26 | import Database.HDBC.Sqlite3.ConnectionImpl(setBusyTimeout) 27 | import Database.HDBC.Sqlite3.Consts 28 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/Connection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# CFILES hdbc-sqlite3-helper.c #-} 3 | -- above line for hugs 4 | 5 | module Database.HDBC.Sqlite3.Connection 6 | (connectSqlite3, connectSqlite3Raw, Impl.Connection()) 7 | where 8 | 9 | import Database.HDBC.Types 10 | import Database.HDBC 11 | import Database.HDBC.DriverUtils 12 | import qualified Database.HDBC.Sqlite3.ConnectionImpl as Impl 13 | import Database.HDBC.Sqlite3.Types 14 | import Database.HDBC.Sqlite3.Statement 15 | import Foreign.C.Types 16 | import Foreign.C.String 17 | import Foreign.Marshal 18 | import Foreign.Storable 19 | import Database.HDBC.Sqlite3.Utils 20 | import Foreign.ForeignPtr 21 | import Foreign.Ptr 22 | import Control.Concurrent.MVar 23 | import qualified Data.ByteString as B 24 | import qualified Data.ByteString.UTF8 as BUTF8 25 | import qualified Data.Char 26 | 27 | {- | Connect to an Sqlite version 3 database. The only parameter needed is 28 | the filename of the database to connect to. 29 | 30 | All database accessor functions are provided in the main HDBC module. -} 31 | connectSqlite3 :: FilePath -> IO Impl.Connection 32 | connectSqlite3 = 33 | genericConnect (B.useAsCString . BUTF8.fromString) 34 | 35 | {- | Connects to a Sqlite v3 database as with 'connectSqlite3', but 36 | instead of converting the supplied 'FilePath' to a C String by performing 37 | a conversion to Unicode, instead converts it by simply dropping all bits past 38 | the eighth. This may be useful in rare situations 39 | if your application or filesystemare not running in Unicode space. -} 40 | connectSqlite3Raw :: FilePath -> IO Impl.Connection 41 | connectSqlite3Raw = genericConnect withCString 42 | 43 | genericConnect :: (String -> (CString -> IO Impl.Connection) -> IO Impl.Connection) 44 | -> FilePath 45 | -> IO Impl.Connection 46 | genericConnect strAsCStrFunc fp = 47 | strAsCStrFunc fp 48 | (\cs -> alloca 49 | (\(p::Ptr (Ptr CSqlite3)) -> 50 | do res <- sqlite3_open cs p 51 | o <- peek p 52 | fptr <- newForeignPtr sqlite3_closeptr o 53 | newconn <- mkConn fp fptr 54 | checkError ("connectSqlite3 " ++ fp) fptr res 55 | return newconn 56 | ) 57 | ) 58 | 59 | mkConn :: FilePath -> Sqlite3 -> IO Impl.Connection 60 | mkConn fp obj = 61 | do children <- newMVar [] 62 | begin_transaction obj children 63 | ver <- (sqlite3_libversion >>= peekCString) 64 | return $ Impl.Connection { 65 | Impl.disconnect = fdisconnect obj children, 66 | Impl.commit = fcommit obj children, 67 | Impl.rollback = frollback obj children, 68 | Impl.run = frun obj children, 69 | Impl.runRaw = frunRaw obj children, 70 | Impl.prepare = newSth obj children True, 71 | Impl.clone = connectSqlite3 fp, 72 | Impl.hdbcDriverName = "sqlite3", 73 | Impl.hdbcClientVer = ver, 74 | Impl.proxiedClientName = "sqlite3", 75 | Impl.proxiedClientVer = ver, 76 | Impl.dbTransactionSupport = True, 77 | Impl.dbServerVer = ver, 78 | Impl.getTables = fgettables obj children, 79 | Impl.describeTable = fdescribeTable obj children, 80 | Impl.setBusyTimeout = fsetbusy obj} 81 | 82 | fgettables o mchildren = 83 | do sth <- newSth o mchildren True "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" 84 | execute sth [] 85 | res1 <- fetchAllRows' sth 86 | let res = map fromSql $ concat res1 87 | return $ seq (length res) res 88 | 89 | fdescribeTable o mchildren name = do 90 | sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")" 91 | execute sth [] 92 | res1 <- fetchAllRows' sth 93 | return $ map describeCol res1 94 | where 95 | describeCol (_:name:typ:notnull:df:pk:_) = 96 | (fromSql name, describeType typ notnull df pk) 97 | 98 | describeType name notnull df pk = 99 | SqlColDesc (typeId name) Nothing Nothing Nothing (nullable notnull) 100 | 101 | nullable SqlNull = Nothing 102 | nullable (SqlString "0") = Just True 103 | nullable (SqlString "1") = Just False 104 | nullable (SqlByteString x) 105 | | BUTF8.toString x == "0" = Just True 106 | | BUTF8.toString x == "1" = Just False 107 | nullable _ = Nothing 108 | 109 | typeId SqlNull = SqlUnknownT "Any" 110 | typeId (SqlString t) = typeId' t 111 | typeId (SqlByteString t) = typeId' $ BUTF8.toString t 112 | typeId _ = SqlUnknownT "Unknown" 113 | 114 | typeId' t = case map Data.Char.toLower t of 115 | ('i':'n':'t':_) -> SqlIntegerT 116 | "text" -> SqlVarCharT 117 | "real" -> SqlRealT 118 | "blob" -> SqlVarBinaryT 119 | "" -> SqlUnknownT "Any" 120 | other -> SqlUnknownT other 121 | 122 | 123 | fsetbusy o ms = withRawSqlite3 o $ \ppdb -> 124 | sqlite3_busy_timeout ppdb ms 125 | 126 | -------------------------------------------------- 127 | -- Guts here 128 | -------------------------------------------------- 129 | 130 | begin_transaction :: Sqlite3 -> ChildList -> IO () 131 | begin_transaction o children = frun o children "BEGIN" [] >> return () 132 | 133 | frun o mchildren query args = 134 | do sth <- newSth o mchildren False query 135 | res <- execute sth args 136 | finish sth 137 | return res 138 | 139 | frunRaw :: Sqlite3 -> ChildList -> String -> IO () 140 | frunRaw o mchildren query = 141 | do sth <- newSth o mchildren False query 142 | executeRaw sth 143 | finish sth 144 | 145 | fcommit o children = do frun o children "COMMIT" [] 146 | begin_transaction o children 147 | frollback o children = do frun o children "ROLLBACK" [] 148 | begin_transaction o children 149 | 150 | fdisconnect :: Sqlite3 -> ChildList -> IO () 151 | fdisconnect o mchildren = withRawSqlite3 o $ \p -> 152 | do closeAllChildren mchildren 153 | r <- sqlite3_close p 154 | checkError "disconnect" o r 155 | 156 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_open2" 157 | sqlite3_open :: CString -> (Ptr (Ptr CSqlite3)) -> IO CInt 158 | 159 | foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_close_finalizer" 160 | sqlite3_closeptr :: FunPtr ((Ptr CSqlite3) -> IO ()) 161 | 162 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_close_app" 163 | sqlite3_close :: Ptr CSqlite3 -> IO CInt 164 | 165 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_busy_timeout2" 166 | sqlite3_busy_timeout :: Ptr CSqlite3 -> CInt -> IO () 167 | 168 | foreign import ccall unsafe "sqlite3.h sqlite3_libversion" 169 | sqlite3_libversion :: IO CString 170 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/ConnectionImpl.hs: -------------------------------------------------------------------------------- 1 | module Database.HDBC.Sqlite3.ConnectionImpl where 2 | 3 | import qualified Database.HDBC.Statement as Types 4 | import qualified Database.HDBC.Types as Types 5 | import Database.HDBC.ColTypes as ColTypes 6 | import Foreign.C.Types 7 | 8 | data Connection = 9 | Connection { 10 | disconnect :: IO (), 11 | commit :: IO (), 12 | rollback :: IO (), 13 | run :: String -> [Types.SqlValue] -> IO Integer, 14 | runRaw :: String -> IO (), 15 | prepare :: String -> IO Types.Statement, 16 | clone :: IO Connection, 17 | hdbcDriverName :: String, 18 | hdbcClientVer :: String, 19 | proxiedClientName :: String, 20 | proxiedClientVer :: String, 21 | dbServerVer :: String, 22 | dbTransactionSupport :: Bool, 23 | getTables :: IO [String], 24 | describeTable :: String -> IO [(String, ColTypes.SqlColDesc)], 25 | -- | Sets the timeout for a lock before returning a busy error. 26 | -- Give the time in milliseconds. 27 | setBusyTimeout :: CInt -> IO () 28 | } 29 | 30 | instance Types.IConnection Connection where 31 | disconnect = disconnect 32 | commit = commit 33 | rollback = rollback 34 | run = run 35 | runRaw = runRaw 36 | prepare = prepare 37 | clone = clone 38 | hdbcDriverName = hdbcDriverName 39 | hdbcClientVer = hdbcClientVer 40 | proxiedClientName = proxiedClientName 41 | proxiedClientVer = proxiedClientVer 42 | dbServerVer = dbServerVer 43 | dbTransactionSupport = dbTransactionSupport 44 | getTables = getTables 45 | describeTable = describeTable 46 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/Consts.hsc: -------------------------------------------------------------------------------- 1 | {- -*- mode: haskell; -*- 2 | vim: set filetype=haskell: 3 | -} 4 | 5 | module Database.HDBC.Sqlite3.Consts 6 | (sqlite_OK, 7 | sqlite_ERROR, 8 | sqlite_INTERNAL, 9 | sqlite_PERM, 10 | sqlite_ABORT, 11 | sqlite_BUSY, 12 | sqlite_LOCKED, 13 | sqlite_NOMEM, 14 | sqlite_READONLY, 15 | sqlite_INTERRUPT, 16 | sqlite_IOERR, 17 | sqlite_CORRUPT, 18 | sqlite_NOTFOUND, 19 | sqlite_FULL, 20 | sqlite_CANTOPEN, 21 | sqlite_PROTOCOL, 22 | sqlite_EMPTY, 23 | sqlite_SCHEMA, 24 | sqlite_TOOBIG, 25 | sqlite_CONSTRAINT, 26 | sqlite_MISMATCH, 27 | sqlite_MISUSE, 28 | sqlite_NOLFS, 29 | sqlite_AUTH, 30 | sqlite_ROW, 31 | sqlite_DONE) 32 | where 33 | 34 | import Foreign.C.Types 35 | 36 | #include 37 | 38 | -- | Successful result 39 | sqlite_OK :: Int 40 | sqlite_OK = #{const SQLITE_OK} 41 | 42 | -- | SQL error or missing database 43 | sqlite_ERROR :: Int 44 | sqlite_ERROR = #{const SQLITE_ERROR} 45 | 46 | -- | An internal logic error in SQLite 47 | sqlite_INTERNAL :: Int 48 | sqlite_INTERNAL = #{const SQLITE_INTERNAL} 49 | 50 | -- | Access permission denied 51 | sqlite_PERM :: Int 52 | sqlite_PERM = #{const SQLITE_PERM} 53 | 54 | -- | Callback routine requested an abort 55 | sqlite_ABORT :: Int 56 | sqlite_ABORT = #{const SQLITE_ABORT} 57 | 58 | -- | The database file is locked 59 | sqlite_BUSY :: Int 60 | sqlite_BUSY = #{const SQLITE_BUSY} 61 | 62 | -- | A table in the database is locked 63 | sqlite_LOCKED :: Int 64 | sqlite_LOCKED = #{const SQLITE_LOCKED} 65 | 66 | -- | A malloc() failed 67 | sqlite_NOMEM :: Int 68 | sqlite_NOMEM = #{const SQLITE_NOMEM} 69 | 70 | -- | Attempt to write a readonly database 71 | sqlite_READONLY :: Int 72 | sqlite_READONLY = #{const SQLITE_READONLY} 73 | 74 | -- | Operation terminated by sqlite_interrupt() 75 | sqlite_INTERRUPT :: Int 76 | sqlite_INTERRUPT = #{const SQLITE_INTERRUPT} 77 | 78 | -- | Some kind of disk I\/O error occurred 79 | sqlite_IOERR :: Int 80 | sqlite_IOERR = #{const SQLITE_IOERR} 81 | 82 | -- | The database disk image is malformed 83 | sqlite_CORRUPT :: Int 84 | sqlite_CORRUPT = #{const SQLITE_CORRUPT} 85 | 86 | -- | (Internal Only) Table or record not found 87 | sqlite_NOTFOUND :: Int 88 | sqlite_NOTFOUND = #{const SQLITE_NOTFOUND} 89 | 90 | -- | Insertion failed because database is full 91 | sqlite_FULL :: Int 92 | sqlite_FULL = #{const SQLITE_FULL} 93 | 94 | -- | Unable to open the database file 95 | sqlite_CANTOPEN :: Int 96 | sqlite_CANTOPEN = #{const SQLITE_CANTOPEN} 97 | 98 | -- | Database lock protocol error 99 | sqlite_PROTOCOL :: Int 100 | sqlite_PROTOCOL = #{const SQLITE_PROTOCOL} 101 | 102 | -- | (Internal Only) Database table is empty 103 | sqlite_EMPTY :: Int 104 | sqlite_EMPTY = #{const SQLITE_EMPTY} 105 | 106 | -- | The database schema changed 107 | sqlite_SCHEMA :: Int 108 | sqlite_SCHEMA = #{const SQLITE_SCHEMA} 109 | 110 | -- | Too much data for one row of a table 111 | sqlite_TOOBIG :: Int 112 | sqlite_TOOBIG = #{const SQLITE_TOOBIG} 113 | 114 | -- | Abort due to constraint violation 115 | sqlite_CONSTRAINT :: Int 116 | sqlite_CONSTRAINT = #{const SQLITE_CONSTRAINT} 117 | 118 | -- | Data type mismatch 119 | sqlite_MISMATCH :: Int 120 | sqlite_MISMATCH = #{const SQLITE_MISMATCH} 121 | 122 | -- | Library used incorrectly 123 | sqlite_MISUSE :: Int 124 | sqlite_MISUSE = #{const SQLITE_MISUSE} 125 | 126 | -- | Uses OS features not supported on host 127 | sqlite_NOLFS :: Int 128 | sqlite_NOLFS = #{const SQLITE_NOLFS} 129 | 130 | -- | Authorization denied 131 | sqlite_AUTH :: Int 132 | sqlite_AUTH = #{const SQLITE_AUTH} 133 | 134 | -- | sqlite_step() has another row ready 135 | sqlite_ROW :: Int 136 | sqlite_ROW = #{const SQLITE_ROW} 137 | 138 | -- | sqlite_step() has finished executing 139 | sqlite_DONE :: Int 140 | sqlite_DONE = #{const SQLITE_DONE} 141 | 142 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/Statement.hsc: -------------------------------------------------------------------------------- 1 | -- -*- mode: haskell; -*- 2 | {-# CFILES hdbc-sqlite3-helper.c #-} 3 | -- Above line for Hugs 4 | module Database.HDBC.Sqlite3.Statement where 5 | import Database.HDBC.Types 6 | import Database.HDBC 7 | import Database.HDBC.Sqlite3.Types 8 | import Database.HDBC.Sqlite3.Utils 9 | import Foreign.C.Types 10 | import Foreign.ForeignPtr 11 | import Foreign.Ptr 12 | import Control.Concurrent.MVar 13 | import Foreign.C.String 14 | import Foreign.Marshal 15 | import Foreign.Storable 16 | import Control.Monad 17 | import qualified Data.ByteString as B 18 | import qualified Data.ByteString.UTF8 as BUTF8 19 | import Data.List 20 | import Control.Exception 21 | import Database.HDBC.DriverUtils 22 | 23 | #include 24 | 25 | {- One annoying thing about Sqlite is that a disconnect operation will actually 26 | fail if there are any active statements. This is highly annoying, and makes 27 | for some somewhat complex algorithms. -} 28 | 29 | data StoState = Empty -- ^ Not initialized or last execute\/fetchrow had no results 30 | | Prepared Stmt -- ^ Prepared but not executed 31 | | Executed Stmt -- ^ Executed and more rows are expected 32 | | Exhausted Stmt -- ^ Executed and at end of rows 33 | 34 | instance Show StoState where 35 | show Empty = "Empty" 36 | show (Prepared _) = "Prepared" 37 | show (Executed _) = "Executed" 38 | show (Exhausted _) = "Exhausted" 39 | 40 | data SState = SState {dbo :: Sqlite3, 41 | stomv :: MVar StoState, 42 | querys :: String, 43 | colnamesmv :: MVar [String], 44 | autoFinish :: Bool} 45 | 46 | newSth :: Sqlite3 -> ChildList -> Bool -> String -> IO Statement 47 | newSth indbo mchildren autoFinish str = 48 | do newstomv <- newMVar Empty 49 | newcolnamesmv <- newMVar [] 50 | let sstate = SState{dbo = indbo, 51 | stomv = newstomv, 52 | querys = str, 53 | colnamesmv = newcolnamesmv, 54 | autoFinish = autoFinish} 55 | modifyMVar_ (stomv sstate) (\_ -> (fprepare sstate >>= return . Prepared)) 56 | let retval = 57 | Statement {execute = fexecute sstate, 58 | executeRaw = fexecuteRaw indbo str, 59 | executeMany = fexecutemany sstate, 60 | finish = public_ffinish sstate, 61 | fetchRow = ffetchrow sstate, 62 | originalQuery = str, 63 | getColumnNames = readMVar (colnamesmv sstate), 64 | describeResult = fail "Sqlite3 backend does not support describeResult"} 65 | addChild mchildren retval 66 | return retval 67 | 68 | {- The deal with adding the \0 below is in response to an apparent bug in 69 | sqlite3. See debian bug #343736. 70 | 71 | This function assumes that any existing query in the state has already 72 | been terminated. (FIXME: should check this at runtime.... never run fprepare 73 | unless state is Empty) 74 | -} 75 | fprepare :: SState -> IO Stmt 76 | fprepare sstate = withRawSqlite3 (dbo sstate) 77 | (\p -> B.useAsCStringLen (BUTF8.fromString ((querys sstate) ++ "\0")) 78 | (\(cs, cslen) -> alloca 79 | (\(newp::Ptr (Ptr CStmt)) -> 80 | (do res <- sqlite3_prepare p cs (fromIntegral cslen) newp nullPtr 81 | checkError ("prepare " ++ (show cslen) ++ ": " ++ (querys sstate)) 82 | (dbo sstate) res 83 | newo <- peek newp 84 | newForeignPtr sqlite3_finalizeptr newo 85 | ) 86 | ) 87 | ) 88 | ) 89 | 90 | 91 | {- General algorithm: find out how many columns we have, check the type 92 | of each to see if it's NULL. If it's not, fetch it as text and return that. 93 | 94 | Note that execute() will have already loaded up the first row -- and we 95 | do that each time. so this function returns the row that is already in sqlite, 96 | then loads the next row. -} 97 | ffetchrow :: SState -> IO (Maybe [SqlValue]) 98 | ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow 99 | where dofetchrow Empty = return (Empty, Nothing) 100 | dofetchrow (Prepared _) = 101 | throwSqlError $ SqlError {seState = "HDBC Sqlite3 fetchrow", 102 | seNativeError = (-1), 103 | seErrorMsg = "Attempt to fetch row from Statement that has not been executed. Query was: " ++ (querys sstate)} 104 | dofetchrow (Executed sto) = withStmt sto (\p -> 105 | do ccount <- sqlite3_column_count p 106 | -- fetch the data 107 | res <- mapM (getCol p) [0..(ccount - 1)] 108 | r <- fstep (dbo sstate) p 109 | if r 110 | then return (Executed sto, Just res) 111 | else if (autoFinish sstate) 112 | then do ffinish (dbo sstate) sto 113 | return (Empty, Just res) 114 | else return (Exhausted sto, Just res) 115 | ) 116 | dofetchrow (Exhausted sto) = return (Exhausted sto, Nothing) 117 | 118 | getCol p icol = 119 | do t <- sqlite3_column_type p icol 120 | if t == #{const SQLITE_NULL} 121 | then return SqlNull 122 | else do text <- sqlite3_column_text p icol 123 | len <- sqlite3_column_bytes p icol 124 | s <- B.packCStringLen (text, fromIntegral len) 125 | case t of 126 | #{const SQLITE_INTEGER} -> return $ SqlInt64 (read $ BUTF8.toString s) 127 | #{const SQLITE_FLOAT} -> return $ SqlDouble (read $ BUTF8.toString s) 128 | #{const SQLITE_BLOB} -> return $ SqlByteString s 129 | #{const SQLITE_TEXT} -> return $ SqlByteString s 130 | _ -> return $ SqlByteString s 131 | 132 | fstep :: Sqlite3 -> Ptr CStmt -> IO Bool 133 | fstep dbo p = 134 | do r <- sqlite3_step p 135 | case r of 136 | #{const SQLITE_ROW} -> return True 137 | #{const SQLITE_DONE} -> return False 138 | #{const SQLITE_ERROR} -> checkError "step" dbo #{const SQLITE_ERROR} 139 | >> (throwSqlError $ SqlError 140 | {seState = "", 141 | seNativeError = 0, 142 | seErrorMsg = "In HDBC step, internal processing error (got SQLITE_ERROR with no error)"}) 143 | x -> checkError "step" dbo x 144 | >> (throwSqlError $ SqlError 145 | {seState = "", 146 | seNativeError = fromIntegral x, 147 | seErrorMsg = "In HDBC step, internal processing error (got error code with no error)"}) 148 | 149 | fexecute sstate args = modifyMVar (stomv sstate) doexecute 150 | where doexecute (Executed sto) = doexecute (Prepared sto) 151 | doexecute (Exhausted sto) = doexecute (Prepared sto) 152 | doexecute Empty = -- already cleaned up from last time 153 | do sto <- fprepare sstate 154 | doexecute (Prepared sto) 155 | doexecute (Prepared sto) = withStmt sto (\p -> 156 | do c <- sqlite3_bind_parameter_count p 157 | when (c /= genericLength args) 158 | (throwSqlError $ SqlError {seState = "", 159 | seNativeError = (-1), 160 | seErrorMsg = "In HDBC execute, received " ++ (show args) ++ " but expected " ++ (show c) ++ " args."}) 161 | sqlite3_reset p >>= checkError "execute (reset)" (dbo sstate) 162 | zipWithM_ (bindArgs p) [1..c] args 163 | 164 | {- Logic for handling counts of changes: look at the total 165 | changes before and after the query. If they differ, 166 | then look at the local changes. (The local change counter 167 | appears to not be updated unless really running a query 168 | that makes a change, according to the docs.) 169 | 170 | This is OK thread-wise because SQLite doesn't support 171 | using a given dbh in more than one thread anyway. -} 172 | origtc <- withSqlite3 (dbo sstate) sqlite3_total_changes 173 | r <- fstep (dbo sstate) p 174 | newtc <- withSqlite3 (dbo sstate) sqlite3_total_changes 175 | changes <- if origtc == newtc 176 | then return 0 177 | else withSqlite3 (dbo sstate) sqlite3_changes 178 | fgetcolnames p >>= swapMVar (colnamesmv sstate) 179 | if r 180 | then return (Executed sto, fromIntegral changes) 181 | else if (autoFinish sstate) 182 | then do ffinish (dbo sstate) sto 183 | return (Empty, fromIntegral changes) 184 | else return (Exhausted sto, fromIntegral changes) 185 | ) 186 | bindArgs p i SqlNull = 187 | sqlite3_bind_null p i >>= 188 | checkError ("execute (binding NULL column " ++ (show i) ++ ")") 189 | (dbo sstate) 190 | bindArgs p i (SqlByteString bs) = 191 | B.useAsCStringLen bs (bindCStringArgs p i) 192 | bindArgs p i arg = bindArgs p i (SqlByteString (fromSql arg)) 193 | 194 | bindCStringArgs p i (cs, len) = 195 | do r <- sqlite3_bind_text2 p i cs (fromIntegral len) 196 | checkError ("execute (binding column " ++ 197 | (show i) ++ ")") (dbo sstate) r 198 | 199 | fexecuteRaw :: Sqlite3 -> String -> IO () 200 | fexecuteRaw dbo query = 201 | withSqlite3 dbo 202 | (\p -> B.useAsCStringLen (BUTF8.fromString (query ++ "\0")) 203 | (\(cs, cslen) -> do 204 | result <- sqlite3_exec p cs nullFunPtr nullPtr nullPtr 205 | case result of 206 | #{const SQLITE_OK} -> return () 207 | s -> do 208 | checkError "exec" dbo s 209 | throwSqlError $ SqlError 210 | {seState = "", 211 | seNativeError = fromIntegral s, 212 | seErrorMsg = "In sqlite3_exec, internal error"} 213 | ) 214 | ) 215 | 216 | fgetcolnames csth = 217 | do count <- sqlite3_column_count csth 218 | mapM (getCol csth) [0..(count -1)] 219 | where getCol csth i = 220 | do cstr <- sqlite3_column_name csth i 221 | bs <- B.packCString cstr 222 | return (BUTF8.toString bs) 223 | 224 | fexecutemany _ [] = return () 225 | fexecutemany sstate (args:[]) = 226 | do fexecute sstate args 227 | return () 228 | fexecutemany sstate (args:arglist) = 229 | do fexecute (sstate { autoFinish = False }) args 230 | fexecutemany sstate arglist 231 | 232 | --ffinish o = withForeignPtr o (\p -> sqlite3_finalize p >>= checkError "finish") 233 | -- Finish and change state 234 | public_ffinish sstate = modifyMVar_ (stomv sstate) worker 235 | where worker (Empty) = return Empty 236 | worker (Prepared sto) = ffinish (dbo sstate) sto >> return Empty 237 | worker (Executed sto) = ffinish (dbo sstate) sto >> return Empty 238 | worker (Exhausted sto) = ffinish (dbo sstate) sto >> return Empty 239 | 240 | ffinish dbo o = withRawStmt o (\p -> do r <- sqlite3_finalize p 241 | checkError "finish" dbo r) 242 | 243 | foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_finalize_finalizer" 244 | sqlite3_finalizeptr :: FunPtr ((Ptr CStmt) -> IO ()) 245 | 246 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_finalize_app" 247 | sqlite3_finalize :: (Ptr CStmt) -> IO CInt 248 | 249 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_prepare2" 250 | sqlite3_prepare :: (Ptr CSqlite3) -> CString -> CInt -> Ptr (Ptr CStmt) -> Ptr (Ptr CString) -> IO CInt 251 | 252 | foreign import ccall unsafe "sqlite3.h sqlite3_bind_parameter_count" 253 | sqlite3_bind_parameter_count :: (Ptr CStmt) -> IO CInt 254 | 255 | foreign import ccall unsafe "sqlite3.h sqlite3_step" 256 | sqlite3_step :: (Ptr CStmt) -> IO CInt 257 | 258 | foreign import ccall unsafe "sqlite3.h sqlite3_exec" 259 | sqlite3_exec :: (Ptr CSqlite3) 260 | -> CString 261 | -> FunPtr (Ptr () -> CInt -> Ptr CString -> Ptr CString) 262 | -> Ptr () 263 | -> Ptr CString 264 | -> IO CInt 265 | 266 | foreign import ccall unsafe "sqlite3.h sqlite3_reset" 267 | sqlite3_reset :: (Ptr CStmt) -> IO CInt 268 | 269 | foreign import ccall unsafe "sqlite3.h sqlite3_column_count" 270 | sqlite3_column_count :: (Ptr CStmt) -> IO CInt 271 | 272 | foreign import ccall unsafe "sqlite3.h sqlite3_column_name" 273 | sqlite3_column_name :: Ptr CStmt -> CInt -> IO CString 274 | 275 | foreign import ccall unsafe "sqlite3.h sqlite3_column_type" 276 | sqlite3_column_type :: (Ptr CStmt) -> CInt -> IO CInt 277 | 278 | foreign import ccall unsafe "sqlite3.h sqlite3_column_text" 279 | sqlite3_column_text :: (Ptr CStmt) -> CInt -> IO CString 280 | 281 | foreign import ccall unsafe "sqlite3.h sqlite3_column_bytes" 282 | sqlite3_column_bytes :: (Ptr CStmt) -> CInt -> IO CInt 283 | 284 | foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_bind_text2" 285 | sqlite3_bind_text2 :: (Ptr CStmt) -> CInt -> CString -> CInt -> IO CInt 286 | 287 | foreign import ccall unsafe "sqlite3.h sqlite3_bind_null" 288 | sqlite3_bind_null :: (Ptr CStmt) -> CInt -> IO CInt 289 | 290 | foreign import ccall unsafe "sqlite3.h sqlite3_changes" 291 | sqlite3_changes :: Ptr CSqlite3 -> IO CInt 292 | 293 | foreign import ccall unsafe "sqlite3.h sqlite3_total_changes" 294 | sqlite3_total_changes :: Ptr CSqlite3 -> IO CInt 295 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/Types.hs: -------------------------------------------------------------------------------- 1 | module Database.HDBC.Sqlite3.Types 2 | where 3 | 4 | import Foreign.ForeignPtr 5 | 6 | data CSqlite3 7 | type Sqlite3 = ForeignPtr CSqlite3 8 | 9 | data CStmt 10 | type Stmt = ForeignPtr CStmt 11 | 12 | -------------------------------------------------------------------------------- /Database/HDBC/Sqlite3/Utils.hsc: -------------------------------------------------------------------------------- 1 | {- -*- mode: haskell; -*- 2 | vim: set filetype=haskell: 3 | -} 4 | 5 | module Database.HDBC.Sqlite3.Utils where 6 | import Foreign.C.String 7 | import Foreign.ForeignPtr 8 | import Foreign.Ptr 9 | import Database.HDBC(throwSqlError) 10 | import Database.HDBC.Types 11 | import Database.HDBC.Sqlite3.Types 12 | import qualified Data.ByteString as B 13 | import qualified Data.ByteString.UTF8 as BUTF8 14 | import Foreign.C.Types 15 | import Control.Exception 16 | import Foreign.Storable 17 | 18 | #include "hdbc-sqlite3-helper.h" 19 | 20 | checkError :: String -> Sqlite3 -> CInt -> IO () 21 | checkError _ _ 0 = return () 22 | checkError msg o res = 23 | withSqlite3 o 24 | (\p -> do rc <- sqlite3_errmsg p 25 | bs <- B.packCString rc 26 | let str = BUTF8.toString bs 27 | throwSqlError $ 28 | SqlError {seState = "", 29 | seNativeError = fromIntegral res, 30 | seErrorMsg = msg ++ ": " ++ str} 31 | ) 32 | 33 | {- This is a little hairy. 34 | 35 | We have a CSqlite3 object that is actually a finalizeonce wrapper around 36 | the real object. We use withSqlite3 to dereference the foreign pointer, 37 | and then extract the pointer to the real object from the finalizeonce struct. 38 | 39 | But, when we close the connection, we need the finalizeonce struct, so that's 40 | done by withRawSqlite3. 41 | 42 | Ditto for statements. -} 43 | 44 | withSqlite3 :: Sqlite3 -> (Ptr CSqlite3 -> IO b) -> IO b 45 | withSqlite3 = genericUnwrap 46 | 47 | withRawSqlite3 :: Sqlite3 -> (Ptr CSqlite3 -> IO b) -> IO b 48 | withRawSqlite3 = withForeignPtr 49 | 50 | withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b 51 | withStmt = genericUnwrap 52 | 53 | withRawStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b 54 | withRawStmt = withForeignPtr 55 | 56 | 57 | genericUnwrap :: ForeignPtr a -> (Ptr a -> IO b) -> IO b 58 | genericUnwrap fptr action = withForeignPtr fptr (\structptr -> 59 | do objptr <- #{peek finalizeonce, encapobj} structptr 60 | action objptr 61 | ) 62 | 63 | foreign import ccall unsafe "sqlite3.h sqlite3_errmsg" 64 | sqlite3_errmsg :: (Ptr CSqlite3) -> IO CString 65 | 66 | -------------------------------------------------------------------------------- /HDBC-sqlite3.cabal: -------------------------------------------------------------------------------- 1 | Name: HDBC-sqlite3 2 | Version: 2.3.3.1 3 | License: BSD3 4 | Maintainer: Erik Hesselink 5 | Author: John Goerzen 6 | Copyright: Copyright (c) 2005-2011 John Goerzen 7 | license-file: LICENSE 8 | extra-source-files: LICENSE, hdbc-sqlite3-helper.h, Makefile 9 | homepage: https://github.com/hdbc/hdbc-sqlite3 10 | Category: Database 11 | synopsis: Sqlite v3 driver for HDBC 12 | Description: This is the Sqlite v3 driver for HDBC, the generic 13 | database access system for Haskell 14 | Stability: Stable 15 | Build-Type: Simple 16 | Cabal-Version: >=1.2.3 17 | extra-source-files: LICENSE, Makefile, README.txt, CHANGELOG.md 18 | 19 | Flag splitBase 20 | description: Choose the new smaller, split-up package. 21 | Flag buildtests 22 | description: Build the executable to run unit tests 23 | default: False 24 | 25 | Library 26 | Build-Depends: base>=4 && < 5, bytestring, mtl, HDBC>=2.3.0.0, utf8-string 27 | 28 | C-Sources: hdbc-sqlite3-helper.c 29 | include-dirs: . 30 | Extra-Libraries: sqlite3 31 | Exposed-Modules: Database.HDBC.Sqlite3 32 | Other-Modules: Database.HDBC.Sqlite3.Connection, 33 | Database.HDBC.Sqlite3.ConnectionImpl, 34 | Database.HDBC.Sqlite3.Statement, 35 | Database.HDBC.Sqlite3.Types, 36 | Database.HDBC.Sqlite3.Utils, 37 | Database.HDBC.Sqlite3.Consts 38 | GHC-Options: -O2 39 | Extensions: ExistentialQuantification, 40 | ForeignFunctionInterface, 41 | EmptyDataDecls, 42 | ScopedTypeVariables, 43 | ScopedTypeVariables 44 | 45 | Executable runtests 46 | if flag(buildtests) 47 | Buildable: True 48 | Build-Depends: HUnit, testpack, containers, convertible, 49 | old-time, time, old-locale 50 | else 51 | Buildable: False 52 | Main-Is: runtests.hs 53 | Other-Modules: SpecificDB, 54 | SpecificDBTests, 55 | TestMisc, 56 | TestSbasics, 57 | TestUtils, 58 | Testbasics, 59 | Tests, 60 | Database.HDBC.Sqlite3.Connection, 61 | Database.HDBC.Sqlite3.ConnectionImpl, 62 | Database.HDBC.Sqlite3.Statement, 63 | Database.HDBC.Sqlite3.Types, 64 | Database.HDBC.Sqlite3.Utils, 65 | Database.HDBC.Sqlite3.Consts 66 | C-Sources: hdbc-sqlite3-helper.c 67 | include-dirs: . 68 | Extra-Libraries: sqlite3 69 | Hs-Source-Dirs: ., testsrc 70 | GHC-Options: -O2 71 | Extensions: ExistentialQuantification, 72 | ForeignFunctionInterface, 73 | EmptyDataDecls, 74 | ScopedTypeVariables, 75 | ScopedTypeVariables 76 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005-2011, John Goerzen 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | * Neither the name of John Goerzen nor the names of its 15 | contributors may be used to endorse or promote products derived from this 16 | software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: setup 2 | @echo "Please use Cabal to build this package; not make." 3 | ./setup configure 4 | ./setup build 5 | 6 | setup: Setup.hs 7 | ghc --make -package Cabal -o setup Setup.hs 8 | 9 | install: setup 10 | ./setup install 11 | 12 | clean: 13 | -runghc Setup.hs clean 14 | -rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \ 15 | `find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \ 16 | local-pkg doctmp 17 | -rm -rf testtmp/* testtmp* 18 | 19 | .PHONY: test 20 | test: test-ghc test-hugs 21 | @echo "" 22 | @echo "All tests pass." 23 | 24 | test-hugs: setup 25 | @echo " ****** Running hugs tests" 26 | ./setup configure -f buildtests --hugs # for GHC 6.10: --extra-include-dirs=/usr/lib/hugs/include 27 | ./setup build 28 | runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \ 29 | dist/scratch/programs/runtests/Main.hs 30 | 31 | test-ghc: setup 32 | @echo " ****** Building GHC tests" 33 | ./setup configure -f buildtests 34 | ./setup build 35 | @echo " ****** Running GHC tests" 36 | ./dist/build/runtests/runtests 37 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | Welcome to HDBC, Haskell Database Connectivity. 2 | 3 | This package provides a database backend driver for Sqlite version 3. 4 | 5 | Please see HDBC itself for documentation on use. If you don't already 6 | have it, you can browse this documentation at 7 | https://hackage.haskell.org/package/HDBC 8 | 9 | This package provides one function in module Database.HDBC.Sqlite3: 10 | 11 | {- | Connect to an Sqlite version 3 database. The only parameter needed is 12 | the filename of the database to connect to. 13 | 14 | All database accessor functions are provided in the main HDBC module. -} 15 | connectSqlite3 :: FilePath -> IO Connection 16 | 17 | DIFFERENCES FROM HDBC STANDARD 18 | ------------------------------ 19 | 20 | SQLite is unable to return the number of modified rows from a table 21 | when you run a "DELETE FROM" command with no WHERE clause. 22 | 23 | On the topic of thread safety, SQLite has some limitations, and thus 24 | HDBC programs that use SQLite will share those limitations. Please 25 | see http://www.sqlite.org/faq.html#q8 for more details. 26 | 27 | describeTable and describeResult are not supported by this module. 28 | 29 | PREREQUISITES 30 | ------------- 31 | 32 | Before installing this package, you'll need to have HDBC 0.99.0 or 33 | above installed. You can download HDBC from http://quux.org/devel/hdbc. 34 | 35 | You'll need either GHC 6.8.x or above, or Hugs 2006xx or above. 36 | 37 | INSTALLATION 38 | ------------ 39 | 40 | The steps to install are: 41 | 42 | 1) ghc --make -o setup Setup.lhs 43 | 44 | 2) ./setup configure 45 | 46 | 3) ./setup build 47 | 48 | 4) ./setup install (as root) 49 | 50 | If you're on Windows, you can omit the leading "./". 51 | 52 | USAGE 53 | ----- 54 | 55 | To use with hugs, you'll want to use hugs -98. 56 | 57 | To use with GHC, you'll want to use: 58 | 59 | -package HDBC -package HDBC-sqlite3 60 | 61 | Or, with Cabal, use: 62 | 63 | Build-Depends: HDBC>=2.0.0, HDBC-sqlite3 64 | 65 | -- John Goerzen 66 | January 2009 67 | December 2005 68 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhugs 2 | 3 | import Distribution.Simple 4 | 5 | main = defaultMain 6 | 7 | -------------------------------------------------------------------------------- /hdbc-sqlite3-helper.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "hdbc-sqlite3-helper.h" 5 | 6 | int sqlite3_bind_text2(sqlite3_stmt* a, int b, const char *c, int d) { 7 | return sqlite3_bind_text(a, b, c, d, SQLITE_TRANSIENT); 8 | } 9 | 10 | /* Sqlite things can't finalize more than once. 11 | We'd like to let people call them from the app to get the error, if any. 12 | Yet we'd also like to be able to have a ForeignPtr finalize them. 13 | 14 | So, here's a little wrapper for things. */ 15 | 16 | 17 | int sqlite3_open2(const char *filename, finalizeonce **ppo) { 18 | sqlite3 *ppDb; 19 | finalizeonce *newobj; 20 | int res; 21 | 22 | res = sqlite3_open(filename, &ppDb); 23 | newobj = malloc(sizeof(finalizeonce)); 24 | if (newobj == NULL) { 25 | fprintf(stderr, "\nhdbc sqlite internal error: couldn't malloc memory for newobj\n"); 26 | return -999; 27 | } 28 | newobj->encapobj = (void *) ppDb; 29 | newobj->isfinalized = 0; 30 | newobj->refcount = 1; 31 | newobj->parent = NULL; 32 | *ppo = newobj; 33 | #ifdef DEBUG_HDBC_SQLITE3 34 | fprintf(stderr, "\nAllocated db at %p %p\n", newobj, newobj->encapobj); 35 | #endif 36 | return res; 37 | } 38 | 39 | int sqlite3_close_app(finalizeonce *ppdb) { 40 | int res; 41 | if (ppdb->isfinalized) { 42 | #ifdef DEBUG_HDBC_SQLITE3 43 | fprintf(stderr, "\nclose_app on already finalized %p\n", ppdb); 44 | #endif 45 | return SQLITE_OK; 46 | } 47 | #ifdef DEBUG_HDBC_SQLITE3 48 | fprintf(stderr, "\nclose_app on non-finalized %p\n", ppdb); 49 | #endif 50 | res = sqlite3_close((sqlite3 *) (ppdb->encapobj)); 51 | ppdb->isfinalized = 1; 52 | return res; 53 | } 54 | 55 | void sqlite3_close_finalizer(finalizeonce *ppdb) { 56 | #ifdef DEBUG_HDBC_SQLITE3 57 | fprintf(stderr, "\nclose_finalizer on %p: %d\n", ppdb, ppdb->isfinalized); 58 | #endif 59 | (ppdb->refcount)--; 60 | sqlite3_conditional_finalizer(ppdb); 61 | } 62 | 63 | void sqlite3_conditional_finalizer(finalizeonce *ppdb) { 64 | #ifdef DEBUG_HDBC_SQLITE3 65 | fprintf(stderr, "\ncond finalizer on %p: refcount %d\n", ppdb, ppdb->refcount); 66 | #endif 67 | if (ppdb->refcount < 1) { 68 | sqlite3_close_app(ppdb); 69 | free(ppdb); 70 | } 71 | } 72 | 73 | void sqlite3_busy_timeout2(finalizeonce *ppdb, int ms) { 74 | sqlite3 *db; 75 | 76 | db = (sqlite3 *) ppdb->encapobj; 77 | sqlite3_busy_timeout(db, ms); 78 | } 79 | 80 | int sqlite3_prepare2(finalizeonce *fdb, const char *zSql, 81 | int nBytes, finalizeonce **ppo, 82 | const char **pzTail) { 83 | 84 | sqlite3_stmt *ppst; 85 | sqlite3 *db; 86 | finalizeonce *newobj; 87 | int res; 88 | 89 | db = (sqlite3 *) fdb->encapobj; 90 | 91 | #ifdef DEBUG_HDBC_SQLITE3 92 | fprintf(stderr, "\nCalling prepare on %p", db); 93 | #endif 94 | #if SQLITE_VERSION_NUMBER > 3003011 95 | res = sqlite3_prepare_v2(db, zSql, nBytes, &ppst, 96 | pzTail); 97 | #else 98 | res = sqlite3_prepare(db, zSql, nBytes, &ppst, 99 | pzTail); 100 | #endif 101 | 102 | /* We don't try to deallocate this in Haskell if there 103 | was an error. */ 104 | if (res != SQLITE_OK) { 105 | if (ppst != NULL) { 106 | sqlite3_finalize(ppst); 107 | } 108 | return res; 109 | 110 | } 111 | 112 | newobj = malloc(sizeof(finalizeonce)); 113 | if (newobj == NULL) { 114 | fprintf(stderr, "\nhdbc sqlite3 internal error: couldn't malloc memory for newobj\n"); 115 | return -999; 116 | } 117 | newobj->encapobj = (void *) ppst; 118 | newobj->isfinalized = 0; 119 | newobj->parent = fdb; 120 | newobj->refcount = 1; 121 | (fdb->refcount)++; 122 | *ppo = newobj; 123 | #ifdef DEBUG_HDBC_SQLITE3 124 | fprintf(stderr, "\nAllocated stmt at %p %p\n", newobj, newobj->encapobj); 125 | #endif 126 | return res; 127 | } 128 | 129 | int sqlite3_finalize_app(finalizeonce *ppst) { 130 | int res; 131 | if (ppst->isfinalized) { 132 | #ifdef DEBUG_HDBC_SQLITE3 133 | fprintf(stderr, "\nfinalize_app on already finalized %p\n", ppst); 134 | #endif 135 | return SQLITE_OK; 136 | } 137 | #ifdef DEBUG_HDBC_SQLITE3 138 | fprintf(stderr, "\nfinalize_app on non-finalized %p\n", ppst); 139 | #endif 140 | res = sqlite3_finalize((sqlite3_stmt *) (ppst->encapobj)); 141 | ppst->isfinalized = 1; 142 | return res; 143 | } 144 | 145 | void sqlite3_finalize_finalizer(finalizeonce *ppst) { 146 | #ifdef DEBUG_HDBC_SQLITE3 147 | fprintf(stderr, "\nfinalize_finalizer on %p: %d\n", ppst, ppst->isfinalized); 148 | #endif 149 | sqlite3_finalize_app(ppst); 150 | (ppst->refcount)--; /* Not really important since no children use 151 | us */ 152 | /* Now decrement the refcount for the parent */ 153 | (ppst->parent->refcount)--; 154 | sqlite3_conditional_finalizer(ppst->parent); 155 | free(ppst); 156 | } 157 | -------------------------------------------------------------------------------- /hdbc-sqlite3-helper.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern int sqlite3_bind_text2(sqlite3_stmt* a, int b, const char *c, int d); 4 | 5 | /* Clever trick: the obj is the first element in the struct, so the pointer 6 | to the struct is the same as the pointer to the obj. */ 7 | 8 | typedef struct TAG_finalizeonce { 9 | void *encapobj; 10 | int refcount; 11 | int isfinalized; 12 | struct TAG_finalizeonce *parent; 13 | } finalizeonce; 14 | 15 | 16 | extern int sqlite3_open2(const char *filename, finalizeonce **ppo); 17 | extern int sqlite3_close_app(finalizeonce *ppdb); 18 | extern void sqlite3_close_finalizer(finalizeonce *ppdb); 19 | extern void sqlite3_conditional_finalizer(finalizeonce *ppdb); 20 | 21 | extern void sqlite3_busy_timeout2(finalizeonce *ppdb, int ms); 22 | extern int sqlite3_prepare2(finalizeonce *fdb, const char *zSql, 23 | int nBytes, finalizeonce **ppo, 24 | const char **pzTail); 25 | extern int sqlite3_finalize_app(finalizeonce *ppst); 26 | extern void sqlite3_finalize_finalizer(finalizeonce *ppst); 27 | 28 | 29 | -------------------------------------------------------------------------------- /testsrc/SpecificDB.hs: -------------------------------------------------------------------------------- 1 | module SpecificDB where 2 | import Database.HDBC 3 | import Database.HDBC.Sqlite3 4 | import Test.HUnit 5 | 6 | connectDB = 7 | handleSqlError (connectSqlite3 "testtmp.sql3") 8 | 9 | dateTimeTypeOfSqlValue :: SqlValue -> String 10 | dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "TEXT" 11 | dateTimeTypeOfSqlValue (SqlEpochTime _) = "INTEGER" 12 | dateTimeTypeOfSqlValue _ = "TEXT" 13 | 14 | supportsFracTime = True -------------------------------------------------------------------------------- /testsrc/SpecificDBTests.hs: -------------------------------------------------------------------------------- 1 | module SpecificDBTests where 2 | import Database.HDBC 3 | import Database.HDBC.Sqlite3 4 | import Test.HUnit 5 | import TestMisc(setup) 6 | 7 | testgetTables = setup $ \dbh -> 8 | do r <- getTables dbh 9 | ["hdbctest2"] @=? r 10 | 11 | tests = TestList [TestLabel "getTables" testgetTables] 12 | -------------------------------------------------------------------------------- /testsrc/TestMisc.hs: -------------------------------------------------------------------------------- 1 | module TestMisc(tests, setup) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import System.IO 6 | import Control.Exception 7 | import Data.Char 8 | import Control.Monad 9 | import qualified Data.Map as Map 10 | 11 | rowdata = 12 | [[SqlInt32 0, toSql "Testing", SqlNull], 13 | [SqlInt32 1, toSql "Foo", SqlInt32 5], 14 | [SqlInt32 2, toSql "Bar", SqlInt32 9]] 15 | 16 | colnames = ["testid", "teststring", "testint"] 17 | alrows :: [[(String, SqlValue)]] 18 | alrows = map (zip colnames) rowdata 19 | 20 | setup f = dbTestCase $ \dbh -> 21 | do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] 22 | sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 23 | executeMany sth rowdata 24 | commit dbh 25 | finally (f dbh) 26 | (do run dbh "DROP TABLE hdbctest2" [] 27 | commit dbh 28 | ) 29 | 30 | cloneTest dbh a = 31 | do dbh2 <- clone dbh 32 | finally (handleSqlError (a dbh2)) 33 | (handleSqlError (disconnect dbh2)) 34 | 35 | testgetColumnNames = setup $ \dbh -> 36 | do sth <- prepare dbh "SELECT * from hdbctest2" 37 | execute sth [] 38 | cols <- getColumnNames sth 39 | finish sth 40 | ["testid", "teststring", "testint"] @=? map (map toLower) cols 41 | 42 | testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` 43 | ["sqlite3"])) $ 44 | do sth <- prepare dbh "SELECT * from hdbctest2" 45 | execute sth [] 46 | cols <- describeResult sth 47 | ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols 48 | let coldata = map snd cols 49 | assertBool "r0 type" (colType (coldata !! 0) `elem` 50 | [SqlBigIntT, SqlIntegerT]) 51 | assertBool "r1 type" (colType (coldata !! 1) `elem` 52 | [SqlVarCharT, SqlLongVarCharT]) 53 | assertBool "r2 type" (colType (coldata !! 2) `elem` 54 | [SqlBigIntT, SqlIntegerT]) 55 | finish sth 56 | 57 | testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` 58 | ["sqlite3"])) $ 59 | do cols <- describeTable dbh "hdbctest2" 60 | ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols 61 | let coldata = map snd cols 62 | assertBool "r0 type" (colType (coldata !! 0) `elem` 63 | [SqlBigIntT, SqlIntegerT]) 64 | assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) 65 | assertBool "r1 type" (colType (coldata !! 1) `elem` 66 | [SqlVarCharT, SqlLongVarCharT]) 67 | assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) 68 | assertBool "r2 type" (colType (coldata !! 2) `elem` 69 | [SqlBigIntT, SqlIntegerT]) 70 | assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) 71 | 72 | testquickQuery = setup $ \dbh -> 73 | do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 74 | rowdata @=? results 75 | 76 | testfetchRowAL = setup $ \dbh -> 77 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 78 | execute sth [] 79 | fetchRowAL sth >>= (Just (head alrows) @=?) 80 | fetchRowAL sth >>= (Just (alrows !! 1) @=?) 81 | fetchRowAL sth >>= (Just (alrows !! 2) @=?) 82 | fetchRowAL sth >>= (Nothing @=?) 83 | finish sth 84 | 85 | testfetchRowMap = setup $ \dbh -> 86 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 87 | execute sth [] 88 | fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) 89 | fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) 90 | fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) 91 | fetchRowMap sth >>= (Nothing @=?) 92 | finish sth 93 | 94 | testfetchAllRowsAL = setup $ \dbh -> 95 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 96 | execute sth [] 97 | fetchAllRowsAL sth >>= (alrows @=?) 98 | 99 | testfetchAllRowsMap = setup $ \dbh -> 100 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 101 | execute sth [] 102 | fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) 103 | 104 | testexception = setup $ \dbh -> 105 | catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" 106 | execute sth [] 107 | assertFailure "No exception was raised" 108 | ) 109 | (\e -> commit dbh) 110 | 111 | testrowcount = setup $ \dbh -> 112 | do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] 113 | assertEqual "UPDATE with no change" 0 r 114 | r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] 115 | assertEqual "UPDATE with 1 change" 1 r 116 | r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] 117 | assertEqual "UPDATE with 2 changes" 2 r 118 | commit dbh 119 | res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 120 | assertEqual "final results" 121 | [[SqlInt32 0, toSql "Testing", SqlInt32 26], 122 | [SqlInt32 1, toSql "Foo", SqlInt32 27], 123 | [SqlInt32 2, toSql "Bar", SqlInt32 27]] res 124 | 125 | {- Since we might be running against a live DB, we can't look at a specific 126 | list here (though a SpecificDB test case may be able to). We can ensure 127 | that our test table is, or is not, present, as appropriate. -} 128 | 129 | testgetTables1 = setup $ \dbh -> 130 | do r <- getTables dbh 131 | True @=? "hdbctest2" `elem` r 132 | 133 | testgetTables2 = dbTestCase $ \dbh -> 134 | do r <- getTables dbh 135 | False @=? "hdbctest2" `elem` r 136 | 137 | testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> 138 | do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 139 | rowdata @=? results 140 | 141 | testnulls = setup $ \dbh -> 142 | do let dn = hdbcDriverName dbh 143 | when (not (dn `elem` ["postgresql", "odbc"])) ( 144 | do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 145 | executeMany sth rows 146 | finish sth 147 | res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] 148 | seq (length res) rows @=? res 149 | ) 150 | where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], 151 | [SqlInt32 101, SqlString "bar\NUL", SqlNull], 152 | [SqlInt32 102, SqlString "\NUL", SqlNull], 153 | [SqlInt32 103, SqlString "\xFF", SqlNull], 154 | [SqlInt32 104, SqlString "regular", SqlNull]] 155 | 156 | testunicode = setup $ \dbh -> 157 | do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 158 | executeMany sth rows 159 | finish sth 160 | res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] 161 | seq (length res) rows @=? res 162 | where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], 163 | [SqlInt32 101, SqlString "bar\x00A3", SqlNull], 164 | [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] 165 | 166 | tests = TestList [TestLabel "getColumnNames" testgetColumnNames, 167 | TestLabel "describeResult" testdescribeResult, 168 | TestLabel "describeTable" testdescribeTable, 169 | TestLabel "quickQuery" testquickQuery, 170 | TestLabel "fetchRowAL" testfetchRowAL, 171 | TestLabel "fetchRowMap" testfetchRowMap, 172 | TestLabel "fetchAllRowsAL" testfetchAllRowsAL, 173 | TestLabel "fetchAllRowsMap" testfetchAllRowsMap, 174 | TestLabel "sql exception" testexception, 175 | TestLabel "clone" testclone, 176 | TestLabel "update rowcount" testrowcount, 177 | TestLabel "get tables1" testgetTables1, 178 | TestLabel "get tables2" testgetTables2, 179 | TestLabel "nulls" testnulls, 180 | TestLabel "unicode" testunicode] 181 | -------------------------------------------------------------------------------- /testsrc/TestSbasics.hs: -------------------------------------------------------------------------------- 1 | module TestSbasics(tests) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import System.IO 6 | import Control.Exception hiding (catch) 7 | 8 | openClosedb = sqlTestCase $ 9 | do dbh <- connectDB 10 | disconnect dbh 11 | 12 | multiFinish = dbTestCase (\dbh -> 13 | do sth <- prepare dbh "SELECT 1 + 1" 14 | sExecute sth [] 15 | finish sth 16 | finish sth 17 | finish sth 18 | ) 19 | 20 | runRawTest = dbTestCase (\dbh -> 21 | do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" 22 | tables <- getTables dbh 23 | assertBool "valid1 table not created!" ("valid1" `elem` tables) 24 | assertBool "valid2 table not created!" ("valid2" `elem` tables) 25 | ) 26 | 27 | 28 | runRawErrorTest = dbTestCase (\dbh -> 29 | do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` 30 | (return . seErrorMsg) 31 | assertEqual "exception text" "exec: near \"INVALID\": syntax error" err 32 | rollback dbh 33 | tables <- getTables dbh 34 | assertBool "valid1 table created!" (not $ "valid1" `elem` tables) 35 | ) 36 | 37 | basicQueries = dbTestCase (\dbh -> 38 | do sth <- prepare dbh "SELECT 1 + 1" 39 | sExecute sth [] 40 | sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) 41 | sFetchRow sth >>= (assertEqual "last row" Nothing) 42 | ) 43 | 44 | createTable = dbTestCase (\dbh -> 45 | do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] 46 | commit dbh 47 | ) 48 | 49 | dropTable = dbTestCase (\dbh -> 50 | do sRun dbh "DROP TABLE hdbctest1" [] 51 | commit dbh 52 | ) 53 | 54 | runReplace = dbTestCase (\dbh -> 55 | do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 56 | sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 57 | commit dbh 58 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" 59 | sExecute sth [] 60 | sFetchRow sth >>= (assertEqual "r1" (Just r1)) 61 | sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", 62 | Just "2", Nothing])) 63 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 64 | ) 65 | where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] 66 | r2 = [Just "runReplace", Just "2", Nothing] 67 | 68 | executeReplace = dbTestCase (\dbh -> 69 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" 70 | sExecute sth [Just "1", Just "1234", Just "Foo"] 71 | sExecute sth [Just "2", Nothing, Just "Bar"] 72 | commit dbh 73 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" 74 | sExecute sth [Just "executeReplace"] 75 | sFetchRow sth >>= (assertEqual "r1" 76 | (Just $ map Just ["executeReplace", "1", "1234", 77 | "Foo"])) 78 | sFetchRow sth >>= (assertEqual "r2" 79 | (Just [Just "executeReplace", Just "2", Nothing, 80 | Just "Bar"])) 81 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 82 | ) 83 | 84 | testExecuteMany = dbTestCase (\dbh -> 85 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" 86 | sExecuteMany sth rows 87 | commit dbh 88 | sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" 89 | sExecute sth [] 90 | mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows 91 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 92 | ) 93 | where rows = [map Just ["1", "1234", "foo"], 94 | map Just ["2", "1341", "bar"], 95 | [Just "3", Nothing, Nothing]] 96 | 97 | testsFetchAllRows = dbTestCase (\dbh -> 98 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" 99 | sExecuteMany sth rows 100 | commit dbh 101 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" 102 | sExecute sth [] 103 | results <- sFetchAllRows sth 104 | assertEqual "" rows results 105 | ) 106 | where rows = map (\x -> [Just . show $ x]) [1..9] 107 | 108 | basicTransactions = dbTestCase (\dbh -> 109 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 110 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" 111 | sExecute sth [Just "0"] 112 | commit dbh 113 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" 114 | sExecute qrysth [] 115 | sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) 116 | 117 | -- Now try a rollback 118 | sExecuteMany sth rows 119 | rollback dbh 120 | sExecute qrysth [] 121 | sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) 122 | 123 | -- Now try another commit 124 | sExecuteMany sth rows 125 | commit dbh 126 | sExecute qrysth [] 127 | sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) 128 | ) 129 | where rows = map (\x -> [Just . show $ x]) [1..9] 130 | 131 | testWithTransaction = dbTestCase (\dbh -> 132 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 133 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" 134 | sExecute sth [Just "0"] 135 | commit dbh 136 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" 137 | sExecute qrysth [] 138 | sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) 139 | 140 | -- Let's try a rollback. 141 | catch (withTransaction dbh (\_ -> do sExecuteMany sth rows 142 | fail "Foo")) 143 | (\_ -> return ()) 144 | sExecute qrysth [] 145 | sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) 146 | 147 | -- And now a commit. 148 | withTransaction dbh (\_ -> sExecuteMany sth rows) 149 | sExecute qrysth [] 150 | sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) 151 | ) 152 | where rows = map (\x -> [Just . show $ x]) [1..9] 153 | 154 | tests = TestList 155 | [ 156 | TestLabel "openClosedb" openClosedb, 157 | TestLabel "multiFinish" multiFinish, 158 | TestLabel "runRawTest" runRawTest, 159 | TestLabel "runRawErrorTest" runRawErrorTest, 160 | TestLabel "basicQueries" basicQueries, 161 | TestLabel "createTable" createTable, 162 | TestLabel "runReplace" runReplace, 163 | TestLabel "executeReplace" executeReplace, 164 | TestLabel "executeMany" testExecuteMany, 165 | TestLabel "sFetchAllRows" testsFetchAllRows, 166 | TestLabel "basicTransactions" basicTransactions, 167 | TestLabel "withTransaction" testWithTransaction, 168 | TestLabel "dropTable" dropTable 169 | ] 170 | -------------------------------------------------------------------------------- /testsrc/TestTime.hs: -------------------------------------------------------------------------------- 1 | module TestTime(tests) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import Control.Exception 6 | import Data.Time 7 | import Data.Time.LocalTime 8 | import Data.Time.Clock.POSIX 9 | import Data.Maybe 10 | import Data.Convertible 11 | import SpecificDB 12 | import System.Locale(defaultTimeLocale) 13 | import Database.HDBC.Locale (iso8601DateFormat) 14 | import qualified System.Time as ST 15 | 16 | instance Eq ZonedTime where 17 | a == b = zonedTimeToUTC a == zonedTimeToUTC b && 18 | zonedTimeZone a == zonedTimeZone b 19 | 20 | testZonedTime :: ZonedTime 21 | testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z")) 22 | "1989-08-01 15:33:01 -0500" 23 | 24 | testZonedTimeFrac :: ZonedTime 25 | testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) 26 | "1989-08-01 15:33:01.536 -0500" 27 | 28 | 29 | rowdata t = [[SqlInt32 100, toSql t, SqlNull]] 30 | 31 | testDTType inputdata convToSqlValue = dbTestCase $ \dbh -> 32 | do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ 33 | \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] 34 | finally (testIt dbh) (do commit dbh 35 | run dbh "DROP TABLE hdbctesttime" [] 36 | commit dbh 37 | ) 38 | where testIt dbh = 39 | do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" 40 | [iToSql 5, value] 41 | commit dbh 42 | r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] 43 | case r of 44 | [[testidsv, testvaluesv]] -> 45 | do assertEqual "testid" (5::Int) (fromSql testidsv) 46 | assertEqual "testvalue" inputdata (fromSql testvaluesv) 47 | value = convToSqlValue inputdata 48 | 49 | mkTest label inputdata convfunc = 50 | TestLabel label (testDTType inputdata convfunc) 51 | 52 | tests = TestList $ 53 | ((TestLabel "Non-frac" $ testIt testZonedTime) : 54 | if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) 55 | 56 | testIt baseZonedTime = 57 | TestList [mkTest "Day" baseDay toSql, 58 | mkTest "TimeOfDay" baseTimeOfDay toSql, 59 | mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql, 60 | mkTest "LocalTime" baseLocalTime toSql, 61 | mkTest "ZonedTime" baseZonedTime toSql, 62 | mkTest "UTCTime" baseUTCTime toSql, 63 | mkTest "DiffTime" baseDiffTime toSql, 64 | mkTest "POSIXTime" basePOSIXTime posixToSql, 65 | mkTest "ClockTime" baseClockTime toSql, 66 | mkTest "CalendarTime" baseCalendarTime toSql, 67 | mkTest "TimeDiff" baseTimeDiff toSql 68 | ] 69 | where 70 | baseDay :: Day 71 | baseDay = localDay baseLocalTime 72 | 73 | baseTimeOfDay :: TimeOfDay 74 | baseTimeOfDay = localTimeOfDay baseLocalTime 75 | 76 | baseZonedTimeOfDay :: (TimeOfDay, TimeZone) 77 | baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) 78 | 79 | baseLocalTime :: LocalTime 80 | baseLocalTime = zonedTimeToLocalTime baseZonedTime 81 | 82 | baseUTCTime :: UTCTime 83 | baseUTCTime = convert baseZonedTime 84 | 85 | baseDiffTime :: NominalDiffTime 86 | baseDiffTime = basePOSIXTime 87 | 88 | basePOSIXTime :: POSIXTime 89 | basePOSIXTime = convert baseZonedTime 90 | 91 | baseTimeDiff :: ST.TimeDiff 92 | baseTimeDiff = convert baseDiffTime 93 | 94 | -- No fractional parts for these two 95 | 96 | baseClockTime :: ST.ClockTime 97 | baseClockTime = convert testZonedTime 98 | 99 | baseCalendarTime :: ST.CalendarTime 100 | baseCalendarTime = convert testZonedTime 101 | -------------------------------------------------------------------------------- /testsrc/TestUtils.hs: -------------------------------------------------------------------------------- 1 | module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where 2 | import Database.HDBC 3 | import Test.HUnit 4 | import Control.Exception 5 | import SpecificDB(connectDB) 6 | 7 | sqlTestCase a = 8 | TestCase (handleSqlError a) 9 | 10 | dbTestCase a = 11 | TestCase (do dbh <- connectDB 12 | finally (handleSqlError (a dbh)) 13 | (handleSqlError (disconnect dbh)) 14 | ) 15 | 16 | printDBInfo = handleSqlError $ 17 | do dbh <- connectDB 18 | putStrLn "+-------------------------------------------------------------------------" 19 | putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ 20 | ", bound to client: " ++ hdbcClientVer dbh 21 | putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ 22 | ", bound to version: " ++ proxiedClientVer dbh 23 | putStrLn $ "| Connected to server version: " ++ dbServerVer dbh 24 | putStrLn "+-------------------------------------------------------------------------\n" 25 | disconnect dbh 26 | -------------------------------------------------------------------------------- /testsrc/Testbasics.hs: -------------------------------------------------------------------------------- 1 | module Testbasics(tests) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import System.IO 6 | import Control.Exception hiding (catch) 7 | 8 | openClosedb = sqlTestCase $ 9 | do dbh <- connectDB 10 | disconnect dbh 11 | 12 | multiFinish = dbTestCase (\dbh -> 13 | do sth <- prepare dbh "SELECT 1 + 1" 14 | r <- execute sth [] 15 | assertEqual "basic count" 0 r 16 | finish sth 17 | finish sth 18 | finish sth 19 | ) 20 | 21 | basicQueries = dbTestCase (\dbh -> 22 | do sth <- prepare dbh "SELECT 1 + 1" 23 | execute sth [] >>= (0 @=?) 24 | r <- fetchAllRows sth 25 | assertEqual "converted from" [["2"]] (map (map fromSql) r) 26 | assertEqual "int32 compare" [[SqlInt32 2]] r 27 | assertEqual "iToSql compare" [[iToSql 2]] r 28 | assertEqual "num compare" [[toSql (2::Int)]] r 29 | assertEqual "nToSql compare" [[nToSql (2::Int)]] r 30 | assertEqual "string compare" [[SqlString "2"]] r 31 | ) 32 | 33 | createTable = dbTestCase (\dbh -> 34 | do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] 35 | commit dbh 36 | ) 37 | 38 | dropTable = dbTestCase (\dbh -> 39 | do run dbh "DROP TABLE hdbctest1" [] 40 | commit dbh 41 | ) 42 | 43 | runReplace = dbTestCase (\dbh -> 44 | do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 45 | assertEqual "insert retval" 1 r 46 | run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 47 | commit dbh 48 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" 49 | rv2 <- execute sth [] 50 | assertEqual "select retval" 0 rv2 51 | r <- fetchAllRows sth 52 | assertEqual "" [r1, r2] r 53 | ) 54 | where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] 55 | r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] 56 | 57 | executeReplace = dbTestCase (\dbh -> 58 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" 59 | execute sth [iToSql 1, iToSql 1234, toSql "Foo"] 60 | execute sth [SqlInt32 2, SqlNull, toSql "Bar"] 61 | commit dbh 62 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" 63 | execute sth [SqlString "executeReplace"] 64 | r <- fetchAllRows sth 65 | assertEqual "result" 66 | [[toSql "executeReplace", iToSql 1, toSql "1234", 67 | toSql "Foo"], 68 | [toSql "executeReplace", iToSql 2, SqlNull, 69 | toSql "Bar"]] 70 | r 71 | ) 72 | 73 | testExecuteMany = dbTestCase (\dbh -> 74 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" 75 | executeMany sth rows 76 | commit dbh 77 | sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" 78 | execute sth [] 79 | r <- fetchAllRows sth 80 | assertEqual "" rows r 81 | ) 82 | where rows = [map toSql ["1", "1234", "foo"], 83 | map toSql ["2", "1341", "bar"], 84 | [toSql "3", SqlNull, SqlNull]] 85 | 86 | testFetchAllRows = dbTestCase (\dbh -> 87 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('fetchAllRows', ?, NULL, NULL)" 88 | executeMany sth rows 89 | commit dbh 90 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows' ORDER BY testid" 91 | execute sth [] 92 | results <- fetchAllRows sth 93 | assertEqual "" rows results 94 | ) 95 | where rows = map (\x -> [iToSql x]) [1..9] 96 | 97 | testFetchAllRows' = dbTestCase (\dbh -> 98 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('fetchAllRows2', ?, NULL, NULL)" 99 | executeMany sth rows 100 | commit dbh 101 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows2' ORDER BY testid" 102 | execute sth [] 103 | results <- fetchAllRows' sth 104 | assertEqual "" rows results 105 | ) 106 | where rows = map (\x -> [iToSql x]) [1..9] 107 | 108 | basicTransactions = dbTestCase (\dbh -> 109 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 110 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" 111 | execute sth [iToSql 0] 112 | commit dbh 113 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" 114 | execute qrysth [] 115 | fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) 116 | 117 | -- Now try a rollback 118 | executeMany sth rows 119 | rollback dbh 120 | execute qrysth [] 121 | fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) 122 | 123 | -- Now try another commit 124 | executeMany sth rows 125 | commit dbh 126 | execute qrysth [] 127 | fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) 128 | ) 129 | where rows = map (\x -> [iToSql $ x]) [1..9] 130 | 131 | testWithTransaction = dbTestCase (\dbh -> 132 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 133 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" 134 | execute sth [toSql "0"] 135 | commit dbh 136 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" 137 | execute qrysth [] 138 | fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) 139 | 140 | -- Let's try a rollback. 141 | catch (withTransaction dbh (\_ -> do executeMany sth rows 142 | fail "Foo")) 143 | (\_ -> return ()) 144 | execute qrysth [] 145 | fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) 146 | 147 | -- And now a commit. 148 | withTransaction dbh (\_ -> executeMany sth rows) 149 | execute qrysth [] 150 | fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) 151 | ) 152 | where rows = map (\x -> [iToSql x]) [1..9] 153 | 154 | tests = TestList 155 | [ 156 | TestLabel "openClosedb" openClosedb, 157 | TestLabel "multiFinish" multiFinish, 158 | TestLabel "basicQueries" basicQueries, 159 | TestLabel "createTable" createTable, 160 | TestLabel "runReplace" runReplace, 161 | TestLabel "executeReplace" executeReplace, 162 | TestLabel "executeMany" testExecuteMany, 163 | TestLabel "fetchAllRows" testFetchAllRows, 164 | TestLabel "fetchAllRows'" testFetchAllRows', 165 | TestLabel "basicTransactions" basicTransactions, 166 | TestLabel "withTransaction" testWithTransaction, 167 | TestLabel "dropTable" dropTable 168 | ] 169 | -------------------------------------------------------------------------------- /testsrc/Tests.hs: -------------------------------------------------------------------------------- 1 | {- arch-tag: Tests main file 2 | -} 3 | 4 | module Tests(tests) where 5 | import Test.HUnit 6 | import qualified Testbasics 7 | import qualified TestSbasics 8 | import qualified SpecificDBTests 9 | import qualified TestMisc 10 | import qualified TestTime 11 | 12 | test1 = TestCase ("x" @=? "x") 13 | 14 | tests = TestList [TestLabel "test1" test1, 15 | TestLabel "String basics" TestSbasics.tests, 16 | TestLabel "SqlValue basics" Testbasics.tests, 17 | TestLabel "SpecificDB" SpecificDBTests.tests, 18 | TestLabel "Misc tests" TestMisc.tests, 19 | TestLabel "Time tests" TestTime.tests] 20 | -------------------------------------------------------------------------------- /testsrc/runtests.hs: -------------------------------------------------------------------------------- 1 | {- arch-tag: Test runner 2 | -} 3 | 4 | module Main where 5 | 6 | import Test.HUnit 7 | import Tests 8 | import TestUtils 9 | 10 | main = do printDBInfo 11 | runTestTT tests 12 | 13 | --------------------------------------------------------------------------------