{-# LANGUAGE ScopedTypeVariables #-} import StrictEq import Database.SQLite3 import qualified Database.SQLite3.Direct as Direct import Prelude hiding (catch) -- Remove this import when GHC 7.6 is released, -- as Prelude no longer exports catch. import Control.Exception (bracket, handleJust, try) import Control.Monad (forM_, when) import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException(..)) import System.Directory import System.Exit (exitFailure) import System.IO import System.IO.Error (isDoesNotExistError, isUserError) import Test.HUnit import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.IO as T data TestEnv = TestEnv { conn :: Database -- ^ Database shared by all the tests , withConn :: forall a. (Database -> IO a) -> IO a -- ^ Bracket for spawning an additional connection. -- This connection will be isolated from others. , withConnShared :: forall a. (Database -> IO a) -> IO a -- ^ Like 'withConn', but every invocation shares the same database. } regressionTests :: [TestEnv -> Test] regressionTests = [ TestLabel "Exec" . testExec , TestLabel "Simple" . testSimplest , TestLabel "Prepare" . testPrepare , TestLabel "CloseBusy" . testCloseBusy , TestLabel "Params" . testBind , TestLabel "Params" . testBindParamCounts , TestLabel "Params" . testBindParamName , TestLabel "Params" . testBindErrorValidation , TestLabel "Columns" . testColumns , TestLabel "Errors" . testErrors , TestLabel "Integrity" . testIntegrity , TestLabel "DecodeError" . testDecodeError ] featureTests :: [TestEnv -> Test] featureTests = [ TestLabel "MultiRowInsert" . testMultiRowInsert ] assertFail :: IO a -> Assertion assertFail action = shouldFail action >>= assertBool "assertFail" -- | Return 'True' if the IO action throws a 'userError', -- which happens when 'fail' is used. shouldFail :: IO a -> IO Bool shouldFail action = do r <- try action case r of Left e -> return $ isUserError e Right _ -> return False withStmt :: Database -> Text -> (Statement -> IO a) -> IO a withStmt conn sql = bracket (prepare conn sql) finalize testExec :: TestEnv -> Test testExec TestEnv{..} = TestCase $ do exec conn "" exec conn " " exec conn ";" exec conn " ; ; ; ; ; " exec conn "--" Left SQLError{sqlError = ErrorError} <- try $ exec conn "/*" -- sqlite3_exec does not allow "/*" to be terminated by end of input, -- but says it's fine. exec conn ";--\n;/**/" withConn $ \conn -> do -- Make sure all the statements passed to exec are executed. -- Test a little value conversion while we're at it. exec conn "CREATE TABLE foo (n FLOAT, t TEXT); \ \INSERT INTO foo VALUES (3.5, null); \ \INSERT INTO foo VALUES (null, 'Ự₦ⓘ₡ợ₫ḝ'); \ \INSERT INTO foo VALUES (null, ''); \ \INSERT INTO foo VALUES (null, 'null'); \ \INSERT INTO foo VALUES (null, null)" withStmt conn ("SELECT * FROM foo") $ \stmt -> do Row <- step stmt [SQLFloat 3.5, SQLNull] <- columns stmt Row <- step stmt [SQLNull, SQLText "Ự₦ⓘ₡ợ₫ḝ"] <- columns stmt Row <- step stmt [SQLNull, SQLText ""] <- columns stmt Row <- step stmt [SQLNull, SQLText "null"] <- columns stmt Row <- step stmt [SQLNull, SQLNull] <- columns stmt Done <- step stmt return () -- Simplest SELECT testSimplest :: TestEnv -> Test testSimplest TestEnv{..} = TestCase $ do stmt <- prepare conn "SELECT 1+1" Row <- step stmt res <- column stmt 0 Done <- step stmt finalize stmt assertEqual "1+1" (SQLInteger 2) res testPrepare :: TestEnv -> Test testPrepare TestEnv{..} = TestCase $ do True <- shouldFail $ prepare conn "" True <- shouldFail $ prepare conn ";" withConn $ \conn -> do withStmt conn "CREATE TABLE foo (a INT, b INT); \ \INSERT INTO foo VALUES (1, 2); \ \INSERT INTO foo VALUES (3, 4)" $ \stmt -> do Done <- step stmt return () withStmt conn "BEGIN; INSERT INTO foo VALUES (5, 6); COMMIT" $ \stmt -> do Done <- step stmt return () withStmt conn "SELECT * FROM foo" $ \stmt -> do Done <- step stmt -- No row was inserted, because only the CREATE TABLE -- statement was run. The rest was ignored. return () Left SQLError{sqlError = ErrorError} <- try $ exec conn "BEGIN" -- We're in a transaction already, so this fails. exec conn "COMMIT" return () testCloseBusy :: TestEnv -> Test testCloseBusy _ = TestCase $ do conn <- open ":memory:" stmt <- prepare conn "SELECT 1" Left SQLError{sqlError = ErrorBusy} <- try $ close conn finalize stmt close conn testBind :: TestEnv -> Test testBind TestEnv{..} = TestCase $ do bracket (prepare conn "SELECT ?") finalize testBind1 bracket (prepare conn "SELECT ?+?") finalize testBind2 where testBind1 stmt = do let params = [SQLInteger 3] bind stmt params Row <- step stmt res <- columns stmt Done <- step stmt assertEqual "single param" params res testBind2 stmt = do let params = [SQLInteger 1, SQLInteger 1] bind stmt params Row <- step stmt res <- columns stmt Done <- step stmt assertEqual "two params param" [SQLInteger 2] res -- Test bindParameterCount testBindParamCounts :: TestEnv -> Test testBindParamCounts TestEnv{..} = TestCase $ do testCase "single $a" "SELECT $a" 1 testCase "3 unique ?NNNs" "SELECT (?1+?1+?1+?2+?3)" 3 testCase "3 positional" "SELECT (?+?+?)" 3 testCase "5 params, 2 gaps" "SELECT ?3, ?5, ?1" 5 testCase "6 params, gaps & auto" "SELECT ?3, ?5, ?1, ?" 6 testCase "8 params, auto & overlap" "SELECT ?, ?5, ?, ?2, ?, ?6, ?" 8 -- 8 because ? grabs an index one greater than the highest index of all -- previous parameters, not just the most recent index. testCase "0 placeholders" "SELECT 1" 0 where testCase label query expected = bracket (prepare conn query) finalize bindParameterCount >>= assertEqual label expected -- Test bindParameterName testBindParamName :: TestEnv -> Test testBindParamName TestEnv{..} = TestCase $ do bracket (prepare conn "SELECT :v + :v2") finalize (testNames [Just ":v", Just ":v2"]) bracket (prepare conn "SELECT ?1 + ?1") finalize (testNames [Just "?1"]) bracket (prepare conn "SELECT ?1 + ?2") finalize (testNames [Just "?1", Just "?2"]) bracket (prepare conn "SELECT ? + ?") finalize (testNames [Nothing, Nothing]) bracket (prepare conn "SELECT $1 + $2") finalize (testNames [Just "$1", Just "$2"]) where testNames names stmt = do count <- bindParameterCount stmt assertEqual "count match" count (fromIntegral $ length names) mapM_ (\(ndx,expecting) -> do name <- bindParameterName stmt ndx assertEqual "name match" expecting name) $ zip [1..] names testBindErrorValidation :: TestEnv -> Test testBindErrorValidation TestEnv{..} = TestCase $ do bracket (prepare conn "SELECT ?") finalize (assertFail . testException1) bracket (prepare conn "SELECT ?") finalize (assertFail . testException2) where -- Invalid use, one param in q string, none given testException1 stmt = bind stmt [] -- Invalid use, one param in q string, 2 given testException2 stmt = bind stmt [SQLInteger 1, SQLInteger 2] testColumns :: TestEnv -> Test testColumns TestEnv{..} = TestCase $ do withConn $ \conn -> do withStmt conn "CREATE TABLE foo (a INT)" command withStmt conn "SELECT * FROM foo" $ \stmt -> do 1 <- columnCount stmt exec conn "ALTER TABLE foo ADD COLUMN b INT" Done <- step stmt 2 <- columnCount stmt return () withStmt conn "SELECT * FROM foo" $ \stmt -> do 2 <- columnCount stmt Done <- step stmt 2 <- columnCount stmt return () withStmt conn "INSERT INTO foo VALUES (1, 2)" command withStmt conn "SELECT * FROM foo" $ \stmt -> do 2 <- columnCount stmt Row <- step stmt 2 <- columnCount stmt [SQLInteger 1, SQLInteger 2] <- columns stmt Done <- step stmt 2 <- columnCount stmt return () withStmt conn "INSERT INTO foo VALUES (3, 4)" command withStmt conn "INSERT INTO foo VALUES (5, 6)" command withStmt conn "SELECT * FROM foo" $ \stmt -> do 2 <- columnCount stmt exec conn "ALTER TABLE foo ADD COLUMN c INT" Row <- step stmt 3 <- columnCount stmt [SQLInteger 1, SQLInteger 2, SQLNull] <- columns stmt exec conn "ALTER TABLE foo ADD COLUMN d INT NOT NULL DEFAULT 42" -- ignored by this prepared statement, now that it has stepped. Row <- step stmt 3 <- columnCount stmt [SQLInteger 3, SQLInteger 4, SQLNull] <- columns stmt Row <- step stmt 3 <- columnCount stmt [SQLInteger 5, SQLInteger 6, SQLNull] <- columns stmt Done <- step stmt 3 <- columnCount stmt reset stmt 3 <- columnCount stmt -- The prepared statement *still* doesn't know -- about the new column. Row <- step stmt 4 <- columnCount stmt -- That's better. [SQLInteger 1, SQLInteger 2, SQLNull, SQLInteger 42] <- columns stmt return () where command stmt = do 0 <- columnCount stmt Done <- step stmt 0 <- columnCount stmt return () -- Testing for specific error codes: -- -- * ErrorConstraint -- -- * ErrorRange -- -- * ErrorLocked -- * ErrorBusy testErrors :: TestEnv -> Test testErrors TestEnv{..} = TestCase $ do withConn $ \conn -> do exec conn "CREATE TABLE foo (n INT UNIQUE)" exec conn "INSERT INTO foo VALUES (3)" expectError ErrorConstraint $ exec conn "INSERT INTO foo VALUES (3)" -- Multiple NULLs are allowed when there's a UNIQUE constraint exec conn "INSERT INTO foo VALUES (null)" exec conn "INSERT INTO foo VALUES (null)" exec conn "CREATE TABLE bar (n INT NOT NULL)" expectError ErrorConstraint $ exec conn "INSERT INTO bar VALUES (null)" withStmt conn "SELECT ?" $ \stmt -> do forM_ [-1, 0, 2] $ \i -> do expectError ErrorRange $ bindSQLData stmt i $ SQLInteger 42 expectError ErrorRange $ bindSQLData stmt i SQLNull bindSQLData stmt 1 $ SQLInteger 42 Row <- step stmt -- If column index is out of range, it returns SQLNull. -- This may or may not be the desired behavior, but at least we know. SQLNull <- column stmt (-1) SQLNull <- column stmt 1 SQLInteger 42 <- column stmt 0 return () withStmt conn "SELECT 1" $ \stmt -> do forM_ [-1, 0, 1, 2] $ \i -> do expectError ErrorRange $ bindSQLData stmt i $ SQLInteger 42 expectError ErrorRange $ bindSQLData stmt i SQLNull bind stmt [] -- This should succeed. Don't whine that there aren't any -- parameters to bind! Row <- step stmt SQLInteger 1 <- column stmt 0 return () withStmt conn "SELECT ?5" $ \stmt -> do forM_ [-1, 0, 6, 7] $ \i -> do expectError ErrorRange $ bindSQLData stmt i $ SQLInteger 42 expectError ErrorRange $ bindSQLData stmt i SQLNull bind stmt $ map SQLInteger [1..5] -- This succeeds, even though 1..4 aren't used. Row <- step stmt [SQLInteger 5] <- columns stmt return () -- Need to access the database with multiple connections. -- "BEGIN; ROLLBACK" causes running statements in the same connection to -- throw SQLITE_ABORT. withConnShared $ \conn -> do foo123456 conn withStmt conn "SELECT * FROM foo" $ \stmt -> do -- "DROP TABLE foo" should succeed, since the statement -- isn't running yet. exec conn "DROP TABLE foo" foo123456 conn Row <- step stmt 2 <- columnCount stmt [SQLInteger 1, SQLInteger 2] <- columns stmt -- "DROP TABLE foo" should fail, now that the statement is running. expectError ErrorLocked $ exec conn "DROP TABLE foo" withConnShared $ \conn -> do expectError ErrorBusy $ exec conn "DROP TABLE foo" -- Apparently, we can pretend to drop the table, but we get ErrorBusy -- if we try to actually COMMIT it. exec conn "BEGIN; DROP TABLE foo" expectError ErrorBusy $ exec conn "COMMIT" exec conn "ROLLBACK" Row <- step stmt 2 <- columnCount stmt [SQLInteger 3, SQLInteger 4] <- columns stmt Row <- step stmt 2 <- columnCount stmt [SQLInteger 5, SQLInteger 6] <- columns stmt expectError ErrorLocked $ exec conn "DROP TABLE foo" withConnShared $ \conn -> expectError ErrorBusy $ exec conn "DROP TABLE foo" Done <- step stmt 2 <- columnCount stmt exec conn "DROP TABLE foo" -- Regular 'reset' throws away the error. Make sure sqlite3_reset did -- not return an error because foo is now gone. sqlite3_reset should -- only return an error if the most recent 'step' failed. Right () <- Direct.reset stmt -- But trying to 'step' again should fail. Left SQLError{sqlError = err} <- try $ step stmt assertBool "Step after table vanishes should fail with SQLITE_ERROR or SQLITE_SCHEMA" (err == ErrorError || -- SQLite 3.7.13 err == ErrorSchema) -- SQLite 3.6.22 where expectError err io = do Left SQLError{sqlError = err'} <- try io assertEqual "testErrors: expectError" err err' foo123456 conn = exec conn "CREATE TABLE foo (a INT, b INT); \ \INSERT INTO foo VALUES (1, 2); \ \INSERT INTO foo VALUES (3, 4); \ \INSERT INTO foo VALUES (5, 6)" -- Make sure data stored in a table comes back as-is. testIntegrity :: TestEnv -> Test testIntegrity TestEnv{..} = TestCase $ do withConn $ \conn -> do exec conn "CREATE TABLE foo (i INT, f FLOAT, t TEXT, b BLOB, n TEXT)" withStmt conn "INSERT INTO foo VALUES (?, ?, ?, ?, ?)" $ \insert -> withStmt conn "SELECT * FROM foo" $ \select -> do let test = testWith (===) testWith f values = do exec conn "DELETE FROM foo" reset insert bind insert values Done <- step insert reset select Row <- step select values' <- columns select Done <- step select return $ f values values' True <- test [SQLInteger 0, SQLFloat 0.0, SQLText T.empty, SQLBlob B.empty, SQLNull] True <- test [SQLInteger minBound, SQLFloat (-1/0), SQLText "\0", SQLBlob (B8.pack "\0"), SQLNull] True <- test [SQLInteger maxBound, SQLFloat (1/0), SQLText "\1114111", SQLBlob ("\255"), SQLNull] -- SQLite3 turns NaN into SQLNull. True <- testWith (\_old new -> new === [SQLNull, SQLNull, SQLNull, SQLNull, SQLNull]) [SQLNull, SQLFloat (0/0), SQLNull, SQLNull, SQLNull] return () testDecodeError :: TestEnv -> Test testDecodeError TestEnv{..} = TestCase $ do withStmt conn "SELECT ?" $ \stmt -> do Right () <- Direct.bindText stmt 1 invalidUtf8 Row <- step stmt Left (DecodeError "Database.SQLite3.columnText: Invalid UTF-8" _) <- try $ column stmt 0 return () -- Verify the assertion that SQLite3 does not validate UTF-8, by writing the -- data to a table on disk and reading it back. withConnShared $ \conn -> do exec conn "CREATE TABLE testDecodeError (a TEXT)" withStmt conn "INSERT INTO testDecodeError VALUES (?)" $ \stmt -> do Right () <- Direct.bindText stmt 1 invalidUtf8 Done <- step stmt return () withConnShared $ \conn -> do withStmt conn "SELECT * FROM testDecodeError" $ \stmt -> do Row <- step stmt TextColumn <- columnType stmt 0 txt <- Direct.columnText stmt 0 assertEqual "testDecodeError: Database altered our invalid UTF-8" invalidUtf8 txt Left (DecodeError "Database.SQLite3.columnText: Invalid UTF-8" _) <- try $ columnText stmt 0 Done <- step stmt return () where invalidUtf8 = Direct.Utf8 $ B.pack [0x80] testMultiRowInsert :: TestEnv -> Test testMultiRowInsert TestEnv{..} = TestCase $ do withConn $ \conn -> do exec conn "CREATE TABLE foo (a INT, b INT)" result <- try $ exec conn "INSERT INTO foo VALUES (1,2), (3,4)" case result of Left SQLError{sqlError = ErrorError} -> assertFailure "Installed SQLite3 does not support multi-row INSERT via the VALUES clause" Left e -> assertFailure $ show e Right () -> do -- Make sure multi-row insert actually worked withStmt conn "SELECT * FROM foo" $ \stmt -> do Row <- step stmt [SQLInteger 1, SQLInteger 2] <- columns stmt Row <- step stmt [SQLInteger 3, SQLInteger 4] <- columns stmt Done <- step stmt return () sharedDBPath :: Text sharedDBPath = "dist/test/direct-sqlite-test-database.db" withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv cb = withConn $ \conn -> cb TestEnv { conn = conn , withConn = withConn , withConnShared = withConnPath sharedDBPath } where withConn = withConnPath ":memory:" withConnPath path = bracket (open path) close runTestGroup :: [TestEnv -> Test] -> IO Bool runTestGroup tests = do Counts{cases, tried, errors, failures} <- withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests return (cases == tried && errors == 0 && failures == 0) main :: IO () main = do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] T.putStrLn $ "Creating " `T.append` sharedDBPath handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (\_ -> return ()) (removeFile $ T.unpack sharedDBPath) open sharedDBPath >>= close ok <- runTestGroup regressionTests when (not ok) exitFailure -- Signal failure if feature tests fail. I'd rather print a noisy warning -- instead, but cabal redirects test output to log files by default. ok <- runTestGroup featureTests when (not ok) exitFailure