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


The Oracle multi-result-set tests require these database objects:

CREATE OR REPLACE VIEW t_whole as
select 0 as n  from dual union select 1 from dual
union select 2 from dual union select 3 from dual
union select 4 from dual union select 5 from dual
union select 6 from dual union select 7 from dual
union select 8 from dual union select 9 from dual
;

CREATE OR REPLACE VIEW t_natural as
select n from
( select t1.n + 10 * t10.n + 100 * t100.n as n
from t_whole t1, t_whole t10, t_whole t100
) t where n > 0 order by 1
;

create or replace package Takusen as type RefCursor is ref cursor; end;

CREATE OR REPLACE PROCEDURE takusenTestProc
(refc1 out Takusen.RefCursor, refc2 out Takusen.RefCursor) AS BEGIN
OPEN refc1 FOR SELECT n*n from t_natural where n < 10 order by 1;
OPEN refc2 FOR SELECT n, n*n, n*n*n from t_natural where n < 10 order by 1;
END;

select n, cursor(
  SELECT nat2.n
  , cursor(SELECT nat3.n from t_natural nat3 where nat3.n < nat2.n order by n)
  from t_natural nat2 where nat2.n < nat.n order by n
)
from t_natural nat where n < 10 order by n;


> {-# LANGUAGE OverlappingInstances #-}

> module Database.Oracle.Test.Enumerator (runTest) where

> import qualified Database.Oracle.Test.OCIFunctions as Low
> import Database.Oracle.Enumerator
> import Database.Util (print_)
> import Database.Test.Performance as Perf
> import Database.Test.Enumerator
> import Control.Monad (when)
> import Control.Monad.Trans (liftIO)
> import Test.MiniUnit
> import Data.Int
> import System.Time


> runTest :: Perf.ShouldRunTests -> [String] -> IO ()
> runTest runPerf args = do
>   let (user:pswd:dbname:_) = args
>   Low.runTest args
>   flip catchDB basicDBExceptionReporter $
>     withSession (connect user pswd dbname) (testBody runPerf)

> testBody runPerf = do
>   runFixture OracleFunctions
>   when (runPerf == Perf.RunTests) runPerformanceTests

> runPerformanceTests = do
>   makeFixture execDrop execDDL_
>   beginTransaction RepeatableRead
>   runTestTT "Oracle performance tests" (map (flip catchDB reportRethrow)
>     [ timedSelect (prefetch 1000 sqlRows2Power20 []) 30 (2^20)
>     , timedSelect (prefetch 1 sqlRows2Power17 []) 60 (2^17)
>     , timedSelect (prefetch 1000 sqlRows2Power17 []) 6 (2^17)
>     , timedCursor (prefetch 1 sqlRows2Power17 []) 60 (2^17)
>     , timedCursor (prefetch 1000 sqlRows2Power17 []) 6 (2^17)
>     ]
>     )
>   commit
>   destroyFixture execDDL_


> runFixture :: OracleFunctions -> DBM mark Session ()
> runFixture fns = do
>   makeFixture execDrop execDDL_
>   execDDL_ makeFixtureMultiResultSet1
>   execDDL_ makeFixtureMultiResultSet2
>   execDDL_ makeFixtureMultiResultSet3
>   execDDL_ makeFixtureMultiResultSet4
>   execDDL_ makeFixtureBindOutput
>   runTestTT "Oracle tests" (map (runOneTest fns) testList)
>   execDDL_ dropFixtureBindOutput
>   execDDL_ dropFixtureMultiResultSet4
>   execDDL_ dropFixtureMultiResultSet3
>   execDDL_ dropFixtureMultiResultSet2
>   execDDL_ dropFixtureMultiResultSet1
>   destroyFixture execDDL_

> runOneTest fns t = catchDB (t fns) reportRethrow

-----------------------------------------------------------

> selectNoRows _ = selectTest sqlNoRows iterNoRows expectNoRows

> selectTerminatesEarly _ = selectTest sqlTermEarly iterTermEarly expectTermEarly

> selectFloatsAndInts fns = selectTest (sqlFloatsAndInts fns) iterFloatsAndInts expectFloatsAndInts

> selectNullString _ = selectTest sqlNullString iterNullString expectNullString

> selectEmptyString _ = selectTest sqlEmptyString iterEmptyString expectEmptyString

> selectUnhandledNull _ = catchDB ( do
>       selectTest sqlUnhandledNull iterUnhandledNull expectUnhandledNull
>       assertFailure sqlUnhandledNull
>   ) (\e -> return () )



> selectNullDate dateFn = selectTest (sqlNullDate dateFn) iterNullDate expectNullDate

> selectDate dateFn = selectTest (sqlDate dateFn) iterDate expectDate

> selectCalDate dateFn = selectTest (sqlDate dateFn) iterCalDate expectCalDate

> selectBoundaryDates dateFn = selectTest (sqlBoundaryDates dateFn) iterBoundaryDates expectBoundaryDates

> selectCursor fns = actionCursor (sqlCursor fns)

> selectExhaustCursor fns = actionExhaustCursor (sqlCursor fns)

> selectBindString _ = actionBindString
>     (prepareQuery (sql sqlBindString))
>     [bindP "a2", bindP "b1"]


> selectBindInt _ = actionBindInt
>   (prepareQuery (sql sqlBindInt))
>   [bindP (1::Int), bindP (2::Int)]


> selectBindIntDoubleString _ = actionBindIntDoubleString
>   (prefetch 0 sqlBindIntDoubleString [bindP (1::Int), bindP (2.2::Double), bindP "row 1", bindP (3::Int), bindP (4.4::Double), bindP "row 2"])

> selectBindDate _ = actionBindDate
>   (prefetch 1 sqlBindDate (map bindP expectBindDate))

> selectBindBoundaryDates _ = actionBindBoundaryDates
>   (prefetch 1 sqlBindBoundaryDates (map bindP expectBoundaryDates))

> selectRebindStmt _ = actionRebind (prepareQuery (sql sqlRebind))
>    [bindP (1::Int)] [bindP (2::Int)]

> boundStmtDML _ = actionBoundStmtDML (prepareCommand (sql sqlBoundStmtDML))
> boundStmtDML2 _ = withTransaction RepeatableRead $ do
>   count <- execDML (cmdbind sqlBoundStmtDML [bindP (100::Int), bindP "100"])
>   assertEqual sqlBoundStmtDML 1 count
>   rollback


> polymorphicFetchTest _ = actionPolymorphicFetch
>   (prefetch 0 sqlPolymorphicFetch [bindP expectPolymorphicFetch])

> polymorphicFetchTestNull _ = actionPolymorphicFetchNull
>   (prefetch 1 sqlPolymorphicFetchNull [])

> exceptionRollback _ = actionExceptionRollback sqlInsertTest4 sqlExceptionRollback


FIXME  check definitions of whole and natural numbers

> dropFixtureMultiResultSet1 = "DROP VIEW t_whole"
> makeFixtureMultiResultSet1 = "CREATE OR REPLACE VIEW t_whole as"
>   ++ " select 0 as n  from dual union select 1 from dual"
>   ++ " union select 2 from dual union select 3 from dual"
>   ++ " union select 4 from dual union select 5 from dual"
>   ++ " union select 6 from dual union select 7 from dual"
>   ++ " union select 8 from dual union select 9 from dual"

> dropFixtureMultiResultSet2 = "DROP VIEW t_natural"
> makeFixtureMultiResultSet2 = "CREATE OR REPLACE VIEW t_natural as"
>   ++ " select n from"
>   ++ " ( select t1.n + 10 * t10.n + 100 * t100.n as n"
>   ++ "   from t_whole t1, t_whole t10, t_whole t100"
>   ++ " ) t where n > 0 order by 1"


> dropFixtureMultiResultSet3 = "DROP package Takusen"
> makeFixtureMultiResultSet3 =
>   "create or replace package Takusen as type RefCursor is ref cursor; end;"

> dropFixtureMultiResultSet4 = "DROP PROCEDURE takusenTestProc"
> makeFixtureMultiResultSet4 = "CREATE OR REPLACE PROCEDURE takusenTestProc"
>   ++ " (refc1 out Takusen.RefCursor, refc2 out Takusen.RefCursor) AS BEGIN"
>   ++ " OPEN refc1 FOR SELECT n*n from t_natural where n < 10 order by 1;"
>   ++ " OPEN refc2 FOR SELECT n, n*n, n*n*n from t_natural where n < 10 order by 1;"
>   ++ " END;"

What would you need to do to make database functions and procedures
callable from Haskell as if they were local functions (IO actions)?

wrapPLSQLFunc funcname parms =
  let
     sqltext = "begin " ++ (head args) ++ " := " ++ funcname ++ "(" ++ placeholders ++ "); end;"
     placeholders = concat (intersperse "," (tail args))
     args = take (length parms) (map (\n -> ":x" ++ show n) [1..])
  in cmdbind sqltext parms

wrapPLSQLProc procname parms =
  let
     sqltext = "begin " ++ procname ++ "(" ++ placeholders ++ "); end;"
     placeholders = concat (intersperse "," args)
     args = take (length parms) (map (\n -> ":x" ++ show n) [1..])
  in cmdbind sqltext parms

convertCcy :: String -> Double -> String -> UTCTime -> DBM mark Session (String, Double)
convertCcy ccyFrom valFrom ccyTo onDate = do
  sqlcmd = wrapPLSQLFunc "pk_fx.convert_ccy"
    [ bindP (Out (0 :: Double))
    , bindP ccyFrom
    , bindP valFrom
    , bindP ccyTo
    , bindP onDate
    ]
  let
    iter :: Monad m => Double -> IterAct m Double
    iter val seed = return (Left val)
  result = doQuery sqlcmd iter undefined
  return result

> selectMultiResultSet _ = do
>   let refcursor :: Maybe StmtHandle; refcursor = Just undefined
>   withTransaction RepeatableRead $ do
>   withPreparedStatement (prepareCommand (sql "begin takusenTestProc(:1,:2); end;")) $ \pstmt -> do
>   withBoundStatement pstmt [bindP (Out refcursor), bindP (Out refcursor)] $ \bstmt -> do
>     dummy <- doQuery bstmt iterMain ()
>     result1 <- doQuery (NextResultSet pstmt) iterRS1 []
>     assertEqual "selectMultiResultSet: RS1" [1,4,9,16,25,36,49,64,81] result1
>     result2 <- doQuery (NextResultSet pstmt) iterRS2 []
>     let expect = [(1,1,1),(2,4,8),(3,9,27),(4,16,64),(5,25,125),(6,36,216)
>           ,(7,49,343),(8,64,512),(9,81,729)]
>     assertEqual "selectMultiResultSet: RS2" expect result2
>     return ()
>   where
>     iterMain :: (Monad m) => RefCursor StmtHandle -> RefCursor StmtHandle -> IterAct m ()
>     iterMain c1 c2 acc = return (Left acc)
>     iterRS1 :: (Monad m) => Int -> IterAct m [Int]
>     iterRS1 i acc = result (acc ++ [i])
>     iterRS2 :: (Monad m) => Int -> Int -> Int -> IterAct m [(Int, Int, Int)]
>     iterRS2 i i2 i3 acc = result (acc ++ [(i, i2, i3)])


> selectNestedMultiResultSet :: OracleFunctions -> DBM mark Session ()
> selectNestedMultiResultSet _ = do
>   let
>     -- This returns two rows, each of which contains one cursor.
>     -- The first cursor returns 101, the second 102.
>     q = "select cursor(select n from dual) from"
>       ++ " (select 101 as n from dual union select 102 from dual)"
>     iterMain (c::RefCursor StmtHandle) acc = do
>       rs <- doQuery c iterInner []
>       result' (c:acc)
>     iterInner (i::Int) acc = do
>       if (i /= 101 && i /= 102)
>         then assertFailure "selectNestedMultiResultSet: inner value not 101 or 102"
>         else return ()
>       result' (i:acc)
>   withTransaction RepeatableRead $ do
>   withPreparedStatement (prepareQuery (sql q)) $ \pstmt -> do
>   withBoundStatement pstmt [] $ \bstmt -> do
>       rs <- doQuery bstmt iterMain []
>       return ()


> selectNestedMultiResultSet2 :: OracleFunctions -> DBM mark Session ()
> selectNestedMultiResultSet2 _ = do
>   let
>     q = "select n, cursor(SELECT nat2.n, cursor"
>         ++ "     (SELECT nat3.n from t_natural nat3 where nat3.n < nat2.n order by n)"
>         ++ "   from t_natural nat2 where nat2.n < nat.n order by n)"
>         ++ " from t_natural nat where n < 10 order by n"
>     iterMain   (outer::Int) (c::RefCursor StmtHandle) acc = do
>       rs <- doQuery c (iterInner outer) []
>       let expect = drop (9-outer) [8,7,6,5,4,3,2,1]
>       assertEqual "processOuter" expect (map fst rs)
>       result' ((outer,c):acc)
>     iterInner outer (inner::Int) (c::RefCursor StmtHandle) acc = do
>       rs <- doQuery c (iterInner2 outer inner) []
>       let expect = drop (9-inner) [8,7,6,5,4,3,2,1]
>       assertEqual "processInner" expect rs
>       result' ((inner,c):acc)
>     iterInner2 outer inner (i::Int) acc = do
>       --print_ (show outer ++ " " ++ show inner ++ " " ++ show i)
>       assertBool "processInner2" (i < inner)
>       result' (i:acc)
>   withTransaction RepeatableRead $ do
>   withPreparedStatement (prepareQuery (sql q)) $ \pstmt -> do
>   withBoundStatement pstmt [] $ \bstmt -> do
>       rs <- doQuery bstmt iterMain []
>       assertEqual "selectNestedMultiResultSet" [9,8,7,6,5,4,3,2,1] (map fst rs)
>       --print_ ""

> selectNestedMultiResultSet3 :: OracleFunctions -> DBM mark Session ()
> selectNestedMultiResultSet3 _ = do
>   let
>     q = "select n, cursor(SELECT nat2.n, cursor"
>         ++ "     (SELECT nat3.n from t_natural nat3 where nat3.n < nat2.n order by n)"
>         ++ "   from t_natural nat2 where nat2.n < nat.n order by n)"
>         ++ " from t_natural nat where n < 10 order by n"
>     iterMain   (outer::Int) (c::RefCursor StmtHandle) acc = do
>       rs <- doQuery c (iterInner outer) []
>       let expect = drop (9-outer) [8,7,6,5,4,3,2,1]
>       assertEqual "processOuter" expect (map fst rs)
>       result' ((outer,c):acc)
>     iterInner outer (inner::Int) (c::RefCursor StmtHandle) acc = do
>       rs <- doQuery c (iterInner2 outer inner) []
>       let expect = drop (9-inner) [8,7,6,5,4,3,2,1]
>       assertEqual "processInner" expect rs
>       result' ((inner,c):acc)
>     iterInner2 outer inner (i::Int) acc = do
>       --print_ (show outer ++ " " ++ show inner ++ " " ++ show i)
>       assertBool "processInner2" (i < inner)
>       result' (i:acc)
>   withTransaction RepeatableRead $ do
>       rs <- doQuery (sql q) iterMain []
>       assertEqual "selectNestedMultiResultSet" [9,8,7,6,5,4,3,2,1] (map fst rs)
>       --print_ ""

> dropFixtureBindOutput = "DROP PROCEDURE takusenTestBindProc"

> makeFixtureBindOutput = "CREATE or replace PROCEDURE takusenTestBindProc(x in out number, y in out varchar2)"
>   ++ " AS BEGIN\n"
>   ++ " y := 'output ' || y;\n"
>   ++ " x := x * 2;\n"
>   ++ " END;"

> bindOutputString _ = do
>   let sqltext = "begin takusenTestBindProc(:1,:2); end;"
>   let qry = cmdbind sqltext [bindP (Out (1234::Int)), bindP (Out (Just "message"))]
>   (x, s) <- doQuery qry iter undefined
>   assertEqual "bindOutputString: int " 2468 x
>   assertEqual "bindOutputString: string " "output message" s
>   where
>     iter :: (Monad m) => Int -> String -> IterAct m (Int, String)
>     iter i s _ = return (Left (i, s))


> bindOutput _ = do
>   let sqltext =
>         "begin :1 := :1 + 1;\n "
>         ++ ":2 := :2 * 2;\n"
>         ++ "end;"
>   let qry = cmdbind sqltext [bindP (Out (44.4 :: Double)), bindP (Out (1234::Int))]
>   (d, i) <- doQuery qry iter undefined
>   assertEqual "bindOutput: double " 45.4 d
>   assertEqual "bindOutput: int " 2468 i
>   where
>     iter :: (Monad m) => Double -> Int -> IterAct m (Double, Int)
>     iter d i _ = return (Left (d, i))


> testList :: [OracleFunctions -> DBM mark Session ()]
> testList =
>   [ selectNoRows, selectTerminatesEarly, selectFloatsAndInts
>   , selectNullString, selectEmptyString, selectUnhandledNull
>   , selectNullDate, selectDate, selectCalDate, selectBoundaryDates
>   , selectCursor, selectExhaustCursor
>   , selectBindString, selectBindInt, selectBindIntDoubleString
>   , selectBindDate, selectBindBoundaryDates, selectRebindStmt
>   , boundStmtDML, boundStmtDML2
>   , polymorphicFetchTest, polymorphicFetchTestNull, exceptionRollback
>   , selectMultiResultSet, selectNestedMultiResultSet
>   , selectNestedMultiResultSet2, selectNestedMultiResultSet3
>   , bindOutput, bindOutputString
>   ]