module Test.Expr.Cursor
( cursorTests
)
where
import qualified Control.Exception.Safe as ExSafe
import qualified Control.Monad.IO.Class as MIO
import qualified Data.ByteString.Char8 as B8
import qualified Data.Int as Int
import Hedgehog ((===))
import qualified Hedgehog as HH
import qualified Orville.PostgreSQL as Orville
import qualified Orville.PostgreSQL.Execution as Execution
import qualified Orville.PostgreSQL.Expr as Expr
import qualified Orville.PostgreSQL.Raw.Connection as Conn
import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
import qualified Orville.PostgreSQL.Raw.SqlValue as SqlValue
import Test.Expr.TestSchema (FooBar, assertEqualFooBarRows, findAllFooBars, mkFooBar, withFooBarData)
import qualified Test.Property as Property
cursorTests :: Orville.ConnectionPool -> Property.Group
cursorTests pool =
Property.group
"Expr - Cursor"
[ prop_cursorInTransaction pool
, prop_cursorOutsideTransactionWithHold pool
, prop_cursorCloseAll pool
, prop_cursorMove pool
, prop_cursorNoScroll pool
, prop_cursorFetchAll pool
, prop_cursorFetchRowCount pool
, prop_cursorFetchForward pool
, prop_cursorFetchForwardCount pool
, prop_cursorFetchForwardAll pool
, prop_cursorFetchBackward pool
, prop_cursorFetchBackwardCount pool
, prop_cursorFetchBackwardAll pool
, prop_cursorFetchFirstLast pool
, prop_cursorFetchNextPrior pool
, prop_cursorFetchAbsolute pool
, prop_cursorFetchRelative pool
]
prop_cursorInTransaction :: Property.NamedDBProperty
prop_cursorInTransaction =
Property.singletonNamedDBProperty "In transaction" $ \pool -> do
result <-
withFooBarData pool [row 1, row 2] $ \connection ->
withTestTransaction connection $
withTestCursor connection Nothing Nothing findAllFooBars $ \cursorName -> do
result <- RawSql.execute connection $ Expr.fetch Nothing cursorName
Execution.readRows result
assertEqualFooBarRows result [row 1]
prop_cursorOutsideTransactionWithHold :: Property.NamedDBProperty
prop_cursorOutsideTransactionWithHold =
Property.singletonNamedDBProperty "Outside transaction (with hold)" $ \pool -> do
result <-
withFooBarData pool [row 1, row 2] $ \connection ->
withTestCursor connection Nothing (Just Expr.withHold) findAllFooBars $ \cursorName -> do
result <- RawSql.execute connection $ Expr.fetch Nothing cursorName
Execution.readRows result
assertEqualFooBarRows result [row 1]
prop_cursorCloseAll :: Property.NamedDBProperty
prop_cursorCloseAll =
Property.singletonNamedDBProperty "Close all cursors" $ \pool -> do
MIO.liftIO . Conn.withPoolConnection pool $ \connection -> do
let
cursorName :: Expr.CursorName
cursorName = Expr.fromIdentifier $ Expr.identifier "testcursor"
declare =
RawSql.executeVoid connection
. Expr.declare cursorName Nothing (Just Expr.withHold)
$ RawSql.unsafeSqlExpression "SELECT 1"
close =
RawSql.executeVoid connection $ Expr.close (Left Expr.allCursors)
-- As long as close doesn't raise an exception, the test passes
ExSafe.bracket_ declare close (pure ())
prop_cursorMove :: Property.NamedDBProperty
prop_cursorMove =
Property.singletonNamedDBProperty "Move" $ \pool -> do
result <-
withFooBarData pool [row 1, row 2, row 3] $ \connection ->
withTestCursor connection Nothing (Just Expr.withHold) findAllFooBars $ \cursorName -> do
RawSql.executeVoid connection $ Expr.move (Just $ Expr.rowCount 2) cursorName
result <- RawSql.execute connection $ Expr.fetch Nothing cursorName
Execution.readRows result
assertEqualFooBarRows result [row 3]
prop_cursorNoScroll :: Property.NamedDBProperty
prop_cursorNoScroll =
Property.singletonNamedDBProperty "Move" $ \pool -> do
scrollBackResult <-
withFooBarData pool [row 1, row 2] $ \connection ->
withTestCursor connection (Just Expr.noScroll) (Just Expr.withHold) findAllFooBars $ \cursorName -> do
RawSql.executeVoid connection $ Expr.move (Just Expr.next) cursorName
ExSafe.try $ RawSql.executeVoid connection $ Expr.move (Just Expr.prior) cursorName
case scrollBackResult of
Right () -> do
HH.footnote "Expected 'executeVoid' to return failure, but it did not"
HH.failure
Left err ->
-- Expected that the execute failed because we tried to scroll backward
-- on a non-scrollable cursor
Conn.sqlExecutionErrorSqlState err === Just (B8.pack "55000")
prop_cursorFetchAll :: Property.NamedDBProperty
prop_cursorFetchAll =
Property.singletonNamedDBProperty "Fetch all" $ \pool -> do
[first] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2]
[Expr.fetchAll]
assertEqualFooBarRows first [row 1, row 2]
prop_cursorFetchRowCount :: Property.NamedDBProperty
prop_cursorFetchRowCount =
Property.singletonNamedDBProperty "Fetch row count" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2, row 3]
[Expr.rowCount 2, Expr.rowCount 2]
assertEqualFooBarRows first [row 1, row 2]
assertEqualFooBarRows second [row 3]
prop_cursorFetchForward :: Property.NamedDBProperty
prop_cursorFetchForward =
Property.singletonNamedDBProperty "Fetch forward" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2]
[Expr.forward, Expr.forward]
assertEqualFooBarRows first [row 1]
assertEqualFooBarRows second [row 2]
prop_cursorFetchForwardCount :: Property.NamedDBProperty
prop_cursorFetchForwardCount =
Property.singletonNamedDBProperty "Fetch forward count" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2, row 3]
[Expr.forwardCount 2, Expr.forwardCount 2]
assertEqualFooBarRows first [row 1, row 2]
assertEqualFooBarRows second [row 3]
prop_cursorFetchForwardAll :: Property.NamedDBProperty
prop_cursorFetchForwardAll =
Property.singletonNamedDBProperty "Fetch forward all" $ \pool -> do
[first] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2]
[Expr.forwardAll]
assertEqualFooBarRows first [row 1, row 2]
prop_cursorFetchBackward :: Property.NamedDBProperty
prop_cursorFetchBackward =
Property.singletonNamedDBProperty "Fetch backward" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2]
[Expr.forwardCount 2, Expr.backward]
assertEqualFooBarRows first [row 1, row 2]
assertEqualFooBarRows second [row 1]
prop_cursorFetchBackwardCount :: Property.NamedDBProperty
prop_cursorFetchBackwardCount =
Property.singletonNamedDBProperty "Fetch backward count" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2, row 3]
[Expr.forwardCount 3, Expr.backwardCount 2]
assertEqualFooBarRows first [row 1, row 2, row 3]
assertEqualFooBarRows second [row 2, row 1]
prop_cursorFetchBackwardAll :: Property.NamedDBProperty
prop_cursorFetchBackwardAll =
Property.singletonNamedDBProperty "Fetch backward all" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2, row 3]
[Expr.forwardCount 4, Expr.backwardAll]
assertEqualFooBarRows first [row 1, row 2, row 3]
assertEqualFooBarRows second [row 3, row 2, row 1]
prop_cursorFetchFirstLast :: Property.NamedDBProperty
prop_cursorFetchFirstLast =
Property.singletonNamedDBProperty "Fetch first/last" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
Nothing
[row 1, row 2, row 3]
[Expr.first, Expr.last]
assertEqualFooBarRows first [row 1]
assertEqualFooBarRows second [row 3]
prop_cursorFetchNextPrior :: Property.NamedDBProperty
prop_cursorFetchNextPrior =
Property.singletonNamedDBProperty "Fetch next/prior" $ \pool -> do
[first, second, third] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2, row 3]
[Expr.next, Expr.next, Expr.prior]
assertEqualFooBarRows first [row 1]
assertEqualFooBarRows second [row 2]
assertEqualFooBarRows third [row 1]
prop_cursorFetchAbsolute :: Property.NamedDBProperty
prop_cursorFetchAbsolute =
Property.singletonNamedDBProperty "Fetch absolute" $ \pool -> do
[first, second] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2, row 3]
[Expr.absolute 3, Expr.absolute (-1)]
assertEqualFooBarRows first [row 3]
assertEqualFooBarRows second [row 3]
prop_cursorFetchRelative :: Property.NamedDBProperty
prop_cursorFetchRelative =
Property.singletonNamedDBProperty "Fetch relative" $ \pool -> do
[first, second, third, fourth] <-
runFetchDirectionsOnData
pool
(Just Expr.scroll)
[row 1, row 2, row 3]
[Expr.relative 1, Expr.relative 2, Expr.relative (-1), Expr.relative 0]
assertEqualFooBarRows first [row 1]
assertEqualFooBarRows second [row 3]
assertEqualFooBarRows third [row 2]
assertEqualFooBarRows fourth [row 2]
row :: Int.Int32 -> FooBar
row n = mkFooBar n ("row " <> show n)
runFetchDirectionsOnData ::
Orville.ConnectionPool ->
Maybe Expr.ScrollExpr ->
[FooBar] ->
[Expr.CursorDirection] ->
HH.PropertyT IO [[[(Maybe B8.ByteString, SqlValue.SqlValue)]]]
runFetchDirectionsOnData pool scroll fooBars directions =
withFooBarData pool fooBars $ \connection ->
withTestCursor connection scroll (Just Expr.withHold) findAllFooBars $ \cursorName ->
let
runDirection direction = do
result <- RawSql.execute connection $ Expr.fetch (Just direction) cursorName
Execution.readRows result
in
traverse runDirection directions
withTestCursor ::
Orville.Connection ->
Maybe Expr.ScrollExpr ->
Maybe Expr.HoldExpr ->
Expr.QueryExpr ->
(Expr.CursorName -> IO a) ->
IO a
withTestCursor connection scroll hold query action =
let
cursorName :: Expr.CursorName
cursorName = Expr.fromIdentifier $ Expr.identifier "testcursor"
declare =
RawSql.executeVoid connection $
Expr.declare cursorName scroll hold query
close =
RawSql.executeVoid connection $ Expr.close (Right cursorName)
in
ExSafe.bracket_ declare close (action cursorName)
withTestTransaction :: Orville.Connection -> IO a -> IO a
withTestTransaction connection action =
let
begin =
RawSql.executeVoid connection $ Expr.beginTransaction Nothing
commit =
RawSql.executeVoid connection $ Expr.commit
in
ExSafe.bracket_ begin commit action