Permalink
Fetching contributors…
Cannot retrieve contributors at this time
830 lines (714 sloc) 32.2 KB
{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
{-# OPTIONS_GHC -fcontext-stack100 #-}
module TestCases where
import qualified Control.Exception as E (Exception, throw, catch) -- for GHC > 6.10
import System.Time
import Test.HUnit
import Text.Regex
import Database.HaskellDB
import Database.HaskellDB.Query (tableName, constantRecord, subQuery, func, count, attributeName, offset)
import Database.HaskellDB.HDBRec ((.=.))
import Control.Monad (when)
import Data.Typeable(Typeable)
import DB1
import DB1.String_tbl as TString
import DB1.Int_tbl as TInt
import DB1.Integer_tbl as TInteger
import DB1.Double_tbl as TDouble
import DB1.Bool_tbl as TBool
import DB1.Calendartime_tbl as TCalendartime
import DB1.Hdb_t1
import DBTest
tests :: Conn -> Test
tests = allTests hdb_test_db
allTests =
dbtests [
tableTests,
fieldTests,
testDeleteAll,
testDeleteNone,
testUpdateNone,
testTop,
testOffset,
queryTests ,
testOrder,
testTransactionInsert,
testInsertOnly insert string_tbl string_data_4
]
-- | Tests which cover generated SQL and do not require a database.
queryTests _ _ = TestList . map (\f -> f undefined undefined) $ [ testUnique1,
testUnique2,
testUnique3,
testUnique4,
testUnique5,
testUnique6,
testUnique7,
testUnique8,
testUnique9,
testUnique10,
testUnique11,
testAggr1,
testAggr2,
testAggrOrder,
testCorrectGroupBy,
testCorrectGroupByNoProjection,
testConcat,
testSubstring,
testFakeSelect,
testCopyAll,
testConcatAggr1,
testConcatAggr2,
testConcatAggr3,
testBracketing1,
testBracketing2,
testBracketing3
]
tableTests =
dbtests [
testTable string_tbl string_data_1,
testTable int_tbl int_data_1,
testTable integer_tbl integer_data_1,
testTable double_tbl double_data_1,
testTable bool_tbl bool_data_1,
testTable calendartime_tbl calendartime_data_1
]
fieldTests = label "fieldTests" $
dbtests [
testField string_tbl string_data_1 TString.f01,
testField string_tbl string_data_1 TString.f02,
testField string_tbl string_data_1 TString.f03,
testField string_tbl string_data_1 TString.f04,
testField int_tbl int_data_1 TInt.f01,
testField int_tbl int_data_1 TInt.f02,
testField int_tbl int_data_1 TInt.f03,
testField int_tbl int_data_1 TInt.f04,
testField integer_tbl integer_data_1 TInteger.f01,
testField integer_tbl integer_data_1 TInteger.f02,
testField integer_tbl integer_data_1 TInteger.f03,
testField integer_tbl integer_data_1 TInteger.f04,
testField double_tbl double_data_1 TDouble.f01,
testField double_tbl double_data_1 TDouble.f02,
testField double_tbl double_data_1 TDouble.f03,
testField double_tbl double_data_1 TDouble.f04,
testField bool_tbl bool_data_1 TBool.f01,
testField bool_tbl bool_data_1 TBool.f02,
testField bool_tbl bool_data_1 TBool.f03,
testField bool_tbl bool_data_1 TBool.f04,
testField calendartime_tbl calendartime_data_1 TCalendartime.f01,
testField calendartime_tbl calendartime_data_1 TCalendartime.f02,
testField calendartime_tbl calendartime_data_1 TCalendartime.f03,
testField calendartime_tbl calendartime_data_1 TCalendartime.f04
]
strangeInputTests = label "strangeInputTests" $
dbtests [
testField string_tbl string_data_strange TString.f01,
testField string_tbl string_data_strange TString.f02,
testField string_tbl string_data_strange TString.f03,
testField string_tbl string_data_strange TString.f04,
testField int_tbl int_data_strange TInt.f01,
testField int_tbl int_data_strange TInt.f02,
testField int_tbl int_data_strange TInt.f03,
testField int_tbl int_data_strange TInt.f04,
testField integer_tbl integer_data_strange TInteger.f01,
testField integer_tbl integer_data_strange TInteger.f02,
testField integer_tbl integer_data_strange TInteger.f03,
testField integer_tbl integer_data_strange TInteger.f04,
testField double_tbl double_data_strange TDouble.f01,
testField double_tbl double_data_strange TDouble.f02,
testField double_tbl double_data_strange TDouble.f03,
testField double_tbl double_data_strange TDouble.f04,
testField calendartime_tbl calendartime_data_strange TCalendartime.f01,
testField calendartime_tbl calendartime_data_strange TCalendartime.f02,
testField calendartime_tbl calendartime_data_strange TCalendartime.f03,
testField calendartime_tbl calendartime_data_strange TCalendartime.f04
]
testTable tbl r =
dbtests [
testUnique tbl r,
testNonUnique tbl r
]
testField tbl r f =
dbtests [
testInsertAndQuery tbl r f
]
testInsertAndQuery tbl r f = dbtest name $ \db ->
do insert db tbl (constantRecord r)
rs <- query db $ do t <- table tbl
project (f << t!f)
assertEqual "Bad result length" 1 (length rs)
assertSame "Bad field value" (r!f) (head rs!f)
where name = "insertAndQuery " ++ tableName tbl ++ "." ++ attributeName f
testUnique tbl r = dbtest name $ \db ->
do insert db tbl (constantRecord r)
insert db tbl (constantRecord r)
rs <- query db $ do { t <- table tbl; unique; return t; }
assertEqual "Bad result length" 1 (length rs)
where name = "unique " ++ tableName tbl
testNonUnique tbl r = dbtest name $ \db ->
do insert db tbl (constantRecord r)
insert db tbl (constantRecord r)
rs <- query db $ table tbl
assertEqual "Bad result length" 2 (length rs)
where name = "nonunique " ++ tableName tbl
testNotDistinct tbl r = dbtest name $ \db ->
do insert db tbl (constantRecord r)
insert db tbl (constantRecord r)
rs <- query db $ table tbl
assertEqual "Bad result length" 2 (length rs)
where name = "not distinct " ++ tableName tbl
-- For running tests that don't really need a database connection, but
-- we want to include in the lists above
noDBTest name test = \_ _ -> TestLabel name (TestCase test)
-- Tests queries with aggregates and ORDER BY columns which do not appear
-- in SELECT still show up in GROUP BY. Note this
-- test does not require any DB access.
testAggrOrder = noDBTest "aggregate order by" $ do
let qryTxt = showSql $ do
t1 <- table int_tbl
t2 <- table int_tbl
order [asc t1 TInt.f02]
project $ TInt.f02 << count(t1 ! TInt.f02)
# TInt.f01 << (t2 ! TInt.f01)
-- Regex which ensures TInt.f02 column appears in GROUP BY, since it also appears
-- in ORDER BY
groupByTxt = mkRegex "GROUP BY.*\n.*f021.*\n.*ORDER BY.*f021"
hasMatch = maybe (False) (const True) (matchRegex groupByTxt qryTxt)
assertBool ("Expected columns did not appear in group by: " ++ qryTxt) hasMatch
-- Test that groupby clause is correctly tracked with projections
testCorrectGroupBy = noDBTest "Testing that groupby is correct with projections" $ do
let qryTxt = showSql $ do
p <- table int_tbl
r <- project (TInt.f01 << (p ! TInt.f01))
unique
return r
groupByTxt = mkRegex "GROUP BY.*f01.*"
hasMatch = maybe (False) (const True) (matchRegex groupByTxt qryTxt)
assertBool ("GROUP BY does not have correct columns: " ++ qryTxt) hasMatch
testCorrectGroupByNoProjection = noDBTest "Testing that groupby is correct without projection" $ do
let qryTxt = showSql $ do
p <- table int_tbl
unique
return p
groupByTxt = mkRegex "GROUP BY.*f01,\n.*f02,\n.*f03,\n.*f04"
hasMatch = maybe (False) (const True) (matchRegex groupByTxt qryTxt)
assertBool ("GROUP BY does not have correct columns: " ++ qryTxt) hasMatch
testUnique1 = noDBTest "Testing that unique and count work together in a subquery." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
t1 <- table int_tbl
unique
project $ TInt.f02 << count(t1 ! TInt.f02)
project $ TInt.f02 << (v ! TInt.f02)
groupByTxt = "SELECT COUNT(f021) as f02\n\
\FROM (SELECT f02 as f021\n\
\ FROM int_tbl as T1) as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique2 = noDBTest "Testing that unique and subquery work together correctly." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
restrict ((s ! TInt.f01) .==. constVal 100)
unique
project $ TInt.f02 << (s ! TInt.f02)
project $ TInt.f02 << (v ! TInt.f02)
groupByTxt = "SELECT f02\n\
\FROM int_tbl as T1\n\
\WHERE (f01 = 100)\n\
\GROUP BY f02"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique3 = noDBTest "Testing that unique and restriction work correctly when an aggregate function is used at top level." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
restrict ((s ! TInt.f01) .==. constVal 100)
unique
project $ TInt.f02 << (s ! TInt.f02)
project $ TInt.f02 << count(v ! TInt.f02)
groupByTxt = "SELECT COUNT(f024) as f02\n\
\FROM (SELECT f02 as f024\n\
\ FROM int_tbl as T1\n\
\ WHERE (f01 = 100)\n\
\ GROUP BY f02) as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique4 = noDBTest "Testing that unique in top-level query works." $ do
let qryTxt = showSql $ do
s <- table int_tbl
restrict ((s ! TInt.f01) .==. constVal 100)
unique
project $ TInt.f02 << (s ! TInt.f02)
groupByTxt = "SELECT f02\n\
\FROM int_tbl as T1\n\
\WHERE (f01 = 100)\n\
\GROUP BY f02"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique5 = noDBTest "Testing that unique, restrict and count in subquery works." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
restrict ((s ! TInt.f01) .==. constVal 100)
unique
project $ TInt.f02 << count(s ! TInt.f02)
project $ TInt.f02 << (v ! TInt.f02)
groupByTxt = "SELECT COUNT(f021) as f02\n\
\FROM (SELECT f02 as f021\n\
\ FROM int_tbl as T1\n\
\ WHERE (f01 = 100)) as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique6 = noDBTest "Testing that unique in subquery and restriction at top-level works." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
unique
project $ TInt.f01 << (s ! TInt.f03)
restrict ((v ! TInt.f01) .==. constVal 100)
project $ TInt.f01 << (v ! TInt.f01)
groupByTxt = "SELECT f013 as f01\n\
\FROM (SELECT f03 as f013\n\
\ FROM int_tbl as T1\n\
\ GROUP BY f03) as T1\n\
\WHERE (f013 = 100)"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique7 = noDBTest "Testing that unique in subquery and restriction plus count at top-level works." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
unique
project $ TInt.f02 << (s ! TInt.f04)
restrict $ (v ! TInt.f02) .==. constant 100
project $ TInt.f02 << count(v ! TInt.f02)
groupByTxt = "SELECT COUNT(f023) as f02\n\
\FROM (SELECT f04 as f023\n\
\ FROM int_tbl as T1\n\
\ GROUP BY f04) as T1\n\
\WHERE (f023 = 100)"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique8 = noDBTest "Testing that group by works correctly with projected expressions (instead of just columns)" $ do
let qryTxt = showSql $ do
v <- subQuery $ do
h <- table int_tbl
project $ TInt.f02 << _case [((h ! TInt.f02) .==. constant 100, constant 0)] (constant (1::Int))
unique
return v
groupByTxt = "SELECT CASE WHEN f02 = 100 THEN 0 ELSE 1 END as f02\n\
\FROM int_tbl as T1\n\
\GROUP BY (CASE WHEN f02 = 100 THEN 0 ELSE 1 END)"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique9 = noDBTest "Testing that group by works correctly with projected expressions and aggregates" $ do
let qryTxt = showSql $ do
v <- subQuery $ do
h <- table int_tbl
project $ TInt.f02 << _case [((h ! TInt.f02) .==. constant 100, constant 0)] (constant (1::Int))
# TInt.f04 << count (h ! TInt.f01)
unique
project $ copyAll v
groupByTxt = "SELECT CASE WHEN f02 = 100 THEN 0 ELSE 1 END as f02,\n\
\ COUNT(f01) as f04\n\
\FROM int_tbl as T1\n\
\GROUP BY (CASE WHEN f02 = 100 THEN 0 ELSE 1 END)"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique10 = noDBTest "Testing that count works when unique is in a subquery." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
t1 <- table int_tbl
unique
project $ TInt.f02 << (t1 ! TInt.f02)
project $ TInt.f02 << count(v ! TInt.f02)
groupByTxt = "SELECT COUNT(f024) as f02\n\
\FROM (SELECT f02 as f024\n\
\ FROM int_tbl as T1\n\
\ GROUP BY f02) as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testUnique11 = noDBTest "Testing that count works when unique and restrict in a subquery." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
s <- table int_tbl
restrict ((s ! TInt.f01) .==. constVal 100)
unique
project $ TInt.f02 << (s ! TInt.f02)
project $ TInt.f02 << count(v ! TInt.f02)
groupByTxt = "SELECT COUNT(f024) as f02\n\
\FROM (SELECT f02 as f024\n\
\ FROM int_tbl as T1\n\
\ WHERE (f01 = 100)\n\
\ GROUP BY f02) as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
-- This query will fail to compile if instances from Data.HList.TypeCastGeneric1 are
-- not imported.
testHasField = noDBTest "Ensuring HasField works with restrict." $ do
let qryTxt = do
s <- table int_tbl
restrict ((s ! TInt.f02) .==. (s ! TInt.f02))
project $ TInt.f03 << (s ! TInt.f03)
groupByTxt = "";
assertBool "If this test compiles it worked." True
-- This test ensures that 'fake' results can be built in code. An
-- incorrect optimization was removing projections w/ no columns, which
-- resulted in the table associated with a query being lost.
testFakeSelect = noDBTest "Testing that fake tables can be built in code." $ do
let qryTxt = showSql $ do {
h <- table int_tbl;
project $ TInt.f02 << constant (1 :: Int); }
expected = "SELECT 1 as f02\n\
\FROM int_tbl as T1"
assertQueryText "Did not generate expected query. " qryTxt expected
testAggr1 = noDBTest "Testing that group does use projected expressions when aggregate is present" $ do
let qryTxt = showSql $ do
h <- table int_tbl
project $ TInt.f02 << _case [((h ! TInt.f02) .==. constant 100, constant 0)] (constant (1::Int))
# TInt.f04 << count (h ! TInt.f01)
groupByTxt = "SELECT CASE WHEN f02 = 100 THEN 0 ELSE 1 END as f02,\n\
\ COUNT(f01) as f04\n\
\FROM int_tbl as T1\n\
\GROUP BY (CASE WHEN f02 = 100 THEN 0 ELSE 1 END)"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
testConcat = noDBTest "Testing SQL concat query" $ do
let qryTxt = showSql $ do
h <- table string_tbl
project $ TString.f02 << concatF (h ! TString.f02) (h ! TString.f04)
result = "SELECT concat(f02,f04) as f02\n\
\FROM string_tbl as T1"
assertQueryText "Concat not generated as expected: " qryTxt result
concatF :: Expr String -> Expr String -> Expr String
concatF str1 str2 = func "concat" str1 str2
substringF :: Expr String -> Expr Int -> Expr Int -> Expr String
substringF str idx len = func "substring" str idx len
testSubstring = noDBTest "Testing SQL concat query" $ do
let qryTxt = showSql $ do
h <- table string_tbl
project $ TString.f02 << substringF (h ! TString.f02) (constant 0) (constant 5)
result = "SELECT substring(f02,0,5) as f02\n\
\FROM string_tbl as T1"
assertQueryText "Substring not generated as expected: " qryTxt result
{-| This query caused an exception due to a bug in defaultSqlBinary. Ensure that doesn't
happen again. Additionally, this test makes sure base tables aren't
dropped, even if they have no columns used. A cross-join may be desired for
some reason. Otherwise, why include the table?
-}
testCopyAll = noDBTest "Test copyAll operator" $ do
let qryTxt = showSql $ do
t1 <- table int_tbl
t2 <- table string_tbl
project $ copyAll t2
expected = "SELECT f012 as f01,\n\
\ f022 as f02,\n\
\ f032 as f03,\n\
\ f042 as f04\n\
\FROM (SELECT f01 as f012,\n\
\ f02 as f022,\n\
\ f03 as f032,\n\
\ f04 as f042\n\
\ FROM string_tbl as T1) as T1,\n\
\ int_tbl as T2"
assertQueryText "Test that copyAll generates query correctly, even if not all columns are used." qryTxt expected
testAggr2 = noDBTest "Testing that top level constants don't cause an extra groupby" $ do
let qryTxt = showSql $ do
v <- subQuery $ do
h <- table int_tbl
project $ TInt.f02 <<- 100
# TInt.f04 << count (h ! TInt.f01)
unique
project $ copyAll v
groupByTxt = "SELECT 100 as f02,\n\
\ COUNT(f01) as f04\n\
\FROM int_tbl as T1"
assertQueryText "Did not generate expected query. " qryTxt groupByTxt
-- | Test non-aggregate functions with aggregates.
testConcatAggr1 = noDBTest "Testing SQL concat query with unique." $ do
let qryTxt = showSql $ do
h <- table string_tbl
unique
project $ TString.f02 << concatF (h ! TString.f02) (h ! TString.f04)
result = "SELECT concat(f021,f041) as f02\n\
\FROM (SELECT f02 as f021,\n\
\ f04 as f041\n\
\ FROM string_tbl as T1) as T1\n\
\GROUP BY (concat(f021,f041))"
assertQueryText "Concat not generated as expected: " qryTxt result
testConcatAggr2 = noDBTest "Testing SQL concat query with a count" $ do
let qryTxt = showSql $ do
v <- subQuery $ do
h <- table string_tbl
unique
project $ TString.f02 << concatF (h ! TString.f02) (h ! TString.f04)
project $ TInt.f02 << count (v ! TString.f02)
result = "SELECT COUNT(f024) as f02\n\
\FROM (SELECT concat(f021,f041) as f024\n\
\ FROM (SELECT f02 as f021,\n\
\ f04 as f041\n\
\ FROM string_tbl as T1) as T1\n\
\ GROUP BY (concat(f021,f041))) as T1"
assertQueryText "Concat not generated as expected: " qryTxt result
testConcatAggr3 = noDBTest "Testing SQL concat query with a count and unique." $ do
let qryTxt = showSql $ do
v <- subQuery $ do
h <- table string_tbl
project $ TString.f02 << concatF (h ! TString.f02) (h ! TString.f04)
project $ TInt.f02 << count (v ! TString.f02)
result = "SELECT COUNT(concat(f02,f04)) as f02\n\
\FROM string_tbl as T1"
assertQueryText "Concat not generated as expected: " qryTxt result
testBracketing1 = noDBTest "Testing that properly bracketed SQL is generated (1)." $ do
let qryTxt = showSql $ do
s <- table int_tbl
restrict (((s ! TInt.f02 .==. s ! TInt.f02) .&&. (s ! TInt.f02 .==. s ! TInt.f02)) .||.
((s ! TInt.f02 .==. s ! TInt.f02) .&&. (s ! TInt.f02 .==. s ! TInt.f02)))
project $ TInt.f03 << (s ! TInt.f03)
result = "SELECT f03\n\
\FROM int_tbl as T1\n\
\WHERE (((f02 = f02) AND (f02 = f02)) OR ((f02 = f02) AND (f02 = f02)))"
assertQueryText "Concat not generated as expected: " qryTxt result
testBracketing2 = noDBTest "Testing that properly bracketed SQL is generated (2)." $ do
let qryTxt = showSql $ do
s <- table int_tbl
restrict (((s ! TInt.f02 .==. s ! TInt.f02) .||. (s ! TInt.f02 .==. s ! TInt.f02)) .&&.
((s ! TInt.f02 .==. s ! TInt.f02) .||. (s ! TInt.f02 .==. s ! TInt.f02)))
project $ TInt.f03 << (s ! TInt.f03)
result = "SELECT f03\n\
\FROM int_tbl as T1\n\
\WHERE (((f02 = f02) OR (f02 = f02)) AND ((f02 = f02) OR (f02 = f02)))"
assertQueryText "Concat not generated as expected: " qryTxt result
testBracketing3 = noDBTest "Testing that properly bracketed SQL is generated (3)." $ do
let qryTxt = showSql $ do
s <- table int_tbl
restrict ((s ! TInt.f02 .==. s ! TInt.f02) .||. (s ! TInt.f02 .==. s ! TInt.f02))
restrict ((s ! TInt.f02 .==. s ! TInt.f02) .||. (s ! TInt.f02 .==. s ! TInt.f02))
restrict ((s ! TInt.f02 .==. s ! TInt.f02) .||. (s ! TInt.f02 .==. s ! TInt.f02))
project $ TInt.f03 << (s ! TInt.f03)
result = "SELECT f03\n\
\FROM int_tbl as T1\n\
\WHERE ((f02 = f02) OR (f02 = f02)) AND ((f02 = f02) OR (f02 = f02)) AND ((f02 = f02) OR (f02 = f02))"
assertQueryText "Concat not generated as expected: " qryTxt result
-- | Helper which asserts that two query strings are equal.
assertQueryText msg query expect = assertBool (msg ++ "\nGot: \n\n" ++ query ++
"\n\nand expected: \n\n" ++ expect)
(query == expect)
-- * Insert
testInsert = dbtest "insert" $ \db ->
do insertData db hdb_t1 hdb_t1_data
rs <- query db $ table hdb_t1
assertEqual "Bad result length" (length hdb_t1_data) (length rs)
testInsertOnly ins tbl r = dbtest name $ \db ->
ins db tbl (constantRecord r)
where name = "rearrange " ++ tableName tbl
-- * Delete
testDeleteAll = dbtest "deleteAll" $ \db ->
do insertData db hdb_t1 hdb_t1_data
delete db hdb_t1 (\_ -> constant True)
rs <- query db $ table hdb_t1
assertBool "Query after complete delete is non-empty" (null rs)
testDeleteNone = dbtest "deleteNone" $ \db ->
do insertData db hdb_t1 hdb_t1_data
rs <- query db $ table hdb_t1
delete db hdb_t1 (\_ -> constant False)
rs' <- query db $ table hdb_t1
assertEqual "Something was changed by a null delete" rs rs'
-- * Update
testUpdateNone = dbtest "updateNone" $ \db ->
do insertData db hdb_t1 hdb_t1_data
rs <- query db $ table hdb_t1
update db hdb_t1 (\_ -> constant False) (\_ -> (t1f02 << constant "flubber"))
rs' <- query db $ table hdb_t1
assertEqual "Something was changed by a null update" rs rs'
testTop = dbtest "top" $ \db ->
do insertData db hdb_t1 hdb_t1_data
rs <- query db $ do t <- table hdb_t1
top 1
return t
assertEqual "Result count" 1 (length rs)
testOffset = dbtest "offset" $ \db ->
do insert db string_tbl (constantRecord string_data_1)
insert db string_tbl (constantRecord string_data_2)
rs <- query db $ do t <- table string_tbl
order [asc t TString.f01]
offset 1
return t
assertEqual "Result count" 1 (length rs)
assertEqual "First record" string_data_1 (rs !! 0)
testOrder = dbtest "order" $ \db ->
do insert db string_tbl (constantRecord string_data_1)
insert db string_tbl (constantRecord string_data_2)
rs <- query db $ do t <- table string_tbl
order [asc t TString.f01]
return t
assertEqual "Result count" 2 (length rs)
assertEqual "First record" string_data_2 (rs !! 0)
assertEqual "Second record" string_data_1 (rs !! 1)
testTransactionInsert dbi conn = TestCase $ E.catch (realTest >> assertFailure "Foo") doTest
where
doTest :: AbortTransaction -> IO ()
doTest _ = return () -- withDB checkForTable conn
(TestLabel _ (TestCase realTest)) = dbtest "transactionInsert" test dbi conn
test db = transaction db $ do
insertData db hdb_t1 hdb_t1_data
E.throw AbortTransaction
return ()
checkForTable db = do
ts <- tables db
when (tableName hdb_t1 `elem` ts)
(assertFailure $ tableName hdb_t1 ++ " should not exist after transaction failure.")
data AbortTransaction = AbortTransaction
deriving (Show, Typeable)
instance E.Exception AbortTransaction
-- * Utilities
assertTableEmpty db tbl =
do rs <- query db $ table tbl
assertBool "Table not empty" (null rs)
assertSame :: (Show a, Same a) => String -> a -> a -> Assertion
assertSame s x y = assertBool msg (same x y)
where msg = s ++ " Expected: " ++ show x ++ ", got " ++ show y
insertData db tbl = mapM_ (insert db tbl)
sameClockTime :: CalendarTime -> CalendarTime -> Bool
sameClockTime t1 t2 = toClockTime t1 == toClockTime t2
-- Hack to replace Eq CalendarTime
class Eq a => Same a where
same :: a -> a -> Bool
same = (==)
instance Same a => Same [a] where
same [] [] = True
same (x:xs) (y:ys) = same x y && same xs ys
same _ _ = False
instance Same a => Same (Maybe a) where
same Nothing Nothing = True
same (Just x) (Just y) = same x y
same _ _ = False
instance Same Char
instance Same Int
instance Same Integer
instance Same Double
instance Same Bool
instance Same CalendarTime where
same = sameClockTime
-- * Test data
string_data = [string_data_1,string_data_2,string_data_3]
string_data_1 =
TString.f01 .=. Just "foo" #
TString.f02 .=. "bar" #
TString.f03 .=. Nothing #
TString.f04 .=. "baz"
string_data_2 =
TString.f01 .=. Just "asdas" #
TString.f02 .=. "dast fsdf e" #
TString.f03 .=. Nothing #
TString.f04 .=. "jhasiude94"
string_data_3 =
TString.f01 .=. Just "dafjht" #
TString.f02 .=. "adsfkasdjfklsadjfalsdf" #
TString.f03 .=. Nothing #
TString.f04 .=. "xxxxxxxx"
-- Test for field rearrangment inside insert,
-- and for the type of F03 not being fixed.
string_data_4 =
TString.f01 .=. Just "dafjht" #
TString.f02 .=. "adsfkasdjfklsadjfalsdf" #
TString.f03 .=. Nothing #
TString.f04 .=. "xxxxxxxx"
-- Test for defaulting of Maybe columns -- F03 should default to Nothing.
string_data_5 =
TString.f01 .=. Just "dafjht" #
TString.f02 .=. "adsfkasdjfklsadjfalsdf" #
TString.f04 .=. "xxxxxxxx"
string_data_strange =
TString.f01 .=. Just "'\"\\;" #
TString.f02 .=. "\n\r\t " #
TString.f03 .=. Nothing #
TString.f04 .=. "\255\246\0"
int_data_1 =
TInt.f01 .=. Just 42 #
TInt.f02 .=. 43 #
TInt.f03 .=. Nothing #
TInt.f04 .=. (-1234)
int_data_strange =
TInt.f01 .=. Just 2147483647 #
TInt.f02 .=. (-2147483648) #
TInt.f03 .=. Nothing #
TInt.f04 .=. 0
integer_data_1 =
TInteger.f01 .=. Just 1 #
TInteger.f02 .=. 123 #
TInteger.f03 .=. Nothing #
TInteger.f04 .=. (-453453)
integer_data_strange =
TInteger.f01 .=. Just 1234567890123456789012345678901234567890 #
TInteger.f02 .=. (-35478572384578913475813465) #
TInteger.f03 .=. Nothing #
TInteger.f04 .=. (-1)
double_data_1 =
TDouble.f01 .=. Just 0.0 #
TDouble.f02 .=. 4.245 #
TDouble.f03 .=. Nothing #
TDouble.f04 .=. (-8.6e15)
double_data_strange =
TDouble.f01 .=. Just (-0.0) #
TDouble.f02 .=. pi #
TDouble.f03 .=. Nothing #
TDouble.f04 .=. (-8.6e37)
bool_data_1 =
TBool.f01 .=. Just True #
TBool.f02 .=. True #
TBool.f03 .=. Nothing #
TBool.f04 .=. False
calendartime_data_1 =
TCalendartime.f01 .=. Just epoch #
TCalendartime.f02 .=. epoch #
TCalendartime.f03 .=. Nothing #
TCalendartime.f04 .=. someTime
calendartime_data_strange =
TCalendartime.f01 .=. Just (epoch { ctYear = 1969 }) #
TCalendartime.f02 .=. someTime { ctYear = 2040 } #
TCalendartime.f03 .=. Nothing #
TCalendartime.f04 .=. epoch { ctYear = 1000 }
hdb_t1_data = [hdb_t1_data_1]
hdb_t1_data_1 =
t1f01 <<- Just "foo" #
t1f02 <<- "bar" #
t1f03 <<- Nothing #
t1f04 <<- "baz" #
t1f05 <<- Just 42 #
t1f06 <<- 43 #
t1f07 <<- Nothing #
t1f08 <<- (-1234) #
t1f09 <<- Just 324234 #
t1f10 <<- 123 #
t1f11 <<- Nothing #
t1f12 <<- (-453453) #
t1f13 <<- Just 0.0 #
t1f14 <<- pi #
t1f15 <<- Nothing #
t1f16 <<- (-8.6e15) #
-- Disabled for now, since booleans don't really work anywhere
-- t1f17 << Just True #
-- t1f18 << True #
-- t1f19 << Nothing #
-- t1f20 << False #
t1f21 <<- Just epoch #
t1f22 <<- epoch #
t1f23 <<- Nothing #
t1f24 <<- someTime
epoch = CalendarTime {
ctYear = 1970,
ctMonth = January,
ctDay = 1,
ctHour = 0,
ctMin = 0,
ctSec = 0,
ctPicosec = 0,
ctWDay = Thursday,
ctYDay = 0,
ctTZName = "UTC",
ctTZ = 0,
ctIsDST = False
}
someTime = CalendarTime {
ctYear = 2006,
ctMonth = July,
ctDay = 18,
ctHour = 13,
ctMin = 37,
ctSec = 15,
ctPicosec = 0,
ctWDay = Tuesday,
ctYDay = 198,
ctTZName = "PDT",
ctTZ = -25200,
ctIsDST = True
}