From 0e78b38f9ef9be3763251c33279d3270f694e46a Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sun, 24 Sep 2017 03:10:27 +0000 Subject: [PATCH 1/8] Fix tests, which now pass under stack LTS-6.35 Drop "old-locale" dependency and tests of conversions from obsolete "old-time" types. Added stack.yaml, for 6.35. Newer LTS versions can't build the tests due to version caps on template-haskell in dependencies. Compilation without the tests dependencies now works through at least LTS-9.5 and even stackage-nightly-2017-09-20. --- HDBC-sqlite3.cabal | 11 +++++++++-- stack.yaml | 8 ++++++++ testsrc/TestSbasics.hs | 4 ++-- testsrc/TestTime.hs | 38 ++++++++++++++------------------------ testsrc/Testbasics.hs | 4 ++-- 5 files changed, 35 insertions(+), 30 deletions(-) create mode 100644 stack.yaml diff --git a/HDBC-sqlite3.cabal b/HDBC-sqlite3.cabal index d1f51ca..e753582 100644 --- a/HDBC-sqlite3.cabal +++ b/HDBC-sqlite3.cabal @@ -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, 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/TestSbasics.hs b/testsrc/TestSbasics.hs index 2a449db..2cb91c8 100644 --- a/testsrc/TestSbasics.hs +++ b/testsrc/TestSbasics.hs @@ -3,7 +3,7 @@ import Test.HUnit import Database.HDBC import TestUtils import System.IO -import Control.Exception hiding (catch) +import Control.Exception openClosedb = sqlTestCase $ do dbh <- connectDB @@ -140,7 +140,7 @@ testWithTransaction = dbTestCase (\dbh -> -- Let's try a rollback. catch (withTransaction dbh (\_ -> do sExecuteMany sth rows fail "Foo")) - (\_ -> return ()) + ( (\_ -> return ()) :: SomeException -> IO () ) sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) diff --git a/testsrc/TestTime.hs b/testsrc/TestTime.hs index 5fd77da..d29caf6 100644 --- a/testsrc/TestTime.hs +++ b/testsrc/TestTime.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module TestTime(tests) where import Test.HUnit import Database.HDBC @@ -5,34 +7,32 @@ import TestUtils import Control.Exception import Data.Time import Data.Time.LocalTime +import Data.Time.Clock 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 testZonedTime :: ZonedTime -testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z")) - "1989-08-01 15:33:01 -0500" +testZonedTime = fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T %z")) + "1989-08-01T15:33:01 -0500" testZonedTimeFrac :: ZonedTime -testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) - "1989-08-01 15:33:01.536 -0500" +testZonedTimeFrac = fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) + "1989-08-01T15:33:01.536 -0500" rowdata t = [[SqlInt32 100, toSql t, SqlNull]] testDTType inputdata convToSqlValue = dbTestCase $ \dbh -> - do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ - \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] + do runRaw dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ + \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") finally (testIt dbh) (do commit dbh - run dbh "DROP TABLE hdbctesttime" [] + runRaw dbh "DROP TABLE hdbctesttime" commit dbh ) where testIt dbh = @@ -62,8 +62,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 @@ -82,19 +80,11 @@ testIt 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/Testbasics.hs b/testsrc/Testbasics.hs index 569dc03..3cbb3f3 100644 --- a/testsrc/Testbasics.hs +++ b/testsrc/Testbasics.hs @@ -3,7 +3,7 @@ import Test.HUnit import Database.HDBC import TestUtils import System.IO -import Control.Exception hiding (catch) +import Control.Exception openClosedb = sqlTestCase $ do dbh <- connectDB @@ -140,7 +140,7 @@ testWithTransaction = dbTestCase (\dbh -> -- Let's try a rollback. catch (withTransaction dbh (\_ -> do executeMany sth rows fail "Foo")) - (\_ -> return ()) + ( (\_ -> return ()) :: SomeException -> IO () ) execute qrysth [] fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) From 45a24ef29905b3fa9ee2ff66336d650fcf33fb8b Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 11:18:51 +0000 Subject: [PATCH 2/8] Initialize ppst to NULL just in case We try to finalize it after failed calls, and, though the SQLite3 documentation promises that it will be initialized to NULL on error, this is liable to elicit compiler warnings, and is not "obviously" correct. --- hdbc-sqlite3-helper.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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; From 58c0d2afec3132407cf9815c9e8a66921f78773b Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 08:14:50 +0000 Subject: [PATCH 3/8] Avoid string conversions when fetching Ints and Doubles --- Database/HDBC/Sqlite3/Statement.hsc | 30 +++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/Database/HDBC/Sqlite3/Statement.hsc b/Database/HDBC/Sqlite3/Statement.hsc index 46bbaaf..c0d1a4b 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 @@ -117,17 +117,17 @@ ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow 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 = @@ -281,6 +281,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 From ee94b1066e2d56b2b6a04b8b163ab478d044cec0 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 08:41:34 +0000 Subject: [PATCH 4/8] Fix warnings - Missing type signatures - Shadowed names - Unused names - Ignored results - Incomplete pattern matches - Missing modules in cabal file * Fixed all warnings reported by GHC 7 in code and tests * Fixed all warnings reported by GHC 8 in the code, tests don't yet build due to version conflicts in dependencies. --- Database/HDBC/Sqlite3/Connection.hs | 36 +++++++------- Database/HDBC/Sqlite3/Consts.hsc | 2 - Database/HDBC/Sqlite3/Statement.hsc | 48 +++++++++--------- Database/HDBC/Sqlite3/Utils.hsc | 1 - HDBC-sqlite3.cabal | 4 +- testsrc/SpecificDB.hs | 5 +- testsrc/SpecificDBTests.hs | 3 +- testsrc/TestMisc.hs | 51 +++++++++++++------ testsrc/TestSbasics.hs | 77 +++++++++++++++++------------ testsrc/TestTime.hs | 59 ++++++++++++++-------- testsrc/TestUtils.hs | 4 ++ testsrc/Testbasics.hs | 68 ++++++++++++++----------- testsrc/Tests.hs | 2 + testsrc/runtests.hs | 3 +- 14 files changed, 218 insertions(+), 145 deletions(-) diff --git a/Database/HDBC/Sqlite3/Connection.hs b/Database/HDBC/Sqlite3/Connection.hs index e3f2dcd..49b1c06 100644 --- a/Database/HDBC/Sqlite3/Connection.hs +++ b/Database/HDBC/Sqlite3/Connection.hs @@ -79,24 +79,21 @@ mkConn fp obj = Impl.describeTable = fdescribeTable obj children, Impl.setBusyTimeout = fsetbusy obj} +fgettables :: Sqlite3 -> ChildList -> IO [String] 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 + res <- execute sth [] >> fetchAllRows' sth + return $ map fromSql $ concat res +fdescribeTable :: Sqlite3 -> ChildList -> String -> IO [(String, SqlColDesc)] fdescribeTable o mchildren name = do sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")" - execute sth [] - res1 <- fetchAllRows' sth - return $ map describeCol res1 + res <- execute sth [] >> fetchAllRows' 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 +117,7 @@ fdescribeTable o mchildren name = do other -> SqlUnknownT other +fsetbusy :: Sqlite3 -> CInt -> IO () fsetbusy o ms = withRawSqlite3 o $ \ppdb -> sqlite3_busy_timeout ppdb ms @@ -130,11 +128,11 @@ fsetbusy o ms = withRawSqlite3 o $ \ppdb -> begin_transaction :: Sqlite3 -> ChildList -> IO () begin_transaction o children = frun o children "BEGIN" [] >> return () +frun :: Sqlite3 -> ChildList -> String -> [SqlValue] -> IO Integer frun o mchildren query args = do sth <- newSth o mchildren False query res <- execute sth args - finish sth - return res + (return $! res) <* finish sth frunRaw :: Sqlite3 -> ChildList -> String -> IO () frunRaw o mchildren query = @@ -142,10 +140,12 @@ frunRaw o mchildren 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 +fcommit :: Sqlite3 -> ChildList -> IO () +fcommit o children = + frun o children "COMMIT" [] >> begin_transaction o children +frollback :: Sqlite3 -> ChildList -> IO () +frollback o children = + frun o children "ROLLBACK" [] >> begin_transaction o children fdisconnect :: Sqlite3 -> ChildList -> IO () fdisconnect o mchildren = withRawSqlite3 o $ \p -> 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 c0d1a4b..17f53f5 100644 --- a/Database/HDBC/Sqlite3/Statement.hsc +++ b/Database/HDBC/Sqlite3/Statement.hsc @@ -44,14 +44,14 @@ data SState = SState {dbo :: Sqlite3, autoFinish :: Bool} newSth :: Sqlite3 -> ChildList -> Bool -> String -> IO Statement -newSth indbo mchildren autoFinish str = +newSth indbo mchildren auto str = do newstomv <- newMVar Empty newcolnamesmv <- newMVar [] let sstate = SState{dbo = indbo, stomv = newstomv, querys = str, colnamesmv = newcolnamesmv, - autoFinish = autoFinish} + autoFinish = auto} modifyMVar_ (stomv sstate) (\_ -> (fprepare sstate >>= return . Prepared)) let retval = Statement {execute = fexecute sstate, @@ -130,22 +130,23 @@ ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow 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) @@ -175,7 +176,7 @@ 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) + _ <- fgetcolnames p >>= swapMVar (colnamesmv sstate) if r then return (Executed sto, fromIntegral changes) else if (autoFinish sstate) @@ -197,15 +198,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 +214,35 @@ 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) + where + getCol s i = + BUTF8.toString <$> (B.packCString =<< sqlite3_column_name s i) +fexecutemany :: SState -> [[SqlValue]] -> IO () fexecutemany _ [] = return () -fexecutemany sstate (args:[]) = - do fexecute sstate args - return () -fexecutemany sstate (args:arglist) = - do fexecute (sstate { autoFinish = False }) args - fexecutemany sstate arglist +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") -- 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 -ffinish dbo o = withRawStmt o (\p -> do r <- sqlite3_finalize p - checkError "finish" dbo r) +ffinish :: Sqlite3 -> Stmt -> IO () +ffinish db st = withRawStmt st $ \p -> + sqlite3_finalize p >>= checkError "finish" db foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_finalize_finalizer" sqlite3_finalizeptr :: FunPtr ((Ptr CStmt) -> IO ()) 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 e753582..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, @@ -74,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/testsrc/SpecificDB.hs b/testsrc/SpecificDB.hs index 3989a43..6655c24 100644 --- a/testsrc/SpecificDB.hs +++ b/testsrc/SpecificDB.hs @@ -1,8 +1,8 @@ module SpecificDB where import Database.HDBC import Database.HDBC.Sqlite3 -import Test.HUnit +connectDB :: IO Connection connectDB = handleSqlError (connectSqlite3 "testtmp.sql3") @@ -11,4 +11,5 @@ 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..c06f82e 100644 --- a/testsrc/SpecificDBTests.hs +++ b/testsrc/SpecificDBTests.hs @@ -1,11 +1,12 @@ module SpecificDBTests where import Database.HDBC -import Database.HDBC.Sqlite3 import Test.HUnit import TestMisc(setup) +testgetTables :: Test testgetTables = setup $ \dbh -> do r <- getTables dbh ["hdbctest2"] @=? r +tests :: Test tests = TestList [TestLabel "getTables" testgetTables] diff --git a/testsrc/TestMisc.hs b/testsrc/TestMisc.hs index 9429237..cbe8ac1 100644 --- a/testsrc/TestMisc.hs +++ b/testsrc/TestMisc.hs @@ -1,48 +1,55 @@ 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 :: (Connection -> IO ()) -> Test setup f = dbTestCase $ \dbh -> - do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] + 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 commit dbh finally (f dbh) - (do run dbh "DROP TABLE hdbctest2" [] + (do _ <- run dbh "DROP TABLE hdbctest2" [] commit dbh ) +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 :: Test testgetColumnNames = setup $ \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 :: Test testdescribeResult = setup $ \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,6 +61,7 @@ testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) finish sth +testdescribeTable :: Test testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` ["sqlite3"])) $ do cols <- describeTable dbh "hdbctest2" @@ -69,52 +77,59 @@ testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) +testquickQuery :: Test testquickQuery = setup $ \dbh -> do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] rowdata @=? results +testfetchRowAL :: Test testfetchRowAL = setup $ \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 :: Test testfetchRowMap = setup $ \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 :: Test testfetchAllRowsAL = setup $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchAllRowsAL sth >>= (alrows @=?) +testfetchAllRowsMap :: Test testfetchAllRowsMap = setup $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] + _ <- execute sth [] fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) +testexception :: Test testexception = setup $ \dbh -> catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" - execute sth [] + _ <- execute sth [] assertFailure "No exception was raised" ) - (\e -> commit dbh) + (\_ -> commit dbh) +testrowcount :: Test testrowcount = setup $ \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" [] assertEqual "final results" @@ -126,18 +141,22 @@ 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 :: Test testgetTables1 = setup $ \dbh -> do r <- getTables dbh True @=? "hdbctest2" `elem` r +testgetTables2 :: Test testgetTables2 = dbTestCase $ \dbh -> do r <- getTables dbh False @=? "hdbctest2" `elem` r +testclone :: Test testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] rowdata @=? results +testnulls :: Test testnulls = setup $ \dbh -> do let dn = hdbcDriverName dbh when (not (dn `elem` ["postgresql", "odbc"])) ( @@ -153,6 +172,7 @@ testnulls = setup $ \dbh -> [SqlInt32 103, SqlString "\xFF", SqlNull], [SqlInt32 104, SqlString "regular", SqlNull]] +testunicode :: Test testunicode = setup $ \dbh -> do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" executeMany sth rows @@ -163,6 +183,7 @@ testunicode = setup $ \dbh -> [SqlInt32 101, SqlString "bar\x00A3", SqlNull], [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] +tests :: Test tests = TestList [TestLabel "getColumnNames" testgetColumnNames, TestLabel "describeResult" testdescribeResult, TestLabel "describeTable" testdescribeTable, diff --git a/testsrc/TestSbasics.hs b/testsrc/TestSbasics.hs index 2cb91c8..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 +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 ()) :: SomeException -> IO () ) - sExecute qrysth [] + _ <- 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 d29caf6..8d289a7 100644 --- a/testsrc/TestTime.hs +++ b/testsrc/TestTime.hs @@ -1,4 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} module TestTime(tests) where import Test.HUnit @@ -6,53 +9,67 @@ import Database.HDBC import TestUtils import Control.Exception import Data.Time -import Data.Time.LocalTime -import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Maybe import Data.Convertible import SpecificDB -instance Eq ZonedTime where - a == b = zonedTimeToUTC a == zonedTimeToUTC b && - zonedTimeZone a == zonedTimeZone b +newtype ZonedTimeEq = ZonedTimeEq { _zt :: ZonedTime } -testZonedTime :: ZonedTime -testZonedTime = fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T %z")) - "1989-08-01T15:33:01 -0500" +instance Show ZonedTimeEq where + show = show . _zt -testZonedTimeFrac :: ZonedTime -testZonedTimeFrac = fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) - "1989-08-01T15:33:01.536 -0500" +instance Eq ZonedTimeEq where + a == b = let a' = _zt a + b' = _zt b + in zonedTimeToUTC a' == zonedTimeToUTC b' && + zonedTimeZone a' == zonedTimeZone b' +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 -rowdata t = [[SqlInt32 100, toSql t, SqlNull]] +testZonedTime :: ZonedTimeEq +testZonedTime = ZonedTimeEq . fromJust $ parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T %z")) + "1989-08-01T15:33:01 -0500" + +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 runRaw dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") - finally (testIt dbh) (do commit dbh - runRaw dbh "DROP TABLE hdbctesttime" - commit dbh - ) - where testIt dbh = - do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" - [iToSql 5, 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, @@ -72,10 +89,10 @@ 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 diff --git a/testsrc/TestUtils.hs b/testsrc/TestUtils.hs index da17fe2..03af919 100644 --- a/testsrc/TestUtils.hs +++ b/testsrc/TestUtils.hs @@ -1,18 +1,22 @@ module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where import Database.HDBC +import Database.HDBC.Sqlite3 import Test.HUnit import Control.Exception import SpecificDB(connectDB) +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)) ) +printDBInfo :: IO () printDBInfo = handleSqlError $ do dbh <- connectDB putStrLn "+-------------------------------------------------------------------------" diff --git a/testsrc/Testbasics.hs b/testsrc/Testbasics.hs index 3cbb3f3..11eeb94 100644 --- a/testsrc/Testbasics.hs +++ b/testsrc/Testbasics.hs @@ -2,13 +2,14 @@ module Testbasics(tests) where import Test.HUnit import Database.HDBC import TestUtils -import System.IO import Control.Exception +openClosedb :: Test openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh +multiFinish :: Test multiFinish = dbTestCase (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" r <- execute sth [] @@ -18,6 +19,7 @@ multiFinish = dbTestCase (\dbh -> finish sth ) +basicQueries :: Test basicQueries = dbTestCase (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" execute sth [] >>= (0 @=?) @@ -30,38 +32,42 @@ basicQueries = dbTestCase (\dbh -> assertEqual "string compare" [[SqlString "2"]] r ) +createTable :: Test createTable = dbTestCase (\dbh -> - do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + do runRaw dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" commit dbh ) +dropTable :: Test dropTable = dbTestCase (\dbh -> - do run dbh "DROP TABLE hdbctest1" [] + do runRaw dbh "DROP TABLE hdbctest1" commit dbh ) +runReplace :: Test runReplace = dbTestCase (\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' ) where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] +executeReplace :: Test executeReplace = dbTestCase (\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"] 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"], @@ -70,87 +76,93 @@ executeReplace = dbTestCase (\dbh -> r ) +testExecuteMany :: Test testExecuteMany = dbTestCase (\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 + sth' <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + _ <- execute sth' [] + r <- fetchAllRows sth' assertEqual "" rows r ) where rows = [map toSql ["1", "1234", "foo"], map toSql ["2", "1341", "bar"], [toSql "3", SqlNull, SqlNull]] +testFetchAllRows :: Test testFetchAllRows = dbTestCase (\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 + sth' <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows' ORDER BY testid" + _ <- execute sth' [] + results <- fetchAllRows sth' assertEqual "" rows results ) where rows = map (\x -> [iToSql x]) [1..9] +testFetchAllRows' :: Test testFetchAllRows' = dbTestCase (\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 + sth' <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows2' ORDER BY testid" + _ <- execute sth' [] + results <- fetchAllRows' sth' assertEqual "" rows results ) where rows = map (\x -> [iToSql x]) [1..9] +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)" - 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)) ) where rows = map (\x -> [iToSql $ x]) [1..9] +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)" - 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 ()) :: SomeException -> IO () ) - execute qrysth [] + _ <- 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)) ) where rows = map (\x -> [iToSql x]) [1..9] +tests :: Test tests = TestList [ TestLabel "openClosedb" openClosedb, 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 () From dbf4d780b806b5ba0bfac8a51ba6d3f360742cc9 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 10:17:35 +0000 Subject: [PATCH 5/8] New connectSqlite3Ext function This allows prepared statements to stay open, so that one can avoid the penalty of recompiling them each time. Applications that disable auto finish MUST finish() *every* statement handle they prepare(). This also supports use of native octet encodings of non-UTF-8 filenames. The existing connect functions are re-implemented in terms of connectSqlite3Ext. When auto-finish is off, it makes no sense to track the open statement handles that only the user will close. Therefore, ChildList becomes a (Maybe ChildList) and is unused when auto-finish is disabled. Since we're not finishing queries when the last result row is read, we at least promptly "reset" the statement, freeing up some of the underlying resources. Finally, single-use statements that the library prepares for its own internal purposes are never auto-finished, and finished explicitly instead. Most of these will become cached statements in the next commit. The previous implementation of clone() was incorrect, it forgot the filename encoding, this is now preserved along with the auto-finish flag. --- Database/HDBC/Sqlite3.hs | 8 ++- Database/HDBC/Sqlite3/Connection.hs | 77 ++++++++++++++++++++--------- Database/HDBC/Sqlite3/Statement.hsc | 31 +++++++----- 3 files changed, 80 insertions(+), 36 deletions(-) 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 49b1c06..e87952f 100644 --- a/Database/HDBC/Sqlite3/Connection.hs +++ b/Database/HDBC/Sqlite3/Connection.hs @@ -3,7 +3,11 @@ -- above line for hugs module Database.HDBC.Sqlite3.Connection - (connectSqlite3, connectSqlite3Raw, Impl.Connection()) + ( connectSqlite3 + , connectSqlite3Raw + , connectSqlite3Ext + , Impl.Connection() + ) where import Database.HDBC.Types @@ -29,8 +33,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,27 +41,55 @@ 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 [] +mkConn :: FilePath -> Sqlite3 -> Bool -> Bool -> IO Impl.Connection +mkConn fp obj auto raw = do + children <- if auto + then Just <$> newMVar [] + else return Nothing begin_transaction obj children ver <- (sqlite3_libversion >>= peekCString) return $ Impl.Connection { @@ -67,8 +98,8 @@ mkConn fp obj = 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.prepare = newSth obj children auto, + Impl.clone = connectSqlite3Ext auto raw fp, Impl.hdbcDriverName = "sqlite3", Impl.hdbcClientVer = ver, Impl.proxiedClientName = "sqlite3", @@ -79,16 +110,18 @@ mkConn fp obj = Impl.describeTable = fdescribeTable obj children, Impl.setBusyTimeout = fsetbusy obj} -fgettables :: Sqlite3 -> ChildList -> IO [String] +fgettables :: Sqlite3 -> Maybe ChildList -> IO [String] fgettables o mchildren = - do sth <- newSth o mchildren True "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" + do sth <- newSth o mchildren False "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" res <- execute sth [] >> fetchAllRows' sth + finish sth return $ map fromSql $ concat res -fdescribeTable :: Sqlite3 -> ChildList -> String -> IO [(String, SqlColDesc)] +fdescribeTable :: Sqlite3 -> Maybe ChildList -> String -> IO [(String, SqlColDesc)] fdescribeTable o mchildren name = do - sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")" + sth <- newSth o mchildren 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 @@ -125,31 +158,31 @@ fsetbusy o ms = withRawSqlite3 o $ \ppdb -> -- Guts here -------------------------------------------------- -begin_transaction :: Sqlite3 -> ChildList -> IO () +begin_transaction :: Sqlite3 -> Maybe ChildList -> IO () begin_transaction o children = frun o children "BEGIN" [] >> return () -frun :: Sqlite3 -> ChildList -> String -> [SqlValue] -> IO Integer +frun :: Sqlite3 -> Maybe ChildList -> String -> [SqlValue] -> IO Integer frun o mchildren query args = do sth <- newSth o mchildren False query res <- execute sth args (return $! res) <* finish sth -frunRaw :: Sqlite3 -> ChildList -> String -> IO () +frunRaw :: Sqlite3 -> Maybe ChildList -> String -> IO () frunRaw o mchildren query = do sth <- newSth o mchildren False query executeRaw sth finish sth -fcommit :: Sqlite3 -> ChildList -> IO () +fcommit :: Sqlite3 -> Maybe ChildList -> IO () fcommit o children = frun o children "COMMIT" [] >> begin_transaction o children -frollback :: Sqlite3 -> ChildList -> IO () +frollback :: Sqlite3 -> Maybe ChildList -> IO () frollback o children = frun o children "ROLLBACK" [] >> begin_transaction o children -fdisconnect :: Sqlite3 -> ChildList -> IO () +fdisconnect :: Sqlite3 -> Maybe ChildList -> IO () fdisconnect o mchildren = withRawSqlite3 o $ \p -> - do closeAllChildren mchildren + do mapM_ closeAllChildren mchildren r <- sqlite3_close p checkError "disconnect" o r diff --git a/Database/HDBC/Sqlite3/Statement.hsc b/Database/HDBC/Sqlite3/Statement.hsc index 17f53f5..5715d99 100644 --- a/Database/HDBC/Sqlite3/Statement.hsc +++ b/Database/HDBC/Sqlite3/Statement.hsc @@ -43,7 +43,7 @@ data SState = SState {dbo :: Sqlite3, colnamesmv :: MVar [String], autoFinish :: Bool} -newSth :: Sqlite3 -> ChildList -> Bool -> String -> IO Statement +newSth :: Sqlite3 -> Maybe ChildList -> Bool -> String -> IO Statement newSth indbo mchildren auto str = do newstomv <- newMVar Empty newcolnamesmv <- newMVar [] @@ -62,7 +62,7 @@ newSth indbo mchildren auto str = originalQuery = str, getColumnNames = readMVar (colnamesmv sstate), describeResult = fail "Sqlite3 backend does not support describeResult"} - addChild mchildren retval + mapM_ (flip addChild retval) mchildren return retval {- The deal with adding the \0 below is in response to an apparent bug in @@ -111,7 +111,9 @@ ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow else if (autoFinish sstate) then do ffinish (dbo 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) @@ -222,16 +224,21 @@ fgetcolnames csth = 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 _ [] = 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") +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 From 9d30abcb0a98a80584f73055ed677123b871d223 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 10:51:40 +0000 Subject: [PATCH 6/8] Bypass preparing BEGIN, COMMIT and ROLLBACK We don't need a statement handle for these, just call sqlite3_exec() via fexecuteRaw(). Also avoid creating a persistent statement handle for the gettables query and the one-shot queries processed by run and runRaw. --- Database/HDBC/Sqlite3/Connection.hs | 81 ++++++++++++++--------------- Database/HDBC/Sqlite3/Statement.hsc | 24 ++++----- 2 files changed, 50 insertions(+), 55 deletions(-) diff --git a/Database/HDBC/Sqlite3/Connection.hs b/Database/HDBC/Sqlite3/Connection.hs index e87952f..df84915 100644 --- a/Database/HDBC/Sqlite3/Connection.hs +++ b/Database/HDBC/Sqlite3/Connection.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# CFILES hdbc-sqlite3-helper.c #-} -- above line for hugs @@ -24,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 @@ -90,14 +92,20 @@ mkConn fp obj auto raw = do children <- if auto then Just <$> newMVar [] else return Nothing - begin_transaction obj children + 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.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", @@ -106,22 +114,21 @@ mkConn fp obj auto raw = do Impl.proxiedClientVer = ver, Impl.dbTransactionSupport = True, Impl.dbServerVer = ver, - Impl.getTables = fgettables obj children, - Impl.describeTable = fdescribeTable obj children, - Impl.setBusyTimeout = fsetbusy obj} - -fgettables :: Sqlite3 -> Maybe ChildList -> IO [String] -fgettables o mchildren = - do sth <- newSth o mchildren False "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" - res <- execute sth [] >> fetchAllRows' sth - finish sth - return $ map fromSql $ concat res - -fdescribeTable :: Sqlite3 -> Maybe ChildList -> String -> IO [(String, SqlColDesc)] -fdescribeTable o mchildren name = do - sth <- newSth o mchildren False $ "PRAGMA table_info(" ++ name ++ ")" - res <- execute sth [] >> fetchAllRows' sth - finish sth + 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 @@ -158,31 +165,19 @@ fsetbusy o ms = withRawSqlite3 o $ \ppdb -> -- Guts here -------------------------------------------------- -begin_transaction :: Sqlite3 -> Maybe ChildList -> IO () -begin_transaction o children = frun o children "BEGIN" [] >> return () - -frun :: Sqlite3 -> Maybe ChildList -> String -> [SqlValue] -> IO Integer -frun o mchildren query args = - do sth <- newSth o mchildren False query - res <- execute sth args - (return $! res) <* finish sth - -frunRaw :: Sqlite3 -> Maybe ChildList -> String -> IO () -frunRaw o mchildren query = - do sth <- newSth o mchildren False query - executeRaw sth - finish sth +frun :: Sqlite3 -> String -> [SqlValue] -> IO Integer +frun o query args = + bracket (newSth o Nothing False query) + (finish) + (flip execute args) -fcommit :: Sqlite3 -> Maybe ChildList -> IO () -fcommit o children = - frun o children "COMMIT" [] >> begin_transaction o children -frollback :: Sqlite3 -> Maybe ChildList -> IO () -frollback o children = - frun o children "ROLLBACK" [] >> begin_transaction o children +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 +fdisconnect o mchildren = + withRawSqlite3 o $ \p -> do + mapM_ closeAllChildren mchildren r <- sqlite3_close p checkError "disconnect" o r diff --git a/Database/HDBC/Sqlite3/Statement.hsc b/Database/HDBC/Sqlite3/Statement.hsc index 5715d99..d9bdff8 100644 --- a/Database/HDBC/Sqlite3/Statement.hsc +++ b/Database/HDBC/Sqlite3/Statement.hsc @@ -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 @@ -52,9 +52,8 @@ newSth indbo mchildren auto str = querys = str, colnamesmv = newcolnamesmv, autoFinish = auto} - modifyMVar_ (stomv sstate) (\_ -> (fprepare sstate >>= return . Prepared)) - let retval = - Statement {execute = fexecute sstate, + retval = + Statement { execute = fexecute sstate, executeRaw = fexecuteRaw indbo str, executeMany = fexecutemany sstate, finish = public_ffinish sstate, @@ -62,6 +61,7 @@ newSth indbo mchildren auto str = originalQuery = str, getColumnNames = readMVar (colnamesmv sstate), describeResult = fail "Sqlite3 backend does not support describeResult"} + modifyMVar_ newstomv $ const $ Prepared <$> fprepare sstate mapM_ (flip addChild retval) mchildren return retval @@ -109,7 +109,7 @@ 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 do r' <- sqlite3_reset p checkError "(fetch) reset" (dbo sstate) r' @@ -182,7 +182,7 @@ fexecute sstate args = modifyMVar (stomv sstate) doexecute 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) ) @@ -243,13 +243,13 @@ fexecutemany s vs = go (s {autoFinish=False}) s vs 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 :: Sqlite3 -> Stmt -> IO () -ffinish db st = withRawStmt st $ \p -> - sqlite3_finalize p >>= checkError "finish" db +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 ()) From dbb60cd7e3982da01fb8c285c54decc3aaac5bd0 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sat, 23 Sep 2017 19:30:00 +0000 Subject: [PATCH 7/8] Save column names on prepare rather than on execute. We'll use the "live" values with requests for an already prepared statement, and only fall-back to the saved values when finished after a previous prepare in auto-finish mode. --- Database/HDBC/Sqlite3/Statement.hsc | 36 +++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/Database/HDBC/Sqlite3/Statement.hsc b/Database/HDBC/Sqlite3/Statement.hsc index d9bdff8..cb868cd 100644 --- a/Database/HDBC/Sqlite3/Statement.hsc +++ b/Database/HDBC/Sqlite3/Statement.hsc @@ -59,11 +59,29 @@ newSth indbo mchildren auto str = finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = str, - getColumnNames = readMVar (colnamesmv sstate), + getColumnNames = getcols sstate, describeResult = fail "Sqlite3 backend does not support describeResult"} 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. @@ -152,9 +171,7 @@ 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) @@ -178,7 +195,6 @@ 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) From 55e9f998dce0c7c68a78d736860ed3bff9f8969d Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Sun, 24 Sep 2017 08:02:57 +0000 Subject: [PATCH 8/8] Added tests for auto-finish off mode. With implicit auto-finish of course the finish happens at the right time automatically, but with auto-finish off, a bit more care is required to not reset the query before all the desired rows are examined. The explicit "finish" for the statements used to fetch all rows when using the lazy fetchAllRows needs to be delayed until the rows have been fully processed (by comparing with the expected values). This is not needed in the non-lazy fetchAllRows' case. Replaced quickQuery with safeQuickQuery' when not explicitly testing quickQuery. The latter is not safe when auto-finish is off. Applications that disable auto-finish must avoid functions like quickQuery and quickQuery' internally leak prepared statements. NB: quickQuery' could be changed to explicitly finish its statement handle. --- testsrc/SpecificDB.hs | 4 ++ testsrc/SpecificDBTests.hs | 8 ++- testsrc/TestMisc.hs | 130 +++++++++++++++++++++---------------- testsrc/TestUtils.hs | 11 +++- testsrc/Testbasics.hs | 108 +++++++++++++++++------------- 5 files changed, 155 insertions(+), 106 deletions(-) diff --git a/testsrc/SpecificDB.hs b/testsrc/SpecificDB.hs index 6655c24..fd851cf 100644 --- a/testsrc/SpecificDB.hs +++ b/testsrc/SpecificDB.hs @@ -6,6 +6,10 @@ 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" diff --git a/testsrc/SpecificDBTests.hs b/testsrc/SpecificDBTests.hs index c06f82e..536f802 100644 --- a/testsrc/SpecificDBTests.hs +++ b/testsrc/SpecificDBTests.hs @@ -3,10 +3,12 @@ import Database.HDBC import Test.HUnit import TestMisc(setup) -testgetTables :: Test -testgetTables = setup $ \dbh -> +testgetTables :: Bool -> Test +testgetTables auto = setup auto $ \dbh -> do r <- getTables dbh ["hdbctest2"] @=? r tests :: Test -tests = TestList [TestLabel "getTables" testgetTables] +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 cbe8ac1..32e95b7 100644 --- a/testsrc/TestMisc.hs +++ b/testsrc/TestMisc.hs @@ -19,17 +19,25 @@ colnames = ["testid", "teststring", "testint"] alrows :: [[(String, SqlValue)]] alrows = map (zip colnames) rowdata -setup :: (Connection -> IO ()) -> Test -setup f = dbTestCase $ \dbh -> +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" [] 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 = @@ -37,16 +45,16 @@ cloneTest dbh a = finally (handleSqlError (a dbh2)) (handleSqlError (disconnect dbh2)) -testgetColumnNames :: Test -testgetColumnNames = setup $ \dbh -> +testgetColumnNames :: Bool -> Test +testgetColumnNames auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2" _ <- execute sth [] cols <- getColumnNames sth finish sth ["testid", "teststring", "testint"] @=? map (map toLower) cols -testdescribeResult :: Test -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 [] @@ -61,8 +69,8 @@ testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) finish sth -testdescribeTable :: Test -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 @@ -77,13 +85,15 @@ testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` [SqlBigIntT, SqlIntegerT]) assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) -testquickQuery :: Test -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 :: Test -testfetchRowAL = setup $ \dbh -> +testfetchRowAL :: Bool -> Test +testfetchRowAL auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" _ <- execute sth [] fetchRowAL sth >>= (Just (head alrows) @=?) @@ -92,8 +102,8 @@ testfetchRowAL = setup $ \dbh -> fetchRowAL sth >>= (Nothing @=?) finish sth -testfetchRowMap :: Test -testfetchRowMap = setup $ \dbh -> +testfetchRowMap :: Bool -> Test +testfetchRowMap auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" _ <- execute sth [] fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) @@ -102,28 +112,31 @@ testfetchRowMap = setup $ \dbh -> fetchRowMap sth >>= (Nothing @=?) finish sth -testfetchAllRowsAL :: Test -testfetchAllRowsAL = setup $ \dbh -> +testfetchAllRowsAL :: Bool -> Test +testfetchAllRowsAL auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" _ <- execute sth [] fetchAllRowsAL sth >>= (alrows @=?) + when (not auto) $ finish sth -testfetchAllRowsMap :: Test -testfetchAllRowsMap = setup $ \dbh -> +testfetchAllRowsMap :: Bool -> Test +testfetchAllRowsMap auto = setup auto $ \dbh -> do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" _ <- execute sth [] fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) + when (not auto) $ finish sth -testexception :: Test -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" ) (\_ -> commit dbh) -testrowcount :: Test -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" [] @@ -131,7 +144,7 @@ testrowcount = setup $ \dbh -> 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], @@ -141,30 +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 :: Test -testgetTables1 = setup $ \dbh -> +testgetTables1 :: Bool -> Test +testgetTables1 auto = setup auto $ \dbh -> do r <- getTables dbh True @=? "hdbctest2" `elem` r -testgetTables2 :: Test -testgetTables2 = dbTestCase $ \dbh -> +testgetTables2 :: Bool -> Test +testgetTables2 auto = dbTestCaseExt auto $ \dbh -> do r <- getTables dbh False @=? "hdbctest2" `elem` r -testclone :: Test -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 :: Test -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], @@ -172,30 +185,37 @@ testnulls = setup $ \dbh -> [SqlInt32 103, SqlString "\xFF", SqlNull], [SqlInt32 104, SqlString "regular", SqlNull]] -testunicode :: Test -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]] +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 "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] +tests = TestList [ TestLabel "auto-finish on" (autoTests True) + , TestLabel "auto-finish off" (autoTests False) + ] diff --git a/testsrc/TestUtils.hs b/testsrc/TestUtils.hs index 03af919..22c93ff 100644 --- a/testsrc/TestUtils.hs +++ b/testsrc/TestUtils.hs @@ -1,9 +1,9 @@ -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 = @@ -16,6 +16,13 @@ dbTestCase a = (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 diff --git a/testsrc/Testbasics.hs b/testsrc/Testbasics.hs index 11eeb94..2013d0b 100644 --- a/testsrc/Testbasics.hs +++ b/testsrc/Testbasics.hs @@ -3,24 +3,23 @@ import Test.HUnit import Database.HDBC import TestUtils import Control.Exception +import Control.Monad (when) -openClosedb :: Test -openClosedb = sqlTestCase $ - do dbh <- connectDB +openClosedb :: Bool -> Test +openClosedb auto = sqlTestCase $ + do dbh <- connectDBExt auto disconnect dbh -multiFinish :: Test -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 :: Test -basicQueries = dbTestCase (\dbh -> +basicQueries :: Bool -> Test +basicQueries auto = dbTestCaseExt auto (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" execute sth [] >>= (0 @=?) r <- fetchAllRows sth @@ -30,22 +29,23 @@ 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 :: Test -createTable = dbTestCase (\dbh -> + +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 :: Test -dropTable = dbTestCase (\dbh -> +dropTable :: Bool -> Test +dropTable auto = dbTestCaseExt auto (\dbh -> do runRaw dbh "DROP TABLE hdbctest1" commit dbh ) -runReplace :: Test -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 @@ -55,15 +55,17 @@ runReplace = dbTestCase (\dbh -> assertEqual "select retval" 0 rv2 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 :: Test -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"] + when (not auto) $ finish sth commit dbh sth' <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" _ <- execute sth' [SqlString "executeReplace"] @@ -74,48 +76,55 @@ executeReplace = dbTestCase (\dbh -> [toSql "executeReplace", iToSql 2, SqlNull, toSql "Bar"]] r + when (not auto) $ finish sth' ) -testExecuteMany :: Test -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 + 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 :: Test -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 + 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' :: Test -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 + 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 :: Test -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] @@ -135,11 +144,12 @@ basicTransactions = dbTestCase (\dbh -> commit dbh _ <- 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 :: Test -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"] @@ -147,7 +157,7 @@ testWithTransaction = dbTestCase (\dbh -> qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" _ <- execute qrysth [] fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) - + -- Let's try a rollback. catch (withTransaction dbh (\_ -> do executeMany sth rows fail "Foo")) @@ -159,22 +169,28 @@ testWithTransaction = dbTestCase (\dbh -> withTransaction dbh (\_ -> executeMany sth rows) _ <- 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) + ]