|
Module      :  Database.PostgreSQL.Test.PGFunctions
Copyright   :  (c) 2004 Oleg Kiselyov, Alistair Bayley
License     :  BSD-style
Maintainer  :  oleg@pobox.com, alistair@abayley.org
Stability   :  experimental
Portability :  non-portable


> {-# OPTIONS -fglasgow-exts #-}

> module Database.PostgreSQL.Test.PGFunctions (runTest) where


> import Database.PostgreSQL.PGFunctions
> import Database.Util
> import Foreign
> import Foreign.C
> import Control.Monad
> import Control.Exception
> import Data.Dynamic
> import System.Environment (getArgs)
> import Test.MiniUnit
> import Data.Char
> import Data.Time


This low-level test assumes that the user has a database with their name.
If not, it won't work. I have a postgres user and a postgres database.

> runTest :: String -> IO ()
> runTest dbname = printPropagateError $ do
>   testOpen ("user=" ++ dbname)
>   db <- openDb ("user=" ++ dbname)
>   disableNoticeReporting db
>   createFixture db
>   runTestTT "Postgres low-level tests" (testlist db)
>   destroyFixture db
>   closeDb db

> testlist db = map ($ db)
>   [ testSelectInts
>   , testSelectDouble
>   , testSelectDate
>   , testSelectDate2
>   , testSelectDate3
>   , testSelectNumeric
>   , testSelectStrings
>   , testSelectInt64
>   , testSelectNoRows
>   , testUnion
>   , testSelectManyRows
>   , testBindString
>   , testBindInt
>   , testBindDouble
>   , testBindDate
>   , testCreateDual
>   , testSelectUTF8Text
>   ]


> ignoreError action = catchPG action (const (return ()))

> printIgnoreError action = catchPG action (putStrLn . show)

> printPropagateError action = catchPG action 
>     (\e -> putStrLn (show e) >> rethrowPG e)

> ddlExec db stmt = nqExec db stmt >> return ()

> testOpen connstr = openDb connstr >>= closeDb

> createFixture db = do
>   -- ignoreError $ ddlExec db "drop table tdual"
>   -- ignoreError $ ddlExec db "drop table t_natural"
>   -- ignoreError $ ddlExec db "drop table t_blob"
>   printPropagateError $
>       ddlExec db "create temp table tdual (dummy text primary key)"
>   printPropagateError $
>       ddlExec db "insert into tdual (dummy) values ('X')"
>   printPropagateError $ ddlExec db 
>		    "create temp table t_natural (n integer primary key)"
>   mapM_ (insertNatural db) [1,2,64,65534,65535,65536]
>   printPropagateError $
>       ddlExec db "create temp table t_blob (b bytea)"
>   printPropagateError $
>       ddlExec db "insert into t_blob values ('blobtest')"

> insertNatural db n = do
>   ddlExec db $ "insert into t_natural values (" ++ (show n) ++ ")"



> destroyFixture db = return () -- our tables are temporary

> testCreateDual db = do
>   ignoreError ( do
>       ddlExec db "create temp table tdual (dummy integer primary key)"
>       assertFailure "PGException not thrown when table already exists"
>     )
>   printPropagateError $ ddlExec db "insert into tdual values (1)"


> testSelectStrings db = do
>   sn <- printPropagateError $
>     stmtPrepare db "" "select text(n) from t_natural where n < 3 order by n;" []
>   (stmt,ntuples) <- stmtExec0t db sn
>   assertEqual "testSelectInts: ntuples" 2 ntuples
>   n <- colValString stmt 1 1
>   assertEqual "testSelectInts: 1" 1 (read n)
>   n <- colValString stmt 2 1
>   assertEqual "testSelectInts: 2" 2 (read n)
>   stmtFinalise stmt

> testSelectInts db = do
>   sn <- printPropagateError $
>     stmtPrepare db "" "select n from t_natural where n < 65536 order by n;" []
>   (rs,ntuples) <- stmtExec0t db sn
>   assertEqual "testSelectInts: ntuples" 5 ntuples
>   n <- colValInt rs 1 1
>   assertEqual "testSelectInts: 1" 1 n
>   n <- colValInt rs 2 1
>   assertEqual "testSelectInts: 2" 2 n
>   n <- colValInt rs 3 1
>   assertEqual "testSelectInts: 64" 64 n
>   n <- colValInt rs 4 1
>   assertEqual "testSelectInts: 65534" 65534 n
>   stmtFinalise rs

> testSelectInt64 db = do
>   sn <- printPropagateError $
>     stmtPrepare db "" "select 20041225235959" []
>     --stmtPrepare db "" "select -1 union select 1 union select 2*1000*1000*1000 order by 1"
>   (stmt,ntuples) <- stmtExec0t db sn
>   n <- colValInt64 stmt 1 1
>   assertEqual "testSelectInt64: 20041225235959" 20041225235959 n
>   stmtFinalise stmt


> testSelectDouble db = do
>   sn <- printPropagateError $ stmtPrepare db "" "select 1.2::float8" []
>   (stmt,ntuples) <- stmtExec0t db sn
>   n <- colValDouble stmt 1 1
>   assertEqual "testSelectDouble: 1.2" 1.2 n
>   stmtFinalise stmt

> testSelectDate db = do
>   sn <- printPropagateError $ stmtPrepare db ""
>     ("select timestamp with time zone '2000-01-01'"
>      ++ " union select timestamp with time zone '2001-01-01'"
>      ++ " union select timestamp with time zone '1999-01-01' order by 1"
>     )
>     []
>   let
>     d1 = UTCTime (fromGregorian 1999 1 1) 0
>     d0 = UTCTime (fromGregorian 2000 1 1) 0
>     d2 = UTCTime (fromGregorian 2001 1 1) 0
>     diff1 = realToFrac (diffUTCTime d1 d0)
>     diff2 = realToFrac (diffUTCTime d2 d0)
>   (stmt,ntuples) <- stmtExec0t db sn
>   d <- colValUTCTime stmt 1 1
>   assertEqual "testSelectDate: 1999" d1 d
>   d <- colValUTCTime stmt 2 1
>   assertEqual "testSelectDate: 2000" d0 d
>   d <- colValUTCTime stmt 3 1
>   assertEqual "testSelectDate: 2001" d2 d
>   stmtFinalise stmt


Here we test some wierd date boundary cases in Postgres.
There's some funnyness around 1916-10-01 02:25:20 when we use time zones.

testSelectDate2: 1, -2627156078
testSelectDate2: 2, -2627156079
testSelectDate2: 3, -2627156080 (without time zone)
testSelectDate2: 4, -2627158159 (with time zone)
diff 3-4: 2080 seconds = 00:34:40

-- Update:

Turns out this is due to my default timezone, which was set to Europe/Dublin
(some odd things happened to Irish timekeeping at 1916-10-01 02:25:20).

Setting it to GMT (rather than Europe/London or Europe/Dublin) fixed it.
Note that Europe/London also has some funnyness in 1847,
so it's also a poor choice if we want to test boundary dates.


> testSelectDate2 db = do
>   let
>     sqltext =  "select timestamp without time zone '1916-10-01 02:25:22', 10"
>      ++ " union select timestamp without time zone '1916-10-01 02:25:21', 20"
>      ++ " union select timestamp without time zone '1916-10-01 02:25:20', 30"
>      ++ " union select timestamp with time zone '1916-10-01 02:25:20' /* this one fails */, 40"
>      ++ " order by 2"
>   sn <- printPropagateError $ stmtPrepare db "" sqltext []
>   let
>     ds = (
>            mkUTCTime 1916 10  1  2 25 22:
>            mkUTCTime 1916 10  1  2 25 21:
>            mkUTCTime 1916 10  1  2 25 20:
>            mkUTCTime 1916 10  1  2 25 20:
>          [] )
>   (stmt,ntuples) <- stmtExec0t db sn
>   let
>     loop n =
>       if n <= ntuples
>         then do
>         x <- colValDouble stmt n 1
>         d <- colValUTCTime stmt n 1
>         assertEqual ("testSelectDate2: " ++ show n ++ "\n" ++ sqltext) (ds!!(n-1)) d
>         loop (n+1)
>         else return ()
>   loop 1
>   stmtFinalise stmt


Postgres only allows specification of -ve years by use of the AD/BC suffix.
Sadly, this differs from the astronomical year number like so:
astro: ...  3,  2,  1,  0, -1, -2, -3,...
ad/bc: ...3AD,2AD,1AD,1BC,2BC,3BC,4BC,...

i.e. 0 astro = 1BC, -1 astro = 2BC, etc.

ISO8601 uses astronomical years, so we ought to be able to write
-1000-12-25 (instead of 1001-01-01 BC), but Postgres won't parse this.

> testSelectDate3 db = do
>   let
>     sqltext =  "select timestamp without time zone '1900-01-01', 10"
>      ++ " union select timestamp without time zone '1000-01-01', 20"
>      ++ " union select timestamp without time zone '0001-01-01', 30"
>      ++ " union select timestamp without time zone '1001-01-01 BC', 40"
>      ++ " order by 2"
>   sn <- printPropagateError $ stmtPrepare db "" sqltext []
>   let
>     ds =
>       mkUTCTime 1900 1  1  0 0 0 :
>       mkUTCTime 1000 1  1  0 0 0 :
>       mkUTCTime 0001 1  1  0 0 0 :
>       mkUTCTime (-1000) 1  1  0 0 0 :
>       []
>   (stmt,ntuples) <- stmtExec0t db sn
>   let
>     loop n =
>       if n <= ntuples
>         then do
>         --x <- colValDouble stmt n 1
>         d <- colValUTCTime stmt n 1
>         assertEqual ("testSelectDate3: " ++ show n ++ "\n" ++ sqltext) (ds!!(n-1)) d
>         loop (n+1)
>         else return ()
>   loop 1
>   stmtFinalise stmt


If we don't specify the type, Postgres gives the number the NUMERIC type.
I don't yet know what the internal binary rep is, nor how to
convert it to an appropriate Haskell type.
Best we can do is marshal/transmist everything as text.

> testSelectNumeric db = do
>   sn <- printPropagateError $ stmtPrepare db "" "select 1.2" []
>   (rs,ntuples) <- stmtExec0t db sn
>   --fmt0 <- fPQfformat rs 0
>   --ct0  <- fPQftype rs 0
>   --putStrLn $ "\ntestSelectNumeric: format " ++ (show fmt0) ++ ", type (oid) " ++ (show ct0)
>   n <- colValDouble rs 1 1
>   assertEqual "testSelectNumeric: 1.2" 1.2 n
>   stmtFinalise rs



> testUnion db = do
>   (stmt,ntuples) <- printPropagateError $
>     stmtExecImm db "select 'h1' from tdual union select 'h2' from tdual union select 'h3' from tdual" []
>   assertEqual "testUnion: ntuples" 3 ntuples
>   s <- colValString stmt 1 1
>   assertEqual "testUnion: h1" "h1" s
>   s <- colValString stmt 2 1
>   assertEqual "testUnion: h2" "h2" s
>   s <- colValString stmt 3 1
>   assertEqual "testUnion: h3" "h3" s
>   stmtFinalise stmt


> testSelectNoRows db = do
>   (stmt,ntuples) <- printPropagateError $
>     stmtExecImm db "select 'h1' from tdual where dummy = '2'" []
>   stmtFinalise stmt
>   assertEqual "testSelectNoRows: done" 0 ntuples


> manyRows :: String
> manyRows = 
>   "select 1 from"
>   ++ "  ( select 1 from tdual union select 0 from tdual) as t1"
>   ++ ", ( select 2 from tdual union select 0 from tdual) as t2"
>   ++ ", ( select 3 from tdual union select 0 from tdual) as t3"
>   ++ ", ( select 4 from tdual union select 0 from tdual) as t4"
>   ++ ", ( select 5 from tdual union select 0 from tdual) as t5"
>   ++ ", ( select 6 from tdual union select 0 from tdual) as t6"
>   ++ ", ( select 7 from tdual union select 0 from tdual) as t7"
>   ++ ", ( select 8 from tdual union select 0 from tdual) as t8"
>   ++ ", ( select 9 from tdual union select 0 from tdual) as t9"
>   ++ ", ( select 10 from tdual union select 0 from tdual) as t10"


> countRows :: DBHandle -> String -> Int -> IO Int
> countRows db sn n = do
>   (stmt,ntuples) <- printPropagateError $ stmtExec0t db sn
>   stmtFinalise stmt
>   if ntuples == 0
>     then return n
>     else countRows db sn (n+ntuples)

> cursor'name = "takusenp"

> testSelectManyRows db = do
>   let prefetch = 200
>   _ <- printPropagateError $ nqExec db "Begin work"
>   let q = "DECLARE " ++ cursor'name ++ " NO SCROLL CURSOR FOR " ++
>		  manyRows
>   _ <- printPropagateError $ nqExec db q
>   let f = "FETCH FORWARD " ++ (show prefetch) ++ " FROM " ++ cursor'name
>   sn <- printPropagateError $ stmtPrepare db "" f []
>   n <- countRows db sn 0
>   _ <- printPropagateError $ nqExec db $ "CLOSE " ++ cursor'name
>   _ <- printPropagateError $ nqExec db $ "commit work"
>   assertEqual "testSelectManyRows: done" 1024 n


> testBindString db = do
>   (rs, ntuples) <- printPropagateError $
>     prepare'n'exec db "" (substituteBindPlaceHolders "select ?") [newBindVal "h1"]
>   n <- colValString rs 1 1
>   assertEqual "testBindString: h1" "h1" n
>   stmtFinalise rs

> testBindInt db = do
>   (rs, ntuples) <- printPropagateError $
>     prepare'n'exec db "" (substituteBindPlaceHolders "select ?") [newBindVal (2001::Int)]
>   n <- colValInt rs 1 1
>   assertEqual "testBindInt: 2001" 2001 n
>   stmtFinalise rs

> testBindDouble db = do
>   let
>     v1 :: Double; v1 = 2.3
>     v2 :: Int; v2 = 2001
>     v3 :: Int; v3 = 2001
>     bindvals = [newBindVal v1, newBindVal v2, newBindVal v3]
>   (rs, ntuples) <- printPropagateError $ do
>     prepare'n'exec db "" (substituteBindPlaceHolders "select ? from tdual where ? = ?") bindvals
>   n <- colValDouble rs 1 1
>   assertEqual "testBindDouble: 2.3" 2.3 n
>   stmtFinalise rs

> testBindDate db = do
>   let
>     v1 :: UTCTime; v1 = UTCTime (fromGregorian 2000 1 1) 0
>     v2 :: UTCTime; v2 = UTCTime (fromGregorian 1980 2 29) 0
>     bindvals = [newBindVal v1, newBindVal v2]
>   (rs, ntuples) <- printPropagateError $
>     prepare'n'exec db "" (substituteBindPlaceHolders "select ?, ?") bindvals
>   n <- colValUTCTime rs 1 1
>   assertEqual "testBindDate: 1 " v1 n
>   n <- colValUTCTime rs 1 2
>   assertEqual "testBindDate: 2 " v2 n
>   stmtFinalise rs

> testSelectUTF8Text db = do
>   -- GREEK SMALL LETTER PHI
>   -- unicode code-point 966
>   -- UTF8: CF86 (207,134)
>   -- UTF16: 03C6
>   let expect = ['\966']
>   let sql = "select '" ++ expect ++ "'"
>   sn <- printPropagateError (stmtPrepare db "" sql [])
>   (stmt,ntuples) <- stmtExec0t db sn
>   assertEqual "testSelectUTF8Text: ntuples" 1 ntuples
>   result <- colValString stmt 1 1
>   assertEqual "testSelectUTF8Text" expect result