bolty-0.2.0.0: test/Main.hs
module Main where
import Test.Sandwich
import Control.Monad.IO.Class (liftIO)
import Data.Bits (shiftL, (.|.))
import Data.Default (def)
import Data.Int (Int64)
import Data.Word (Word32, Word64)
import qualified Data.HashMap.Lazy as H
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as V
import qualified Validation as Val
import Data.PackStream.Ps (Ps(..), PackStream(..))
import Data.PackStream (pack, unpack)
import Data.PackStream.Integer (toPSInteger)
import qualified Data.PackStream.Result as R
import Database.Bolty hiding (Error)
import Database.Bolty.Decode (DecodeError(..), decodeRow, decodeRows)
import Database.Bolty.Record (lookupField)
import qualified Database.Bolty.ResultSet as RS
import Database.Bolty.Logging (QueryLog(..))
import Database.Bolty.Notification (Notification(..), Severity(..), Position(..), parseNotifications)
import Database.Bolty.Plan (PlanNode(..), ProfileNode(..), parsePlan, parseProfile, renderPlan)
import Database.Bolty.Stats (QueryStats(..), parseStats, formatStatsLine)
import Database.Bolty.Admin (totalAffected)
import Database.Bolty.Value.Type (Node(..), Relationship(..), UnboundRelationship(..)
, Path(..), Date(..), Time(..), LocalTime(..)
, DateTime(..), DateTimeZoneId(..), LocalDateTime(..)
, Duration(..), Point2D(..), Point3D(..))
import Database.Bolty.Message.Request (Request(..), Hello(..), Route(..), RouteExtra(..)
, Begin(..), RunExtra(..)
, RunAutoCommitTransaction(..)
, Logon(..), TelemetryApi(..)
, Pull(..), defaultPull)
import Database.Bolty.Message.Response (Response(..), RoutingTable(..), parseRoutingTable, extractBookmark, QueryMeta(..))
import qualified Database.Bolty.Message.Response as Resp
import qualified Data.Aeson.KeyMap as KM
import Database.Bolty.Routing (parseAddress)
import Database.Bolty.Session (newBookmarkManager, getBookmarks, updateBookmark)
import Database.Bolty.Decode (psToBolt, boltToPs)
import Database.Bolty.Value.Helpers (sigLocalDateTime, supportsLogonLogoff, supportsTelemetry)
import Control.Exception (IOException, SomeException, fromException, toException)
import qualified Data.Aeson as Aeson
import Data.Aeson (fromJSON, toJSON)
import qualified Data.Aeson.Types as Aeson (Result(..), parseEither)
import qualified Data.ByteString as BS
import qualified Data.Vector.Mutable as MV
import Test.QuickCheck (Arbitrary(..), Gen, Result, oneof, listOf,
quickCheckResult, isSuccess, property,
withMaxSuccess, elements, chooseInt)
import GHC.Clock (getMonotonicTimeNSec)
import Data.PackStream (pack', unpack')
import Database.Bolty.Connection.Type (Error(..))
-- = Helpers
setUserAgent :: UserAgent -> Config -> Config
setUserAgent ua Config{..} = Config { user_agent = ua, .. }
-- = Config validation tests
configTests :: TopSpec
configTests = describe "Config validation" $ do
it "validates default config" $ do
case validateConfig (def :: Config) of
Val.Failure errs -> expectationFailure $ "Default config should validate: " <> show errs
Val.Success _ -> pure ()
it "rejects empty host" $ do
let cfg = (def :: Config) { host = "" }
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Empty host should be rejected"
it "rejects empty user agent name" $ do
let cfg = setUserAgent (UserAgent "" "1.0") (def :: Config)
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Empty user agent name should be rejected"
it "rejects empty user agent version" $ do
let cfg = setUserAgent (UserAgent "bolty" "") (def :: Config)
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Empty user agent version should be rejected"
it "rejects empty version list" $ do
let cfg = (def :: Config) { versions = [] }
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Empty version list should be rejected"
-- = Version validation tests
versionTests :: TopSpec
versionTests = describe "Version validation" $ do
it "rejects major version < 4" $ do
let cfg = (def :: Config) { versions = [Version 0 3] }
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Major version < 4 should be rejected"
it "rejects version 4.1 (below 4.4 floor)" $ do
let cfg = (def :: Config) { versions = [Version 1 4] }
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Version 4.1 should be rejected (below 4.4 floor)"
it "accepts version 5.0" $ do
let cfg = (def :: Config) { versions = [Version 0 5] }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Version 5.0 should validate: " <> show errs
Val.Success _ -> pure ()
-- = Bolt value extractor tests
extractorTests :: TopSpec
extractorTests = describe "Bolt value extractors" $ do
it "asText extracts text" $ do
asText (BoltString "hello") `shouldBe` Just "hello"
it "asText returns Nothing for non-text" $ do
asText (BoltInteger 42) `shouldBe` Nothing
it "asInt extracts integer" $ do
asInt (BoltInteger 42) `shouldBe` Just 42
it "asInt returns Nothing for non-integer" $ do
asInt (BoltString "hello") `shouldBe` Nothing
it "asBool extracts boolean" $ do
asBool (BoltBoolean True) `shouldBe` Just True
asBool (BoltBoolean False) `shouldBe` Just False
it "asBool returns Nothing for non-boolean" $ do
asBool BoltNull `shouldBe` Nothing
it "asFloat extracts float" $ do
asFloat (BoltFloat 3.14) `shouldBe` Just 3.14
it "asNull extracts null" $ do
asNull BoltNull `shouldBe` Just ()
it "asNull returns Nothing for non-null" $ do
asNull (BoltInteger 0) `shouldBe` Nothing
it "asList extracts list" $ do
let v = V.fromList [BoltInteger 1, BoltInteger 2]
asList (BoltList v) `shouldBe` Just v
it "asDict extracts dictionary" $ do
let m = H.fromList [("key", BoltString "value")]
asDict (BoltDictionary m) `shouldBe` Just m
-- = Record accessor tests
recordTests :: TopSpec
recordTests = describe "Record accessors" $ do
let columns = V.fromList ["name", "age", "city"]
let record = V.fromList [BoltString "Alice", BoltInteger 30, BoltString "Paris"]
it "lookupField finds existing field" $ do
lookupField columns "name" record `shouldBe` Just (BoltString "Alice")
lookupField columns "age" record `shouldBe` Just (BoltInteger 30)
lookupField columns "city" record `shouldBe` Just (BoltString "Paris")
it "lookupField returns Nothing for missing field" $ do
lookupField columns "email" record `shouldBe` Nothing
it "lookupField returns Nothing for empty record" $ do
lookupField columns "name" V.empty `shouldBe` Nothing
-- = PackStream round-trip tests
-- = Message serialization tests
messageTests :: TopSpec
messageTests = describe "Message serialization" $ do
it "HELLO with None scheme produces correct structure" $ do
let hello = Hello (UserAgent "bolty" "2.0") None NoRouting False
let ps = toPs (RHello hello)
case ps of
PsStructure 0x01 fields -> do
V.length fields `shouldBe` 1
case V.head fields of
PsDictionary m -> do
case H.lookup "user_agent" m of
Just (PsString ua) -> ua `shouldBe` "bolty/2.0"
_ -> expectationFailure "expected user_agent string"
case H.lookup "scheme" m of
Just (PsString s) -> s `shouldBe` "none"
_ -> expectationFailure "expected scheme string"
H.member "routing" m `shouldBe` False
_ -> expectationFailure "expected dictionary as HELLO field"
_ -> expectationFailure "expected structure with tag 0x01"
it "HELLO with Basic scheme includes principal and credentials" $ do
let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "password") NoRouting False
let ps = toPs (RHello hello)
case ps of
PsStructure 0x01 fields -> case V.head fields of
PsDictionary m -> do
H.lookup "scheme" m `shouldBe` Just (PsString "basic")
H.lookup "principal" m `shouldBe` Just (PsString "neo4j")
H.lookup "credentials" m `shouldBe` Just (PsString "password")
_ -> expectationFailure "expected dictionary"
_ -> expectationFailure "expected structure"
it "HELLO with Routing includes routing dict" $ do
let hello = Hello (UserAgent "bolty" "2.0") None Routing False
let ps = toPs (RHello hello)
case ps of
PsStructure 0x01 fields -> case V.head fields of
PsDictionary m -> case H.lookup "routing" m of
Just (PsDictionary r) -> H.null r `shouldBe` True
_ -> expectationFailure "expected routing dictionary"
_ -> expectationFailure "expected dictionary"
_ -> expectationFailure "expected structure"
it "GOODBYE produces empty structure with tag 0x02" $ do
let ps = toPs RGoodbye
case ps of
PsStructure 0x02 fields -> V.null fields `shouldBe` True
_ -> expectationFailure "expected structure with tag 0x02"
it "RESET produces empty structure with tag 0x0F" $ do
let ps = toPs RReset
case ps of
PsStructure 0x0F fields -> V.null fields `shouldBe` True
_ -> expectationFailure "expected structure with tag 0x0F"
it "HELLO round-trips through PackStream" $ do
let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting False
let request = RHello hello
let ps = toPs request
let encoded = pack ps
case unpack encoded of
Left e -> expectationFailure $ "decode failed: " <> T.unpack e
Right ps' -> do
-- Verify the decoded Ps matches
ps' `shouldBe` ps
it "SUCCESS response round-trips through PackStream" $ do
let meta = H.fromList [("server", PsString "Neo4j/5.0.0"), ("connection_id", PsString "bolt-1")]
let response = RSuccess meta
let ps = toPs response
let encoded = pack ps
case unpack encoded of
Left e -> expectationFailure $ "decode failed: " <> T.unpack e
Right ps' -> ps' `shouldBe` ps
-- = Structure round-trip tests
structureRoundTripTests :: TopSpec
structureRoundTripTests = describe "Structure round-trips" $ do
it "round-trips Node" $ do
let node = Node 42 (V.fromList ["Person", "Employee"])
(H.fromList [("name", PsString "Alice"), ("age", PsInteger 30)])
"4:abc:42"
(fromPs (toPs node) :: R.Result Node) `shouldBe` R.Success node
it "round-trips Relationship" $ do
let rel = Relationship 1 10 20 "KNOWS"
(H.fromList [("since", PsInteger 2020)])
"4:abc:1" "4:abc:10" "4:abc:20"
(fromPs (toPs rel) :: R.Result Relationship) `shouldBe` R.Success rel
it "round-trips UnboundRelationship" $ do
let urel = UnboundRelationship 5 "LIKES" H.empty "4:abc:5"
(fromPs (toPs urel) :: R.Result UnboundRelationship) `shouldBe` R.Success urel
it "round-trips Path" $ do
let n1 = Node 1 (V.singleton "A") H.empty "4:abc:1"
let n2 = Node 2 (V.singleton "B") H.empty "4:abc:2"
let r1 = UnboundRelationship 10 "TO" H.empty "4:abc:10"
let path = Path (V.fromList [n1, n2]) (V.singleton r1) (V.fromList [1, 1])
(fromPs (toPs path) :: R.Result Path) `shouldBe` R.Success path
it "round-trips Date" $ do
let d = Date 19738
(fromPs (toPs d) :: R.Result Date) `shouldBe` R.Success d
it "round-trips Time" $ do
let t = Time 43200000000000 3600
(fromPs (toPs t) :: R.Result Time) `shouldBe` R.Success t
it "round-trips LocalTime" $ do
let lt = LocalTime 43200000000000
(fromPs (toPs lt) :: R.Result LocalTime) `shouldBe` R.Success lt
it "round-trips DateTime" $ do
let dt = DateTime 1705312800 0 3600
(fromPs (toPs dt) :: R.Result DateTime) `shouldBe` R.Success dt
it "round-trips DateTimeZoneId" $ do
let dtz = DateTimeZoneId 1705312800 0 "Europe/Paris"
(fromPs (toPs dtz) :: R.Result DateTimeZoneId) `shouldBe` R.Success dtz
it "round-trips LocalDateTime" $ do
let ldt = LocalDateTime 1705312800 500000000
(fromPs (toPs ldt) :: R.Result LocalDateTime) `shouldBe` R.Success ldt
it "round-trips Duration" $ do
let dur = Duration 14 10 3600 0
(fromPs (toPs dur) :: R.Result Duration) `shouldBe` R.Success dur
it "round-trips Point2D" $ do
let p = Point2D 7203 1.5 2.5
(fromPs (toPs p) :: R.Result Point2D) `shouldBe` R.Success p
it "round-trips Point3D" $ do
let p = Point3D 9157 1.0 2.0 3.0
(fromPs (toPs p) :: R.Result Point3D) `shouldBe` R.Success p
it "Node structure dispatches correctly through Bolt" $ do
let node = Node 42 (V.fromList ["Person"])
(H.fromList [("name", PsString "Alice")])
"4:abc:42"
let ps = toPs node
case (fromPs ps :: R.Result Bolt) of
R.Success (BoltNode n) -> n `shouldBe` node
other -> expectationFailure $ "Expected BoltNode, got: " <> show other
it "Date structure dispatches correctly through Bolt" $ do
let d = Date 19738
let ps = toPs d
case (fromPs ps :: R.Result Bolt) of
R.Success (BoltDate d') -> d' `shouldBe` d
other -> expectationFailure $ "Expected BoltDate, got: " <> show other
it "Point2D structure dispatches correctly through Bolt" $ do
let p = Point2D 7203 1.5 2.5
let ps = toPs p
case (fromPs ps :: R.Result Bolt) of
R.Success (BoltPoint2D p') -> p' `shouldBe` p
other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other
-- = AccessMode tests
accessModeTests :: TopSpec
accessModeTests = describe "AccessMode" $ do
it "ReadAccess encodes to PsString \"r\"" $
toPs ReadAccess `shouldBe` PsString "r"
it "WriteAccess encodes to PsString \"w\"" $
toPs WriteAccess `shouldBe` PsString "w"
it "round-trips ReadAccess" $
(fromPs (toPs ReadAccess) :: R.Result AccessMode) `shouldBe` R.Success ReadAccess
it "round-trips WriteAccess" $
(fromPs (toPs WriteAccess) :: R.Result AccessMode) `shouldBe` R.Success WriteAccess
it "rejects an unknown single-char string" $
case (fromPs (PsString "x") :: R.Result AccessMode) of
R.Error _ -> pure ()
R.Success a -> expectationFailure $ "Expected Error, got: " <> show a
it "rejects the empty string" $
case (fromPs (PsString "") :: R.Result AccessMode) of
R.Error _ -> pure ()
R.Success a -> expectationFailure $ "Expected Error, got: " <> show a
it "rejects a non-string Ps" $
case (fromPs (PsInteger 1) :: R.Result AccessMode) of
R.Error _ -> pure ()
R.Success a -> expectationFailure $ "Expected Error, got: " <> show a
it "enumerates exhaustively via Bounded + Enum" $
[minBound .. maxBound] `shouldBe` [ReadAccess, WriteAccess]
-- Per Bolt spec, "mode" in BEGIN/RUN extra is optional with default "w".
-- A spec-compliant peer may omit it on write transactions.
it "Begin.fromPs accepts absent \"mode\" key and defaults to WriteAccess" $ do
-- Mirror a spec-compliant peer's BEGIN extra dict: required keys
-- present, optional keys (mode, tx_timeout, db, imp_user) omitted.
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
]
case (fromPs dict :: R.Result Begin) of
R.Success b -> b.mode `shouldBe` WriteAccess
R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e
it "Begin.fromPs accepts explicit \"mode\" = \"r\"" $ do
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
, ("mode", PsString "r")
]
case (fromPs dict :: R.Result Begin) of
R.Success b -> b.mode `shouldBe` ReadAccess
R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e
it "RunExtra.fromPs accepts absent \"mode\" key and defaults to WriteAccess" $ do
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
]
case (fromPs dict :: R.Result RunExtra) of
R.Success r -> (r :: RunExtra).mode `shouldBe` WriteAccess
R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e
it "RunExtra.fromPs accepts explicit \"mode\" = \"r\"" $ do
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
, ("mode", PsString "r")
]
case (fromPs dict :: R.Result RunExtra) of
R.Success r -> (r :: RunExtra).mode `shouldBe` ReadAccess
R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e
-- Invalid mode values must surface as an Error from the parent decoder,
-- not silently fall back to WriteAccess (which is the absent-key default).
it "Begin.fromPs rejects invalid \"mode\" value" $ do
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
, ("mode", PsString "x")
]
case (fromPs dict :: R.Result Begin) of
R.Error _ -> pure ()
R.Success b -> expectationFailure $ "Expected Error, got mode=" <> show b.mode
it "RunExtra.fromPs rejects invalid \"mode\" value" $ do
let dict = PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
, ("mode", PsString "X") -- uppercase: a likely human-typo case
]
case (fromPs dict :: R.Result RunExtra) of
R.Error _ -> pure ()
R.Success r -> expectationFailure $ "Expected Error, got mode=" <> show ((r :: RunExtra).mode)
-- Third lookupMode callsite: the autocommit RUN decoder (fromPsToRunRequest).
-- Routes through PsStructure 0x10 + the metadata-keys gate that picks the
-- autocommit branch over the explicit-tx branch.
it "Autocommit RUN decoder accepts absent \"mode\" and defaults to WriteAccess" $ do
let runDict = PsDictionary $ H.fromList
[ ("query", PsString "RETURN 1")
, ("parameters", PsDictionary H.empty)
, ("extra", PsDictionary $ H.fromList
[ ("bookmarks", toPs (V.empty :: V.Vector T.Text))
, ("tx_metadata", PsDictionary H.empty)
])
, ("bookmarks", toPs (V.empty :: V.Vector T.Text)) -- forces autocommit branch
, ("tx_metadata", PsDictionary H.empty)
]
case (fromPs (PsStructure 0x10 (V.singleton runDict)) :: R.Result Request) of
R.Success (RRunAutoCommitTransaction rac) ->
(rac :: RunAutoCommitTransaction).mode `shouldBe` WriteAccess
R.Success _ ->
expectationFailure "Expected RRunAutoCommitTransaction, got a different Request constructor"
R.Error e ->
expectationFailure $ "Expected Success, got: " <> T.unpack e
-- = Pool config tests
poolConfigTests :: TopSpec
poolConfigTests = describe "Pool config" $ do
it "defaultPoolConfig has maxPingRetries == 1" $ do
maxPingRetries defaultPoolConfig `shouldBe` 1
it "defaultPoolConfig has maxConnections == 10" $ do
maxConnections defaultPoolConfig `shouldBe` 10
it "defaultPoolConfig has idleTimeout == 60" $ do
idleTimeout defaultPoolConfig `shouldBe` 60
it "defaultPoolConfig maxConnections >= 1 (required by resource-pool)" $ do
(maxConnections defaultPoolConfig >= 1) `shouldBe` True
-- = Retry config and isTransient tests
retryTests :: TopSpec
retryTests = describe "Retry logic" $ do
it "isTransient returns True for transient error" $ do
isTransient (ResponseErrorFailure "Neo.TransientError.Transaction.DeadlockDetected" "deadlock") `shouldBe` True
it "isTransient returns True for other transient error codes" $ do
isTransient (ResponseErrorFailure "Neo.TransientError.General.MemoryPoolOutOfMemoryError" "oom") `shouldBe` True
it "isTransient returns False for client error" $ do
isTransient (ResponseErrorFailure "Neo.ClientError.Statement.SyntaxError" "bad syntax") `shouldBe` False
it "isTransient returns False for database error" $ do
isTransient (ResponseErrorFailure "Neo.DatabaseError.General.UnknownError" "unknown") `shouldBe` False
it "isTransient returns False for ResetFailed" $ do
isTransient ResetFailed `shouldBe` False
it "isTransient returns False for AuthentificationFailed" $ do
isTransient AuthentificationFailed `shouldBe` False
it "defaultRetryConfig has expected values" $ do
maxRetries defaultRetryConfig `shouldBe` 5
initialDelay defaultRetryConfig `shouldBe` 200_000
maxDelay defaultRetryConfig `shouldBe` 5_000_000
-- = Route serialization tests
routeTests :: TopSpec
routeTests = describe "Route serialization" $ do
it "Route serializes to 3-field structure with tag 0x66" $ do
let route = Route H.empty V.empty (RouteExtra Nothing Nothing)
let ps = toPs (RRoute route)
case ps of
PsStructure 0x66 fields -> V.length fields `shouldBe` 3
_ -> expectationFailure $ "expected structure with tag 0x66, got: " <> show ps
it "Route with address and bookmarks round-trips through PackStream" $ do
let route = Route (H.singleton "address" (PsString "localhost:7687"))
(V.fromList ["bk1", "bk2"])
(RouteExtra (Just "neo4j") Nothing)
let ps = toPs (RRoute route)
let encoded = pack ps
case unpack encoded of
Left e -> expectationFailure $ "decode failed: " <> T.unpack e
Right ps' -> ps' `shouldBe` ps
it "Route round-trips through Request fromPs/toPs" $ do
let route = Route H.empty V.empty (RouteExtra Nothing Nothing)
let request = RRoute route
let ps = toPs request
case (fromPs ps :: R.Result Request) of
R.Success (RRoute Route{routing, bookmarks, extra = _}) -> do
H.null routing `shouldBe` True
V.null bookmarks `shouldBe` True
R.Success _other -> expectationFailure $ "expected RRoute, got other Request"
R.Error e -> expectationFailure $ "fromPs failed: " <> T.unpack e
-- = Routing table parsing tests
routingTableTests :: TopSpec
routingTableTests = describe "parseRoutingTable" $ do
it "parses valid response with multiple roles" $ do
let meta = H.singleton "rt" $ PsDictionary $ H.fromList
[ ("ttl", PsInteger (toPSInteger (300 :: Int64)))
, ("db", PsString "neo4j")
, ("servers", PsList $ V.fromList
[ PsDictionary $ H.fromList
[ ("role", PsString "ROUTE")
, ("addresses", PsList $ V.fromList [PsString "r1:7687", PsString "r2:7687"])
]
, PsDictionary $ H.fromList
[ ("role", PsString "READ")
, ("addresses", PsList $ V.fromList [PsString "rd1:7687"])
]
, PsDictionary $ H.fromList
[ ("role", PsString "WRITE")
, ("addresses", PsList $ V.fromList [PsString "wr1:7687"])
]
])
]
case parseRoutingTable meta of
Right RoutingTable{ttl, db, routers, readers, writers} -> do
ttl `shouldBe` 300
db `shouldBe` "neo4j"
V.length routers `shouldBe` 2
V.length readers `shouldBe` 1
V.length writers `shouldBe` 1
V.head routers `shouldBe` "r1:7687"
V.head readers `shouldBe` "rd1:7687"
V.head writers `shouldBe` "wr1:7687"
Left e -> expectationFailure $ "parse failed: " <> T.unpack e
it "fails on missing rt key" $ do
let meta = H.singleton "other" (PsString "value")
case parseRoutingTable meta of
Left _ -> pure ()
Right _ -> expectationFailure "expected failure for missing rt key"
it "fails on missing servers key" $ do
let meta = H.singleton "rt" $ PsDictionary $ H.fromList
[ ("ttl", PsInteger (toPSInteger (300 :: Int64)))
, ("db", PsString "neo4j")
]
case parseRoutingTable meta of
Left _ -> pure ()
Right _ -> expectationFailure "expected failure for missing servers key"
it "handles CE single-server-all-roles response" $ do
let addr = PsString "localhost:7687"
let meta = H.singleton "rt" $ PsDictionary $ H.fromList
[ ("ttl", PsInteger (toPSInteger (300 :: Int64)))
, ("db", PsString "neo4j")
, ("servers", PsList $ V.fromList
[ PsDictionary $ H.fromList
[ ("role", PsString "ROUTE"), ("addresses", PsList $ V.singleton addr) ]
, PsDictionary $ H.fromList
[ ("role", PsString "READ"), ("addresses", PsList $ V.singleton addr) ]
, PsDictionary $ H.fromList
[ ("role", PsString "WRITE"), ("addresses", PsList $ V.singleton addr) ]
])
]
case parseRoutingTable meta of
Right RoutingTable{routers, readers, writers} -> do
V.length routers `shouldBe` 1
V.length readers `shouldBe` 1
V.length writers `shouldBe` 1
V.head routers `shouldBe` "localhost:7687"
V.head readers `shouldBe` "localhost:7687"
V.head writers `shouldBe` "localhost:7687"
Left e -> expectationFailure $ "parse failed: " <> T.unpack e
it "isTransient returns True for RoutingTableError" $ do
isTransient (RoutingTableError "test") `shouldBe` True
-- = parseAddress tests
parseAddressTests :: TopSpec
parseAddressTests = describe "parseAddress" $ do
it "parses host:port" $ do
parseAddress "localhost:7687" `shouldBe` ("localhost", 7687)
it "parses host with non-default port" $ do
parseAddress "db.example.com:9999" `shouldBe` ("db.example.com", 9999)
it "falls back to 7687 for missing port" $ do
parseAddress "localhost" `shouldBe` ("localhost", 7687)
it "falls back to 7687 for non-numeric port" $ do
parseAddress "localhost:abc" `shouldBe` ("localhost", 7687)
it "parses port 0" $ do
parseAddress "host:0" `shouldBe` ("host", 0)
-- = RoutingPoolConfig tests
routingPoolConfigTests :: TopSpec
routingPoolConfigTests = describe "RoutingPool config" $ do
it "defaultRoutingPoolConfig has refreshBuffer == 10" $ do
refreshBuffer defaultRoutingPoolConfig `shouldBe` 10
it "defaultRoutingPoolConfig has routingDb == Nothing" $ do
routingDb defaultRoutingPoolConfig `shouldBe` Nothing
it "defaultRoutingPoolConfig uses defaultPoolConfig" $ do
maxConnections (poolConfig defaultRoutingPoolConfig) `shouldBe` 10
-- = Routing error detection tests
routingErrorTests :: TopSpec
routingErrorTests = describe "Routing error detection" $ do
it "isRoutingError returns True for NotALeader" $ do
isRoutingError (ResponseErrorFailure "Neo.ClientError.Cluster.NotALeader" "not a leader") `shouldBe` True
it "isRoutingError returns True for ForbiddenOnReadOnlyDatabase" $ do
isRoutingError (ResponseErrorFailure "Neo.ClientError.General.ForbiddenOnReadOnlyDatabase" "read only") `shouldBe` True
it "isRoutingError returns False for transient error" $ do
isRoutingError (ResponseErrorFailure "Neo.TransientError.Transaction.DeadlockDetected" "deadlock") `shouldBe` False
it "isRoutingError returns False for syntax error" $ do
isRoutingError (ResponseErrorFailure "Neo.ClientError.Statement.SyntaxError" "bad syntax") `shouldBe` False
it "isRoutingError returns False for non-response errors" $ do
isRoutingError ResetFailed `shouldBe` False
isRoutingError (RoutingTableError "test") `shouldBe` False
-- = Bookmark management tests
bookmarkTests :: TopSpec
bookmarkTests = describe "Bookmark management" $ do
it "new BookmarkManager starts empty" $ do
bm <- liftIO $ newBookmarkManager []
bms <- liftIO $ getBookmarks bm
bms `shouldBe` []
it "new BookmarkManager with initial bookmarks" $ do
bm <- liftIO $ newBookmarkManager ["bm1", "bm2"]
bms <- liftIO $ getBookmarks bm
bms `shouldBe` ["bm1", "bm2"]
it "updateBookmark replaces bookmarks with single new one" $ do
bm <- liftIO $ newBookmarkManager ["old1", "old2"]
liftIO $ updateBookmark bm "new1"
bms <- liftIO $ getBookmarks bm
bms `shouldBe` ["new1"]
it "updateBookmark on empty manager adds bookmark" $ do
bm <- liftIO $ newBookmarkManager []
liftIO $ updateBookmark bm "bm1"
bms <- liftIO $ getBookmarks bm
bms `shouldBe` ["bm1"]
it "successive updateBookmark calls keep only the latest" $ do
bm <- liftIO $ newBookmarkManager []
liftIO $ updateBookmark bm "bm1"
liftIO $ updateBookmark bm "bm2"
bms <- liftIO $ getBookmarks bm
bms `shouldBe` ["bm2"]
it "extractBookmark extracts bookmark from metadata" $ do
let meta = H.fromList [("bookmark", PsString "FB:kcwQ123")]
extractBookmark meta `shouldBe` Just "FB:kcwQ123"
it "extractBookmark returns Nothing when no bookmark" $ do
let meta = H.fromList [("server", PsString "Neo4j/5.0")]
extractBookmark meta `shouldBe` Nothing
it "extractBookmark returns Nothing for non-string bookmark" $ do
let meta = H.fromList [("bookmark", PsInteger 42)]
extractBookmark meta `shouldBe` Nothing
-- = Session config tests
sessionConfigTests :: TopSpec
sessionConfigTests = describe "Session config" $ do
it "defaultSessionConfig has default database" $ do
database defaultSessionConfig `shouldBe` Nothing
it "defaultSessionConfig has WriteAccess mode" $ do
accessMode defaultSessionConfig `shouldBe` WriteAccess
it "defaultSessionConfig has no initial bookmarks" $ do
sessionBookmarks defaultSessionConfig `shouldBe` []
-- = Validation strategy tests
validationStrategyTests :: TopSpec
validationStrategyTests = describe "Validation strategy" $ do
it "defaultPoolConfig uses PingIfIdle 30" $ do
validationStrategy defaultPoolConfig `shouldBe` PingIfIdle 30
it "AlwaysPing /= NeverPing" $ do
(AlwaysPing == NeverPing) `shouldBe` False
it "PingIfIdle 30 == PingIfIdle 30" $ do
(PingIfIdle 30 == PingIfIdle 30) `shouldBe` True
it "PingIfIdle 10 /= PingIfIdle 60" $ do
(PingIfIdle 10 == PingIfIdle 60) `shouldBe` False
it "show AlwaysPing" $ do
show AlwaysPing `shouldBe` "AlwaysPing"
it "show NeverPing" $ do
show NeverPing `shouldBe` "NeverPing"
it "show PingIfIdle 30" $ do
show (PingIfIdle 30) `shouldBe` "PingIfIdle 30"
-- = Version 5.x validation tests
version5xTests :: TopSpec
version5xTests = describe "Version 5.x validation" $ do
it "accepts version 5.1" $ do
let cfg = (def :: Config) { versions = [Version 1 5] }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Version 5.1 should validate: " <> show errs
Val.Success _ -> pure ()
it "accepts version 5.2" $ do
let cfg = (def :: Config) { versions = [Version 2 5] }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Version 5.2 should validate: " <> show errs
Val.Success _ -> pure ()
it "accepts version 5.3" $ do
let cfg = (def :: Config) { versions = [Version 3 5] }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Version 5.3 should validate: " <> show errs
Val.Success _ -> pure ()
it "accepts version 5.4" $ do
let cfg = (def :: Config) { versions = [Version 4 5] }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Version 5.4 should validate: " <> show errs
Val.Success _ -> pure ()
it "rejects version 5.5" $ do
let cfg = (def :: Config) { versions = [Version 5 5] }
case validateConfig cfg of
Val.Failure _ -> pure ()
Val.Success _ -> expectationFailure "Version 5.5 should be rejected"
it "default config offers 5.4 and 4.4" $ do
let cfg = def :: Config
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Default config should validate: " <> show errs
Val.Success _ -> do
let vs = versions cfg
-- Should contain 5.4 as highest and 4.4 as fallback
any (\(Version m mj) -> mj == 5 && m == 4) vs `shouldBe` True
any (\(Version m mj) -> mj == 4 && m == 4) vs `shouldBe` True
-- = LOGON/LOGOFF/TELEMETRY message tests
logonLogoffTests :: TopSpec
logonLogoffTests = describe "LOGON/LOGOFF/TELEMETRY message serialization" $ do
it "LOGON serializes to structure with tag 0x6A and auth dictionary" $ do
let logonReq = RLogon (Logon (Basic "neo4j" "password"))
let ps = toPs logonReq
case ps of
PsStructure 0x6A fields -> do
V.length fields `shouldBe` 1
case V.head fields of
PsDictionary m -> do
H.lookup "scheme" m `shouldBe` Just (PsString "basic")
H.lookup "principal" m `shouldBe` Just (PsString "neo4j")
H.lookup "credentials" m `shouldBe` Just (PsString "password")
_ -> expectationFailure "expected dictionary as LOGON field"
_ -> expectationFailure $ "expected structure with tag 0x6A, got: " <> show ps
it "LOGON round-trips through PackStream" $ do
let logonReq = RLogon (Logon (Basic "neo4j" "pass"))
let ps = toPs logonReq
let encoded = pack ps
case unpack encoded of
Left e -> expectationFailure $ "decode failed: " <> T.unpack e
Right ps' -> ps' `shouldBe` ps
it "LOGOFF serializes to empty structure with tag 0x6B" $ do
let ps = toPs RLogoff
case ps of
PsStructure 0x6B fields -> V.null fields `shouldBe` True
_ -> expectationFailure $ "expected structure with tag 0x6B, got: " <> show ps
it "TELEMETRY serializes to structure with tag 0x54 and integer field" $ do
let ps = toPs (RTelemetry ManagedTransactions)
case ps of
PsStructure 0x54 fields -> do
V.length fields `shouldBe` 1
case V.head fields of
PsInteger _ -> pure ()
_ -> expectationFailure "expected integer field for TELEMETRY"
_ -> expectationFailure $ "expected structure with tag 0x54, got: " <> show ps
it "TELEMETRY round-trips through PackStream" $ do
let telReq = RTelemetry ExplicitTransactions
let ps = toPs telReq
let encoded = pack ps
case unpack encoded of
Left e -> expectationFailure $ "decode failed: " <> T.unpack e
Right ps' -> ps' `shouldBe` ps
it "TelemetryApi values encode to correct integers" $ do
let check api expected = case toPs (RTelemetry api) of
PsStructure 0x54 fields -> case V.head fields of
PsInteger n -> case fromPs (PsInteger n) :: R.Result Int64 of
R.Success v -> v `shouldBe` expected
R.Error e -> expectationFailure $ "fromPs failed: " <> T.unpack e
_ -> expectationFailure "expected integer"
_ -> expectationFailure "expected structure"
check ManagedTransactions 0
check ExplicitTransactions 1
check ImplicitTransactions 2
check ExecuteQuery 3
-- = Version helper tests
versionHelperTests :: TopSpec
versionHelperTests = describe "Version helpers" $ do
let mkVersion :: Word32 -> Word32 -> Word32
mkVersion major minor = major .|. (minor `shiftL` 8)
it "supportsLogonLogoff returns True for 5.1" $ do
supportsLogonLogoff (mkVersion 5 1) `shouldBe` True
it "supportsLogonLogoff returns True for 5.4" $ do
supportsLogonLogoff (mkVersion 5 4) `shouldBe` True
it "supportsLogonLogoff returns False for 5.0" $ do
supportsLogonLogoff (mkVersion 5 0) `shouldBe` False
it "supportsLogonLogoff returns False for 4.4" $ do
supportsLogonLogoff (mkVersion 4 4) `shouldBe` False
it "supportsTelemetry returns True for 5.4" $ do
supportsTelemetry (mkVersion 5 4) `shouldBe` True
it "supportsTelemetry returns False for 5.3" $ do
supportsTelemetry (mkVersion 5 3) `shouldBe` False
it "supportsTelemetry returns False for 5.0" $ do
supportsTelemetry (mkVersion 5 0) `shouldBe` False
it "supportsTelemetry returns False for 4.4" $ do
supportsTelemetry (mkVersion 4 4) `shouldBe` False
-- = Query logging config tests
loggingConfigTests :: TopSpec
loggingConfigTests = describe "Query logging config" $ do
it "default config has queryLogger = Nothing" $ do
case queryLogger (def :: Config) of
Nothing -> pure ()
Just _ -> expectationFailure "Expected queryLogger to be Nothing"
it "config with logger validates" $ do
let cfg = (def :: Config) { queryLogger = Just (\_ _ -> pure ()) }
case validateConfig cfg of
Val.Failure errs -> expectationFailure $ "Config with logger should validate: " <> show errs
Val.Success _ -> pure ()
it "QueryLog can be constructed" $ do
let ql = QueryLog
{ qlCypher = "RETURN 1"
, qlParameters = H.empty
, qlRowCount = 1
, qlServerFirst = 5
, qlServerLast = 10
, qlClientTime = 15.0
}
qlCypher ql `shouldBe` "RETURN 1"
qlRowCount ql `shouldBe` 1
qlServerFirst ql `shouldBe` 5
qlServerLast ql `shouldBe` 10
qlClientTime ql `shouldBe` 15.0
-- = Notification parsing tests
notificationTests :: TopSpec
notificationTests = describe "Notification parsing" $ do
it "parses Nothing to empty vector" $ do
V.length (parseNotifications Nothing) `shouldBe` 0
it "parses empty list to empty vector" $ do
V.length (parseNotifications (Just (PsList V.empty))) `shouldBe` 0
it "parses non-list to empty vector" $ do
V.length (parseNotifications (Just (PsString "bad"))) `shouldBe` 0
it "parses a valid notification" $ do
let notif = PsDictionary $ H.fromList
[ ("code", PsString "Neo.ClientNotification.Statement.CartesianProduct")
, ("title", PsString "Cartesian product warning")
, ("description", PsString "This query builds a cartesian product")
, ("severity", PsString "WARNING")
, ("category", PsString "PERFORMANCE")
, ("position", PsDictionary $ H.fromList
[ ("offset", PsInteger 0)
, ("line", PsInteger 1)
, ("column", PsInteger 1)
])
]
let result = parseNotifications (Just (PsList (V.singleton notif)))
V.length result `shouldBe` 1
let n = V.head result
nCode n `shouldBe` "Neo.ClientNotification.Statement.CartesianProduct"
nTitle n `shouldBe` "Cartesian product warning"
nDescription n `shouldBe` "This query builds a cartesian product"
nSeverity n `shouldBe` SevWarning
nCategory n `shouldBe` "PERFORMANCE"
nPosition n `shouldBe` Just (Position 0 1 1)
it "parses INFORMATION severity" $ do
let notif = PsDictionary $ H.fromList
[ ("code", PsString "Neo.ClientNotification.Statement.FeatureDeprecationWarning")
, ("title", PsString "Deprecated")
, ("description", PsString "Use newer syntax")
, ("severity", PsString "INFORMATION")
, ("category", PsString "DEPRECATION")
]
let result = parseNotifications (Just (PsList (V.singleton notif)))
V.length result `shouldBe` 1
nSeverity (V.head result) `shouldBe` SevInformation
nPosition (V.head result) `shouldBe` Nothing
it "handles missing optional fields" $ do
let notif = PsDictionary $ H.fromList
[ ("code", PsString "Neo.Test.Code")
, ("title", PsString "Test")
, ("description", PsString "Test desc")
]
let result = parseNotifications (Just (PsList (V.singleton notif)))
V.length result `shouldBe` 1
nCategory (V.head result) `shouldBe` ""
nPosition (V.head result) `shouldBe` Nothing
it "skips malformed entries in list" $ do
let good = PsDictionary $ H.fromList
[ ("code", PsString "Neo.Test.Code")
, ("title", PsString "Test")
, ("description", PsString "Test desc")
]
let bad = PsString "not a notification"
let result = parseNotifications (Just (PsList (V.fromList [good, bad, good])))
V.length result `shouldBe` 2
it "default config has notificationHandler = Nothing" $ do
case notificationHandler (def :: Config) of
Nothing -> pure ()
Just _ -> expectationFailure "Expected notificationHandler to be Nothing"
-- = Query stats parsing tests
statsTests :: TopSpec
statsTests = describe "Query stats parsing" $ do
it "parses Nothing to Nothing" $ do
parseStats Nothing `shouldBe` Nothing
it "parses non-dictionary to Nothing" $ do
parseStats (Just (PsString "bad")) `shouldBe` Nothing
it "parses full stats dictionary" $ do
let statsPs = PsDictionary $ H.fromList
[ ("nodes-created", PsInteger 2)
, ("nodes-deleted", PsInteger 1)
, ("relationships-created", PsInteger 3)
, ("relationships-deleted", PsInteger 0)
, ("properties-set", PsInteger 5)
, ("labels-added", PsInteger 2)
, ("labels-removed", PsInteger 0)
, ("indexes-added", PsInteger 0)
, ("indexes-removed", PsInteger 0)
, ("constraints-added", PsInteger 0)
, ("constraints-removed", PsInteger 0)
, ("contains-updates", PsBoolean True)
, ("contains-system-updates", PsBoolean False)
, ("system-updates", PsInteger 0)
]
case parseStats (Just statsPs) of
Nothing -> expectationFailure "Expected Just QueryStats"
Just qs -> do
nodesCreated qs `shouldBe` 2
nodesDeleted qs `shouldBe` 1
relationshipsCreated qs `shouldBe` 3
propertiesSet qs `shouldBe` 5
labelsAdded qs `shouldBe` 2
containsUpdates qs `shouldBe` True
containsSystemUpdates qs `shouldBe` False
it "missing keys default to 0/False" $ do
let statsPs = PsDictionary $ H.fromList
[ ("nodes-created", PsInteger 1)
, ("contains-updates", PsBoolean True)
]
case parseStats (Just statsPs) of
Nothing -> expectationFailure "Expected Just QueryStats"
Just qs -> do
nodesCreated qs `shouldBe` 1
nodesDeleted qs `shouldBe` 0
relationshipsCreated qs `shouldBe` 0
labelsAdded qs `shouldBe` 0
containsUpdates qs `shouldBe` True
containsSystemUpdates qs `shouldBe` False
systemUpdates qs `shouldBe` 0
it "parses empty dictionary" $ do
case parseStats (Just (PsDictionary H.empty)) of
Nothing -> expectationFailure "Expected Just QueryStats"
Just qs -> do
nodesCreated qs `shouldBe` 0
containsUpdates qs `shouldBe` False
-- = totalAffected
it "totalAffected Nothing returns 0" $
totalAffected Nothing `shouldBe` 0
it "totalAffected of zeros is 0" $
totalAffected (Just zeroStats) `shouldBe` 0
it "totalAffected counts CREATE side effects (1 node + 1 prop + 1 label = 3)" $
totalAffected (Just zeroStats { nodesCreated = 1, propertiesSet = 1, labelsAdded = 1 })
`shouldBe` 3
it "totalAffected counts a DETACH DELETE as 1" $
totalAffected (Just zeroStats { nodesDeleted = 1 }) `shouldBe` 1
it "totalAffected sums create + delete (no cancellation)" $
totalAffected (Just zeroStats { nodesCreated = 5, nodesDeleted = 5 }) `shouldBe` 10
it "totalAffected counts indexes and constraints" $
totalAffected (Just zeroStats
{ constraintsAdded = 1, indexesAdded = 2, indexesRemoved = 1 })
`shouldBe` 4
it "totalAffected ignores containsUpdates and systemUpdates" $
-- System updates are tracked separately and shouldn't bleed into the
-- schema-update tally.
totalAffected (Just zeroStats { containsUpdates = True, systemUpdates = 99 })
`shouldBe` 0
-- = formatStatsLine
it "formatStatsLine renders every counter for an all-zero stat" $
formatStatsLine zeroStats `shouldBe`
"Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \
\+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0"
it "formatStatsLine renders a CREATE-style breakdown" $
formatStatsLine zeroStats { nodesCreated = 1, propertiesSet = 1, labelsAdded = 1 }
`shouldBe` "Stats: +nodes=1 -nodes=0 +rels=0 -rels=0 props=1 \
\+labels=1 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0"
it "formatStatsLine renders every field with a non-zero value" $
let allOnes = QueryStats 1 1 1 1 1 1 1 1 1 1 1 False False 0
in formatStatsLine allOnes `shouldBe`
"Stats: +nodes=1 -nodes=1 +rels=1 -rels=1 props=1 \
\+labels=1 -labels=1 +idx=1 -idx=1 +constr=1 -constr=1"
-- | Helper used by the totalAffected/formatStatsLine cases above.
zeroStats :: QueryStats
zeroStats = QueryStats 0 0 0 0 0 0 0 0 0 0 0 False False 0
-- = Plan/Profile parsing tests
planTests :: TopSpec
planTests = describe "Plan parsing" $ do
it "parsePlan Nothing returns Nothing" $ do
parsePlan Nothing `shouldBe` Nothing
it "parsePlan non-dictionary returns Nothing" $ do
parsePlan (Just (PsString "bad")) `shouldBe` Nothing
it "parsePlan parses a simple plan node" $ do
let planPs = PsDictionary $ H.fromList
[ ("operatorType", PsString "ProduceResults@neo4j")
, ("args", PsDictionary $ H.fromList
[ ("planner-impl", PsString "IDP")
, ("runtime", PsString "SLOTTED")
])
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 10.0)
, ("children", PsList V.empty)
]
case parsePlan (Just planPs) of
Nothing -> expectationFailure "Expected Just PlanNode"
Just pn -> do
pnOperatorType pn `shouldBe` "ProduceResults@neo4j"
H.size (pnArguments pn) `shouldBe` 2
pnIdentifiers pn `shouldBe` V.fromList ["n"]
pnEstimatedRows pn `shouldBe` 10.0
V.length (pnChildren pn) `shouldBe` 0
it "parsePlan parses nested children" $ do
let child = PsDictionary $ H.fromList
[ ("operatorType", PsString "AllNodesScan@neo4j")
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 100.0)
, ("children", PsList V.empty)
]
let root = PsDictionary $ H.fromList
[ ("operatorType", PsString "ProduceResults@neo4j")
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 100.0)
, ("children", PsList $ V.fromList [child])
]
case parsePlan (Just root) of
Nothing -> expectationFailure "Expected Just PlanNode"
Just pn -> do
V.length (pnChildren pn) `shouldBe` 1
pnOperatorType (V.head (pnChildren pn)) `shouldBe` "AllNodesScan@neo4j"
it "parsePlan requires operatorType" $ do
let planPs = PsDictionary $ H.fromList
[ ("identifiers", PsList V.empty)
, ("estimatedRows", PsFloat 1.0)
]
parsePlan (Just planPs) `shouldBe` Nothing
it "parsePlan defaults missing optional fields" $ do
let planPs = PsDictionary $ H.fromList
[ ("operatorType", PsString "NodeByLabelScan")
]
case parsePlan (Just planPs) of
Nothing -> expectationFailure "Expected Just PlanNode"
Just pn -> do
pnArguments pn `shouldBe` H.empty
pnIdentifiers pn `shouldBe` V.empty
pnEstimatedRows pn `shouldBe` 0.0
V.length (pnChildren pn) `shouldBe` 0
it "parsePlan skips malformed children" $ do
let good = PsDictionary $ H.fromList
[ ("operatorType", PsString "Scan") ]
let bad = PsString "not a plan node"
let root = PsDictionary $ H.fromList
[ ("operatorType", PsString "Root")
, ("children", PsList $ V.fromList [good, bad, good])
]
case parsePlan (Just root) of
Nothing -> expectationFailure "Expected Just PlanNode"
Just pn -> V.length (pnChildren pn) `shouldBe` 2
-- = renderPlan
it "renderPlan emits operator + estimated rows for a leaf" $
renderPlan 0 (leafPlan "AllNodesScan" 100.0 [])
`shouldBe` "+ AllNodesScan (~100.0 rows)\n"
it "renderPlan emits a vars: line when identifiers are present" $
renderPlan 0 (leafPlan "NodeByLabelScan" 5.0 ["u"])
`shouldBe` "+ NodeByLabelScan (~5.0 rows)\n vars: u\n"
it "renderPlan indents two spaces per depth level" $
renderPlan 2 (leafPlan "Limit" 1.0 [])
`shouldBe` " + Limit (~1.0 rows)\n"
it "renderPlan walks a parent->child tree" $
let child = leafPlan "Scan" 10.0 ["n"]
parent = (leafPlan "Projection" 10.0 ["n", "x"])
{ pnChildren = V.singleton child }
in renderPlan 0 parent `shouldBe`
"+ Projection (~10.0 rows)\n\
\ vars: n, x\n\
\ + Scan (~10.0 rows)\n\
\ vars: n\n"
it "renderPlan keeps multiple children in source order" $
let c1 = leafPlan "L" 1.0 []
c2 = leafPlan "R" 2.0 []
parent = (leafPlan "Join" 3.0 [])
{ pnChildren = V.fromList [c1, c2] }
in renderPlan 0 parent `shouldBe`
"+ Join (~3.0 rows)\n\
\ + L (~1.0 rows)\n\
\ + R (~2.0 rows)\n"
-- | Helper: build a childless 'PlanNode' from operator + estimated rows
-- + identifiers. Used by the renderPlan tests.
leafPlan :: T.Text -> Double -> [T.Text] -> PlanNode
leafPlan op est idents = PlanNode
{ pnOperatorType = op
, pnArguments = H.empty
, pnIdentifiers = V.fromList idents
, pnEstimatedRows = est
, pnChildren = V.empty
}
profileTests :: TopSpec
profileTests = describe "Profile parsing" $ do
it "parseProfile Nothing returns Nothing" $ do
parseProfile Nothing `shouldBe` Nothing
it "parseProfile non-dictionary returns Nothing" $ do
parseProfile (Just (PsString "bad")) `shouldBe` Nothing
it "parseProfile parses a full profile node" $ do
let profPs = PsDictionary $ H.fromList
[ ("operatorType", PsString "ProduceResults@neo4j")
, ("args", PsDictionary $ H.fromList
[ ("runtime", PsString "SLOTTED") ])
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 10.0)
, ("dbHits", PsInteger 42)
, ("rows", PsInteger 10)
, ("pageCacheHits", PsInteger 5)
, ("pageCacheMisses", PsInteger 2)
, ("time", PsInteger 1234)
, ("children", PsList V.empty)
]
case parseProfile (Just profPs) of
Nothing -> expectationFailure "Expected Just ProfileNode"
Just pr -> do
prOperatorType pr `shouldBe` "ProduceResults@neo4j"
prDbHits pr `shouldBe` 42
prRows pr `shouldBe` 10
prPageCacheHits pr `shouldBe` 5
prPageCacheMisses pr `shouldBe` 2
prTime pr `shouldBe` 1234
prEstimatedRows pr `shouldBe` 10.0
V.length (prChildren pr) `shouldBe` 0
it "parseProfile parses nested children" $ do
let child = PsDictionary $ H.fromList
[ ("operatorType", PsString "AllNodesScan@neo4j")
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 100.0)
, ("dbHits", PsInteger 101)
, ("rows", PsInteger 100)
, ("children", PsList V.empty)
]
let root = PsDictionary $ H.fromList
[ ("operatorType", PsString "ProduceResults@neo4j")
, ("identifiers", PsList $ V.fromList [PsString "n"])
, ("estimatedRows", PsFloat 100.0)
, ("dbHits", PsInteger 0)
, ("rows", PsInteger 100)
, ("children", PsList $ V.fromList [child])
]
case parseProfile (Just root) of
Nothing -> expectationFailure "Expected Just ProfileNode"
Just pr -> do
V.length (prChildren pr) `shouldBe` 1
prDbHits (V.head (prChildren pr)) `shouldBe` 101
it "parseProfile requires operatorType" $ do
let profPs = PsDictionary $ H.fromList
[ ("dbHits", PsInteger 5)
, ("rows", PsInteger 1)
]
parseProfile (Just profPs) `shouldBe` Nothing
it "parseProfile defaults missing numeric fields to 0" $ do
let profPs = PsDictionary $ H.fromList
[ ("operatorType", PsString "NodeByLabelScan")
]
case parseProfile (Just profPs) of
Nothing -> expectationFailure "Expected Just ProfileNode"
Just pr -> do
prDbHits pr `shouldBe` 0
prRows pr `shouldBe` 0
prPageCacheHits pr `shouldBe` 0
prPageCacheMisses pr `shouldBe` 0
prTime pr `shouldBe` 0
prEstimatedRows pr `shouldBe` 0.0
it "parseProfile handles estimatedRows as integer" $ do
let profPs = PsDictionary $ H.fromList
[ ("operatorType", PsString "Scan")
, ("estimatedRows", PsInteger 42)
]
case parseProfile (Just profPs) of
Nothing -> expectationFailure "Expected Just ProfileNode"
Just pr -> prEstimatedRows pr `shouldBe` 42.0
-- = Server hint tests
serverHintTests :: TopSpec
serverHintTests = describe "Server hint config" $ do
it "defaultPoolConfig idleTimeout is 60" $ do
idleTimeout defaultPoolConfig `shouldBe` 60
-- = Decode tests
decodeTests :: TopSpec
decodeTests = describe "Record decoding" $ do
let columns = V.fromList ["name", "age", "active"]
let record = V.fromList [BoltString "Alice", BoltInteger 30, BoltBoolean True]
it "bool decodes BoltBoolean True" $ do
runDecode Database.Bolty.bool (BoltBoolean True) `shouldBe` Right True
it "bool rejects BoltString" $ do
case runDecode Database.Bolty.bool (BoltString "x") of
Left (TypeMismatch _ _) -> pure ()
other -> expectationFailure $ "Expected TypeMismatch, got: " <> show other
it "int decodes BoltInteger" $ do
case runDecode Database.Bolty.int (BoltInteger 42) of
Right n -> n `shouldBe` 42
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "int64 decodes BoltInteger to Int64" $ do
runDecode int64 (BoltInteger 42) `shouldBe` Right (42 :: Int64)
it "text decodes BoltString" $ do
runDecode Database.Bolty.text (BoltString "hello") `shouldBe` Right "hello"
it "float decodes BoltFloat" $ do
runDecode Database.Bolty.float (BoltFloat 3.14) `shouldBe` Right 3.14
it "nullable text decodes BoltNull to Nothing" $ do
runDecode (nullable Database.Bolty.text) BoltNull `shouldBe` Right Nothing
it "nullable text decodes BoltString to Just" $ do
runDecode (nullable Database.Bolty.text) (BoltString "x") `shouldBe` Right (Just "x")
it "list int decodes BoltList" $ do
let v = BoltList $ V.fromList [BoltInteger 1, BoltInteger 2, BoltInteger 3]
case runDecode (Database.Bolty.list Database.Bolty.int) v of
Right xs -> V.length xs `shouldBe` 3
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "column 0 text decodes first field" $ do
decodeRow (column 0 Database.Bolty.text) columns record `shouldBe` Right "Alice"
it "column 5 on 3-element record gives IndexOutOfBounds" $ do
decodeRow (column 5 Database.Bolty.text) columns record `shouldBe` Left (IndexOutOfBounds 5 3)
it "field 'name' text finds column by name" $ do
decodeRow (field "name" Database.Bolty.text) columns record `shouldBe` Right "Alice"
it "field 'missing' gives MissingField" $ do
decodeRow (field "missing" Database.Bolty.text) columns record `shouldBe` Left (MissingField "missing")
it "decodeRows maps decoder over multiple records" $ do
let recs = V.fromList [record, record]
case decodeRows (field "name" Database.Bolty.text) columns recs of
Right vs -> vs `shouldBe` V.fromList ["Alice", "Alice"]
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "RowDecoder Applicative composes" $ do
let decoder = (,) <$> field "name" Database.Bolty.text <*> field "age" int64
decodeRow decoder columns record `shouldBe` Right ("Alice", 30)
-- = sigLocalDateTime regression test
sigLocalDateTimeTest :: TopSpec
sigLocalDateTimeTest = describe "sigLocalDateTime tag" $ do
it "sigLocalDateTime is 0x64 (not 0x66)" $ do
sigLocalDateTime `shouldBe` 0x64
-- = psToBolt / boltToPs tests
psToBoltTests :: TopSpec
psToBoltTests = describe "psToBolt" $ do
it "converts Node PsStructure to BoltNode" $ do
let n = Node 1 (V.singleton "Person") (H.singleton "name" (PsString "Alice")) "4:abc:1"
case psToBolt (toPs n) of
BoltNode n' -> n' `shouldBe` n
other -> expectationFailure $ "Expected BoltNode, got: " <> show other
it "converts Relationship PsStructure to BoltRelationship" $ do
let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20"
case psToBolt (toPs r) of
BoltRelationship r' -> r' `shouldBe` r
other -> expectationFailure $ "Expected BoltRelationship, got: " <> show other
it "converts UnboundRelationship PsStructure to BoltUnboundRelationship" $ do
let ur = UnboundRelationship 5 "LIKES" H.empty "4:abc:5"
case psToBolt (toPs ur) of
BoltUnboundRelationship ur' -> ur' `shouldBe` ur
other -> expectationFailure $ "Expected BoltUnboundRelationship, got: " <> show other
it "converts Path PsStructure to BoltPath" $ do
let n1 = Node 1 (V.singleton "A") H.empty "4:abc:1"
let n2 = Node 2 (V.singleton "B") H.empty "4:abc:2"
let r1 = UnboundRelationship 10 "TO" H.empty "4:abc:10"
let p = Path (V.fromList [n1, n2]) (V.singleton r1) (V.fromList [1, 1])
case psToBolt (toPs p) of
BoltPath p' -> p' `shouldBe` p
other -> expectationFailure $ "Expected BoltPath, got: " <> show other
it "converts Date PsStructure to BoltDate" $ do
let d = Date 19738
case psToBolt (toPs d) of
BoltDate d' -> d' `shouldBe` d
other -> expectationFailure $ "Expected BoltDate, got: " <> show other
it "converts Time PsStructure to BoltTime" $ do
let t = Time 43200000000000 3600
case psToBolt (toPs t) of
BoltTime t' -> t' `shouldBe` t
other -> expectationFailure $ "Expected BoltTime, got: " <> show other
it "converts LocalTime PsStructure to BoltLocalTime" $ do
let lt = LocalTime 43200000000000
case psToBolt (toPs lt) of
BoltLocalTime lt' -> lt' `shouldBe` lt
other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other
it "converts DateTime PsStructure to BoltDateTime" $ do
let dt = DateTime 1705312800 0 3600
case psToBolt (toPs dt) of
BoltDateTime dt' -> dt' `shouldBe` dt
other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other
it "converts DateTimeZoneId PsStructure to BoltDateTimeZoneId" $ do
let dtz = DateTimeZoneId 1705312800 0 "Europe/Paris"
case psToBolt (toPs dtz) of
BoltDateTimeZoneId dtz' -> dtz' `shouldBe` dtz
other -> expectationFailure $ "Expected BoltDateTimeZoneId, got: " <> show other
it "converts LocalDateTime PsStructure to BoltLocalDateTime" $ do
let ldt = LocalDateTime 1705312800 500000000
case psToBolt (toPs ldt) of
BoltLocalDateTime ldt' -> ldt' `shouldBe` ldt
other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other
it "converts Duration PsStructure to BoltDuration" $ do
let dur = Duration 14 10 3600 0
case psToBolt (toPs dur) of
BoltDuration dur' -> dur' `shouldBe` dur
other -> expectationFailure $ "Expected BoltDuration, got: " <> show other
it "converts Point2D PsStructure to BoltPoint2D" $ do
let p = Point2D 7203 1.5 2.5
case psToBolt (toPs p) of
BoltPoint2D p' -> p' `shouldBe` p
other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other
it "converts Point3D PsStructure to BoltPoint3D" $ do
let p = Point3D 9157 1.0 2.0 3.0
case psToBolt (toPs p) of
BoltPoint3D p' -> p' `shouldBe` p
other -> expectationFailure $ "Expected BoltPoint3D, got: " <> show other
it "unknown structure tag returns BoltNull" $ do
psToBolt (PsStructure 0xFF V.empty) `shouldBe` BoltNull
boltToPsRoundTripTests :: TopSpec
boltToPsRoundTripTests = describe "boltToPs round-trips" $ do
it "round-trips BoltNode" $ do
let n = Node 1 (V.singleton "Person") (H.singleton "name" (PsString "Alice")) "4:abc:1"
let bolt = BoltNode n
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltRelationship" $ do
let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20"
let bolt = BoltRelationship r
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltDate" $ do
let bolt = BoltDate (Date 19738)
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltDateTime" $ do
let bolt = BoltDateTime (DateTime 1705312800 0 3600)
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltLocalDateTime" $ do
let bolt = BoltLocalDateTime (LocalDateTime 1705312800 500000000)
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltDuration" $ do
let bolt = BoltDuration (Duration 14 10 3600 0)
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltPoint2D" $ do
let bolt = BoltPoint2D (Point2D 7203 1.5 2.5)
psToBolt (boltToPs bolt) `shouldBe` bolt
it "round-trips BoltPoint3D" $ do
let bolt = BoltPoint3D (Point3D 9157 1.0 2.0 3.0)
psToBolt (boltToPs bolt) `shouldBe` bolt
-- = patch_bolt tests
patchBoltTests :: TopSpec
patchBoltTests = describe "patch_bolt in HELLO" $ do
it "HELLO with patchBolt=True includes patch_bolt key" $ do
let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting True
let ps = toPs (RHello hello)
case ps of
PsStructure 0x01 fields -> case V.head fields of
PsDictionary m -> case H.lookup "patch_bolt" m of
Just (PsList v) -> V.toList v `shouldBe` [PsString "utc"]
_ -> expectationFailure "expected patch_bolt list"
_ -> expectationFailure "expected dictionary"
_ -> expectationFailure "expected structure"
it "HELLO with patchBolt=False omits patch_bolt key" $ do
let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting False
let ps = toPs (RHello hello)
case ps of
PsStructure 0x01 fields -> case V.head fields of
PsDictionary m -> H.member "patch_bolt" m `shouldBe` False
_ -> expectationFailure "expected dictionary"
_ -> expectationFailure "expected structure"
-- = ResultSet tests
resultSetTests :: TopSpec
resultSetTests = describe "ResultSet" $ do
let cols = V.fromList ["name", "age"]
let mkRecord n a = V.fromList [BoltString n, BoltInteger a]
let rs = ResultSet cols $ V.fromList
[ mkRecord "Alice" 30
, mkRecord "Bob" 25
, mkRecord "Carol" 35
]
describe "decodeResultSet" $ do
it "decodes 2-column, 3-row result" $ do
let decoder = (,) <$> field "name" Database.Bolty.text <*> field "age" int64
decodeResultSet decoder rs `shouldBe`
Right (V.fromList [("Alice", 30), ("Bob", 25), ("Carol", 35)])
it "returns empty vector for empty result set" $ do
let emptyRs = ResultSet cols V.empty
decodeResultSet (field "name" Database.Bolty.text) emptyRs `shouldBe` Right V.empty
it "returns MissingField for absent column" $ do
decodeResultSet (field "email" Database.Bolty.text) rs `shouldBe` Left (MissingField "email")
it "returns TypeMismatch for wrong type" $ do
case decodeResultSet (field "name" int64) rs of
Left (TypeMismatch _ _) -> pure ()
other -> expectationFailure $ "Expected TypeMismatch, got: " <> show other
describe "groupByField" $ do
let groupCols = V.fromList ["parent", "child"]
let mkGroupRec p c = V.fromList [p, c]
it "groups 4 rows into 2 groups of 2" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec (BoltString "A") (BoltString "c2")
, mkGroupRec (BoltString "B") (BoltString "c3")
, mkGroupRec (BoltString "B") (BoltString "c4")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 2
fst (groups V.! 0) `shouldBe` "A"
V.length (RS.records (snd (groups V.! 0))) `shouldBe` 2
fst (groups V.! 1) `shouldBe` "B"
V.length (RS.records (snd (groups V.! 1))) `shouldBe` 2
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "skips NULL keys (does not break consecutive run)" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec BoltNull (BoltString "c2")
, mkGroupRec (BoltString "A") (BoltString "c3")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
-- NULL rows are simply dropped; "A" remains current group
V.length groups `shouldBe` 1
fst (groups V.! 0) `shouldBe` "A"
V.length (RS.records (snd (groups V.! 0))) `shouldBe` 2
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "NULL between different keys does not merge them" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec BoltNull (BoltString "c2")
, mkGroupRec (BoltString "B") (BoltString "c3")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 2
fst (groups V.! 0) `shouldBe` "A"
fst (groups V.! 1) `shouldBe` "B"
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "consecutive grouping: [A, A, B, A] produces 3 groups" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec (BoltString "A") (BoltString "c2")
, mkGroupRec (BoltString "B") (BoltString "c3")
, mkGroupRec (BoltString "A") (BoltString "c4")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 3
fst (groups V.! 0) `shouldBe` "A"
fst (groups V.! 1) `shouldBe` "B"
fst (groups V.! 2) `shouldBe` "A"
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "returns empty vector for empty result set" $ do
let emptyRs = ResultSet groupCols V.empty
groupByField (field "parent" (nullable Database.Bolty.text)) emptyRs `shouldBe` Right V.empty
it "returns empty vector when all keys are NULL" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec BoltNull (BoltString "c1")
, mkGroupRec BoltNull (BoltString "c2")
]
groupByField (field "parent" (nullable Database.Bolty.text)) groupRs `shouldBe` Right V.empty
it "single record produces one group" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1") ]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 1
fst (groups V.! 0) `shouldBe` "A"
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "propagates decode error" $ do
case groupByField (field "missing" (nullable Database.Bolty.text)) rs of
Left (MissingField "missing") -> pure ()
other -> expectationFailure $ "Expected MissingField, got: " <> show other
it "preserves field names in sub-ResultSets" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec (BoltString "A") (BoltString "c2")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 1
RS.fields (snd (groups V.! 0)) `shouldBe` groupCols
Left e -> expectationFailure $ "Expected success, got: " <> show e
it "full pipeline: group then decode within groups" $ do
let groupRs = ResultSet groupCols $ V.fromList
[ mkGroupRec (BoltString "A") (BoltString "c1")
, mkGroupRec (BoltString "A") (BoltString "c2")
, mkGroupRec (BoltString "B") (BoltString "c3")
]
case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of
Right groups -> do
V.length groups `shouldBe` 2
let childDecoder = field "child" Database.Bolty.text
case decodeResultSet childDecoder (snd (groups V.! 0)) of
Right children -> children `shouldBe` V.fromList ["c1", "c2"]
Left e -> expectationFailure $ "Decode failed: " <> show e
case decodeResultSet childDecoder (snd (groups V.! 1)) of
Right children -> children `shouldBe` V.fromList ["c3"]
Left e -> expectationFailure $ "Decode failed: " <> show e
Left e -> expectationFailure $ "Expected success, got: " <> show e
-- = Issue 01: NOOP chunk handling tests
noopChunkTests :: TopSpec
noopChunkTests = describe "Issue 01: NOOP chunk handling" $ do
-- Simulates receiveResponse's decode step for an assembled message payload.
-- Returns Nothing for NOOP (skip), Just for real messages.
let processPayload :: BS.ByteString -> Maybe (Either T.Text Response)
processPayload bs
| BS.null bs = Nothing
| otherwise = Just (unpack' bs)
it "single NOOP should be Nothing (skip)" $ do
case processPayload BS.empty of
Nothing -> pure ()
Just _ -> expectationFailure "NOOP should return Nothing, not Just"
it "batch with 3 NOOPs and 2 real messages should yield 2 results" $ do
let record = pack' $ RRecord (V.singleton (BoltInteger 1))
let success = pack' $ RSuccess H.empty
let payloads = [BS.empty, record, BS.empty, BS.empty, success]
let results = [x | Just x <- map processPayload payloads]
length results `shouldBe` 2 -- FAILS: 5 (NOOPs become Just too)
it "all-NOOP batch should yield no results" $ do
let results = [x | Just x <- map processPayload [BS.empty, BS.empty, BS.empty]]
length results `shouldBe` 0 -- FAILS: 3
it "NOOP between two RECORDs should not cause errors" $ do
let r1 = pack' $ RRecord (V.singleton (BoltInteger 1))
let r2 = pack' $ RRecord (V.singleton (BoltInteger 2))
let results = [x | Just x <- map processPayload [r1, BS.empty, r2]]
let errors = [e | Left e <- results]
length errors `shouldBe` 0 -- FAILS: 1 error from the NOOP
it "NOOP should be Nothing, valid message should be Just (Right ...)" $ do
let msg = pack' $ RRecord (V.singleton (BoltInteger 42))
case (processPayload BS.empty, processPayload msg) of
(Nothing, Just (Right _)) -> pure ()
_ -> expectationFailure "NOOP should be Nothing; valid message should be Just (Right ...)"
-- = Issue 02: Stale connection retry tests
staleConnectionRetryTests :: TopSpec
staleConnectionRetryTests = describe "Issue 02: Stale connection retry" $ do
-- Replica of isConnectionError from Pool.hs (fixed)
let isConnectionError :: SomeException -> Bool
isConnectionError e
| Just (_ :: IOException) <- fromException e = True
| Just (NonboltyError _) <- fromException e = True
| otherwise = False
it "EOF from connectionGetExact should be retryable" $ do
let err = toException (userError "Network.Connection.connectionGet: end of file" :: IOException)
isConnectionError err `shouldBe` True
it "connection reset by peer should be retryable" $ do
let err = toException (userError "recv: does not exist (Connection reset by peer)" :: IOException)
isConnectionError err `shouldBe` True
it "broken pipe should be retryable" $ do
let err = toException (userError "send: resource vanished (Broken pipe)" :: IOException)
isConnectionError err `shouldBe` True
it "connection refused should be retryable" $ do
let err = toException (userError "connect: does not exist (Connection refused)" :: IOException)
isConnectionError err `shouldBe` True
it "network unreachable should be retryable" $ do
let err = toException (userError "connect: does not exist (Network is unreachable)" :: IOException)
isConnectionError err `shouldBe` True
it "NonboltyError wrapping an IOException should be retryable" $ do
let inner = toException (userError "wrapped IO error" :: IOException)
let err = toException (NonboltyError inner)
isConnectionError err `shouldBe` True
it "AuthentificationFailed should NOT be retryable" $ do
let err = toException AuthentificationFailed
isConnectionError err `shouldBe` False
it "ResetFailed should NOT be retryable" $ do
let err = toException ResetFailed
isConnectionError err `shouldBe` False
it "CannotReadResponse should NOT be retryable" $ do
let err = toException (CannotReadResponse "bad data")
isConnectionError err `shouldBe` False
it "pure userError (not IOException) should NOT be retryable" $ do
-- userError wrapped in SomeException via fail — but fail in IO creates IOException,
-- so we test a non-IO exception type explicitly.
let err = toException (ResponseErrorRecords)
isConnectionError err `shouldBe` False
-- = Issue 03: IOVector accumulation tests (was V.snoc quadratic)
vectorSnocTests :: TopSpec
vectorSnocTests = describe "Issue 03: IOVector accumulation" $ do
it "IOVector doubling copies at most 2*N elements total (O(n))" $ do
-- V.snoc copies k elements per append → N*(N-1)/2 total (quadratic).
-- IOVector with doubling: at most 2*N total (linear).
let n = 1000 :: Int
let iovectorBudget = 2 * n -- 2000
let snocCopies = n * (n - 1) `div` 2 -- 499500
(iovectorBudget < snocCopies) `shouldBe` True
it "IOVector doubling needs only O(log n) grow operations" $ do
let n = 1000
let iovectorGrows = ceiling (logBase 2 (fromIntegral n / 64 :: Double)) :: Int -- ~4
(iovectorGrows < 10) `shouldBe` True
it "IOVector accumulates 10K elements correctly" $ liftIO $ do
let n = 10000
go buf i
| i >= n = pure buf
| otherwise = do
buf' <- if i >= MV.length buf
then MV.unsafeGrow buf (MV.length buf)
else pure buf
MV.write buf' i (i :: Int)
go buf' (i + 1)
buf <- MV.new 64
finalBuf <- go buf 0
frozen <- V.unsafeFreeze finalBuf
let result = V.take n frozen
V.length result `shouldBe` n
V.head result `shouldBe` 0
V.last result `shouldBe` (n - 1)
it "IOVector is >10x faster than V.snoc for 10K elements" $ liftIO $ do
let n = 10000
t0 <- getMonotonicTimeNSec
let !snocResult = foldl (\acc i -> V.snoc acc (i :: Int)) V.empty [1..n]
t1 <- getMonotonicTimeNSec
t2 <- getMonotonicTimeNSec
buf <- MV.new 64
let go b i
| i >= n = pure b
| otherwise = do
b' <- if i >= MV.length b then MV.unsafeGrow b (MV.length b) else pure b
MV.write b' i i
go b' (i + 1)
finalBuf <- go buf 0
frozen <- V.unsafeFreeze finalBuf
let !_mvResult = V.take n frozen
t3 <- getMonotonicTimeNSec
V.length snocResult `shouldBe` n
let mvNs = max 1 (t3 - t2)
let ratio = fromIntegral (t1 - t0) / fromIntegral mvNs :: Double
(ratio > 10) `shouldBe` True
it "IOVector with 0 elements freezes to empty vector" $ liftIO $ do
buf <- MV.new 64
frozen <- V.unsafeFreeze buf
let result = V.take 0 frozen
V.length result `shouldBe` 0
it "IOVector with 1 element freezes correctly" $ liftIO $ do
buf <- MV.new 64
MV.write buf 0 (42 :: Int)
frozen <- V.unsafeFreeze buf
let result = V.take 1 frozen
V.length result `shouldBe` 1
V.head result `shouldBe` 42
it "IOVector at exact initial capacity (64) needs no grow" $ liftIO $ do
let n = 64
buf <- MV.new 64
let go i
| i >= n = pure ()
| otherwise = MV.write buf i (i :: Int) >> go (i + 1)
go 0
MV.length buf `shouldBe` 64
frozen <- V.unsafeFreeze buf
let result = V.take n frozen
V.length result `shouldBe` 64
V.head result `shouldBe` 0
V.last result `shouldBe` 63
it "IOVector at capacity+1 (65) triggers exactly one grow" $ liftIO $ do
let n = 65
go buf i
| i >= n = pure buf
| otherwise = do
buf' <- if i >= MV.length buf
then MV.unsafeGrow buf (MV.length buf)
else pure buf
MV.write buf' i (i :: Int)
go buf' (i + 1)
buf <- MV.new 64
finalBuf <- go buf 0
MV.length finalBuf `shouldBe` 128 -- doubled from 64
frozen <- V.unsafeFreeze finalBuf
let result = V.take n frozen
V.length result `shouldBe` 65
V.head result `shouldBe` 0
V.last result `shouldBe` 64
it "V.freeze and V.take finalize in under 1ms" $ liftIO $ do
let n = 50000
buf <- MV.new (n * 2)
let go i
| i >= n = pure ()
| otherwise = MV.write buf i (i :: Int) >> go (i + 1)
go 0
t0 <- getMonotonicTimeNSec
frozen <- V.unsafeFreeze buf
let result = V.take n frozen
t1 <- getMonotonicTimeNSec
V.length result `shouldBe` n
let freezeNs = t1 - t0
(freezeNs < 1_000_000) `shouldBe` True
-- = Issue 04: Batched PULL / back-pressure tests
batchedPullTests :: TopSpec
batchedPullTests = describe "Issue 04: Batched PULL / back-pressure" $ do
it "defaultPull.n should be 1000 (matching official drivers)" $ do
n defaultPull `shouldBe` 1000
it "defaultPull serializes with n > 0 in PackStream" $ do
-- Test the PackStream representation layer (not just the Haskell field).
case toPs defaultPull of
PsDictionary m -> case H.lookup "n" m of
Just nPs -> case fromPs nPs :: R.Result Int64 of
R.Success nVal -> (nVal > 0) `shouldBe` True
R.Error e -> expectationFailure $ "cannot decode n: " <> T.unpack e
Nothing -> expectationFailure "Pull dictionary should have 'n' key"
_ -> expectationFailure "Pull should serialize as PsDictionary"
it "Pull with n=1000 round-trips correctly" $ do
let pull = Pull { n = 1000, qid = Nothing }
let decoded = unpack' (pack' pull) :: Either T.Text Pull
case decoded of
Right p -> n p `shouldBe` 1000
Left e -> expectationFailure $ "Pull should round-trip: " <> T.unpack e
it "defaultPull round-trips through binary with n > 0" $ do
-- Test the full encode/decode pipeline (not just the Haskell field or Ps form).
let decoded = unpack' (pack' defaultPull) :: Either T.Text Pull
case decoded of
Right p -> (n p > 0) `shouldBe` True
Left e -> expectationFailure $ "defaultPull should round-trip: " <> T.unpack e
it "PoolConfig has a fetchSize field defaulting to 1000" $ do
let pc = defaultPoolConfig
maxConnections pc `shouldBe` 10
idleTimeout pc `shouldBe` 60
fetchSize pc `shouldBe` 1000
it "custom fetchSize on PoolConfig is preserved" $ do
let pc = defaultPoolConfig { fetchSize = 500 }
fetchSize pc `shouldBe` 500
it "Pull with n=-1 (fetch all) round-trips correctly" $ do
let pull = Pull { n = -1, qid = Nothing }
let decoded = unpack' (pack' pull) :: Either T.Text Pull
case decoded of
Right p -> n p `shouldBe` (-1)
Left e -> expectationFailure $ "Pull n=-1 should round-trip: " <> T.unpack e
it "Pull with qid round-trips correctly" $ do
let pull = Pull { n = 1000, qid = Just 7 }
let decoded = unpack' (pack' pull) :: Either T.Text Pull
case decoded of
Right p -> do
n p `shouldBe` 1000
qid p `shouldBe` Just 7
Left e -> expectationFailure $ "Pull with qid should round-trip: " <> T.unpack e
-- = Issue 05: Max connection lifetime tests
maxConnectionLifetimeTests :: TopSpec
maxConnectionLifetimeTests = describe "Issue 05: Max connection lifetime" $ do
it "PoolConfig should have a maxLifetime field" $ do
let pc = defaultPoolConfig
maxConnections pc `shouldBe` 10
idleTimeout pc `shouldBe` 60
maxLifetime pc `shouldBe` 3600
it "default maxLifetime should be 3600 seconds (1 hour)" $ do
-- Java, Python, JS, .NET drivers all default to 1 hour.
maxLifetime defaultPoolConfig `shouldBe` 3600
it "maxLifetime is configurable" $ do
let pc = defaultPoolConfig { maxLifetime = 1800 }
maxLifetime pc `shouldBe` 1800
it "withConnection lifetime check uses monotonic createdAt" $ do
-- Verify the mechanism: connection age = now - createdAt.
-- A connection created "now" has age ~0 and should not be evicted.
let maxLifetimeNs = round (3600 * 1_000_000_000 :: Double) :: Word64
now <- liftIO getMonotonicTimeNSec
let age = now - now -- freshly created connection
(age > maxLifetimeNs) `shouldBe` False
it "expired connection age exceeds maxLifetimeNs" $ do
-- Simulate an old connection: createdAt = now - 2 hours.
let maxLifetimeNs = round (3600 * 1_000_000_000 :: Double) :: Word64
now <- liftIO getMonotonicTimeNSec
let twoHoursAgoNs = 2 * 3600 * 1_000_000_000
let createdAt = now - twoHoursAgoNs
let age = now - createdAt
(age > maxLifetimeNs) `shouldBe` True
it "connection at exactly maxLifetime is NOT evicted (strict >)" $ do
-- The check is `age > maxLifetimeNs`, not `>=`.
-- A connection whose age equals maxLifetime exactly should survive.
let maxLifetimeNs = round (3600 * 1_000_000_000 :: Double) :: Word64
let age = maxLifetimeNs
(age > maxLifetimeNs) `shouldBe` False
it "maxLifetimeNs conversion is accurate" $ do
-- 3600 seconds * 1e9 ns/s = 3_600_000_000_000 ns
let maxLifetimeNs = round (3600 * 1_000_000_000 :: Double) :: Word64
maxLifetimeNs `shouldBe` 3_600_000_000_000
-- 1800 seconds
let halfHourNs = round (1800 * 1_000_000_000 :: Double) :: Word64
halfHourNs `shouldBe` 1_800_000_000_000
it "server hint capping: min(configured, 2 * hint)" $ do
-- Replicate the effectiveMaxLifetime logic from createPool.
let effectiveMaxLifetime :: Double -> Maybe Int -> Double
effectiveMaxLifetime configured hint = case hint of
Just serverSecs | serverSecs > 0 ->
min configured (fromIntegral serverSecs * 2)
_ -> configured
-- No hint: use configured value.
effectiveMaxLifetime 3600 Nothing `shouldBe` 3600
-- Hint 1800s (30 min): 2*1800=3600, min(3600,3600)=3600.
effectiveMaxLifetime 3600 (Just 1800) `shouldBe` 3600
-- Hint 600s (10 min): 2*600=1200, min(3600,1200)=1200.
effectiveMaxLifetime 3600 (Just 600) `shouldBe` 1200
-- Hint 7200s (2 hr): 2*7200=14400, min(3600,14400)=3600.
effectiveMaxLifetime 3600 (Just 7200) `shouldBe` 3600
-- Short configured, large hint: configured wins.
effectiveMaxLifetime 300 (Just 7200) `shouldBe` 300
it "maxLifetime = 0 means evict all connections immediately" $ do
let maxLifetimeNs = round (0 * 1_000_000_000 :: Double) :: Word64
maxLifetimeNs `shouldBe` 0
-- Any positive age should exceed 0.
let age = 1 :: Word64
(age > maxLifetimeNs) `shouldBe` True
-- = Arbitrary instances for QuickCheck
-- | Generate an arbitrary Ps value (primitives only, no structures).
-- Uses fractional doubles for PsFloat to survive JSON integer/float ambiguity.
arbitraryPs :: Gen Ps
arbitraryPs = oneof
[ pure PsNull
, PsBoolean <$> arbitrary
, PsInteger . toPSInteger <$> (arbitrary :: Gen Int64)
, PsFloat <$> arbitraryFractionalDouble
, PsString . T.pack <$> arbitrary
, PsBytes . BS.pack <$> arbitrary
, PsList . V.fromList <$> listOfSmall arbitraryPs
, PsDictionary . H.fromList <$> listOfSmall ((,) <$> (T.pack <$> arbitrary) <*> arbitraryPs)
]
-- | Generate a finite (non-NaN, non-Infinite) Double.
arbitraryFiniteDouble :: Gen Double
arbitraryFiniteDouble = do
d <- arbitrary
pure $ if isNaN d || isInfinite d then 0.0 else d
-- | Like 'listOf' but keeps the size small to avoid deep nesting.
listOfSmall :: Gen a -> Gen [(a)]
listOfSmall g = do
n <- chooseInt (0, 3)
sequence (replicate n g)
arbitraryProperties :: Gen (H.HashMap T.Text Ps)
arbitraryProperties = H.fromList <$> listOfSmall ((,) <$> (T.pack <$> arbitrary) <*> arbitraryPs)
instance Arbitrary Node where
arbitrary = Node <$> arbitrary <*> (V.fromList <$> listOfSmall (T.pack <$> arbitrary))
<*> arbitraryProperties <*> (T.pack <$> arbitrary)
instance Arbitrary Relationship where
arbitrary = Relationship <$> arbitrary <*> arbitrary <*> arbitrary
<*> (T.pack <$> arbitrary) <*> arbitraryProperties <*> (T.pack <$> arbitrary)
<*> (T.pack <$> arbitrary) <*> (T.pack <$> arbitrary)
instance Arbitrary UnboundRelationship where
arbitrary = UnboundRelationship <$> arbitrary <*> (T.pack <$> arbitrary)
<*> arbitraryProperties <*> (T.pack <$> arbitrary)
instance Arbitrary Path where
arbitrary = Path <$> (V.fromList <$> listOfSmall arbitrary)
<*> (V.fromList <$> listOfSmall arbitrary)
<*> (V.fromList <$> listOfSmall arbitrary)
instance Arbitrary Date where
arbitrary = Date <$> arbitrary
instance Arbitrary Time where
arbitrary = Time <$> arbitrary <*> arbitrary
instance Arbitrary LocalTime where
arbitrary = LocalTime <$> arbitrary
instance Arbitrary DateTime where
arbitrary = DateTime <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary DateTimeZoneId where
arbitrary = DateTimeZoneId <$> arbitrary <*> arbitrary <*> (T.pack <$> arbitrary)
instance Arbitrary LocalDateTime where
arbitrary = LocalDateTime <$> arbitrary <*> arbitrary
instance Arbitrary Duration where
arbitrary = Duration <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary Point2D where
arbitrary = Point2D <$> arbitrary <*> arbitraryFiniteDouble <*> arbitraryFiniteDouble
instance Arbitrary Point3D where
arbitrary = Point3D <$> arbitrary <*> arbitraryFiniteDouble <*> arbitraryFiniteDouble <*> arbitraryFiniteDouble
-- | Arbitrary Bolt values. Excludes BoltFloat with whole-number values
-- (which round-trip as BoltInteger due to JSON number ambiguity).
instance Arbitrary Bolt where
arbitrary = oneof
[ pure BoltNull
, BoltBoolean <$> arbitrary
, BoltInteger . toPSInteger <$> (arbitrary :: Gen Int64)
, BoltFloat <$> arbitraryFractionalDouble
, BoltBytes . BS.pack <$> arbitrary
, BoltString . T.pack <$> arbitrary
, BoltList . V.fromList <$> listOfSmall arbitrary
, BoltDictionary . H.fromList <$> listOfSmall ((,) <$> arbitrarySafeKey <*> arbitrary)
, BoltNode <$> arbitrary
, BoltRelationship <$> arbitrary
, BoltUnboundRelationship <$> arbitrary
, BoltPath <$> arbitrary
, BoltDate <$> arbitrary
, BoltTime <$> arbitrary
, BoltLocalTime <$> arbitrary
, BoltDateTime <$> arbitrary
, BoltDateTimeZoneId <$> arbitrary
, BoltLocalDateTime <$> arbitrary
, BoltDuration <$> arbitrary
, BoltPoint2D <$> arbitrary
, BoltPoint3D <$> arbitrary
]
-- | Generate a Double that is finite and has a fractional part,
-- so it survives the JSON integer/float round-trip unambiguously.
arbitraryFractionalDouble :: Gen Double
arbitraryFractionalDouble = do
d <- arbitrary
let d' = if isNaN d || isInfinite d then 1.5 else d
-- Ensure it has a fractional part
pure $ if d' == fromIntegral (round d' :: Int64) then d' + 0.5 else d'
-- | Generate dictionary keys that don't collide with Bolt type tags.
arbitrarySafeKey :: Gen T.Text
arbitrarySafeKey = T.pack <$> elements
["a", "b", "name", "value", "foo", "bar", "x", "count", "data", "key"]
-- = ToJSON / FromJSON unit tests
aesonTests :: TopSpec
aesonTests = describe "ToJSON / FromJSON instances" $ do
describe "ToJSON Bolt primitives" $ do
it "encodes BoltNull as JSON null" $ do
toJSON BoltNull `shouldBe` Aeson.Null
it "encodes BoltBoolean" $ do
toJSON (BoltBoolean True) `shouldBe` Aeson.Bool True
it "encodes BoltInteger as JSON number" $ do
toJSON (BoltInteger 42) `shouldBe` Aeson.Number 42
it "encodes BoltFloat as JSON number" $ do
toJSON (BoltFloat 3.14) `shouldBe` Aeson.Number 3.14
it "encodes BoltFloat NaN as null" $ do
toJSON (BoltFloat (0/0)) `shouldBe` Aeson.Null
it "encodes BoltFloat Infinity as null" $ do
toJSON (BoltFloat (1/0)) `shouldBe` Aeson.Null
it "encodes BoltString as JSON string" $ do
toJSON (BoltString "hello") `shouldBe` Aeson.String "hello"
it "encodes BoltBytes as base64 object" $ do
let json = toJSON (BoltBytes "Hello")
json `shouldBe` Aeson.object ["bytes" Aeson..= ("SGVsbG8=" :: T.Text)]
it "encodes BoltList as JSON array" $ do
let json = toJSON (BoltList (V.fromList [BoltInteger 1, BoltString "a"]))
json `shouldBe` Aeson.toJSON [Aeson.Number 1, Aeson.String "a"]
it "encodes BoltDictionary as JSON object" $ do
let json = toJSON (BoltDictionary (H.fromList [("x", BoltInteger 1)]))
json `shouldBe` Aeson.object ["x" Aeson..= (1 :: Int)]
describe "ToJSON Bolt complex types" $ do
it "encodes BoltNode wrapped in 'node' key" $ do
let n = Node 1 (V.singleton "Person") H.empty "4:abc:1"
let json = toJSON (BoltNode n)
json `shouldBe` Aeson.object ["node" Aeson..= toJSON n]
it "encodes BoltRelationship wrapped in 'relationship' key" $ do
let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20"
let json = toJSON (BoltRelationship r)
json `shouldBe` Aeson.object ["relationship" Aeson..= toJSON r]
it "encodes BoltDate wrapped in 'date' key" $ do
let json = toJSON (BoltDate (Date 19738))
json `shouldBe` Aeson.object ["date" Aeson..= Aeson.object ["days" Aeson..= (19738 :: Int)]]
it "encodes BoltDuration wrapped in 'duration' key" $ do
let json = toJSON (BoltDuration (Duration 14 10 3600 0))
json `shouldBe` Aeson.object ["duration" Aeson..= toJSON (Duration 14 10 3600 0)]
it "encodes BoltPoint2D wrapped in 'point2d' key" $ do
let json = toJSON (BoltPoint2D (Point2D 4326 1.5 2.5))
json `shouldBe` Aeson.object ["point2d" Aeson..= toJSON (Point2D 4326 1.5 2.5)]
describe "FromJSON Bolt" $ do
it "decodes JSON null as BoltNull" $ do
fromJSON Aeson.Null `shouldBe` Aeson.Success BoltNull
it "decodes JSON bool as BoltBoolean" $ do
fromJSON (Aeson.Bool False) `shouldBe` Aeson.Success (BoltBoolean False)
it "decodes JSON integer number as BoltInteger" $ do
fromJSON (Aeson.Number 42) `shouldBe` Aeson.Success (BoltInteger 42)
it "decodes JSON fractional number as BoltFloat" $ do
fromJSON (Aeson.Number 3.14) `shouldBe` Aeson.Success (BoltFloat 3.14)
it "decodes JSON string as BoltString" $ do
fromJSON (Aeson.String "hello") `shouldBe` Aeson.Success (BoltString "hello")
it "decodes base64 bytes object as BoltBytes" $ do
let json = Aeson.object ["bytes" Aeson..= ("SGVsbG8=" :: T.Text)]
fromJSON json `shouldBe` Aeson.Success (BoltBytes "Hello")
it "decodes node wrapper as BoltNode" $ do
let n = Node 1 (V.singleton "Person") H.empty "4:abc:1"
fromJSON (toJSON (BoltNode n)) `shouldBe` Aeson.Success (BoltNode n)
it "decodes relationship wrapper as BoltRelationship" $ do
let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20"
fromJSON (toJSON (BoltRelationship r)) `shouldBe` Aeson.Success (BoltRelationship r)
it "decodes duration wrapper as BoltDuration" $ do
let d = Duration 14 10 3600 0
fromJSON (toJSON (BoltDuration d)) `shouldBe` Aeson.Success (BoltDuration d)
it "decodes point2d wrapper as BoltPoint2D" $ do
let p = Point2D 4326 1.5 2.5
fromJSON (toJSON (BoltPoint2D p)) `shouldBe` Aeson.Success (BoltPoint2D p)
it "decodes point3d wrapper as BoltPoint3D" $ do
let p = Point3D 4979 1.0 2.5 3.5
fromJSON (toJSON (BoltPoint3D p)) `shouldBe` Aeson.Success (BoltPoint3D p)
describe "FromJSON Bolt edge cases" $ do
it "single-key dict with type-tag key but wrong value falls back to BoltDictionary" $ do
-- {"node": 42} is not a valid Node, so it should be a dictionary
let json = Aeson.object ["node" Aeson..= (42 :: Int)]
fromJSON json `shouldBe` Aeson.Success (BoltDictionary (H.fromList [("node", BoltInteger 42)]))
it "single-key dict with 'bytes' but invalid base64 falls back to BoltDictionary" $ do
let json = Aeson.object ["bytes" Aeson..= (42 :: Int)]
fromJSON json `shouldBe` Aeson.Success (BoltDictionary (H.fromList [("bytes", BoltInteger 42)]))
it "single-key dict with unknown key decodes as BoltDictionary" $ do
let json = Aeson.object ["foo" Aeson..= (1 :: Int)]
fromJSON json `shouldBe` Aeson.Success (BoltDictionary (H.fromList [("foo", BoltInteger 1)]))
it "multi-key object decodes as BoltDictionary" $ do
let json = Aeson.object ["a" Aeson..= (1 :: Int), "b" Aeson..= (2 :: Int)]
let result = fromJSON json :: Aeson.Result Bolt
case result of
Aeson.Success (BoltDictionary m) -> do
H.size m `shouldBe` 2
_ -> expectationFailure "expected BoltDictionary"
it "empty object decodes as empty BoltDictionary" $ do
fromJSON (Aeson.object []) `shouldBe` Aeson.Success (BoltDictionary H.empty)
describe "Sub-type round-trips" $ do
it "Node round-trips through JSON" $ do
let n = Node 42 (V.fromList ["Person", "Employee"]) (H.fromList [("name", PsString "Alice")]) "4:abc:42"
fromJSON (toJSON n) `shouldBe` Aeson.Success n
it "Relationship round-trips through JSON" $ do
let r = Relationship 1 10 20 "KNOWS" (H.fromList [("since", PsInteger 2020)]) "4:abc:1" "4:abc:10" "4:abc:20"
fromJSON (toJSON r) `shouldBe` Aeson.Success r
it "Path round-trips through JSON" $ do
let n1 = Node 1 V.empty H.empty "4:abc:1"
let n2 = Node 2 V.empty H.empty "4:abc:2"
let rel = UnboundRelationship 10 "KNOWS" H.empty "4:abc:10"
let p = Path (V.fromList [n1, n2]) (V.singleton rel) (V.fromList [1, 1, 2])
fromJSON (toJSON p) `shouldBe` Aeson.Success p
it "Date round-trips through JSON" $ do
let d = Date 19738
fromJSON (toJSON d) `shouldBe` Aeson.Success d
it "Time round-trips through JSON" $ do
let t = Time 43200000000000 3600
fromJSON (toJSON t) `shouldBe` Aeson.Success t
it "DateTime round-trips through JSON" $ do
let dt = DateTime 1705312800 500000000 3600
fromJSON (toJSON dt) `shouldBe` Aeson.Success dt
it "DateTimeZoneId round-trips through JSON" $ do
let dt = DateTimeZoneId 1705312800 0 "Europe/Paris"
fromJSON (toJSON dt) `shouldBe` Aeson.Success dt
it "Duration round-trips through JSON" $ do
let d = Duration 14 10 3600 500000000
fromJSON (toJSON d) `shouldBe` Aeson.Success d
it "Point2D round-trips through JSON" $ do
let p = Point2D 4326 12.34 56.78
fromJSON (toJSON p) `shouldBe` Aeson.Success p
it "Point3D round-trips through JSON" $ do
let p = Point3D 4979 12.34 56.78 90.12
fromJSON (toJSON p) `shouldBe` Aeson.Success p
describe "aesonValue decoder" $ do
it "decodes all primitive Bolt types" $ do
let dec b = runDecode aesonValue b
dec BoltNull `shouldBe` Right Aeson.Null
dec (BoltBoolean True) `shouldBe` Right (Aeson.Bool True)
dec (BoltInteger 42) `shouldBe` Right (Aeson.Number 42)
dec (BoltFloat 3.14) `shouldBe` Right (Aeson.Number 3.14)
dec (BoltString "hi") `shouldBe` Right (Aeson.String "hi")
it "decodes graph types (previously rejected)" $ do
let n = Node 1 V.empty H.empty ""
let dec = runDecode aesonValue (BoltNode n)
case dec of
Right _ -> pure ()
Left e -> expectationFailure $ "aesonValue should handle Node: " <> show e
describe "QuickCheck: fromJSON . toJSON === id" $ do
it "Bolt round-trips through JSON (1000 cases)" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 1000 $ \(bolt :: Bolt) ->
fromJSON (toJSON bolt) == Aeson.Success bolt
assertQC r
it "Node round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(n :: Node) ->
fromJSON (toJSON n) == Aeson.Success n
assertQC r
it "Relationship round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(r :: Relationship) ->
fromJSON (toJSON r) == Aeson.Success r
assertQC r
it "Date round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(d :: Date) ->
fromJSON (toJSON d) == Aeson.Success d
assertQC r
it "Duration round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(d :: Duration) ->
fromJSON (toJSON d) == Aeson.Success d
assertQC r
it "Point2D round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(p :: Point2D) ->
fromJSON (toJSON p) == Aeson.Success p
assertQC r
it "Point3D round-trips through JSON" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 500 $ \(p :: Point3D) ->
fromJSON (toJSON p) == Aeson.Success p
assertQC r
describe "parsePs / psToAeson (public Aeson interop)" $ do
it "parsePs handles every JSON scalar type" $ do
let parse v = Aeson.parseEither parsePs v
parse Aeson.Null `shouldBe` Right PsNull
parse (Aeson.Bool True) `shouldBe` Right (PsBoolean True)
parse (Aeson.String "hi") `shouldBe` Right (PsString "hi")
parse (Aeson.Number 42) `shouldBe` Right (PsInteger (toPSInteger (42 :: Int)))
parse (Aeson.Number 1.5) `shouldBe` Right (PsFloat 1.5)
it "parsePs handles arrays and nested objects" $ do
let parse v = Aeson.parseEither parsePs v
parse (Aeson.Array (V.fromList [Aeson.Number 1, Aeson.String "two"])) `shouldBe`
Right (PsList (V.fromList [PsInteger (toPSInteger (1 :: Int)), PsString "two"]))
it "parsePs decodes the {bytes: <base64>} shape into PsBytes" $ do
let v = Aeson.Object (KM.fromList [("bytes", Aeson.String "aGVsbG8=")]) -- "hello"
case Aeson.parseEither parsePs v of
Right (PsBytes bs) -> bs `shouldBe` "hello"
Right other -> expectationFailure $ "expected PsBytes, got " <> show other
Left err -> expectationFailure err
it "parsePs falls back to dictionary when {bytes: ...} value isn't valid base64" $ do
let v = Aeson.Object (KM.fromList [("bytes", Aeson.String "not base 64!!!")])
case Aeson.parseEither parsePs v of
Right (PsDictionary _) -> pure ()
other -> expectationFailure $ "expected PsDictionary fallback, got " <> show other
it "psToAeson is the inverse of parsePs for plain values" $ do
let original = PsList (V.fromList
[ PsNull
, PsBoolean True
, PsString "x"
, PsInteger (toPSInteger (7 :: Int))
, PsFloat 1.5
])
let json = psToAeson original
Aeson.parseEither parsePs json `shouldBe` Right original
it "parsePs handles negative integers" $ do
Aeson.parseEither parsePs (Aeson.Number (-7))
`shouldBe` Right (PsInteger (toPSInteger (-7 :: Int)))
it "parsePs falls back to dictionary when {bytes: ...} has extra keys" $ do
-- The bytes shape is a single-key match: {"bytes": "<base64>"}.
-- Adding any other key turns the value back into a regular dictionary.
let v = Aeson.Object (KM.fromList
[ ("bytes", Aeson.String "aGVsbG8=")
, ("extra", Aeson.String "noise")
])
case Aeson.parseEither parsePs v of
Right (PsDictionary d) -> H.size d `shouldBe` 2
other -> expectationFailure $ "expected PsDictionary, got " <> show other
it "parsePs falls back to PsFloat for integers above PSInteger range" $ do
-- PSInteger covers [-2^63, 2^64-1]. 2^64 = 18446744073709551616.
-- Larger than that exceeds the range and must round-trip through PsFloat
-- rather than silently truncate.
let huge = "18446744073709551617" -- 2^64 + 1
case Aeson.eitherDecodeStrict (TE.encodeUtf8 (T.pack huge)) of
Left err -> expectationFailure $ "JSON parse failed: " <> err
Right v -> case Aeson.parseEither parsePs v of
Right (PsFloat _) -> pure ()
Right other -> expectationFailure $
"expected PsFloat fallback for huge integer, got " <> show other
Left err -> expectationFailure err
describe "Show QueryMeta (smoke)" $ do
it "Show QueryMeta produces a non-empty string" $
-- The data constructor has 13 fields; this just pins that the
-- standalone Show derive landed and doesn't fail at runtime.
let m = QueryMeta
{ Resp.bookmark = Nothing
, Resp.t_last = 0
, Resp.type_ = "r"
, Resp.stats = Nothing
, Resp.parsedStats = Nothing
, Resp.plan = Nothing
, Resp.profile = Nothing
, Resp.notifications = Nothing
, Resp.parsedNotifications = V.empty
, Resp.parsedPlan = Nothing
, Resp.parsedProfile = Nothing
, Resp.db = "neo4j"
}
in (length (show m) > 0) `shouldBe` True
adminHelperTests :: TopSpec
adminHelperTests = describe "Database.Bolty.Admin outcome helpers" $ do
it "describeReadOutcome prints ReadOK without inspecting fields" $
-- Build a fully-zeroed ReadOK; the helper should not need to print it.
let stub = ReadOK emptyResultSet emptyMeta
in describeReadOutcome stub `shouldBe` "ReadOK"
it "describeReadOutcome includes the stats line for ReadAbortedByWrite" $
describeReadOutcome (ReadAbortedByWrite zeroStats) `shouldBe`
"ReadAbortedByWrite (Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \
\+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0)"
it "describeWriteOutcome prints WriteCommitted without inspecting fields" $
describeWriteOutcome (WriteCommitted emptyResultSet emptyMeta) `shouldBe` "WriteCommitted"
it "describeWriteOutcome shows expected/actual when stats are absent" $
describeWriteOutcome (WriteAbortedMismatch 5 3 Nothing) `shouldBe`
"WriteAbortedMismatch expected=5 actual=3"
it "describeWriteOutcome appends the stats line when present" $
describeWriteOutcome (WriteAbortedMismatch 5 3 (Just zeroStats)) `shouldBe`
"WriteAbortedMismatch expected=5 actual=3 (Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \
\+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0)"
-- Helpers for the Tx-helper tests above.
emptyResultSet :: RS.ResultSet
emptyResultSet = RS.ResultSet V.empty V.empty
emptyMeta :: QueryMeta
emptyMeta = QueryMeta
{ Resp.bookmark = Nothing
, Resp.t_last = 0
, Resp.type_ = "r"
, Resp.stats = Nothing
, Resp.parsedStats = Nothing
, Resp.plan = Nothing
, Resp.profile = Nothing
, Resp.notifications = Nothing
, Resp.parsedNotifications = V.empty
, Resp.parsedPlan = Nothing
, Resp.parsedProfile = Nothing
, Resp.db = "neo4j"
}
-- | Assert a QuickCheck result, failing the sandwich test on property failure.
assertQC r
| isSuccess r = pure ()
| otherwise = expectationFailure $ "QuickCheck: " <> show r
-- = Main
main :: IO ()
main = runSandwichWithCommandLineArgs defaultOptions $ do
configTests
versionTests
version5xTests
extractorTests
recordTests
messageTests
logonLogoffTests
structureRoundTripTests
accessModeTests
poolConfigTests
retryTests
routeTests
routingTableTests
parseAddressTests
routingPoolConfigTests
routingErrorTests
bookmarkTests
sessionConfigTests
validationStrategyTests
versionHelperTests
loggingConfigTests
notificationTests
statsTests
planTests
profileTests
serverHintTests
decodeTests
sigLocalDateTimeTest
psToBoltTests
boltToPsRoundTripTests
patchBoltTests
resultSetTests
noopChunkTests
staleConnectionRetryTests
vectorSnocTests
batchedPullTests
maxConnectionLifetimeTests
aesonTests
adminHelperTests