diff --git a/Database/HDBC/Sqlite3.hs b/Database/HDBC/Sqlite3.hs index e6cc8aa..75d041a 100644 --- a/Database/HDBC/Sqlite3.hs +++ b/Database/HDBC/Sqlite3.hs @@ -15,13 +15,17 @@ Written by John Goerzen, jgoerzen\@complete.org module Database.HDBC.Sqlite3 ( -- * Sqlite3 Basics - connectSqlite3, connectSqlite3Raw, Connection(), setBusyTimeout, + connectSqlite3, connectSqlite3Raw, connectSqlite3Ext, Connection(), + setBusyTimeout, -- * Sqlite3 Error Consts module Database.HDBC.Sqlite3.Consts ) where -import Database.HDBC.Sqlite3.Connection(connectSqlite3, connectSqlite3Raw, Connection()) +import Database.HDBC.Sqlite3.Connection( connectSqlite3 + , connectSqlite3Raw + , connectSqlite3Ext + , Connection()) import Database.HDBC.Sqlite3.ConnectionImpl(setBusyTimeout) import Database.HDBC.Sqlite3.Consts diff --git a/Database/HDBC/Sqlite3/Connection.hs b/Database/HDBC/Sqlite3/Connection.hs index e3f2dcd..df84915 100644 --- a/Database/HDBC/Sqlite3/Connection.hs +++ b/Database/HDBC/Sqlite3/Connection.hs @@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# CFILES hdbc-sqlite3-helper.c #-} -- above line for hugs module Database.HDBC.Sqlite3.Connection - (connectSqlite3, connectSqlite3Raw, Impl.Connection()) + ( connectSqlite3 + , connectSqlite3Raw + , connectSqlite3Ext + , Impl.Connection() + ) where import Database.HDBC.Types @@ -20,6 +25,7 @@ import Database.HDBC.Sqlite3.Utils import Foreign.ForeignPtr import Foreign.Ptr import Control.Concurrent.MVar +import Control.Exception (bracket) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import qualified Data.Char @@ -29,8 +35,7 @@ the filename of the database to connect to. All database accessor functions are provided in the main HDBC module. -} connectSqlite3 :: FilePath -> IO Impl.Connection -connectSqlite3 = - genericConnect (B.useAsCString . BUTF8.fromString) +connectSqlite3 = connectSqlite3Ext True False {- | Connects to a Sqlite v3 database as with 'connectSqlite3', but instead of converting the supplied 'FilePath' to a C String by performing @@ -38,65 +43,97 @@ a conversion to Unicode, instead converts it by simply dropping all bits past the eighth. This may be useful in rare situations if your application or filesystemare not running in Unicode space. -} connectSqlite3Raw :: FilePath -> IO Impl.Connection -connectSqlite3Raw = genericConnect withCString +connectSqlite3Raw = connectSqlite3Ext True True + +{- | Connect to an Sqlite version 3 database as with connectSqlite3, but if +auto-finish is disabled, HDBC will not auto-finish prepared statements after +the last row is fetched. Keeping the statement in its prepared state improves +the performance of repeated execution of cached prepared statements, and +eliminates the overhead of tracking open statement handles by HDBC. + +With auto-finish disabled, the application is responsible for explicitly +finishing all application prepared statements before @disconnect@ is called. +Otherwise, the SQLite3 database may, at that time, throw an exception when +some prepared statements are still open, they may not be finalized in time +via garbage collection even if they are already out of scope. + +The filesystem in which the database resides is by default assumed to support +UTF-8 filenames. If that's not the case, set @raw@ to 'True' and provide a +'FilePath` that holds the byte encoding of the native filename. -} +connectSqlite3Ext :: Bool -- ^ Auto-finish statements + -> Bool -- ^ If true Raw 8-bit name encoding else UTF-8 + -> FilePath -- ^ Database file name + -> IO Impl.Connection +connectSqlite3Ext auto raw = + let nameDecoder = if raw then withCString + else (B.useAsCString . BUTF8.fromString) + in genericConnect nameDecoder auto raw genericConnect :: (String -> (CString -> IO Impl.Connection) -> IO Impl.Connection) + -> Bool + -> Bool -> FilePath -> IO Impl.Connection -genericConnect strAsCStrFunc fp = +genericConnect strAsCStrFunc auto raw fp = strAsCStrFunc fp (\cs -> alloca (\(p::Ptr (Ptr CSqlite3)) -> do res <- sqlite3_open cs p o <- peek p fptr <- newForeignPtr sqlite3_closeptr o - newconn <- mkConn fp fptr + newconn <- mkConn fp fptr auto raw checkError ("connectSqlite3 " ++ fp) fptr res return newconn ) ) -mkConn :: FilePath -> Sqlite3 -> IO Impl.Connection -mkConn fp obj = - do children <- newMVar [] - begin_transaction obj children +mkConn :: FilePath -> Sqlite3 -> Bool -> Bool -> IO Impl.Connection +mkConn fp obj auto raw = do + children <- if auto + then Just <$> newMVar [] + else return Nothing + fexecuteRaw obj "BEGIN" + + let alltables = "SELECT name\ + \ FROM sqlite_master\ + \ WHERE type='table'\ + \ ORDER BY name" + ver <- (sqlite3_libversion >>= peekCString) return $ Impl.Connection { Impl.disconnect = fdisconnect obj children, - Impl.commit = fcommit obj children, - Impl.rollback = frollback obj children, - Impl.run = frun obj children, - Impl.runRaw = frunRaw obj children, - Impl.prepare = newSth obj children True, - Impl.clone = connectSqlite3 fp, + Impl.commit = newtransaction obj "COMMIT", + Impl.rollback = newtransaction obj "ROLLBACK", + Impl.run = frun obj, + Impl.runRaw = fexecuteRaw obj, + Impl.prepare = newSth obj children auto, + Impl.clone = connectSqlite3Ext auto raw fp, Impl.hdbcDriverName = "sqlite3", Impl.hdbcClientVer = ver, Impl.proxiedClientName = "sqlite3", Impl.proxiedClientVer = ver, Impl.dbTransactionSupport = True, Impl.dbServerVer = ver, - Impl.getTables = fgettables obj children, - Impl.describeTable = fdescribeTable obj children, - Impl.setBusyTimeout = fsetbusy obj} - -fgettables o mchildren = - do sth <- newSth o mchildren True "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" - execute sth [] - res1 <- fetchAllRows' sth - let res = map fromSql $ concat res1 - return $ seq (length res) res - -fdescribeTable o mchildren name = do - sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")" - execute sth [] - res1 <- fetchAllRows' sth - return $ map describeCol res1 + Impl.getTables = fgettables obj alltables, + Impl.describeTable = fdescribeTable obj, + Impl.setBusyTimeout = fsetbusy obj } + +fgettables :: Sqlite3 -> String -> IO [String] +fgettables obj query = + bracket (newSth obj Nothing False query) + (finish) $ \sth -> do + res <- execute sth [] >> fetchAllRows' sth + return $ map fromSql $ concat res + +fdescribeTable :: Sqlite3 -> String -> IO [(String, SqlColDesc)] +fdescribeTable o name = do + sth <- newSth o Nothing False $ "PRAGMA table_info(" ++ name ++ ")" + res <- execute sth [] *> fetchAllRows' sth <* finish sth + return [ (fromSql nm, describeType typ notnull df pk) + | (_:nm:typ:notnull:df:pk:_) <- res ] where - describeCol (_:name:typ:notnull:df:pk:_) = - (fromSql name, describeType typ notnull df pk) - - describeType name notnull df pk = - SqlColDesc (typeId name) Nothing Nothing Nothing (nullable notnull) + describeType nm notnull _ _ = + SqlColDesc (typeId nm) Nothing Nothing Nothing (nullable notnull) nullable SqlNull = Nothing nullable (SqlString "0") = Just True @@ -120,6 +157,7 @@ fdescribeTable o mchildren name = do other -> SqlUnknownT other +fsetbusy :: Sqlite3 -> CInt -> IO () fsetbusy o ms = withRawSqlite3 o $ \ppdb -> sqlite3_busy_timeout ppdb ms @@ -127,29 +165,19 @@ fsetbusy o ms = withRawSqlite3 o $ \ppdb -> -- Guts here -------------------------------------------------- -begin_transaction :: Sqlite3 -> ChildList -> IO () -begin_transaction o children = frun o children "BEGIN" [] >> return () - -frun o mchildren query args = - do sth <- newSth o mchildren False query - res <- execute sth args - finish sth - return res - -frunRaw :: Sqlite3 -> ChildList -> String -> IO () -frunRaw o mchildren query = - do sth <- newSth o mchildren False query - executeRaw sth - finish sth - -fcommit o children = do frun o children "COMMIT" [] - begin_transaction o children -frollback o children = do frun o children "ROLLBACK" [] - begin_transaction o children - -fdisconnect :: Sqlite3 -> ChildList -> IO () -fdisconnect o mchildren = withRawSqlite3 o $ \p -> - do closeAllChildren mchildren +frun :: Sqlite3 -> String -> [SqlValue] -> IO Integer +frun o query args = + bracket (newSth o Nothing False query) + (finish) + (flip execute args) + +newtransaction :: Sqlite3 -> String -> IO () +newtransaction obj how = fexecuteRaw obj how >> fexecuteRaw obj "BEGIN" + +fdisconnect :: Sqlite3 -> Maybe ChildList -> IO () +fdisconnect o mchildren = + withRawSqlite3 o $ \p -> do + mapM_ closeAllChildren mchildren r <- sqlite3_close p checkError "disconnect" o r diff --git a/Database/HDBC/Sqlite3/Consts.hsc b/Database/HDBC/Sqlite3/Consts.hsc index 23ba9db..22cb23f 100644 --- a/Database/HDBC/Sqlite3/Consts.hsc +++ b/Database/HDBC/Sqlite3/Consts.hsc @@ -31,8 +31,6 @@ module Database.HDBC.Sqlite3.Consts sqlite_DONE) where -import Foreign.C.Types - #include -- | Successful result diff --git a/Database/HDBC/Sqlite3/Statement.hsc b/Database/HDBC/Sqlite3/Statement.hsc index 46bbaaf..cb868cd 100644 --- a/Database/HDBC/Sqlite3/Statement.hsc +++ b/Database/HDBC/Sqlite3/Statement.hsc @@ -17,7 +17,7 @@ import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Data.List -import Control.Exception +import Data.Int (Int64) import Database.HDBC.DriverUtils #include @@ -26,7 +26,7 @@ import Database.HDBC.DriverUtils fail if there are any active statements. This is highly annoying, and makes for some somewhat complex algorithms. -} -data StoState = Empty -- ^ Not initialized or last execute\/fetchrow had no results +data StoState = Empty -- ^ Not initialized or auto-finished | Prepared Stmt -- ^ Prepared but not executed | Executed Stmt -- ^ Executed and more rows are expected | Exhausted Stmt -- ^ Executed and at end of rows @@ -43,27 +43,45 @@ data SState = SState {dbo :: Sqlite3, colnamesmv :: MVar [String], autoFinish :: Bool} -newSth :: Sqlite3 -> ChildList -> Bool -> String -> IO Statement -newSth indbo mchildren autoFinish str = +newSth :: Sqlite3 -> Maybe ChildList -> Bool -> String -> IO Statement +newSth indbo mchildren auto str = do newstomv <- newMVar Empty newcolnamesmv <- newMVar [] let sstate = SState{dbo = indbo, stomv = newstomv, querys = str, colnamesmv = newcolnamesmv, - autoFinish = autoFinish} - modifyMVar_ (stomv sstate) (\_ -> (fprepare sstate >>= return . Prepared)) - let retval = - Statement {execute = fexecute sstate, + autoFinish = auto} + retval = + Statement { execute = fexecute sstate, executeRaw = fexecuteRaw indbo str, executeMany = fexecutemany sstate, finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = str, - getColumnNames = readMVar (colnamesmv sstate), + getColumnNames = getcols sstate, describeResult = fail "Sqlite3 backend does not support describeResult"} - addChild mchildren retval + modifyMVar_ newstomv $ const $ Prepared <$> fprepare sstate + mapM_ (flip addChild retval) mchildren return retval + where + -- Fetching the column names from Sqlite3 requires the statement to + -- be in a prepared state. + -- + -- With auto-finish off, the statement will stay prepared, and we'll + -- always fetch "live" column data. With auto-finish on, we save + -- the column names each time we prepare, as they could be requested + -- after the statement was automatically finished when returning the + -- last row. + -- + getcols :: SState -> IO [String] + getcols sstate = readMVar (stomv sstate) >>= stocols sstate + + stocols :: SState -> StoState -> IO [String] + stocols _ (Prepared sto) = withStmt sto $ fgetcolnames + stocols _ (Executed sto) = withStmt sto $ fgetcolnames + stocols _ (Exhausted sto) = withStmt sto $ fgetcolnames + stocols sstate Empty = readMVar (colnamesmv sstate) {- The deal with adding the \0 below is in response to an apparent bug in sqlite3. See debian bug #343736. @@ -73,8 +91,8 @@ been terminated. (FIXME: should check this at runtime.... never run fprepare unless state is Empty) -} fprepare :: SState -> IO Stmt -fprepare sstate = withRawSqlite3 (dbo sstate) - (\p -> B.useAsCStringLen (BUTF8.fromString ((querys sstate) ++ "\0")) +fprepare sstate = withRawSqlite3 (dbo sstate) $ \p -> do + s <- B.useAsCStringLen (BUTF8.fromString ((querys sstate) ++ "\0")) (\(cs, cslen) -> alloca (\(newp::Ptr (Ptr CStmt)) -> (do res <- sqlite3_prepare p cs (fromIntegral cslen) newp nullPtr @@ -83,10 +101,11 @@ fprepare sstate = withRawSqlite3 (dbo sstate) newo <- peek newp newForeignPtr sqlite3_finalizeptr newo ) - ) - ) + ) ) - + modifyMVar_ (colnamesmv sstate) $ const $ withStmt s $ fgetcolnames + return s + {- General algorithm: find out how many columns we have, check the type of each to see if it's NULL. If it's not, fetch it as text and return that. @@ -109,49 +128,50 @@ ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow if r then return (Executed sto, Just res) else if (autoFinish sstate) - then do ffinish (dbo sstate) sto + then do ffinish sstate sto return (Empty, Just res) - else return (Exhausted sto, Just res) + else do r' <- sqlite3_reset p + checkError "(fetch) reset" (dbo sstate) r' + return (Exhausted sto, Just res) ) dofetchrow (Exhausted sto) = return (Exhausted sto, Nothing) getCol p icol = do t <- sqlite3_column_type p icol - if t == #{const SQLITE_NULL} - then return SqlNull - else do text <- sqlite3_column_text p icol - len <- sqlite3_column_bytes p icol - s <- B.packCStringLen (text, fromIntegral len) - case t of - #{const SQLITE_INTEGER} -> return $ SqlInt64 (read $ BUTF8.toString s) - #{const SQLITE_FLOAT} -> return $ SqlDouble (read $ BUTF8.toString s) - #{const SQLITE_BLOB} -> return $ SqlByteString s - #{const SQLITE_TEXT} -> return $ SqlByteString s - _ -> return $ SqlByteString s + case t of + #{const SQLITE_NULL} -> return SqlNull + #{const SQLITE_INTEGER} -> SqlInt64 <$> sqlite3_column_int64 p icol + #{const SQLITE_FLOAT} -> SqlDouble <$> sqlite3_column_double p icol + _ -> SqlByteString <$> getbytes p icol + + getbytes p icol = + do str <- sqlite3_column_text p icol + len <- sqlite3_column_bytes p icol + B.packCStringLen (str, fromIntegral len) + fstep :: Sqlite3 -> Ptr CStmt -> IO Bool -fstep dbo p = +fstep db p = do r <- sqlite3_step p case r of #{const SQLITE_ROW} -> return True #{const SQLITE_DONE} -> return False - #{const SQLITE_ERROR} -> checkError "step" dbo #{const SQLITE_ERROR} + #{const SQLITE_ERROR} -> checkError "step" db #{const SQLITE_ERROR} >> (throwSqlError $ SqlError {seState = "", seNativeError = 0, seErrorMsg = "In HDBC step, internal processing error (got SQLITE_ERROR with no error)"}) - x -> checkError "step" dbo x + x -> checkError "step" db x >> (throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral x, seErrorMsg = "In HDBC step, internal processing error (got error code with no error)"}) +fexecute :: SState -> [SqlValue] -> IO Integer fexecute sstate args = modifyMVar (stomv sstate) doexecute where doexecute (Executed sto) = doexecute (Prepared sto) doexecute (Exhausted sto) = doexecute (Prepared sto) - doexecute Empty = -- already cleaned up from last time - do sto <- fprepare sstate - doexecute (Prepared sto) + doexecute Empty = doexecute =<< Prepared <$> fprepare sstate doexecute (Prepared sto) = withStmt sto (\p -> do c <- sqlite3_bind_parameter_count p when (c /= genericLength args) @@ -175,11 +195,10 @@ fexecute sstate args = modifyMVar (stomv sstate) doexecute changes <- if origtc == newtc then return 0 else withSqlite3 (dbo sstate) sqlite3_changes - fgetcolnames p >>= swapMVar (colnamesmv sstate) if r then return (Executed sto, fromIntegral changes) else if (autoFinish sstate) - then do ffinish (dbo sstate) sto + then do ffinish sstate sto return (Empty, fromIntegral changes) else return (Exhausted sto, fromIntegral changes) ) @@ -197,15 +216,15 @@ fexecute sstate args = modifyMVar (stomv sstate) doexecute (show i) ++ ")") (dbo sstate) r fexecuteRaw :: Sqlite3 -> String -> IO () -fexecuteRaw dbo query = - withSqlite3 dbo +fexecuteRaw db query = + withSqlite3 db (\p -> B.useAsCStringLen (BUTF8.fromString (query ++ "\0")) - (\(cs, cslen) -> do + (\(cs, _) -> do result <- sqlite3_exec p cs nullFunPtr nullPtr nullPtr case result of #{const SQLITE_OK} -> return () s -> do - checkError "exec" dbo s + checkError "exec" db s throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral s, @@ -213,32 +232,40 @@ fexecuteRaw dbo query = ) ) +fgetcolnames :: Ptr CStmt -> IO [String] fgetcolnames csth = do count <- sqlite3_column_count csth mapM (getCol csth) [0..(count -1)] - where getCol csth i = - do cstr <- sqlite3_column_name csth i - bs <- B.packCString cstr - return (BUTF8.toString bs) - -fexecutemany _ [] = return () -fexecutemany sstate (args:[]) = - do fexecute sstate args - return () -fexecutemany sstate (args:arglist) = - do fexecute (sstate { autoFinish = False }) args - fexecutemany sstate arglist - ---ffinish o = withForeignPtr o (\p -> sqlite3_finalize p >>= checkError "finish") + where + getCol s i = + BUTF8.toString <$> (B.packCString =<< sqlite3_column_name s i) + +-- When auto-finish is enabled, the final argument vector is executed with the +-- true value of the auto-finish flag, while for any other initial vectors the +-- auto-finish flag appears disabled. Perhaps we should find a way to detect +-- misuse of this interface for queries, as only the results of the final +-- query are seen by the caller, and any prior results are reset unread. +-- +fexecutemany :: SState -> [[SqlValue]] -> IO () +fexecutemany s@(SState{autoFinish=False}) vs = mapM_ (fexecute s) vs +fexecutemany s vs@(_:[]) = mapM_ (fexecute s) vs +fexecutemany s vs = go (s {autoFinish=False}) s vs + where + go _ t (args:[]) = fexecute t args >>= const (return ()) + go i t (args:more) = fexecute i args >>= const (go i t more) + go _ _ [] = return () + -- Finish and change state +public_ffinish :: SState -> IO () public_ffinish sstate = modifyMVar_ (stomv sstate) worker where worker (Empty) = return Empty - worker (Prepared sto) = ffinish (dbo sstate) sto >> return Empty - worker (Executed sto) = ffinish (dbo sstate) sto >> return Empty - worker (Exhausted sto) = ffinish (dbo sstate) sto >> return Empty + worker (Prepared sto) = ffinish sstate sto >> return Empty + worker (Executed sto) = ffinish sstate sto >> return Empty + worker (Exhausted sto) = ffinish sstate sto >> return Empty -ffinish dbo o = withRawStmt o (\p -> do r <- sqlite3_finalize p - checkError "finish" dbo r) +ffinish :: SState -> Stmt -> IO () +ffinish sstate sto = withRawStmt sto $ \p -> + sqlite3_finalize p >>= checkError "finish" (dbo sstate) foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_finalize_finalizer" sqlite3_finalizeptr :: FunPtr ((Ptr CStmt) -> IO ()) @@ -281,6 +308,12 @@ foreign import ccall unsafe "sqlite3.h sqlite3_column_text" foreign import ccall unsafe "sqlite3.h sqlite3_column_bytes" sqlite3_column_bytes :: (Ptr CStmt) -> CInt -> IO CInt +foreign import ccall unsafe "sqlite3.h sqlite3_column_int64" + sqlite3_column_int64 :: (Ptr CStmt) -> CInt -> IO Int64 + +foreign import ccall unsafe "sqlite3.h sqlite3_column_double" + sqlite3_column_double :: (Ptr CStmt) -> CInt -> IO Double + foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_bind_text2" sqlite3_bind_text2 :: (Ptr CStmt) -> CInt -> CString -> CInt -> IO CInt diff --git a/Database/HDBC/Sqlite3/Utils.hsc b/Database/HDBC/Sqlite3/Utils.hsc index 38c2d80..13e4c32 100644 --- a/Database/HDBC/Sqlite3/Utils.hsc +++ b/Database/HDBC/Sqlite3/Utils.hsc @@ -12,7 +12,6 @@ import Database.HDBC.Sqlite3.Types import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Foreign.C.Types -import Control.Exception import Foreign.Storable #include "hdbc-sqlite3-helper.h" diff --git a/HDBC-sqlite3.cabal b/HDBC-sqlite3.cabal index d1f51ca..321a048 100644 --- a/HDBC-sqlite3.cabal +++ b/HDBC-sqlite3.cabal @@ -35,7 +35,7 @@ Library Database.HDBC.Sqlite3.Types, Database.HDBC.Sqlite3.Utils, Database.HDBC.Sqlite3.Consts - GHC-Options: -O2 + GHC-Options: -O2 -Wall Extensions: ExistentialQuantification, ForeignFunctionInterface, EmptyDataDecls, @@ -45,8 +45,13 @@ Library Executable runtests if flag(buildtests) Buildable: True - Build-Depends: HUnit, testpack, containers, convertible, - old-time, time, old-locale + Build-Depends: HUnit + , QuickCheck + , testpack + , template-haskell + , containers + , convertible + , time else Buildable: False Main-Is: runtests.hs @@ -54,9 +59,11 @@ Executable runtests SpecificDBTests, TestMisc, TestSbasics, + TestTime, TestUtils, Testbasics, Tests, + Database.HDBC.Sqlite3, Database.HDBC.Sqlite3.Connection, Database.HDBC.Sqlite3.ConnectionImpl, Database.HDBC.Sqlite3.Statement, @@ -67,7 +74,7 @@ Executable runtests include-dirs: . Extra-Libraries: sqlite3 Hs-Source-Dirs: ., testsrc - GHC-Options: -O2 + GHC-Options: -O2 -Wall Extensions: ExistentialQuantification, ForeignFunctionInterface, EmptyDataDecls, diff --git a/hdbc-sqlite3-helper.c b/hdbc-sqlite3-helper.c index 502185a..c708b0d 100644 --- a/hdbc-sqlite3-helper.c +++ b/hdbc-sqlite3-helper.c @@ -81,7 +81,7 @@ int sqlite3_prepare2(finalizeonce *fdb, const char *zSql, int nBytes, finalizeonce **ppo, const char **pzTail) { - sqlite3_stmt *ppst; + sqlite3_stmt *ppst = NULL; sqlite3 *db; finalizeonce *newobj; int res; diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..771aa18 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-6.35 +extra-deps: +- testpack-2.1.3.0 +- HUnit-1.2.5.2 +- QuickCheck-2.7.6 +- template-haskell-2.10.0.0 +flags: {} +extra-package-dbs: [] diff --git a/testsrc/SpecificDB.hs b/testsrc/SpecificDB.hs index 3989a43..fd851cf 100644 --- a/testsrc/SpecificDB.hs +++ b/testsrc/SpecificDB.hs @@ -1,14 +1,19 @@ module SpecificDB where import Database.HDBC import Database.HDBC.Sqlite3 -import Test.HUnit +connectDB :: IO Connection connectDB = handleSqlError (connectSqlite3 "testtmp.sql3") +connectDBExt :: Bool -> IO Connection +connectDBExt auto = + handleSqlError (connectSqlite3Ext auto False "testtmp.sql3") + dateTimeTypeOfSqlValue :: SqlValue -> String dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "TEXT" dateTimeTypeOfSqlValue (SqlEpochTime _) = "INTEGER" dateTimeTypeOfSqlValue _ = "TEXT" -supportsFracTime = True \ No newline at end of file +supportsFracTime :: Bool +supportsFracTime = True diff --git a/testsrc/SpecificDBTests.hs b/testsrc/SpecificDBTests.hs index 18296c1..536f802 100644 --- a/testsrc/SpecificDBTests.hs +++ b/testsrc/SpecificDBTests.hs @@ -1,11 +1,14 @@ module SpecificDBTests where import Database.HDBC -import Database.HDBC.Sqlite3 import Test.HUnit import TestMisc(setup) -testgetTables = setup $ \dbh -> +testgetTables :: Bool -> Test +testgetTables auto = setup auto $ \dbh -> do r <- getTables dbh ["hdbctest2"] @=? r -tests = TestList [TestLabel "getTables" testgetTables] +tests :: Test +tests = TestList [ TestLabel "getTables auto-finish on" (testgetTables True) + , TestLabel "getTables auto-finish off" (testgetTables False) + ] diff --git a/testsrc/TestMisc.hs b/testsrc/TestMisc.hs index 9429237..32e95b7 100644 --- a/testsrc/TestMisc.hs +++ b/testsrc/TestMisc.hs @@ -1,48 +1,63 @@ module TestMisc(tests, setup) where import Test.HUnit import Database.HDBC +import Database.HDBC.Sqlite3 import TestUtils -import System.IO import Control.Exception import Data.Char import Control.Monad import qualified Data.Map as Map +rowdata :: [[SqlValue]] rowdata = [[SqlInt32 0, toSql "Testing", SqlNull], [SqlInt32 1, toSql "Foo", SqlInt32 5], [SqlInt32 2, toSql "Bar", SqlInt32 9]] +colnames :: [String] colnames = ["testid", "teststring", "testint"] alrows :: [[(String, SqlValue)]] alrows = map (zip colnames) rowdata -setup f = dbTestCase $ \dbh -> - do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] +setup :: Bool -> (Connection -> IO ()) -> Test +setup auto f = dbTestCaseExt auto $ \dbh -> + do _ <- run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" executeMany sth rowdata + when (not auto) $ finish sth commit dbh finally (f dbh) - (do run dbh "DROP TABLE hdbctest2" [] + (do _ <- run dbh "DROP TABLE hdbctest2" [] commit dbh ) +safeQuickQuery' :: Connection -> String -> [SqlValue] -> IO [[SqlValue]] +safeQuickQuery' conn query args = do + bracket (prepare conn query) + (finish) $ \sth -> do + _ <- execute sth args + fetchAllRows' sth + +cloneTest :: forall b conn. IConnection conn => + conn -> (conn -> IO b) -> IO b cloneTest dbh a = do dbh2 <- clone dbh finally (handleSqlError (a dbh2)) (handleSqlError (disconnect dbh2)) -testgetColumnNames = setup $ \dbh -> +testgetColumnNames :: Bool -> Test +testgetColumnNames auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2" - execute sth [] + _ <- execute sth [] cols <- getColumnNames sth finish sth ["testid", "teststring", "testint"] @=? map (map toLower) cols -testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` +testdescribeResult :: Bool -> Test +testdescribeResult auto = setup auto $ \dbh -> when (not ((hdbcDriverName dbh) `elem` ["sqlite3"])) $ do sth <- prepare dbh "SELECT * from hdbctest2" - execute sth [] + _ <- execute sth [] cols <- describeResult sth ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols let coldata = map snd cols @@ -54,7 +69,8 @@ testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) finish sth -testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` +testdescribeTable :: Bool -> Test +testdescribeTable auto = setup auto $ \dbh -> when (not ((hdbcDriverName dbh) `elem` ["sqlite3"])) $ do cols <- describeTable dbh "hdbctest2" ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols @@ -69,54 +85,66 @@ testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) -testquickQuery = setup $ \dbh -> +-- Quick query creates a hidden prepared statement in the parent HDBC +-- library, and is not suitable for use without auto-finish. +testquickQuery :: Bool -> Test +testquickQuery _ = setup True $ \dbh -> do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] rowdata @=? results -testfetchRowAL = setup $ \dbh -> +testfetchRowAL :: Bool -> Test +testfetchRowAL auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchRowAL sth >>= (Just (head alrows) @=?) fetchRowAL sth >>= (Just (alrows !! 1) @=?) fetchRowAL sth >>= (Just (alrows !! 2) @=?) fetchRowAL sth >>= (Nothing @=?) finish sth -testfetchRowMap = setup $ \dbh -> +testfetchRowMap :: Bool -> Test +testfetchRowMap auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) fetchRowMap sth >>= (Nothing @=?) finish sth -testfetchAllRowsAL = setup $ \dbh -> +testfetchAllRowsAL :: Bool -> Test +testfetchAllRowsAL auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchAllRowsAL sth >>= (alrows @=?) + when (not auto) $ finish sth -testfetchAllRowsMap = setup $ \dbh -> +testfetchAllRowsMap :: Bool -> Test +testfetchAllRowsMap auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) + when (not auto) $ finish sth -testexception = setup $ \dbh -> - catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" - execute sth [] +testexception :: Bool -> Test +testexception auto = setup auto $ \dbh -> + catchSql (do bracket (prepare dbh "SELECT invalidcol FROM hdbctest2") + (finish) + (flip execute []) >> return () assertFailure "No exception was raised" ) - (\e -> commit dbh) + (\_ -> commit dbh) -testrowcount = setup $ \dbh -> +testrowcount :: Bool -> Test +testrowcount auto = setup auto $ \dbh -> do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] assertEqual "UPDATE with no change" 0 r - r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] - assertEqual "UPDATE with 1 change" 1 r - r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] - assertEqual "UPDATE with 2 changes" 2 r + r' <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] + assertEqual "UPDATE with 1 change" 1 r' + r'' <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] + assertEqual "UPDATE with 2 changes" 2 r'' commit dbh - res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + res <- safeQuickQuery' dbh "SELECT * from hdbctest2 ORDER BY testid" [] assertEqual "final results" [[SqlInt32 0, toSql "Testing", SqlInt32 26], [SqlInt32 1, toSql "Foo", SqlInt32 27], @@ -126,26 +154,30 @@ testrowcount = setup $ \dbh -> list here (though a SpecificDB test case may be able to). We can ensure that our test table is, or is not, present, as appropriate. -} -testgetTables1 = setup $ \dbh -> +testgetTables1 :: Bool -> Test +testgetTables1 auto = setup auto $ \dbh -> do r <- getTables dbh True @=? "hdbctest2" `elem` r -testgetTables2 = dbTestCase $ \dbh -> +testgetTables2 :: Bool -> Test +testgetTables2 auto = dbTestCaseExt auto $ \dbh -> do r <- getTables dbh False @=? "hdbctest2" `elem` r -testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> - do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] +testclone :: Bool -> Test +testclone auto = setup auto $ \dbho -> cloneTest dbho $ \dbh -> + do results <- safeQuickQuery' dbh "SELECT * from hdbctest2 ORDER BY testid" [] rowdata @=? results -testnulls = setup $ \dbh -> +testnulls :: Bool -> Test +testnulls auto = setup auto $ \dbh -> do let dn = hdbcDriverName dbh when (not (dn `elem` ["postgresql", "odbc"])) ( do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" executeMany sth rows finish sth - res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] - seq (length res) rows @=? res + res <- safeQuickQuery' dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + rows @=? res ) where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], [SqlInt32 101, SqlString "bar\NUL", SqlNull], @@ -153,28 +185,37 @@ testnulls = setup $ \dbh -> [SqlInt32 103, SqlString "\xFF", SqlNull], [SqlInt32 104, SqlString "regular", SqlNull]] -testunicode = setup $ \dbh -> +testunicode :: Bool -> Test +testunicode auto = setup auto $ \dbh -> do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" executeMany sth rows finish sth - res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] - seq (length res) rows @=? res + res <- safeQuickQuery' dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + rows @=? res where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], [SqlInt32 101, SqlString "bar\x00A3", SqlNull], [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] -tests = TestList [TestLabel "getColumnNames" testgetColumnNames, - TestLabel "describeResult" testdescribeResult, - TestLabel "describeTable" testdescribeTable, - TestLabel "quickQuery" testquickQuery, - TestLabel "fetchRowAL" testfetchRowAL, - TestLabel "fetchRowMap" testfetchRowMap, - TestLabel "fetchAllRowsAL" testfetchAllRowsAL, - TestLabel "fetchAllRowsMap" testfetchAllRowsMap, - TestLabel "sql exception" testexception, - TestLabel "clone" testclone, - TestLabel "update rowcount" testrowcount, - TestLabel "get tables1" testgetTables1, - TestLabel "get tables2" testgetTables2, - TestLabel "nulls" testnulls, - TestLabel "unicode" testunicode] +autoTests :: Bool -> Test +autoTests auto = TestList + [ TestLabel "getColumnNames" (testgetColumnNames auto) + , TestLabel "describeResult" (testdescribeResult auto) + , TestLabel "describeTable" (testdescribeTable auto) + , TestLabel "quickQuery" (testquickQuery auto) + , TestLabel "fetchRowAL" (testfetchRowAL auto) + , TestLabel "fetchRowMap" (testfetchRowMap auto) + , TestLabel "fetchAllRowsAL" (testfetchAllRowsAL auto) + , TestLabel "fetchAllRowsMap" (testfetchAllRowsMap auto) + , TestLabel "sql exception" (testexception auto) + , TestLabel "clone" (testclone auto) + , TestLabel "update rowcount" (testrowcount auto) + , TestLabel "get tables1" (testgetTables1 auto) + , TestLabel "get tables2" (testgetTables2 auto) + , TestLabel "nulls" (testnulls auto) + , TestLabel "unicode" (testunicode auto) + ] + +tests :: Test +tests = TestList [ TestLabel "auto-finish on" (autoTests True) + , TestLabel "auto-finish off" (autoTests False) + ] diff --git a/testsrc/TestSbasics.hs b/testsrc/TestSbasics.hs index 2a449db..414e124 100644 --- a/testsrc/TestSbasics.hs +++ b/testsrc/TestSbasics.hs @@ -2,21 +2,23 @@ module TestSbasics(tests) where import Test.HUnit import Database.HDBC import TestUtils -import System.IO -import Control.Exception hiding (catch) +import Control.Exception +openClosedb :: Test openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh +multiFinish :: Test multiFinish = dbTestCase (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" - sExecute sth [] + _ <- sExecute sth [] finish sth finish sth finish sth ) +runRawTest :: Test runRawTest = dbTestCase (\dbh -> do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" tables <- getTables dbh @@ -25,6 +27,7 @@ runRawTest = dbTestCase (\dbh -> ) +runRawErrorTest :: Test runRawErrorTest = dbTestCase (\dbh -> do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` (return . seErrorMsg) @@ -34,29 +37,33 @@ runRawErrorTest = dbTestCase (\dbh -> assertBool "valid1 table created!" (not $ "valid1" `elem` tables) ) +basicQueries :: Test basicQueries = dbTestCase (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" - sExecute sth [] + _ <- sExecute sth [] sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) sFetchRow sth >>= (assertEqual "last row" Nothing) ) +createTable :: Test createTable = dbTestCase (\dbh -> - do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + do _ <- sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] commit dbh ) +dropTable :: Test dropTable = dbTestCase (\dbh -> - do sRun dbh "DROP TABLE hdbctest1" [] + do _ <- sRun dbh "DROP TABLE hdbctest1" [] commit dbh ) +runReplace :: Test runReplace = dbTestCase (\dbh -> - do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 - sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 + do _ <- sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + _ <- sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 commit dbh sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" - sExecute sth [] + _ <- sExecute sth [] sFetchRow sth >>= (assertEqual "r1" (Just r1)) sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", Just "2", Nothing])) @@ -65,92 +72,98 @@ runReplace = dbTestCase (\dbh -> where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] r2 = [Just "runReplace", Just "2", Nothing] +executeReplace :: Test executeReplace = dbTestCase (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" - sExecute sth [Just "1", Just "1234", Just "Foo"] - sExecute sth [Just "2", Nothing, Just "Bar"] + _ <- sExecute sth [Just "1", Just "1234", Just "Foo"] + _ <- sExecute sth [Just "2", Nothing, Just "Bar"] commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" - sExecute sth [Just "executeReplace"] - sFetchRow sth >>= (assertEqual "r1" + sth' <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + _ <- sExecute sth' [Just "executeReplace"] + sFetchRow sth' >>= (assertEqual "r1" (Just $ map Just ["executeReplace", "1", "1234", "Foo"])) - sFetchRow sth >>= (assertEqual "r2" + sFetchRow sth' >>= (assertEqual "r2" (Just [Just "executeReplace", Just "2", Nothing, Just "Bar"])) - sFetchRow sth >>= (assertEqual "lastrow" Nothing) + sFetchRow sth' >>= (assertEqual "lastrow" Nothing) ) +testExecuteMany :: Test testExecuteMany = dbTestCase (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" sExecuteMany sth rows commit dbh - sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" - sExecute sth [] - mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows + sth' <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi' ORDER BY testid" + _ <- sExecute sth' [] + mapM_ (\r -> sFetchRow sth' >>= (assertEqual "" (Just r))) rows sFetchRow sth >>= (assertEqual "lastrow" Nothing) ) where rows = [map Just ["1", "1234", "foo"], map Just ["2", "1341", "bar"], [Just "3", Nothing, Nothing]] +testsFetchAllRows :: Test testsFetchAllRows = dbTestCase (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" sExecuteMany sth rows commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" - sExecute sth [] - results <- sFetchAllRows sth + sth' <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + _ <- sExecute sth' [] + results <- sFetchAllRows sth' assertEqual "" rows results ) - where rows = map (\x -> [Just . show $ x]) [1..9] + where rows = map (\x -> [Just . show $ x]) ([1..9 :: Int]) +basicTransactions :: Test basicTransactions = dbTestCase (\dbh -> do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" - sExecute sth [Just "0"] + _ <- sExecute sth [Just "0"] commit dbh qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" - sExecute qrysth [] + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) -- Now try a rollback sExecuteMany sth rows rollback dbh - sExecute qrysth [] + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) -- Now try another commit sExecuteMany sth rows commit dbh - sExecute qrysth [] + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) ) - where rows = map (\x -> [Just . show $ x]) [1..9] + where rows = map (\x -> [Just . show $ x]) ([1..9 :: Int]) +testWithTransaction :: Test testWithTransaction = dbTestCase (\dbh -> do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" - sExecute sth [Just "0"] + _ <- sExecute sth [Just "0"] commit dbh qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" - sExecute qrysth [] + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) -- Let's try a rollback. catch (withTransaction dbh (\_ -> do sExecuteMany sth rows fail "Foo")) - (\_ -> return ()) - sExecute qrysth [] + ( (\_ -> return ()) :: SomeException -> IO () ) + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) -- And now a commit. withTransaction dbh (\_ -> sExecuteMany sth rows) - sExecute qrysth [] + _ <- sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) ) - where rows = map (\x -> [Just . show $ x]) [1..9] + where rows = map (\x -> [Just . show $ x]) ([1..9 :: Int]) +tests :: Test tests = TestList [ TestLabel "openClosedb" openClosedb, diff --git a/testsrc/TestTime.hs b/testsrc/TestTime.hs index 5fd77da..8d289a7 100644 --- a/testsrc/TestTime.hs +++ b/testsrc/TestTime.hs @@ -1,58 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + module TestTime(tests) where import Test.HUnit import Database.HDBC import TestUtils import Control.Exception import Data.Time -import Data.Time.LocalTime import Data.Time.Clock.POSIX import Data.Maybe import Data.Convertible import SpecificDB -import System.Locale(defaultTimeLocale) -import Database.HDBC.Locale (iso8601DateFormat) -import qualified System.Time as ST -instance Eq ZonedTime where - a == b = zonedTimeToUTC a == zonedTimeToUTC b && - zonedTimeZone a == zonedTimeZone b +newtype ZonedTimeEq = ZonedTimeEq { _zt :: ZonedTime } + +instance Show ZonedTimeEq where + show = show . _zt -testZonedTime :: ZonedTime -testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z")) - "1989-08-01 15:33:01 -0500" +instance Eq ZonedTimeEq where + a == b = let a' = _zt a + b' = _zt b + in zonedTimeToUTC a' == zonedTimeToUTC b' && + zonedTimeZone a' == zonedTimeZone b' -testZonedTimeFrac :: ZonedTime -testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) - "1989-08-01 15:33:01.536 -0500" +instance (Convertible a ZonedTime) => (Convertible a ZonedTimeEq) where + safeConvert v = ZonedTimeEq <$> (safeConvert v) +instance (Convertible ZonedTime b) => (Convertible ZonedTimeEq b) where + safeConvert (ZonedTimeEq v) = safeConvert v +testZonedTime :: ZonedTimeEq +testZonedTime = ZonedTimeEq . fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T %z")) + "1989-08-01T15:33:01 -0500" -rowdata t = [[SqlInt32 100, toSql t, SqlNull]] +testZonedTimeFrac :: ZonedTimeEq +testZonedTimeFrac = ZonedTimeEq . fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) + "1989-08-01T15:33:01.536 -0500" +testDTType :: forall a. (Eq a, Show a, Convertible SqlValue a) => + a -> (a -> SqlValue) -> Test testDTType inputdata convToSqlValue = dbTestCase $ \dbh -> - do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ - \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] - finally (testIt dbh) (do commit dbh - run dbh "DROP TABLE hdbctesttime" [] - commit dbh - ) - where testIt dbh = - do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" - [iToSql 5, value] + do runRaw dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ + \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") + finally (convcmp dbh) (do commit dbh + runRaw dbh "DROP TABLE hdbctesttime" + commit dbh + ) + where convcmp dbh = + do _ <- run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" + [iToSql 5, value] commit dbh r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] case r of [[testidsv, testvaluesv]] -> do assertEqual "testid" (5::Int) (fromSql testidsv) assertEqual "testvalue" inputdata (fromSql testvaluesv) + _ -> assertEqual "testquery" "one pair" "not one pair" value = convToSqlValue inputdata +mkTest :: forall a. (Eq a, Show a, Convertible SqlValue a) => + String -> a -> (a -> SqlValue) -> Test mkTest label inputdata convfunc = TestLabel label (testDTType inputdata convfunc) +tests :: Test tests = TestList $ ((TestLabel "Non-frac" $ testIt testZonedTime) : if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) +testIt :: ZonedTimeEq -> Test testIt baseZonedTime = TestList [mkTest "Day" baseDay toSql, mkTest "TimeOfDay" baseTimeOfDay toSql, @@ -62,8 +79,6 @@ testIt baseZonedTime = mkTest "UTCTime" baseUTCTime toSql, mkTest "DiffTime" baseDiffTime toSql, mkTest "POSIXTime" basePOSIXTime posixToSql, - mkTest "ClockTime" baseClockTime toSql, - mkTest "CalendarTime" baseCalendarTime toSql, mkTest "TimeDiff" baseTimeDiff toSql ] where @@ -74,27 +89,19 @@ testIt baseZonedTime = baseTimeOfDay = localTimeOfDay baseLocalTime baseZonedTimeOfDay :: (TimeOfDay, TimeZone) - baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) + baseZonedTimeOfDay = fromSql (SqlZonedTime $ _zt baseZonedTime) baseLocalTime :: LocalTime - baseLocalTime = zonedTimeToLocalTime baseZonedTime + baseLocalTime = zonedTimeToLocalTime $ _zt baseZonedTime baseUTCTime :: UTCTime baseUTCTime = convert baseZonedTime - baseDiffTime :: NominalDiffTime - baseDiffTime = basePOSIXTime - basePOSIXTime :: POSIXTime basePOSIXTime = convert baseZonedTime - baseTimeDiff :: ST.TimeDiff - baseTimeDiff = convert baseDiffTime - - -- No fractional parts for these two - - baseClockTime :: ST.ClockTime - baseClockTime = convert testZonedTime + baseDiffTime :: NominalDiffTime + baseDiffTime = basePOSIXTime - baseCalendarTime :: ST.CalendarTime - baseCalendarTime = convert testZonedTime + baseTimeDiff :: DiffTime + baseTimeDiff = secondsToDiffTime 1506226306 diff --git a/testsrc/TestUtils.hs b/testsrc/TestUtils.hs index da17fe2..22c93ff 100644 --- a/testsrc/TestUtils.hs +++ b/testsrc/TestUtils.hs @@ -1,18 +1,29 @@ -module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where +module TestUtils(connectDB, connectDBExt, sqlTestCase, dbTestCase, dbTestCaseExt, printDBInfo) where import Database.HDBC +import Database.HDBC.Sqlite3 import Test.HUnit import Control.Exception -import SpecificDB(connectDB) +import SpecificDB(connectDB, connectDBExt) +sqlTestCase :: IO () -> Test sqlTestCase a = TestCase (handleSqlError a) +dbTestCase :: (Connection -> IO ()) -> Test dbTestCase a = TestCase (do dbh <- connectDB finally (handleSqlError (a dbh)) (handleSqlError (disconnect dbh)) ) +dbTestCaseExt :: Bool -> (Connection -> IO()) -> Test +dbTestCaseExt auto a = + TestCase (do dbh <- connectDBExt auto + finally (handleSqlError (a dbh)) + (handleSqlError (disconnect dbh)) + ) + +printDBInfo :: IO () printDBInfo = handleSqlError $ do dbh <- connectDB putStrLn "+-------------------------------------------------------------------------" diff --git a/testsrc/Testbasics.hs b/testsrc/Testbasics.hs index 569dc03..2013d0b 100644 --- a/testsrc/Testbasics.hs +++ b/testsrc/Testbasics.hs @@ -2,23 +2,24 @@ module Testbasics(tests) where import Test.HUnit import Database.HDBC import TestUtils -import System.IO -import Control.Exception hiding (catch) +import Control.Exception +import Control.Monad (when) -openClosedb = sqlTestCase $ - do dbh <- connectDB +openClosedb :: Bool -> Test +openClosedb auto = sqlTestCase $ + do dbh <- connectDBExt auto disconnect dbh -multiFinish = dbTestCase (\dbh -> +multiFinish :: Bool -> Test +multiFinish auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" r <- execute sth [] assertEqual "basic count" 0 r - finish sth - finish sth - finish sth + finish sth >> finish sth >> finish sth ) -basicQueries = dbTestCase (\dbh -> +basicQueries :: Bool -> Test +basicQueries auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" execute sth [] >>= (0 @=?) r <- fetchAllRows sth @@ -28,141 +29,168 @@ basicQueries = dbTestCase (\dbh -> assertEqual "num compare" [[toSql (2::Int)]] r assertEqual "nToSql compare" [[nToSql (2::Int)]] r assertEqual "string compare" [[SqlString "2"]] r + when (not auto) $ finish sth ) - -createTable = dbTestCase (\dbh -> - do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + +createTable :: Bool -> Test +createTable auto = dbTestCaseExt auto (\dbh -> + do runRaw dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" commit dbh ) -dropTable = dbTestCase (\dbh -> - do run dbh "DROP TABLE hdbctest1" [] +dropTable :: Bool -> Test +dropTable auto = dbTestCaseExt auto (\dbh -> + do runRaw dbh "DROP TABLE hdbctest1" commit dbh ) -runReplace = dbTestCase (\dbh -> +runReplace :: Bool -> Test +runReplace auto = dbTestCaseExt auto (\dbh -> do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 assertEqual "insert retval" 1 r - run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 + _ <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 commit dbh sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" rv2 <- execute sth [] assertEqual "select retval" 0 rv2 - r <- fetchAllRows sth - assertEqual "" [r1, r2] r + r' <- fetchAllRows sth + assertEqual "" [r1, r2] r' + when (not auto) $ finish sth ) - where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] -executeReplace = dbTestCase (\dbh -> +executeReplace :: Bool -> Test +executeReplace auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" - execute sth [iToSql 1, iToSql 1234, toSql "Foo"] - execute sth [SqlInt32 2, SqlNull, toSql "Bar"] + _ <- execute sth [iToSql 1, iToSql 1234, toSql "Foo"] + _ <- execute sth [SqlInt32 2, SqlNull, toSql "Bar"] + when (not auto) $ finish sth commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" - execute sth [SqlString "executeReplace"] - r <- fetchAllRows sth + sth' <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + _ <- execute sth' [SqlString "executeReplace"] + r <- fetchAllRows sth' assertEqual "result" [[toSql "executeReplace", iToSql 1, toSql "1234", toSql "Foo"], [toSql "executeReplace", iToSql 2, SqlNull, toSql "Bar"]] r + when (not auto) $ finish sth' ) -testExecuteMany = dbTestCase (\dbh -> +testExecuteMany :: Bool -> Test +testExecuteMany auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" executeMany sth rows commit dbh - sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" - execute sth [] - r <- fetchAllRows sth + when (not auto) $ finish sth + sth' <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + _ <- execute sth' [] + r <- fetchAllRows sth' assertEqual "" rows r + when (not auto) $ finish sth' ) where rows = [map toSql ["1", "1234", "foo"], map toSql ["2", "1341", "bar"], [toSql "3", SqlNull, SqlNull]] -testFetchAllRows = dbTestCase (\dbh -> +testFetchAllRows :: Bool -> Test +testFetchAllRows auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('fetchAllRows', ?, NULL, NULL)" executeMany sth rows commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows' ORDER BY testid" - execute sth [] - results <- fetchAllRows sth + when (not auto) $ finish sth + sth' <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows' ORDER BY testid" + _ <- execute sth' [] + results <- fetchAllRows sth' assertEqual "" rows results + when (not auto) $ finish sth' ) where rows = map (\x -> [iToSql x]) [1..9] -testFetchAllRows' = dbTestCase (\dbh -> +testFetchAllRows' :: Bool -> Test +testFetchAllRows' auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('fetchAllRows2', ?, NULL, NULL)" executeMany sth rows commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows2' ORDER BY testid" - execute sth [] - results <- fetchAllRows' sth + when (not auto) $ finish sth + sth' <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows2' ORDER BY testid" + _ <- execute sth' [] + results <- fetchAllRows' sth' + when (not auto) $ finish sth' assertEqual "" rows results ) where rows = map (\x -> [iToSql x]) [1..9] -basicTransactions = dbTestCase (\dbh -> +basicTransactions :: Bool -> Test +basicTransactions auto = dbTestCaseExt auto (\dbh -> do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" - execute sth [iToSql 0] + _ <- execute sth [iToSql 0] commit dbh qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" - execute qrysth [] + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) -- Now try a rollback executeMany sth rows rollback dbh - execute qrysth [] + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) -- Now try another commit executeMany sth rows commit dbh - execute qrysth [] + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) + when (not auto) $ finish sth >> finish qrysth ) where rows = map (\x -> [iToSql $ x]) [1..9] -testWithTransaction = dbTestCase (\dbh -> +testWithTransaction :: Bool -> Test +testWithTransaction auto = dbTestCaseExt auto (\dbh -> do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" - execute sth [toSql "0"] + _ <- execute sth [toSql "0"] commit dbh qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" - execute qrysth [] + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) - + -- Let's try a rollback. catch (withTransaction dbh (\_ -> do executeMany sth rows fail "Foo")) - (\_ -> return ()) - execute qrysth [] + ( (\_ -> return ()) :: SomeException -> IO () ) + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) -- And now a commit. withTransaction dbh (\_ -> executeMany sth rows) - execute qrysth [] + _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) + when (not auto) $ finish sth >> finish qrysth ) where rows = map (\x -> [iToSql x]) [1..9] - + +autoTests :: Bool -> Test +autoTests auto = TestList + [ TestLabel "openClosedb" (openClosedb auto) + , TestLabel "multiFinish" (multiFinish auto) + , TestLabel "basicQueries" (basicQueries auto) + , TestLabel "createTable" (createTable auto) + , TestLabel "runReplace" (runReplace auto) + , TestLabel "executeReplace" (executeReplace auto) + , TestLabel "executeMany" (testExecuteMany auto) + , TestLabel "fetchAllRows" (testFetchAllRows auto) + , TestLabel "fetchAllRows'" (testFetchAllRows' auto) + , TestLabel "basicTransactions" (basicTransactions auto) + , TestLabel "withTransaction" (testWithTransaction auto) + , TestLabel "dropTable" (dropTable True) + ] + +tests :: Test tests = TestList - [ - TestLabel "openClosedb" openClosedb, - TestLabel "multiFinish" multiFinish, - TestLabel "basicQueries" basicQueries, - TestLabel "createTable" createTable, - TestLabel "runReplace" runReplace, - TestLabel "executeReplace" executeReplace, - TestLabel "executeMany" testExecuteMany, - TestLabel "fetchAllRows" testFetchAllRows, - TestLabel "fetchAllRows'" testFetchAllRows', - TestLabel "basicTransactions" basicTransactions, - TestLabel "withTransaction" testWithTransaction, - TestLabel "dropTable" dropTable - ] + [ TestLabel "Auto-finish true tests" (autoTests True) + , TestLabel "Auto-finish false tests" (autoTests False) + ] diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs index 31b7bc0..0423486 100644 --- a/testsrc/Tests.hs +++ b/testsrc/Tests.hs @@ -9,8 +9,10 @@ import qualified SpecificDBTests import qualified TestMisc import qualified TestTime +test1 :: Test test1 = TestCase ("x" @=? "x") +tests :: Test tests = TestList [TestLabel "test1" test1, TestLabel "String basics" TestSbasics.tests, TestLabel "SqlValue basics" Testbasics.tests, diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs index f3c0acb..3261765 100644 --- a/testsrc/runtests.hs +++ b/testsrc/runtests.hs @@ -7,6 +7,7 @@ import Test.HUnit import Tests import TestUtils +main :: IO () main = do printDBInfo - runTestTT tests + runTestTT tests >> return ()