bolty-0.1.0.0: integration/Main.hs
module Main where
import Control.Exception (SomeException, fromException, try)
import Control.Monad.IO.Class (liftIO)
import Test.Sandwich
import Data.Default (def)
import qualified Data.HashMap.Lazy as H
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Validation as Val
import System.Environment (lookupEnv)
import Data.Int (Int64)
import Data.IORef (newIORef, readIORef, writeIORef)
import Database.Bolty
import Database.Bolty.Connection (queryIO, queryPIO, queryIO')
import Database.Bolty.Message.Response (SuccessPull(..))
import qualified Database.Bolty.Message.Response as Resp
import Database.Bolty.Decode (DecodeError(..))
import Database.Bolty.Logging (QueryLog(..))
import Database.Bolty.Notification (Notification(..), Severity(..))
import Database.Bolty.Stats (QueryStats(..))
import Database.Bolty.Value.Type (Node(..), Relationship(..), Path(..)
, Date(..), Time(..), LocalTime(..)
, DateTime(..), DateTimeZoneId(..)
, LocalDateTime(..), Duration(..)
, Point2D(..), Point3D(..))
import Database.Bolty.Value.Helpers (supportsLogonLogoff, versionMajor, versionMinor)
import Data.PackStream.Ps (Ps(..))
-- ================================================================
-- Test types
-- ================================================================
-- | Example type used to test 'FromBolt' decoding.
data PersonResult = PersonResult T.Text Int64
deriving (Show, Eq)
instance FromBolt PersonResult where
rowDecoder = PersonResult
<$> field "name" Database.Bolty.text
<*> field "age" int64
-- ================================================================
-- Config helpers
-- ================================================================
-- | Neo4j 5 config: reads NEO4J_HOST/NEO4J_PORT, defaults to 127.0.0.1:7687
neo4j5Config :: IO Config
neo4j5Config = do
h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST"
p <- maybe 7687 read <$> lookupEnv "NEO4J_PORT"
pure def
{ host = h
, port = p
, scheme = Basic "neo4j" "testpassword"
, use_tls = False
}
-- | Neo4j 4.4 config: reads NEO4J_HOST/NEO4J_44_PORT, defaults to 127.0.0.1:7688
neo4j44Config :: IO Config
neo4j44Config = do
h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST"
p <- maybe 7688 read <$> lookupEnv "NEO4J_44_PORT"
pure def
{ host = h
, port = p
, scheme = Basic "neo4j" "testpassword"
, use_tls = False
}
-- | Config for the no-auth Neo4j instance (port 7689)
noAuthConfig :: IO Config
noAuthConfig = do
h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST"
p <- maybe 7689 read <$> lookupEnv "NEO4J_NOAUTH_PORT"
pure def
{ host = h
, port = p
, scheme = None
, use_tls = False
}
-- | Validate a config or fail
mkGetConfig :: IO Config -> IO ValidatedConfig
mkGetConfig mkConfig = do
cfg <- mkConfig
case validateConfig cfg of
Val.Failure errs -> fail $ "Config invalid: " <> show errs
Val.Success vc -> pure vc
-- | Connect, run action, close
mkWithConn :: IO Config -> (Connection -> IO a) -> IO a
mkWithConn mkConfig f = do
cfg <- mkGetConfig mkConfig
conn <- connect cfg
result <- f conn
close conn
pure result
-- ================================================================
-- Core test suite — runs against any Neo4j version
-- ================================================================
coreTestSuite :: String -> IO Config -> TopSpec
coreTestSuite label mkConfig = do
let getConf = mkGetConfig mkConfig
let wp :: (Connection -> IO a) -> IO a
wp = mkWithConn mkConfig
describe (label ++ " - Basic queries") $ do
it "connects and disconnects" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
liftIO $ close pipe
it "runs RETURN 1 and gets result" $ do
result <- liftIO $ wp $ \p -> queryIO p "RETURN 1 AS n"
V.length result `shouldBe` 1
let record = V.head result
V.length record `shouldBe` 1
case asInt (V.head record) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head record)
it "runs RETURN with string" $ do
result <- liftIO $ wp $ \p -> queryIO p "RETURN 'hello' AS greeting"
V.length result `shouldBe` 1
case asText (V.head $ V.head result) of
Just t -> t `shouldBe` "hello"
Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head result)
it "runs UNWIND to get multiple rows" $ do
result <- liftIO $ wp $ \p -> queryIO p "UNWIND range(1, 5) AS n RETURN n"
V.length result `shouldBe` 5
it "runs query with full metadata" $ do
result <- liftIO $ wp $ \p -> queryIO' p "RETURN 42 AS answer"
V.length (Resp.records result) `shouldBe` 1
describe (label ++ " - Parameterized queries") $ do
it "passes integer parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $x AS n" (H.singleton "x" (PsInteger 42))
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure $ "Expected 42, got: " <> show (V.head $ V.head result)
it "passes string parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $name AS name" (H.singleton "name" (PsString "Neo"))
case asText (V.head $ V.head result) of
Just t -> t `shouldBe` "Neo"
Nothing -> expectationFailure $ "Expected 'Neo'"
it "passes boolean parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $b AS b" (H.singleton "b" (PsBoolean True))
case asBool (V.head $ V.head result) of
Just b -> b `shouldBe` True
Nothing -> expectationFailure "Expected True"
it "passes null parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $x AS x" (H.singleton "x" PsNull)
case asNull (V.head $ V.head result) of
Just _ -> pure ()
Nothing -> expectationFailure "Expected null"
it "passes float parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $x AS x" (H.singleton "x" (PsFloat 3.14))
case asFloat (V.head $ V.head result) of
Just d -> d `shouldBe` 3.14
Nothing -> expectationFailure "Expected 3.14"
it "passes multiple parameters" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "RETURN $a + $b AS sum"
(H.fromList [("a", PsInteger 10), ("b", PsInteger 32)])
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
it "passes list parameter" $ do
result <- liftIO $ wp $ \p ->
queryPIO p "UNWIND $xs AS x RETURN x"
(H.singleton "xs" (PsList $ V.fromList [PsInteger 1, PsInteger 2, PsInteger 3]))
V.length result `shouldBe` 3
describe (label ++ " - Transactions") $ do
it "withTransaction commits on success" $ do
liftIO $ wp $ \p ->
withTransaction p $ \conn -> do
_ <- queryIO conn "CREATE (n:TestCommit {value: 1})"
pure ()
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestCommit) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestCommit) DELETE n" >> pure ()
it "withTransaction rolls back on error" $ do
liftIO $ wp $ \p -> queryIO p "CREATE (n:TestRollback {value: 1})" >> pure ()
result :: Either SomeException () <- liftIO $ try $
wp $ \p ->
withTransaction p $ \conn -> do
_ <- queryIO conn "MATCH (n:TestRollback) DELETE n"
_ <- queryIO conn "THIS IS NOT VALID CYPHER"
pure ()
case result of
Left _ -> pure ()
Right _ -> expectationFailure "Expected transaction to fail"
count <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestRollback) RETURN count(n) AS c"
case asInt (V.head $ V.head count) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected count 1"
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestRollback) DELETE n" >> pure ()
it "multiple queries in a transaction" $ do
liftIO $ wp $ \p ->
withTransaction p $ \conn -> do
_ <- queryIO conn "CREATE (n:TestMulti {value: 1})"
_ <- queryIO conn "CREATE (n:TestMulti {value: 2})"
_ <- queryIO conn "CREATE (n:TestMulti {value: 3})"
pure ()
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestMulti) RETURN n.value AS v ORDER BY v"
V.length result `shouldBe` 3
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestMulti) DELETE n" >> pure ()
it "query with parameters inside transaction" $ do
liftIO $ wp $ \p ->
withTransaction p $ \conn ->
queryPIO conn "CREATE (n:TestTxParam {name: $name})" (H.singleton "name" (PsString "alice"))
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestTxParam) RETURN n.name AS name"
case asText (V.head $ V.head result) of
Just t -> t `shouldBe` "alice"
Nothing -> expectationFailure "Expected 'alice'"
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestTxParam) DELETE n" >> pure ()
describe (label ++ " - Graph type queries") $ do
it "returns a Node" $ do
result <- liftIO $ wp $ \p ->
queryIO p "CREATE (n:TestGraphNode {name: 'Alice', age: 30}) RETURN n"
V.length result `shouldBe` 1
case asNode (V.head $ V.head result) of
Just Node{labels, properties} -> do
V.toList labels `shouldContain` ["TestGraphNode"]
case H.lookup "name" properties of
Just (PsString n) -> n `shouldBe` "Alice"
_ -> expectationFailure "Expected name property"
Nothing -> expectationFailure $ "Expected BoltNode, got: " <> show (V.head $ V.head result)
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestGraphNode) DELETE n" >> pure ()
it "returns a Relationship" $ do
liftIO $ wp $ \p ->
queryIO p "CREATE (a:TestGraphRelA)-[r:KNOWS {since: 2020}]->(b:TestGraphRelB) RETURN r"
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (a:TestGraphRelA)-[r:KNOWS]->(b:TestGraphRelB) RETURN r"
V.length result `shouldBe` 1
case asRelationship (V.head $ V.head result) of
Just Relationship{type_, properties} -> do
type_ `shouldBe` "KNOWS"
case H.lookup "since" properties of
Just (PsInteger n) -> n `shouldBe` 2020
_ -> expectationFailure "Expected since property"
Nothing -> expectationFailure $ "Expected BoltRelationship, got: " <> show (V.head $ V.head result)
liftIO $ wp $ \p -> queryIO p "MATCH (a:TestGraphRelA)-[r]->(b:TestGraphRelB) DELETE r, a, b" >> pure ()
it "returns a Path" $ do
liftIO $ wp $ \p ->
queryIO p "CREATE (a:TestPath {name: 'start'})-[:STEP]->(b:TestPath {name: 'end'})"
result <- liftIO $ wp $ \p ->
queryIO p "MATCH p=(a:TestPath)-[*]->(b:TestPath) RETURN p"
V.length result `shouldBe` 1
case asPath (V.head $ V.head result) of
Just path -> do
V.length (nodes path) `shouldBe` 2
V.length (rels path) `shouldBe` 1
Nothing -> expectationFailure $ "Expected BoltPath, got: " <> show (V.head $ V.head result)
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestPath) DETACH DELETE n" >> pure ()
it "returns a Date" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN date('2024-01-15') AS d"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDate (Date dys) -> dys `shouldBe` 19737
other -> expectationFailure $ "Expected BoltDate, got: " <> show other
it "returns a Point2D" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN point({x: 1.0, y: 2.0, srid: 7203}) AS p"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltPoint2D Point2D{srid, x, y} -> do
srid `shouldBe` 7203
x `shouldBe` 1.0
y `shouldBe` 2.0
other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other
describe (label ++ " - Temporal and spatial types") $ do
it "returns a DateTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN datetime('2024-01-15T12:30:00Z') AS dt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDateTime _ -> pure ()
other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other
it "returns a LocalDateTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN localdatetime('2024-01-15T12:30:00') AS ldt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltLocalDateTime _ -> pure ()
other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other
it "returns a Time" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN time('12:30:00+01:00') AS t"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltTime _ -> pure ()
other -> expectationFailure $ "Expected BoltTime, got: " <> show other
it "returns a LocalTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN localtime('12:30:00') AS lt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltLocalTime _ -> pure ()
other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other
it "returns a Date (temporal)" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN date('2024-01-15') AS d"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDate _ -> pure ()
other -> expectationFailure $ "Expected BoltDate, got: " <> show other
it "returns a Duration" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN duration('P1Y2M3DT4H') AS dur"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDuration _ -> pure ()
other -> expectationFailure $ "Expected BoltDuration, got: " <> show other
it "returns a Point2D (spatial)" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN point({x: 1.0, y: 2.0}) AS p"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltPoint2D _ -> pure ()
other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other
it "returns a Point3D" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN point({x: 1.0, y: 2.0, z: 3.0}) AS p"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltPoint3D _ -> pure ()
other -> expectationFailure $ "Expected BoltPoint3D, got: " <> show other
describe (label ++ " - Retry transactions") $ do
it "withRetryTransaction commits on success" $ do
liftIO $ wp $ \p ->
withRetryTransaction defaultRetryConfig p $ \conn -> do
_ <- queryIO conn "CREATE (n:TestRetryCommit {value: 1})"
pure ()
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestRetryCommit) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestRetryCommit) DELETE n" >> pure ()
it "withRetryTransaction propagates non-transient errors" $ do
result :: Either SomeException () <- liftIO $ try $
wp $ \p ->
withRetryTransaction defaultRetryConfig p $ \conn -> do
_ <- queryIO conn "THIS IS NOT VALID CYPHER"
pure ()
case result of
Left _ -> pure ()
Right _ -> expectationFailure "Expected non-transient error to propagate"
it "withTransaction' works through pool" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
liftIO $ withTransaction' pool $ \conn -> do
_ <- queryIO conn "CREATE (n:TestPoolTx {value: 42})"
pure ()
result <- liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestPoolTx) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestPoolTx) DELETE n" >> pure ()
liftIO $ destroyPool pool
describe (label ++ " - Connection health checks") $ do
it "ping returns True on healthy connection" $ do
result <- liftIO $ wp $ \p -> do
healthy <- ping p
pure healthy
result `shouldBe` True
it "ping resets state to Ready" $ do
liftIO $ wp $ \p -> do
_ <- queryIO p "RETURN 1 AS n"
healthy <- ping p
healthy `shouldBe` True
result <- queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 2
Nothing -> fail "Expected 2"
it "withConnection validates connections" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
result <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 42 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
liftIO $ destroyPool pool
it "pool survives multiple checkout cycles" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
r1 <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 1 AS n"
r2 <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
liftIO $ destroyPool pool
describe (label ++ " - Pipelining error recovery") $ do
it "invalid query fails and connection recovers" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
result :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "INVALID CYPHER"
case result of
Left _ -> pure ()
Right _ -> expectationFailure "Expected failure for invalid Cypher"
-- Connection should still work after error recovery
result2 <- liftIO $ queryIO pipe "RETURN 1 AS n"
V.length result2 `shouldBe` 1
case asInt (V.head $ V.head result2) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result2)
liftIO $ close pipe
it "multiple consecutive failures recover" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Run 3 invalid queries in sequence, catching each
_ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 1"
_ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 2"
_ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 3"
-- Connection should still work
result <- liftIO $ queryIO pipe "RETURN 42 AS n"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result)
liftIO $ close pipe
it "valid query works after error in auto-commit" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- First run a valid query to confirm connection works
r1 <- liftIO $ queryIO pipe "RETURN 'before' AS s"
V.length r1 `shouldBe` 1
-- Trigger an error
_ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "NOT VALID CYPHER"
-- Run another valid query
r2 <- liftIO $ queryIO pipe "RETURN 'after' AS s"
V.length r2 `shouldBe` 1
case asText (V.head $ V.head r2) of
Just t -> t `shouldBe` "after"
Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head r2)
liftIO $ close pipe
it "connection recovers after transaction error" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Transaction with invalid query should fail
_ :: Either SomeException () <- liftIO $ try $
withTransaction pipe $ \conn -> do
_ <- queryIO conn "INVALID CYPHER IN TX"
pure ()
-- Same connection should still work for a new transaction
liftIO $ withTransaction pipe $ \conn -> do
r <- queryIO conn "RETURN 'recovered' AS s"
case asText (V.head $ V.head r) of
Just t -> t `shouldBe` "recovered"
Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head r)
liftIO $ close pipe
it "parameterized query error recovers" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Invalid Cypher with parameters
_ :: Either SomeException (V.Vector Record) <- liftIO $ try $
queryPIO pipe "NOT VALID $param" (H.singleton "param" (PsInteger 1))
-- Connection should still work
result <- liftIO $ queryPIO pipe "RETURN $x AS n" (H.singleton "x" (PsInteger 99))
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 99
Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result)
liftIO $ close pipe
-- ================================================================
-- Connection validation test suite
-- ================================================================
validationTestSuite :: String -> IO Config -> TopSpec
validationTestSuite label mkConfig = do
let getConf = mkGetConfig mkConfig
describe (label ++ " - Connection validation") $ do
it "AlwaysPing pool works" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = AlwaysPing }
pool <- liftIO $ createPool cfg pc
result <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 1 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ destroyPool pool
it "NeverPing pool works" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = NeverPing }
pool <- liftIO $ createPool cfg pc
result <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
liftIO $ destroyPool pool
it "PingIfIdle 0 always pings (acts like AlwaysPing)" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = PingIfIdle 0 }
pool <- liftIO $ createPool cfg pc
result <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 3 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 3
Nothing -> expectationFailure "Expected 3"
liftIO $ destroyPool pool
it "PingIfIdle 3600 skips ping for recent connections" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = PingIfIdle 3600 }
pool <- liftIO $ createPool cfg pc
-- First use - will ping since connection is fresh from pool
r1 <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 10 AS n"
-- Second use - should skip ping (connection was just active)
r2 <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 20 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 10
Nothing -> expectationFailure "Expected 10"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 20
Nothing -> expectationFailure "Expected 20"
liftIO $ destroyPool pool
it "pool survives multiple checkouts with AlwaysPing" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = AlwaysPing }
pool <- liftIO $ createPool cfg pc
results <- liftIO $ sequence
[ withConnection pool $ \p -> queryIO p "RETURN 1 AS n"
, withConnection pool $ \p -> queryIO p "RETURN 2 AS n"
, withConnection pool $ \p -> queryIO p "RETURN 3 AS n"
]
length results `shouldBe` 3
liftIO $ destroyPool pool
it "withTransaction' works with NeverPing pool" $ do
cfg <- liftIO getConf
let pc = defaultPoolConfig { validationStrategy = NeverPing }
pool <- liftIO $ createPool cfg pc
liftIO $ withTransaction' pool $ \conn -> do
_ <- queryIO conn "CREATE (n:TestNeverPingTx {value: 1})"
pure ()
result <- liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestNeverPingTx) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestNeverPingTx) DELETE n" >> pure ()
liftIO $ destroyPool pool
-- ================================================================
-- Routing test suite — runs against any Neo4j version
-- ================================================================
routingTestSuite :: String -> IO Config -> TopSpec
routingTestSuite label mkBaseConfig = do
let mkRoutingConfig = do
cfg <- mkBaseConfig
pure cfg { routing = Routing }
let getRoutingConf = mkGetConfig mkRoutingConfig
let wrp f = do
cfg <- getRoutingConf
pipe <- connect cfg
result <- f pipe
close pipe
pure result
describe (label ++ " - Routing") $ do
it "fetches routing table" $ do
result <- liftIO $ wrp $ \p ->
getRoutingTable p Nothing
(ttl result > 0) `shouldBe` True
(V.length (writers result) > 0) `shouldBe` True
(V.length (readers result) > 0) `shouldBe` True
(V.length (routers result) > 0) `shouldBe` True
it "routing table addresses contain host:port format" $ do
result <- liftIO $ wrp $ \p ->
getRoutingTable p Nothing
let allAddrs = writers result <> readers result <> routers result
V.forM_ allAddrs $ \addr ->
T.isInfixOf ":" addr `shouldBe` True
it "withRoutingConnection ReadAccess executes a read query" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 1 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected integer 1"
liftIO $ destroyRoutingPool rp
it "withRoutingConnection WriteAccess executes a write query" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "CREATE (n:TestRoutingWrite {value: 1})" >> pure ()
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "MATCH (n:TestRoutingWrite) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestRoutingWrite) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
it "withRoutingTransaction creates and reads back data" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
liftIO $ withRoutingTransaction rp WriteAccess $ \conn -> do
_ <- queryIO conn "CREATE (n:TestRoutingTx {value: 42})"
pure ()
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "MATCH (n:TestRoutingTx) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestRoutingTx) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
it "routing works after forced table refresh" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
_ <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 1 AS n"
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
liftIO $ destroyRoutingPool rp
-- ================================================================
-- Auth scheme tests (Neo4j 5 only — uses no-auth server on port 7689)
-- ================================================================
-- | Check if an Error is AuthentificationFailed
isAuthFailed :: SomeException -> Bool
isAuthFailed e = case fromException e of
Just AuthentificationFailed -> True
_ -> False
authSchemeTests :: TopSpec
authSchemeTests = do
let wpNoAuth = mkWithConn noAuthConfig
describe "Auth schemes" $ do
it "connects with None scheme to no-auth server" $ do
result <- liftIO $ wpNoAuth $ \p -> queryIO p "RETURN 1 AS n"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result)
it "None scheme fails on auth-required server" $ do
cfg <- liftIO neo4j5Config
let noneConfig = cfg { scheme = None }
case validateConfig noneConfig of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
result :: Either SomeException () <- liftIO $ try $ do
pipe <- connect vc
_ <- queryIO pipe "RETURN 1"
close pipe
case result of
Left e | isAuthFailed e -> pure ()
Left e -> expectationFailure $ "Expected AuthentificationFailed, got: " <> show e
Right _ -> expectationFailure "Expected authentication to fail"
it "Basic auth with wrong password fails" $ do
cfg <- liftIO neo4j5Config
let badConfig = cfg { scheme = Basic "neo4j" "wrongpassword" }
case validateConfig badConfig of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
result :: Either SomeException () <- liftIO $ try $ do
pipe <- connect vc
_ <- queryIO pipe "RETURN 1"
close pipe
case result of
Left e | isAuthFailed e -> pure ()
Left e -> expectationFailure $ "Expected AuthentificationFailed, got: " <> show e
Right _ -> expectationFailure "Expected authentication to fail"
-- ================================================================
-- Session test suite — managed transactions with bookmarks
-- ================================================================
sessionTestSuite :: String -> IO Config -> TopSpec
sessionTestSuite label mkConfig = do
let getConf = mkGetConfig mkConfig
describe (label ++ " - Sessions") $ do
it "writeTransaction commits and returns result" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
result <- liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestSessionWrite {value: 1}) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
-- cleanup
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionWrite) DELETE n" >> pure ()
liftIO $ destroyPool pool
it "readTransaction executes read query" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
result <- liftIO $ readTransaction session $ \conn ->
queryIO conn "RETURN 42 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
liftIO $ destroyPool pool
it "writeTransaction rolls back on error" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
-- First create a node to verify rollback later
liftIO $ withConnection pool $ \p ->
queryIO p "CREATE (n:TestSessionRB {value: 1})" >> pure ()
-- Transaction that should fail and rollback
result :: Either SomeException () <- liftIO $ try $
writeTransaction session $ \conn -> do
_ <- queryIO conn "MATCH (n:TestSessionRB) DELETE n"
_ <- queryIO conn "THIS IS NOT VALID CYPHER"
pure ()
case result of
Left _ -> pure ()
Right _ -> expectationFailure "Expected transaction to fail"
-- Node should still exist (rollback)
count <- liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionRB) RETURN count(n) AS c"
case asInt (V.head $ V.head count) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected count 1"
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionRB) DELETE n" >> pure ()
liftIO $ destroyPool pool
it "writeTransaction produces a bookmark" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
-- Before any transaction, bookmarks should be empty
bms0 <- liftIO $ getLastBookmarks session
bms0 `shouldBe` []
-- After a write transaction, there should be a bookmark
liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestSessionBM {value: 1})" >> pure ()
bms1 <- liftIO $ getLastBookmarks session
length bms1 `shouldBe` 1
-- Cleanup
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionBM) DELETE n" >> pure ()
liftIO $ destroyPool pool
it "bookmarks update after each transaction" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
-- First transaction
liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestSessionBM2 {value: 1})" >> pure ()
bms1 <- liftIO $ getLastBookmarks session
length bms1 `shouldBe` 1
-- Second transaction
liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestSessionBM2 {value: 2})" >> pure ()
bms2 <- liftIO $ getLastBookmarks session
length bms2 `shouldBe` 1
-- Bookmark should have changed
(bms1 /= bms2) `shouldBe` True
-- Cleanup
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionBM2) DELETE n" >> pure ()
liftIO $ destroyPool pool
it "initial bookmarks are passed to first transaction" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
-- First session: create data and get bookmark
session1 <- liftIO $ createSession pool defaultSessionConfig
liftIO $ writeTransaction session1 $ \conn ->
queryIO conn "CREATE (n:TestSessionCross {value: 99})" >> pure ()
bms <- liftIO $ getLastBookmarks session1
-- Second session: use bookmark from first session
let cfg2 = defaultSessionConfig { sessionBookmarks = bms }
session2 <- liftIO $ createSession pool cfg2
result <- liftIO $ readTransaction session2 $ \conn ->
queryIO conn "MATCH (n:TestSessionCross) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 99
Nothing -> expectationFailure "Expected 99"
-- Cleanup
liftIO $ withConnection pool $ \p ->
queryIO p "MATCH (n:TestSessionCross) DELETE n" >> pure ()
liftIO $ destroyPool pool
-- ================================================================
-- Routing session tests
-- ================================================================
routingSessionTests :: TopSpec
routingSessionTests = do
let getRoutingConf = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing })
describe "Routing sessions" $ do
it "createRoutingSession + writeTransaction works" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
session <- liftIO $ createRoutingSession rp defaultSessionConfig
liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestRoutingSession {value: 1})" >> pure ()
result <- liftIO $ readTransaction session $ \conn ->
queryIO conn "MATCH (n:TestRoutingSession) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
-- Cleanup
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestRoutingSession) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
it "routing session produces bookmarks" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
session <- liftIO $ createRoutingSession rp defaultSessionConfig
bms0 <- liftIO $ getLastBookmarks session
bms0 `shouldBe` []
liftIO $ writeTransaction session $ \conn ->
queryIO conn "CREATE (n:TestRoutingSessBM {value: 1})" >> pure ()
bms1 <- liftIO $ getLastBookmarks session
length bms1 `shouldBe` 1
-- Cleanup
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestRoutingSessBM) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
-- ================================================================
-- Failover tests
-- ================================================================
failoverTests :: TopSpec
failoverTests = do
let getRoutingConf = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing })
describe "Failover" $ do
it "withRoutingConnection works after cache invalidation" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
-- Normal operation
r1 <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 1 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
-- Invalidate cache and verify it still works (triggers refresh)
liftIO $ invalidateRoutingTable rp
r2 <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
liftIO $ destroyRoutingPool rp
it "withRoutingTransaction works after cache invalidation" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
liftIO $ invalidateRoutingTable rp
liftIO $ withRoutingTransaction rp WriteAccess $ \conn -> do
_ <- queryIO conn "CREATE (n:TestFailoverTx {value: 1})"
pure ()
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "MATCH (n:TestFailoverTx) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestFailoverTx) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
it "session writeTransaction works after cache invalidation" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
session <- liftIO $ createRoutingSession rp defaultSessionConfig
liftIO $ invalidateRoutingTable rp
liftIO $ writeTransaction session $ \conn -> do
_ <- queryIO conn "CREATE (n:TestFailoverSess {value: 1})"
pure ()
result <- liftIO $ readTransaction session $ \conn ->
queryIO conn "MATCH (n:TestFailoverSess) RETURN n.value AS v"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ withRoutingConnection rp WriteAccess $ \p ->
queryIO p "MATCH (n:TestFailoverSess) DELETE n" >> pure ()
liftIO $ destroyRoutingPool rp
it "repeated cache invalidation does not break operations" $ do
cfg <- liftIO getRoutingConf
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
-- Invalidate multiple times
liftIO $ invalidateRoutingTable rp
liftIO $ invalidateRoutingTable rp
liftIO $ invalidateRoutingTable rp
result <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 42 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
liftIO $ destroyRoutingPool rp
-- ================================================================
-- Routing edge case tests (shared, uses Neo4j 5 config)
-- ================================================================
routingEdgeCaseTests :: TopSpec
routingEdgeCaseTests = do
let wp5 = mkWithConn neo4j5Config
let getRoutingConf5 = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing })
describe "Routing edge cases" $ do
it "getRoutingTable works even without routing flag in HELLO" $ do
-- CE accepts ROUTE even without routing in HELLO
result <- liftIO $ wp5 $ \p -> getRoutingTable p Nothing
(ttl result > 0) `shouldBe` True
it "createRoutingPool to unreachable host fails" $ do
cfg <- liftIO neo4j5Config
let badCfg = cfg { host = "192.0.2.1", port = 19999, scheme = None }
case validateConfig badCfg of
Val.Failure _ -> expectationFailure "Config should validate"
Val.Success vc -> do
result :: Either SomeException RoutingPool <- liftIO $ try $
createRoutingPool vc defaultRoutingPoolConfig
case result of
Left _ -> pure ()
Right rp -> do
liftIO $ destroyRoutingPool rp
expectationFailure "Expected failure connecting to unreachable host"
it "routing pool reuses cached table on consecutive calls" $ do
cfg <- liftIO getRoutingConf5
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
r1 <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 1 AS n"
r2 <- liftIO $ withRoutingConnection rp ReadAccess $ \p ->
queryIO p "RETURN 2 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
liftIO $ destroyRoutingPool rp
it "destroyRoutingPool is idempotent" $ do
cfg <- liftIO getRoutingConf5
rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig
liftIO $ destroyRoutingPool rp
liftIO $ destroyRoutingPool rp
-- ================================================================
-- LOGON/LOGOFF tests (Bolt 5.1+)
-- ================================================================
logonLogoffTestSuite :: TopSpec
logonLogoffTestSuite = do
let getConf = mkGetConfig neo4j5Config
let wp :: (Connection -> IO a) -> IO a
wp = mkWithConn neo4j5Config
describe "LOGON/LOGOFF (Bolt 5.1+)" $ do
it "connects with 5.1+ handshake (HELLO + LOGON)" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Verify negotiated version is 5.1+
let ver = connectionVersion pipe
versionMajor ver `shouldBe` 5
(versionMinor ver >= 1) `shouldBe` True
liftIO $ close pipe
it "queries work after 5.1+ handshake" $ do
result <- liftIO $ wp $ \p -> queryIO p "RETURN 42 AS n"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
it "transactions work after 5.1+ handshake" $ do
liftIO $ wp $ \p ->
withTransaction p $ \conn -> do
_ <- queryIO conn "CREATE (n:TestLogonTx {value: 1})"
pure ()
result <- liftIO $ wp $ \p ->
queryIO p "MATCH (n:TestLogonTx) RETURN n.value AS v"
V.length result `shouldBe` 1
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ wp $ \p -> queryIO p "MATCH (n:TestLogonTx) DELETE n" >> pure ()
it "logoff + logon re-authenticates on same connection" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Verify version supports logon/logoff
let ver = connectionVersion pipe
if supportsLogonLogoff ver then do
-- Query before logoff
r1 <- liftIO $ queryIO pipe "RETURN 1 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
-- Logoff and logon again
liftIO $ logoff pipe
liftIO $ logon pipe (Basic "neo4j" "testpassword")
-- Query after re-auth
r2 <- liftIO $ queryIO pipe "RETURN 2 AS n"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
else
pure () -- skip on 5.0
liftIO $ close pipe
it "logoff + logon with None scheme on no-auth server" $ do
naCfg <- liftIO $ mkGetConfig noAuthConfig
pipe <- liftIO $ connect naCfg
let ver = connectionVersion pipe
if supportsLogonLogoff ver then do
r1 <- liftIO $ queryIO pipe "RETURN 1 AS n"
case asInt (V.head $ V.head r1) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ logoff pipe
liftIO $ logon pipe None
r2 <- liftIO $ queryIO pipe "RETURN 2 AS n"
case asInt (V.head $ V.head r2) of
Just n -> n `shouldBe` 2
Nothing -> expectationFailure "Expected 2"
else
pure ()
liftIO $ close pipe
-- ================================================================
-- Telemetry tests
-- ================================================================
telemetryTestSuite :: TopSpec
telemetryTestSuite = do
let getConf = mkGetConfig neo4j5Config
describe "Telemetry" $ do
it "sendTelemetry does not break operations" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
-- Send telemetry (no-op if server doesn't support it)
liftIO $ sendTelemetry pipe ManagedTransactions
-- Verify connection still works
result <- liftIO $ queryIO pipe "RETURN 1 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ close pipe
it "session telemetry does not break managed transactions" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
session <- liftIO $ createSession pool defaultSessionConfig
result <- liftIO $ writeTransaction session $ \conn ->
queryIO conn "RETURN 42 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 42
Nothing -> expectationFailure "Expected 42"
-- Second transaction should also work (telemetry already sent)
result2 <- liftIO $ readTransaction session $ \conn ->
queryIO conn "RETURN 99 AS n"
case asInt (V.head $ V.head result2) of
Just n -> n `shouldBe` 99
Nothing -> expectationFailure "Expected 99"
liftIO $ destroyPool pool
-- ================================================================
-- Query logging integration tests
-- ================================================================
setQueryLogger :: Maybe (QueryLog -> QueryMeta -> IO ()) -> Config -> Config
setQueryLogger ql Config{..} = Config { queryLogger = ql, .. }
loggingTestSuite :: TopSpec
loggingTestSuite = do
describe "Query logging" $ do
it "logger callback fires and receives correct cypher" $ do
logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog)
cfg <- liftIO neo4j5Config
let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg
case validateConfig cfgWithLogger of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryIO pipe "RETURN 1 AS n"
liftIO $ close pipe
logged <- liftIO $ readIORef logRef
case logged of
Nothing -> expectationFailure "Logger should have been called"
Just ql -> qlCypher ql `shouldBe` "RETURN 1 AS n"
it "logger reports correct row count" $ do
logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog)
cfg <- liftIO neo4j5Config
let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg
case validateConfig cfgWithLogger of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryIO pipe "UNWIND range(1, 5) AS n RETURN n"
liftIO $ close pipe
logged <- liftIO $ readIORef logRef
case logged of
Nothing -> expectationFailure "Logger should have been called"
Just ql -> qlRowCount ql `shouldBe` 5
it "client timing is positive" $ do
logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog)
cfg <- liftIO neo4j5Config
let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg
case validateConfig cfgWithLogger of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryIO pipe "RETURN 1 AS n"
liftIO $ close pipe
logged <- liftIO $ readIORef logRef
case logged of
Nothing -> expectationFailure "Logger should have been called"
Just ql -> (qlClientTime ql > 0) `shouldBe` True
it "server timing values are non-negative" $ do
logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog)
cfg <- liftIO neo4j5Config
let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg
case validateConfig cfgWithLogger of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryIO pipe "RETURN 1 AS n"
liftIO $ close pipe
logged <- liftIO $ readIORef logRef
case logged of
Nothing -> expectationFailure "Logger should have been called"
Just ql -> do
(qlServerFirst ql >= 0) `shouldBe` True
(qlServerLast ql >= 0) `shouldBe` True
it "logger fires for parameterized queries" $ do
logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog)
cfg <- liftIO neo4j5Config
let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg
case validateConfig cfgWithLogger of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryPIO pipe "RETURN $x AS n" (H.singleton "x" (PsInteger 42))
liftIO $ close pipe
logged <- liftIO $ readIORef logRef
case logged of
Nothing -> expectationFailure "Logger should have been called"
Just ql -> do
qlCypher ql `shouldBe` "RETURN $x AS n"
H.member "x" (qlParameters ql) `shouldBe` True
-- ================================================================
-- Notification integration tests
-- ================================================================
notificationTestSuite :: TopSpec
notificationTestSuite = do
describe "Notifications" $ do
it "notification handler fires for cartesian product warning" $ do
notifsRef <- liftIO $ newIORef ([] :: [Notification])
cfg <- liftIO neo4j5Config
let cfgWithHandler = cfg { notificationHandler = Just (\n -> do
ns <- readIORef notifsRef
writeIORef notifsRef (n : ns)) }
case validateConfig cfgWithHandler of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
-- A cartesian product query should produce a notification
_ <- liftIO $ queryIO pipe "MATCH (a), (b) RETURN count(*)"
liftIO $ close pipe
notifs <- liftIO $ readIORef notifsRef
(length notifs > 0) `shouldBe` True
-- At least one should be about cartesian product
let codes = map nCode notifs
any (T.isInfixOf "CartesianProduct") codes `shouldBe` True
it "parsedNotifications available via queryMeta" $ do
cfg <- liftIO $ mkGetConfig neo4j5Config
pipe <- liftIO $ connect cfg
result <- liftIO $ queryIO' pipe "MATCH (a), (b) RETURN count(*)"
liftIO $ close pipe
let notifs = parsedNotifications (infos result)
(V.length notifs > 0) `shouldBe` True
it "no notifications for simple query" $ do
notifsRef <- liftIO $ newIORef ([] :: [Notification])
cfg <- liftIO neo4j5Config
let cfgWithHandler = cfg { notificationHandler = Just (\n -> do
ns <- readIORef notifsRef
writeIORef notifsRef (n : ns)) }
case validateConfig cfgWithHandler of
Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs
Val.Success vc -> do
pipe <- liftIO $ connect vc
_ <- liftIO $ queryIO pipe "RETURN 1 AS n"
liftIO $ close pipe
notifs <- liftIO $ readIORef notifsRef
length notifs `shouldBe` 0
-- ================================================================
-- Query stats integration tests
-- ================================================================
statsTestSuite :: TopSpec
statsTestSuite = do
let wp :: (Connection -> IO a) -> IO a
wp = mkWithConn neo4j5Config
describe "Query statistics" $ do
it "CREATE query has nodesCreated == 1" $ do
result <- liftIO $ wp $ \p -> do
r <- queryIO' p "CREATE (n:TestStats {value: 1}) RETURN n"
_ <- queryIO p "MATCH (n:TestStats) DELETE n"
pure r
case parsedStats (infos result) of
Nothing -> expectationFailure "Expected stats for CREATE query"
Just qs -> nodesCreated qs `shouldBe` 1
it "read-only query has no stats" $ do
result <- liftIO $ wp $ \p -> queryIO' p "RETURN 1 AS n"
parsedStats (infos result) `shouldBe` Nothing
it "CREATE + SET has propertiesSet > 0" $ do
result <- liftIO $ wp $ \p -> do
r <- queryIO' p "CREATE (n:TestStats2 {a: 1, b: 2}) RETURN n"
_ <- queryIO p "MATCH (n:TestStats2) DELETE n"
pure r
case parsedStats (infos result) of
Nothing -> expectationFailure "Expected stats"
Just qs -> (propertiesSet qs > 0) `shouldBe` True
-- ================================================================
-- Server hints integration tests
-- ================================================================
serverHintTestSuite :: TopSpec
serverHintTestSuite = do
let getConf = mkGetConfig neo4j5Config
describe "Server hints" $ do
it "Neo4j 5 reports server idle timeout" $ do
cfg <- liftIO getConf
pipe <- liftIO $ connect cfg
let sto = connectionServerIdleTimeout pipe
liftIO $ close pipe
-- Neo4j 5 should report a timeout (typically 120 seconds)
case sto of
Just secs -> (secs > 0) `shouldBe` True
Nothing -> pure () -- Some Neo4j configs may not send this
it "pool works with server idle timeout hint" $ do
cfg <- liftIO getConf
pool <- liftIO $ createPool cfg defaultPoolConfig
result <- liftIO $ withConnection pool $ \p ->
queryIO p "RETURN 1 AS n"
case asInt (V.head $ V.head result) of
Just n -> n `shouldBe` 1
Nothing -> expectationFailure "Expected 1"
liftIO $ destroyPool pool
-- ================================================================
-- Decode integration tests
-- ================================================================
decodeTestSuite :: TopSpec
decodeTestSuite = do
let wp :: (Connection -> IO a) -> IO a
wp = mkWithConn neo4j5Config
describe "Record decoding (integration)" $ do
it "queryWith decodes RETURN 1 with column 0 int64" $ do
result <- liftIO $ wp $ \p -> runBolt p $
queryWith (column 0 int64) "RETURN 1 AS n" mempty
case result of
Right v -> do
V.length v `shouldBe` 1
V.head v `shouldBe` (1 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "queryWith with parameters decodes correctly" $ do
result <- liftIO $ wp $ \p -> runBolt p $
queryWith (column 0 int64) "RETURN $x AS n" (H.singleton "x" (PsInteger 42))
case result of
Right v -> V.head v `shouldBe` (42 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "queryWith with field 'name' text" $ do
result <- liftIO $ wp $ \p -> runBolt p $
queryWith (field "name" Database.Bolty.text) "RETURN 'hello' AS name" mempty
case result of
Right v -> V.head v `shouldBe` "hello"
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "queryWith returns Left on type mismatch" $ do
result <- liftIO $ wp $ \p -> runBolt p $
queryWith (field "n" Database.Bolty.text) "RETURN 1 AS n" mempty
case result of
Left (TypeMismatch _ _) -> pure ()
other -> expectationFailure $ "Expected Left TypeMismatch, got: " <> show other
it "queryWith with multi-column Applicative decoder" $ do
result <- liftIO $ wp $ \p -> runBolt p $
queryWith ((,) <$> field "name" Database.Bolty.text <*> field "age" int64)
"RETURN 'Alice' AS name, 30 AS age" mempty
case result of
Right v -> V.head v `shouldBe` ("Alice" :: T.Text, 30 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "query with FromBolt instance" $ do
result <- liftIO $ wp $ \p -> runBolt p $
query "RETURN 'Alice' AS name, 30 AS age" mempty
case result of
Right v -> do
let PersonResult n a = V.head v
n `shouldBe` "Alice"
a `shouldBe` (30 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "queryResult + decodeResultSet for multi-pass decoding" $ do
rs <- liftIO $ wp $ \p -> runBolt p $
queryResult "RETURN 'Alice' AS name, 30 AS age" mempty
case decodeResultSet (field "name" Database.Bolty.text) rs of
Right names -> V.head names `shouldBe` "Alice"
Left e -> expectationFailure $ "Expected Right, got: " <> show e
case decodeResultSet (field "age" int64) rs of
Right ages -> V.head ages `shouldBe` (30 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
it "queryMeta returns metadata" $ do
(rs, meta) <- liftIO $ wp $ \p -> runBolt p $
queryResultMeta "RETURN 1 AS n" mempty
case decodeResultSet (field "n" int64) rs of
Right v -> V.head v `shouldBe` (1 :: Int64)
Left e -> expectationFailure $ "Expected Right, got: " <> show e
-- QueryMeta should have a bookmark
case bookmark meta of
Just _ -> pure ()
Nothing -> pure () -- not all servers return bookmarks for auto-commit
it "BoltM monadic pattern" $ do
liftIO $ wp $ \conn -> runBolt conn $ do
result <- query "RETURN 'hello' AS name, 42 AS age" mempty
case result of
Right v -> liftIO $ V.head v `shouldBe` PersonResult "hello" 42
Left e -> liftIO $ expectationFailure $ show e
-- ================================================================
-- Temporal type tests — runs against any Neo4j version
-- ================================================================
temporalTestSuite :: String -> IO Config -> TopSpec
temporalTestSuite label mkConfig = do
let wp :: (Connection -> IO a) -> IO a
wp = mkWithConn mkConfig
describe (label ++ " - Temporal types") $ do
it "returns a DateTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN datetime('2024-01-15T12:30:00Z') AS dt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDateTime DateTime{seconds, nanoseconds} -> do
(seconds > 0) `shouldBe` True
nanoseconds `shouldBe` 0
other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other
it "returns a LocalDateTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN localdatetime('2024-01-15T12:30:00') AS ldt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltLocalDateTime LocalDateTime{seconds, nanoseconds} -> do
(seconds > 0) `shouldBe` True
nanoseconds `shouldBe` 0
other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other
it "returns a Time" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN time('12:30:00+01:00') AS t"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltTime Time{nanoseconds, tz_offset_seconds} -> do
(nanoseconds > 0) `shouldBe` True
tz_offset_seconds `shouldBe` 3600
other -> expectationFailure $ "Expected BoltTime, got: " <> show other
it "returns a LocalTime" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN localtime('12:30:00') AS lt"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltLocalTime LocalTime{nanoseconds} ->
(nanoseconds > 0) `shouldBe` True
other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other
it "returns a Duration" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN duration('P1Y2M3DT4H') AS d"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDuration _ -> pure ()
other -> expectationFailure $ "Expected BoltDuration, got: " <> show other
it "returns a DateTimeZoneId" $ do
result <- liftIO $ wp $ \p ->
queryIO p "RETURN datetime({year: 2024, month: 1, day: 15, hour: 12, timezone: 'Europe/Paris'}) AS dtz"
V.length result `shouldBe` 1
case V.head $ V.head result of
BoltDateTimeZoneId DateTimeZoneId{tz_id} ->
tz_id `shouldBe` "Europe/Paris"
other -> expectationFailure $ "Expected BoltDateTimeZoneId, got: " <> show other
-- ================================================================
-- Main
-- ================================================================
main :: IO ()
main = runSandwichWithCommandLineArgs defaultOptions $ do
-- Core test suite against Neo4j 5
coreTestSuite "Neo4j 5" neo4j5Config
-- Core test suite against Neo4j 4.4
coreTestSuite "Neo4j 4.4" neo4j44Config
-- Connection validation tests
validationTestSuite "Neo4j 5" neo4j5Config
validationTestSuite "Neo4j 4.4" neo4j44Config
-- Routing tests against Neo4j 5
routingTestSuite "Neo4j 5" neo4j5Config
-- Routing tests against Neo4j 4.4
routingTestSuite "Neo4j 4.4" neo4j44Config
-- Session tests against Neo4j 5
sessionTestSuite "Neo4j 5" neo4j5Config
-- Session tests against Neo4j 4.4
sessionTestSuite "Neo4j 4.4" neo4j44Config
-- Routing session tests (Neo4j 5 only - requires routing pool)
routingSessionTests
-- Failover tests (Neo4j 5 only)
failoverTests
-- Auth scheme tests (Neo4j 5 + no-auth server)
authSchemeTests
-- Routing edge cases
routingEdgeCaseTests
-- LOGON/LOGOFF tests (Bolt 5.1+)
logonLogoffTestSuite
-- Telemetry tests
telemetryTestSuite
-- Query logging tests (Neo4j 5)
loggingTestSuite
-- Notification tests (Neo4j 5)
notificationTestSuite
-- Query stats tests (Neo4j 5)
statsTestSuite
-- Server hints tests (Neo4j 5)
serverHintTestSuite
-- Decode tests (Neo4j 5)
decodeTestSuite
-- Temporal type tests
temporalTestSuite "Neo4j 5" neo4j5Config
temporalTestSuite "Neo4j 4.4" neo4j44Config