bolty-0.1.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)
import qualified Data.HashMap.Lazy as H
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Validation as Val
import 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)
import Database.Bolty.Stats (QueryStats(..), parseStats)
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(..)
, Logon(..), TelemetryApi(..))
import Database.Bolty.Message.Response (Response(..), RoutingTable(..), parseRoutingTable, extractBookmark)
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)
-- = 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
packstreamRoundTripTests :: TopSpec
packstreamRoundTripTests = describe "PackStream round-trips" $ do
it "round-trips PsNull" $ do
unpack (pack PsNull) `shouldBe` Right PsNull
it "round-trips PsBoolean True" $ do
unpack (pack (PsBoolean True)) `shouldBe` Right (PsBoolean True)
it "round-trips PsBoolean False" $ do
unpack (pack (PsBoolean False)) `shouldBe` Right (PsBoolean False)
it "round-trips PsInteger small" $ do
unpack (pack (PsInteger 42)) `shouldBe` Right (PsInteger 42)
it "round-trips PsInteger negative" $ do
unpack (pack (PsInteger (-100))) `shouldBe` Right (PsInteger (-100))
it "round-trips PsInteger zero" $ do
unpack (pack (PsInteger 0)) `shouldBe` Right (PsInteger 0)
it "round-trips PsFloat" $ do
unpack (pack (PsFloat 3.14)) `shouldBe` Right (PsFloat 3.14)
it "round-trips PsString" $ do
unpack (pack (PsString "hello world")) `shouldBe` Right (PsString "hello world")
it "round-trips PsString empty" $ do
unpack (pack (PsString "")) `shouldBe` Right (PsString "")
it "round-trips PsString unicode" $ do
unpack (pack (PsString "\x1F600 emoji")) `shouldBe` Right (PsString "\x1F600 emoji")
it "round-trips PsList empty" $ do
unpack (pack (PsList V.empty)) `shouldBe` Right (PsList V.empty)
it "round-trips PsList with values" $ do
let v = PsList $ V.fromList [PsInteger 1, PsString "two", PsBoolean True]
unpack (pack v) `shouldBe` Right v
it "round-trips PsDictionary empty" $ do
unpack (pack (PsDictionary H.empty)) `shouldBe` Right (PsDictionary H.empty)
it "round-trips PsDictionary with entries" $ do
let d = PsDictionary $ H.fromList [("key", PsString "value"), ("num", PsInteger 42)]
unpack (pack d) `shouldBe` Right d
it "round-trips nested structures" $ do
let nested = PsList $ V.fromList
[ PsDictionary $ H.fromList [("a", PsInteger 1)]
, PsList $ V.fromList [PsNull, PsBoolean False]
]
unpack (pack nested) `shouldBe` Right nested
-- Integer range tests
it "round-trips PsInteger tiny positive (127)" $ do
unpack (pack (PsInteger 127)) `shouldBe` Right (PsInteger 127)
it "round-trips PsInteger tiny negative (-16)" $ do
unpack (pack (PsInteger (-16))) `shouldBe` Right (PsInteger (-16))
it "round-trips PsInteger INT_8 range (128)" $ do
unpack (pack (PsInteger 128)) `shouldBe` Right (PsInteger 128)
it "round-trips PsInteger INT_8 range (-128)" $ do
unpack (pack (PsInteger (-128))) `shouldBe` Right (PsInteger (-128))
it "round-trips PsInteger INT_16 range (1000)" $ do
unpack (pack (PsInteger 1000)) `shouldBe` Right (PsInteger 1000)
it "round-trips PsInteger INT_32 range (100000)" $ do
unpack (pack (PsInteger 100000)) `shouldBe` Right (PsInteger 100000)
it "round-trips PsInteger INT_64 range (maxBound)" $ do
let big = PsInteger 9223372036854775807
unpack (pack big) `shouldBe` Right big
it "round-trips PsInteger INT_64 range (minBound)" $ do
let small = PsInteger (-9223372036854775808)
unpack (pack small) `shouldBe` Right small
-- Bytes tests
it "round-trips PsBytes empty" $ do
unpack (pack (PsBytes "")) `shouldBe` Right (PsBytes "")
it "round-trips PsBytes with data" $ do
let bs = PsBytes "\x00\x01\x02\xFF"
unpack (pack bs) `shouldBe` Right bs
-- Structure tests
it "round-trips PsStructure empty fields" $ do
let s = PsStructure 0x01 V.empty
unpack (pack s) `shouldBe` Right s
it "round-trips PsStructure with one field (like HELLO)" $ do
let s = PsStructure 0x01 $ V.singleton $ PsDictionary $ H.fromList
[("user_agent", PsString "bolty/2.0"), ("scheme", PsString "none")]
unpack (pack s) `shouldBe` Right s
it "round-trips PsStructure with multiple fields" $ do
let s = PsStructure 0x4E $ V.fromList -- Node structure tag
[ PsInteger 1 -- id
, PsList (V.fromList [PsString "Person"]) -- labels
, PsDictionary (H.fromList [("name", PsString "Alice")]) -- properties
, PsString "4:abc:1" -- element_id
]
unpack (pack s) `shouldBe` Right s
-- Larger collection tests
it "round-trips PsList with 16 elements (LIST_8)" $ do
let v = PsList $ V.fromList [PsInteger (fromIntegral i) | i <- [0..15 :: Int]]
unpack (pack v) `shouldBe` Right v
it "round-trips Text via PackStream class" $ do
let txt = "hello" :: T.Text
let result = either R.Error R.Success $ unpack (pack txt)
(fromPs =<< result) `shouldBe` R.Success txt
it "round-trips Bool via PackStream class" $ do
let result = either R.Error R.Success $ unpack (pack True)
(fromPs =<< result) `shouldBe` R.Success True
-- = 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
-- = 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
-- = 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
-- = 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
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
-- = Main
main :: IO ()
main = runSandwichWithCommandLineArgs defaultOptions $ do
configTests
versionTests
version5xTests
extractorTests
recordTests
packstreamRoundTripTests
messageTests
logonLogoffTests
structureRoundTripTests
poolConfigTests
retryTests
routeTests
routingTableTests
parseAddressTests
routingPoolConfigTests
routingErrorTests
bookmarkTests
sessionConfigTests
validationStrategyTests
versionHelperTests
loggingConfigTests
notificationTests
statsTests
planTests
profileTests
serverHintTests
decodeTests
sigLocalDateTimeTest
psToBoltTests
boltToPsRoundTripTests
patchBoltTests
resultSetTests