TestCases.hs

{-# 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
                        }