bolty 0.1.0.2 → 0.1.1.0

raw patch · 10 files changed

+1260/−222 lines, 10 filesdep +QuickCheckdep +base64-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, base64-bytestring

API changes (from Hackage documentation)

Files

• bolty.cabal +6/−3
• src/Database/Bolty/Connection.hs +63/−14
• src/Database/Bolty/Connection/Config.hs +1/−1
• src/Database/Bolty/Connection/Pipe.hs +24/−11
• src/Database/Bolty/Connection/Type.hs +8/−0
• src/Database/Bolty/Decode.hs +6/−19
• src/Database/Bolty/Message/Request.hs +4/−2
• src/Database/Bolty/Pool.hs +87/−45
• src/Database/Bolty/Value/Type.hs +328/−2
• test/Main.hs +733/−125

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           bolty-version:        0.1.0.2+version:        0.1.1.0 synopsis:       Haskell driver for Neo4j (BOLT protocol 4.4-5.4) description:    Native Haskell driver for Neo4j graph database using the BOLT protocol.                 Supports BOLT versions 4.4 through 5.4 with connection pooling,@@ -89,6 +89,7 @@   build-depends:       aeson >=2.1 && <2.3     , base >=4.18 && <5+    , base64-bytestring >=1.0 && <1.3     , bytestring >=0.11 && <0.13     , crypton-connection >=0.3 && <0.5     , data-default >=0.7 && <0.9@@ -194,7 +195,9 @@       ViewPatterns   ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-safe-haskell-mode -Wno-name-shadowing -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unused-imports -Wno-unused-packages   build-depends:-      base >=4.18 && <5+      QuickCheck+    , aeson >=2.1 && <2.3+    , base >=4.18 && <5     , bolty     , bytestring >=0.11 && <0.13     , crypton-connection >=0.3 && <0.5

@@ -19,6 +19,8 @@ import           Database.Bolty.Record  import           Control.Exception             (SomeException, throwIO, try)+import           Data.IORef                    (IORef, newIORef, readIORef, writeIORef)+import           Data.Kind                     (Type) import           Data.Text                     (Text) import           Data.Word                     (Word64) import           Debug.Trace                   (traceEventIO)@@ -30,10 +32,45 @@ import qualified Data.HashMap.Lazy as H import qualified Data.Text as T import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV import           Data.PackStream.Ps (Ps, fromPs) import           Data.PackStream.Result (Result(..))  +-- ---------------------------------------------------------------------------+-- Growable vector (O(n) amortized appends via mutable IOVector + doubling)+-- ---------------------------------------------------------------------------++type GrowVec :: Type -> Type+type role GrowVec representational+data GrowVec a = GrowVec+  { gvBuf  :: !(IORef (MV.IOVector a))+  , gvLen  :: !(IORef Int)+  }++newGrowVec :: IO (GrowVec a)+newGrowVec = do+  buf <- MV.new 64+  GrowVec <$> newIORef buf <*> newIORef 0++pushGrowVec :: GrowVec a -> a -> IO ()+pushGrowVec GrowVec{gvBuf, gvLen} x = do+  i <- readIORef gvLen+  buf <- readIORef gvBuf+  buf' <- if i >= MV.length buf+          then MV.unsafeGrow buf (MV.length buf)+          else pure buf+  MV.write buf' i x+  writeIORef gvBuf buf'+  writeIORef gvLen (i + 1)++freezeGrowVec :: GrowVec a -> IO (V.Vector a)+freezeGrowVec GrowVec{gvBuf, gvLen} = do+  n <- readIORef gvLen+  buf <- readIORef gvBuf+  V.unsafeFreeze (MV.take n buf)++ -- | Run a query, return only records. queryIO :: HasCallStack => Connection -> Text -> IO (V.Vector Record) queryIO conn cypher = records <$> queryPIO' conn cypher H.empty@@ -87,10 +124,12 @@ requestResponsePullIO :: HasCallStack => Connection -> IO SuccessPull requestResponsePullIO conn = do   P.requireStateIO conn [Streaming, TXstreaming] "PULL"-  P.flushIO conn $ RPull defaultPull-  go V.empty+  let pull = Pull { n = conn.fetchSize, qid = Nothing }+  P.flushIO conn $ RPull pull+  gv <- newGrowVec+  go gv   where-    go records = do+    go gv = do       response <- P.fetchIO conn       case response of         RSuccess meta -> do@@ -100,14 +139,16 @@                              _            -> False                            Nothing -> False           if has_more then do-            P.flushIO conn $ RPull defaultPull-            go records+            let pull = Pull { n = conn.fetchSize, qid = Nothing }+            P.flushIO conn $ RPull pull+            go gv           else do+            recs <- freezeGrowVec gv             st <- P.getState conn             P.setState conn $ case st of               TXstreaming -> TXready               _           -> Ready-            case makeSuccessPull records meta of+            case makeSuccessPull recs meta of               Left err -> throwIO $ WrongMessageFormat err               Right v  -> pure v         RIgnored -> do@@ -117,7 +158,9 @@           P.setState conn Failed           P.reset conn           throwIO $ ResponseErrorFailure code message-        RRecord record -> go $ V.snoc records record+        RRecord record -> do+          pushGrowVec gv record+          go gv  -- | Run a parameterized query, returning column names alongside records. queryPWithFieldsIO :: HasCallStack => Connection -> T.Text -> H.HashMap T.Text Ps -> IO (V.Vector T.Text, V.Vector Record)@@ -161,8 +204,9 @@         _       -> RRunAutoCommitTransaction $ mkRunAutoCommit cypher params    -- Pipeline: send RUN + PULL before receiving either response+  let pull = Pull { n = conn.fetchSize, qid = Nothing }   P.flushIO conn runRequest-  P.flushIO conn (RPull defaultPull)+  P.flushIO conn (RPull pull)    -- Receive RUN response   runResult <- try @SomeException $ do@@ -191,15 +235,16 @@       throwIO err     Right runResp -> do       -- Receive PULL responses-      pullResp <- pullRecords conn V.empty+      gv <- newGrowVec+      pullResp <- pullRecords conn gv       t1 <- getMonotonicTimeNSec       traceEventIO "STOP boltWireIO"       pure (runResp, pullResp, t1 - t0)  -- | Pull all records from an in-progress pipelined query. -- The initial PULL has already been sent; this receives responses and handles has_more pagination.-pullRecords :: HasCallStack => Connection -> V.Vector Record -> IO SuccessPull-pullRecords conn recs = do+pullRecords :: HasCallStack => Connection -> GrowVec Record -> IO SuccessPull+pullRecords conn gv = do   response <- P.fetchIO conn   case response of     RSuccess meta -> do@@ -209,9 +254,11 @@                          _            -> False                        Nothing -> False       if has_more then do-        P.flushIO conn $ RPull defaultPull-        pullRecords conn recs+        let pull = Pull { n = conn.fetchSize, qid = Nothing }+        P.flushIO conn $ RPull pull+        pullRecords conn gv       else do+        recs <- freezeGrowVec gv         st <- P.getState conn         P.setState conn $ case st of           TXstreaming -> TXready@@ -226,7 +273,9 @@       P.setState conn Failed       P.reset conn       throwIO $ ResponseErrorFailure code message-    RRecord record -> pullRecords conn $ V.snoc recs record+    RRecord record -> do+      pushGrowVec gv record+      pullRecords conn gv  -- | Fire the query logger callback if configured. fireLogger :: Connection -> T.Text -> H.HashMap T.Text Ps -> SuccessRun -> SuccessPull -> Word64 -> IO ()

@@ -20,7 +20,7 @@   s <- validateScheme scheme   validated_versions <- boltVersionsToSpec versions   ua <- validateUserAgent user_agent-  pure $ ValidatedConfig {host = h, port, scheme = s, use_tls, versions = validated_versions, timeout, user_agent = ua, routing, queryLogger, notificationHandler}+  pure $ ValidatedConfig {host = h, port, scheme = s, use_tls, versions = validated_versions, timeout, user_agent = ua, routing, queryLogger, notificationHandler, fetchSize = 1000}  validateScheme :: Scheme -> V.Validation [T.Text] Scheme validateScheme s@(Basic principal credentials) = do

@@ -23,6 +23,7 @@   , connectionServerIdleTimeout   , touchConnection   , connectionLastActivity+  , connectionCreatedAt   -- * Transaction primitives (plain IO)   , beginTx   , commitTx@@ -91,7 +92,9 @@                     , server_agent = agent, connection_id = conn_id, lastActivity = actRef                     , telemetry_enabled = telem, serverIdleTimeout = idleTimeout                     , queryLogger = queryLogger-                    , notificationHandler = notificationHandler }+                    , notificationHandler = notificationHandler+                    , fetchSize = fetchSize+                    , createdAt = now }   -- | Send GOODBYE (if supported) and close the connection.@@ -243,17 +246,23 @@   -- | Receive and decode a chunked BOLT response from the wire.+-- Silently skips NOOP chunks (zero-length messages used as keep-alive probes+-- since Bolt 4.1). receiveResponse :: MonadPipe m => NC.Connection -> Int -> m Response-receiveResponse rawConn tout = do-  bs :: BS.ByteString <- whileJustM $ do-          size :: Word16 <- C.receiveBinary rawConn tout 2-          if size == 0 then-            pure Nothing-          else-            Just <$> C.receiveBytestring rawConn tout (fromIntegral size)-  case PS.unpack' bs of-    Left e         -> throwError $ CannotReadResponse e-    Right response -> pure response+receiveResponse rawConn tout = readMessage+  where+    readMessage = do+      bs :: BS.ByteString <- whileJustM $ do+              size :: Word16 <- C.receiveBinary rawConn tout 2+              if size == 0 then+                pure Nothing+              else+                Just <$> C.receiveBytestring rawConn tout (fromIntegral size)+      if BS.null bs+        then readMessage  -- NOOP: discard and read next message+        else case PS.unpack' bs of+          Left e         -> throwError $ CannotReadResponse e+          Right response -> pure response   -- | Serialize and send a BOLT request as chunked data on the wire.@@ -351,6 +360,10 @@ -- | Get the monotonic timestamp (in nanoseconds) of the last connection activity. connectionLastActivity :: MonadIO m => Connection -> m Word64 connectionLastActivity Connection{lastActivity} = liftIO $ readIORef lastActivity++-- | Get the monotonic timestamp (in nanoseconds) when this connection was created.+connectionCreatedAt :: Connection -> Word64+connectionCreatedAt Connection{createdAt} = createdAt   -- ---------------------------------------------------------------------------

@@ -19,6 +19,7 @@ import           Data.Kind                       (Type) import           Control.Exception               (Exception, SomeException) import           Data.Default                    (Default(..))+import           Data.Int                        (Int64) import           Data.IORef                      (IORef) import           Data.Text                       (Text) import           Data.Word                       (Word16, Word32, Word64)@@ -93,6 +94,8 @@   , user_agent           :: UserAgent   , queryLogger          :: Maybe (QueryLog -> QueryMeta -> IO ())   , notificationHandler  :: Maybe (Notification -> IO ())+  , fetchSize            :: Int64+  -- ^ Maximum number of records per PULL batch. Default: 1000.   }  @@ -137,6 +140,11 @@   -- ^ Optional callback fired after each query completes.   , notificationHandler  :: Maybe (Notification -> IO ())   -- ^ Optional callback fired for each server notification.+  , fetchSize            :: Int64+  -- ^ Maximum number of records per PULL batch.+  , createdAt            :: Word64+  -- ^ Monotonic nanosecond timestamp when this connection was created.+  -- Used by the pool to enforce 'maxLifetime'.   }  

@@ -48,21 +48,19 @@ import           TextShow                (TextShow(..), fromText) import           Data.Int                (Int64) import qualified Data.Aeson              as Aeson-import qualified Data.Aeson.Key          as Key-import qualified Data.Aeson.KeyMap       as Aeson import qualified Data.ByteString         as BS import qualified Data.HashMap.Lazy       as H import qualified Data.Text               as T import qualified Data.UUID.Types         as UUID import qualified Data.Vector             as V-import           Data.Scientific         (fromFloatDigits)+import           Data.Aeson               (ToJSON(..)) import           Data.Time.Calendar.OrdinalDate (Day) import           Data.Time.Clock         (UTCTime) import           Data.Time.Clock.POSIX   (posixSecondsToUTCTime) import           Data.Time.Format.ISO8601 (iso8601ParseM) import           Data.Time.LocalTime     (TimeOfDay)-import           GHC.Float               (int2Double) + import           Data.PackStream.Integer (PSInteger, fromPSInteger) import           Data.PackStream.Ps      (Ps(..), PackStream(..)) import           Data.PackStream.Result  (Result(..))@@ -239,22 +237,11 @@ -- * Aeson decoder  -- | Decode any Bolt value to an 'Aeson.Value'.+--+-- Uses the 'ToJSON' instance on 'Bolt', which handles all constructors+-- including graph types, temporal types, and spatial types. aesonValue :: Decode Aeson.Value-aesonValue = Decode boltToAeson-  where-    boltToAeson :: Bolt -> Either DecodeError Aeson.Value-    boltToAeson BoltNull = Right Aeson.Null-    boltToAeson (BoltBoolean b) = Right $ Aeson.Bool b-    boltToAeson (BoltInteger n) = case fromPSInteger n :: Maybe Int of-      Just i  -> Right $ Aeson.Number $ fromFloatDigits $ int2Double i-      Nothing -> Left $ TypeMismatch "Aeson.Value" "Integer (out of range)"-    boltToAeson (BoltFloat d) = Right $ Aeson.Number $ fromFloatDigits d-    boltToAeson (BoltString t) = Right $ Aeson.String t-    boltToAeson (BoltList v) = Aeson.Array <$> traverse boltToAeson v-    boltToAeson (BoltDictionary m) = do-      pairs <- traverse boltToAeson m-      Right $ Aeson.Object $ Aeson.fromList $ map (\(k, v) -> (Key.fromText k, v)) $ H.toList pairs-    boltToAeson other = Left $ TypeMismatch "Aeson.Value" (boltTypeName other)+aesonValue = Decode (Right . toJSON)   -- * Node property decoders

@@ -278,9 +278,11 @@       extra     <- fromPs (fields V.! 2)       Success $ RRoute Route{routing, bookmarks, extra} --- | Default 'Pull' requesting all records (@n = -1@) with no explicit query ID.+-- | Default 'Pull' requesting up to 1000 records per batch, with no explicit query ID.+-- Matches the default fetch size used by the official Neo4j drivers (Java, Python, JS, .NET).+-- Use @n = -1@ to request all records in a single batch (no back-pressure). defaultPull :: Pull-defaultPull = Pull{n = -1, qid = Nothing}+defaultPull = Pull{n = 1000, qid = Nothing}  -- | PULL message payload with record count and optional query ID. type Pull :: Type

@@ -17,7 +17,8 @@   , poolCounters   ) where -import           Control.Exception                (SomeException, mask, try, fromException, throwIO)+import           Control.Exception                (IOException, SomeException, mask, try, fromException, throwIO)+import           Data.Int                         (Int64) import           Data.IORef                       (IORef, newIORef, readIORef, atomicModifyIORef') import           Data.Pool                        (Pool) import qualified Data.Pool                        as Pool@@ -26,10 +27,10 @@ import           GHC.Stack                        (HasCallStack)  import           Data.Kind                        (Type)-import           Database.Bolty.Connection.Type   (Connection, ValidatedConfig, Error(..))+import           Database.Bolty.Connection.Type   (Connection, ValidatedConfig(..), Error(..)) import qualified Database.Bolty.Connection.Pipe   as P import           Database.Bolty.Connection.Pipe   (touchConnection, connectionLastActivity,-                                                   connectionServerIdleTimeout)+                                                   connectionServerIdleTimeout, connectionCreatedAt)   -- | Configuration for retry logic on transient failures.@@ -79,9 +80,17 @@   -- ^ Retry configuration for transient failures. Default: 'defaultRetryConfig'.   , validationStrategy :: ValidationStrategy   -- ^ How to validate connections on checkout. Default: 'AlwaysPing'.+  , fetchSize          :: Int64+  -- ^ Maximum number of records per PULL batch. Default: 1000.+  -- Official Neo4j drivers (Java, Python, JS, .NET) default to 1000.+  -- Use @-1@ to request all records in a single batch (no back-pressure).+  , maxLifetime        :: Double+  -- ^ Maximum lifetime of a connection in seconds. Default: 3600 (1 hour).+  -- Connections older than this are discarded on checkout and replaced with fresh ones.+  -- Official Neo4j drivers default to 1 hour.   } --- | Default pool configuration: 10 max connections, 60 second idle timeout, 1 ping retry.+-- | Default pool configuration: 10 max connections, 60 second idle timeout, 1 ping retry, 1000 fetch size, 1 hour max lifetime. defaultPoolConfig :: PoolConfig defaultPoolConfig = PoolConfig   { maxConnections     = 10@@ -89,18 +98,21 @@   , maxPingRetries     = 1   , retryConfig        = defaultRetryConfig   , validationStrategy = PingIfIdle 30+  , fetchSize          = 1000+  , maxLifetime        = 3600   }   -- | A pool of Neo4j connections with health-check and retry configuration. type BoltPool :: Type data BoltPool = BoltPool-  { bpPool        :: !(Pool Connection)-  , bpMaxRetries  :: !Int-  , bpRetryConfig :: !RetryConfig-  , bpValidation  :: !ValidationStrategy-  , bpActiveConns :: !(IORef Int)-  , bpTotalAcqs   :: !(IORef Int)+  { bpPool           :: !(Pool Connection)+  , bpMaxRetries     :: !Int+  , bpRetryConfig    :: !RetryConfig+  , bpValidation     :: !ValidationStrategy+  , bpMaxLifetimeNs  :: !Word64+  , bpActiveConns    :: !(IORef Int)+  , bpTotalAcqs      :: !(IORef Int)   , bpTotalWaitNs :: !(IORef Word64)   } @@ -122,13 +134,23 @@ -- idle timeout is capped to @min(configured, hint - 5)@ so connections -- are recycled before the server closes them. createPool :: HasCallStack => ValidatedConfig -> PoolConfig -> IO BoltPool-createPool cfg PoolConfig{..} = do+createPool cfg0 pc = do+  let PoolConfig{maxConnections, idleTimeout, maxPingRetries, retryConfig, validationStrategy, fetchSize = fs, maxLifetime} = pc+  let cfg = cfg0 { Database.Bolty.Connection.Type.fetchSize = fs }   -- Probe a connection to discover the server's idle timeout hint.   probe <- P.connect cfg-  let effectiveIdle = case connectionServerIdleTimeout probe of+  let serverHint = connectionServerIdleTimeout probe+  let effectiveIdle = case serverHint of         Just serverSecs | serverSecs > 5 ->           min idleTimeout (fromIntegral (serverSecs - 5))         _ -> idleTimeout+  -- Cap maxLifetime from server hint: use min(configured, 2 * hint) so+  -- connections are recycled before the server considers them stale.+  let effectiveMaxLifetime = case serverHint of+        Just serverSecs | serverSecs > 0 ->+          min maxLifetime (fromIntegral serverSecs * 2)+        _ -> maxLifetime+  let maxLifetimeNs = round (effectiveMaxLifetime * 1_000_000_000) :: Word64   P.close probe   let poolCfg = Pool.setNumStripes (Just 1)               $ Pool.defaultPoolConfig@@ -142,6 +164,7 @@   waitRef   <- newIORef 0   pure BoltPool { bpPool = pool, bpMaxRetries = maxPingRetries                 , bpRetryConfig = retryConfig, bpValidation = validationStrategy+                , bpMaxLifetimeNs = maxLifetimeNs                 , bpActiveConns = activeRef, bpTotalAcqs = acqRef, bpTotalWaitNs = waitRef }  @@ -155,7 +178,7 @@ -- On connection failure during the action, discards the dead connection and -- retries once with a fresh one. withConnection :: HasCallStack => BoltPool -> (Connection -> IO a) -> IO a-withConnection BoltPool{bpPool, bpMaxRetries, bpValidation, bpActiveConns, bpTotalAcqs, bpTotalWaitNs} action =+withConnection BoltPool{bpPool, bpMaxRetries, bpValidation, bpMaxLifetimeNs, bpActiveConns, bpTotalAcqs, bpTotalWaitNs} action =     go (bpMaxRetries + 1) True   where     go 0 _ = fail "withConnection: no healthy connection available"@@ -167,30 +190,39 @@       atomicModifyIORef' bpTotalAcqs $ \x -> (x + 1, ())       atomicModifyIORef' bpTotalWaitNs $ \x -> (x + (t1 - t0), ())       let decActive = atomicModifyIORef' bpActiveConns $ \x -> (x - 1, ())-      shouldPing <- needsPing bpValidation conn-      healthy <- if shouldPing then P.ping conn else pure True-      if healthy+      -- Check max lifetime: discard connections that have been alive too long.+      -- Does not consume a retry — the replacement from the pool will be fresh.+      let age = t1 - connectionCreatedAt conn+      if age > bpMaxLifetimeNs         then do-          result <- try $ restore (action conn)-          case result of-            Right x -> do-              touchConnection conn-              Pool.putResource localPool conn-              decActive-              pure x-            Left (e :: SomeException)-              | canRetryDead, isConnectionError e -> do-                  Pool.destroyResource bpPool localPool conn-                  decActive-                  restore $ go n False   -- retry with fresh connection, no more retries-              | otherwise -> do-                  Pool.destroyResource bpPool localPool conn-                  decActive-                  restore $ throwIOSome e-        else do           Pool.destroyResource bpPool localPool conn           decActive-          restore $ go (n - 1) canRetryDead+          restore $ go n canRetryDead+        else do+          shouldPing <- needsPing bpValidation conn+          healthy <- if shouldPing then P.ping conn else pure True+          if healthy+            then do+              result <- try $ restore (action conn)+              case result of+                Right x -> do+                  touchConnection conn+                  Pool.putResource localPool conn+                  decActive+                  pure x+                Left (e :: SomeException)+                  | canRetryDead, isConnectionError e -> do+                      Pool.destroyResource bpPool localPool conn+                      decActive+                      restore $ go n False   -- retry with fresh connection, no more retries+                  | otherwise -> do+                      Pool.destroyResource bpPool localPool conn+                      decActive+                      restore $ throwIOSome e+            else do+              Pool.destroyResource bpPool localPool conn+              decActive+              restore $ go (n - 1) canRetryDead      throwIOSome :: SomeException -> IO a     throwIOSome = throwIO' where@@ -198,9 +230,10 @@       throwIO' = Control.Exception.throwIO      isConnectionError :: SomeException -> Bool-    isConnectionError e = case fromException e :: Maybe Error of-      Just (NonboltyError _) -> True-      _                      -> False+    isConnectionError e+      | Just (_ :: IOException) <- fromException e = True+      | Just (NonboltyError _)  <- fromException e = True+      | otherwise = False   -- | Check if a connection needs a ping based on the validation strategy.@@ -233,7 +266,7 @@ -- Use 'acquireConnection' when you need the connection to outlive a callback -- (e.g. for streaming with @bracketIO@). acquireConnection :: BoltPool -> IO CheckedOutConnection-acquireConnection bp@BoltPool{bpPool, bpMaxRetries, bpValidation, bpActiveConns, bpTotalAcqs, bpTotalWaitNs} =+acquireConnection bp@BoltPool{bpPool, bpMaxRetries, bpValidation, bpMaxLifetimeNs, bpActiveConns, bpTotalAcqs, bpTotalWaitNs} =     go (bpMaxRetries + 1)   where     go 0 = fail "acquireConnection: no healthy connection available"@@ -244,15 +277,24 @@       atomicModifyIORef' bpActiveConns $ \x -> (x + 1, ())       atomicModifyIORef' bpTotalAcqs $ \x -> (x + 1, ())       atomicModifyIORef' bpTotalWaitNs $ \x -> (x + (t1 - t0), ())-      shouldPing <- needsPing bpValidation conn-      healthy <- if shouldPing then P.ping conn else pure True-      if healthy-        then pure CheckedOutConnection-              { cocConnection = conn, cocLocalPool = localPool, cocBoltPool = bp }-        else do+      -- Check max lifetime: discard connections that have been alive too long.+      -- Does not consume a retry — the replacement from the pool will be fresh.+      let age = t1 - connectionCreatedAt conn+      if age > bpMaxLifetimeNs+        then do           Pool.destroyResource bpPool localPool conn           atomicModifyIORef' bpActiveConns $ \x -> (x - 1, ())-          go (n - 1)+          go n+        else do+          shouldPing <- needsPing bpValidation conn+          healthy <- if shouldPing then P.ping conn else pure True+          if healthy+            then pure CheckedOutConnection+                  { cocConnection = conn, cocLocalPool = localPool, cocBoltPool = bp }+            else do+              Pool.destroyResource bpPool localPool conn+              atomicModifyIORef' bpActiveConns $ \x -> (x - 1, ())+              go (n - 1)   -- | Release a connection back to the pool after successful use.

@@ -24,6 +24,7 @@   , Point3D(..)   ) where +import           Control.Applicative    ((<|>), empty) import           Data.Int              (Int64) import           Data.Kind             (Type) import           GHC.Generics          (Generic)@@ -32,16 +33,25 @@ import qualified Data.Text             as T import qualified Data.Vector           as V -import           Data.PackStream.Ps+import           Data.PackStream.Ps hiding ((.=), (.:)) import           Data.PackStream.Result  (Result(..))-import           Data.PackStream.Integer (PSInteger)+import           Data.PackStream.Integer (PSInteger, fromIntegerTry) import           Database.Bolty.Value.Helpers (sigNode, sigRel, sigURel, sigPath                                               , sigDate, sigTime, sigLocalTime, sigDateTime                                               , sigDateTimeZoneId, sigLocalDateTime, sigDuration                                               , sigPoint2D, sigPoint3D) import           Numeric                (showHex) +import qualified Data.Aeson              as Aeson+import qualified Data.Aeson.Key          as Key+import qualified Data.Aeson.KeyMap       as KM+import           Data.Aeson              (ToJSON(..), FromJSON(..), (.=), (.:))+import           Data.Aeson.Types        (Parser)+import qualified Data.ByteString.Base64  as B64+import qualified Data.Text.Encoding      as TE+import           Data.Scientific         (Scientific, fromFloatDigits, floatingOrInteger, toRealFloat) + -- | A typed Neo4j value. Every field in a query result record is a 'Bolt'. type Bolt :: Type data Bolt@@ -371,6 +381,322 @@   fromPs (PsStructure t fs) | t == sigPoint3D, V.length fs == 4 =     Point3D <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3)   fromPs other = typeMismatch "Point3D" other+++-- = Aeson (ToJSON / FromJSON) instances++-- | Convert a PackStream property value to JSON.+psToAeson :: Ps -> Aeson.Value+psToAeson PsNull           = Aeson.Null+psToAeson (PsBoolean b)    = Aeson.Bool b+psToAeson (PsInteger n)    = Aeson.Number (fromIntegral n)+psToAeson (PsFloat d)+  | isNaN d || isInfinite d = Aeson.Null+  | otherwise               = Aeson.Number (fromFloatDigits d)+psToAeson (PsString t)     = Aeson.String t+psToAeson (PsBytes bs)     = Aeson.object ["bytes" .= TE.decodeLatin1 (B64.encode bs)]+psToAeson (PsList v)       = Aeson.Array (V.map psToAeson v)+psToAeson (PsDictionary m) = Aeson.Object $ KM.fromList+  [(Key.fromText k, psToAeson v) | (k, v) <- H.toList m]+psToAeson (PsStructure _ _) = Aeson.Null  -- structures never appear in Neo4j properties++-- | Parse a JSON value as a PackStream property value.+parsePs :: Aeson.Value -> Parser Ps+parsePs Aeson.Null       = pure PsNull+parsePs (Aeson.Bool b)   = pure (PsBoolean b)+parsePs (Aeson.Number n) = pure (scientificToPs n)+parsePs (Aeson.String t) = pure (PsString t)+parsePs (Aeson.Array v)  = PsList <$> traverse parsePs v+parsePs (Aeson.Object obj) = case KM.toList obj of+  [(k, Aeson.String b64)] | Key.toText k == "bytes" ->+    case B64.decode (TE.encodeUtf8 b64) of+      Right bs -> pure (PsBytes bs)+      Left _   -> parsePsDictionary  -- not valid base64, treat as regular dictionary+  _ -> parsePsDictionary+  where+    parsePsDictionary = PsDictionary . H.fromList <$>+      traverse (\(k, v) -> (,) (Key.toText k) <$> parsePs v) (KM.toList obj)++-- | Convert a Scientific to a PackStream value.+scientificToPs :: Scientific -> Ps+scientificToPs n = case floatingOrInteger n :: Either Double Integer of+  Right i -> case fromIntegerTry i of+    Right psi -> PsInteger psi+    Left _    -> PsFloat (toRealFloat n)+  Left d    -> PsFloat d++-- | Convert a Scientific to a Bolt value.+scientificToBolt :: Scientific -> Bolt+scientificToBolt n = case floatingOrInteger n :: Either Double Integer of+  Right i -> case fromIntegerTry i of+    Right psi -> BoltInteger psi+    Left _    -> BoltFloat (toRealFloat n)+  Left d    -> BoltFloat d++-- | Encode a property map to JSON.+propsToAeson :: H.HashMap T.Text Ps -> Aeson.Value+propsToAeson m = Aeson.Object $ KM.fromList+  [(Key.fromText k, psToAeson v) | (k, v) <- H.toList m]++-- | Parse a JSON object as a property map.+propsFromAeson :: Aeson.Value -> Parser (H.HashMap T.Text Ps)+propsFromAeson = Aeson.withObject "properties" $ \obj ->+  H.fromList <$> traverse (\(k, v) -> (,) (Key.toText k) <$> parsePs v) (KM.toList obj)+++instance ToJSON Node where+  toJSON Node{..} = Aeson.object+    [ "id"         .= id+    , "labels"     .= labels+    , "properties" .= propsToAeson properties+    , "element_id" .= element_id+    ]++instance FromJSON Node where+  parseJSON = Aeson.withObject "Node" $ \o ->+    Node <$> o .: "id"+         <*> o .: "labels"+         <*> (propsFromAeson =<< o .: "properties")+         <*> o .: "element_id"+++instance ToJSON Relationship where+  toJSON Relationship{..} = Aeson.object+    [ "id"                    .= id+    , "startNodeId"           .= startNodeId+    , "endNodeId"             .= endNodeId+    , "type"                  .= type_+    , "properties"            .= propsToAeson properties+    , "element_id"            .= element_id+    , "start_node_element_id" .= start_node_element_id+    , "end_node_element_id"   .= end_node_element_id+    ]++instance FromJSON Relationship where+  parseJSON = Aeson.withObject "Relationship" $ \o ->+    Relationship <$> o .: "id"+                 <*> o .: "startNodeId"+                 <*> o .: "endNodeId"+                 <*> o .: "type"+                 <*> (propsFromAeson =<< o .: "properties")+                 <*> o .: "element_id"+                 <*> o .: "start_node_element_id"+                 <*> o .: "end_node_element_id"+++instance ToJSON UnboundRelationship where+  toJSON UnboundRelationship{..} = Aeson.object+    [ "id"         .= id+    , "type"       .= type_+    , "properties" .= propsToAeson properties+    , "element_id" .= element_id+    ]++instance FromJSON UnboundRelationship where+  parseJSON = Aeson.withObject "UnboundRelationship" $ \o ->+    UnboundRelationship <$> o .: "id"+                        <*> o .: "type"+                        <*> (propsFromAeson =<< o .: "properties")+                        <*> o .: "element_id"+++instance ToJSON Path where+  toJSON Path{..} = Aeson.object+    [ "nodes"         .= nodes+    , "relationships" .= rels+    , "indices"       .= indices+    ]++instance FromJSON Path where+  parseJSON = Aeson.withObject "Path" $ \o ->+    Path <$> o .: "nodes"+         <*> o .: "relationships"+         <*> o .: "indices"+++instance ToJSON Date where+  toJSON Date{..} = Aeson.object ["days" .= days]++instance FromJSON Date where+  parseJSON = Aeson.withObject "Date" $ \o ->+    Date <$> o .: "days"+++instance ToJSON Time where+  toJSON Time{..} = Aeson.object+    [ "nanoseconds"       .= nanoseconds+    , "tz_offset_seconds" .= tz_offset_seconds+    ]++instance FromJSON Time where+  parseJSON = Aeson.withObject "Time" $ \o ->+    Time <$> o .: "nanoseconds"+         <*> o .: "tz_offset_seconds"+++instance ToJSON LocalTime where+  toJSON LocalTime{..} = Aeson.object ["nanoseconds" .= nanoseconds]++instance FromJSON LocalTime where+  parseJSON = Aeson.withObject "LocalTime" $ \o ->+    LocalTime <$> o .: "nanoseconds"+++instance ToJSON DateTime where+  toJSON DateTime{..} = Aeson.object+    [ "seconds"           .= seconds+    , "nanoseconds"       .= nanoseconds+    , "tz_offset_seconds" .= tz_offset_seconds+    ]++instance FromJSON DateTime where+  parseJSON = Aeson.withObject "DateTime" $ \o ->+    DateTime <$> o .: "seconds"+             <*> o .: "nanoseconds"+             <*> o .: "tz_offset_seconds"+++instance ToJSON DateTimeZoneId where+  toJSON DateTimeZoneId{..} = Aeson.object+    [ "seconds"     .= seconds+    , "nanoseconds" .= nanoseconds+    , "tz_id"       .= tz_id+    ]++instance FromJSON DateTimeZoneId where+  parseJSON = Aeson.withObject "DateTimeZoneId" $ \o ->+    DateTimeZoneId <$> o .: "seconds"+                   <*> o .: "nanoseconds"+                   <*> o .: "tz_id"+++instance ToJSON LocalDateTime where+  toJSON LocalDateTime{..} = Aeson.object+    [ "seconds"     .= seconds+    , "nanoseconds" .= nanoseconds+    ]++instance FromJSON LocalDateTime where+  parseJSON = Aeson.withObject "LocalDateTime" $ \o ->+    LocalDateTime <$> o .: "seconds"+                  <*> o .: "nanoseconds"+++instance ToJSON Duration where+  toJSON Duration{..} = Aeson.object+    [ "months"      .= months+    , "days"        .= days+    , "seconds"     .= seconds+    , "nanoseconds" .= nanoseconds+    ]++instance FromJSON Duration where+  parseJSON = Aeson.withObject "Duration" $ \o ->+    Duration <$> o .: "months"+             <*> o .: "days"+             <*> o .: "seconds"+             <*> o .: "nanoseconds"+++instance ToJSON Point2D where+  toJSON Point2D{..} = Aeson.object+    [ "srid" .= srid+    , "x"    .= x+    , "y"    .= y+    ]++instance FromJSON Point2D where+  parseJSON = Aeson.withObject "Point2D" $ \o ->+    Point2D <$> o .: "srid"+            <*> o .: "x"+            <*> o .: "y"+++instance ToJSON Point3D where+  toJSON Point3D{..} = Aeson.object+    [ "srid" .= srid+    , "x"    .= x+    , "y"    .= y+    , "z"    .= z+    ]++instance FromJSON Point3D where+  parseJSON = Aeson.withObject "Point3D" $ \o ->+    Point3D <$> o .: "srid"+            <*> o .: "x"+            <*> o .: "y"+            <*> o .: "z"+++instance ToJSON Bolt where+  toJSON BoltNull             = Aeson.Null+  toJSON (BoltBoolean b)      = Aeson.Bool b+  toJSON (BoltInteger n)      = Aeson.Number (fromIntegral n)+  toJSON (BoltFloat d)+    | isNaN d || isInfinite d = Aeson.Null+    | otherwise               = Aeson.Number (fromFloatDigits d)+  toJSON (BoltBytes bs)       = Aeson.object ["bytes" .= TE.decodeLatin1 (B64.encode bs)]+  toJSON (BoltString t)       = Aeson.String t+  toJSON (BoltList v)         = toJSON v+  toJSON (BoltDictionary m)   = toJSON m+  toJSON (BoltNode n)                = Aeson.object ["node" .= n]+  toJSON (BoltRelationship r)        = Aeson.object ["relationship" .= r]+  toJSON (BoltUnboundRelationship r) = Aeson.object ["unboundRelationship" .= r]+  toJSON (BoltPath p)                = Aeson.object ["path" .= p]+  toJSON (BoltDate d)                = Aeson.object ["date" .= d]+  toJSON (BoltTime t)                = Aeson.object ["time" .= t]+  toJSON (BoltLocalTime t)           = Aeson.object ["localTime" .= t]+  toJSON (BoltDateTime dt)           = Aeson.object ["dateTime" .= dt]+  toJSON (BoltDateTimeZoneId dt)     = Aeson.object ["dateTimeZoneId" .= dt]+  toJSON (BoltLocalDateTime dt)      = Aeson.object ["localDateTime" .= dt]+  toJSON (BoltDuration d)            = Aeson.object ["duration" .= d]+  toJSON (BoltPoint2D p)             = Aeson.object ["point2d" .= p]+  toJSON (BoltPoint3D p)             = Aeson.object ["point3d" .= p]++-- | Note: JSON cannot distinguish @BoltFloat 1.0@ from @BoltInteger 1@.+-- Whole-number floats will round-trip as 'BoltInteger'. For lossless+-- serialization use the PackStream wire format instead.+instance FromJSON Bolt where+  parseJSON Aeson.Null     = pure BoltNull+  parseJSON (Aeson.Bool b) = pure (BoltBoolean b)+  parseJSON (Aeson.Number n) = pure (scientificToBolt n)+  parseJSON (Aeson.String t) = pure (BoltString t)+  parseJSON (Aeson.Array v)  = BoltList <$> traverse parseJSON v+  parseJSON (Aeson.Object obj) = case KM.toList obj of+    -- Single-key objects are tried as typed Bolt values first.+    -- On parse failure the object is treated as a plain BoltDictionary+    -- so that e.g. {"node": 42} does not reject — it round-trips as a+    -- dictionary rather than erroring out.+    [(key, val)] -> tryTyped (Key.toText key) val <|> parseBoltDictionary obj+    _            -> parseBoltDictionary obj+    where+      tryTyped "bytes"                v = parseBoltBytes v+      tryTyped "node"                 v = BoltNode <$> parseJSON v+      tryTyped "relationship"         v = BoltRelationship <$> parseJSON v+      tryTyped "unboundRelationship"  v = BoltUnboundRelationship <$> parseJSON v+      tryTyped "path"                 v = BoltPath <$> parseJSON v+      tryTyped "date"                 v = BoltDate <$> parseJSON v+      tryTyped "time"                 v = BoltTime <$> parseJSON v+      tryTyped "localTime"            v = BoltLocalTime <$> parseJSON v+      tryTyped "dateTime"             v = BoltDateTime <$> parseJSON v+      tryTyped "dateTimeZoneId"       v = BoltDateTimeZoneId <$> parseJSON v+      tryTyped "localDateTime"        v = BoltLocalDateTime <$> parseJSON v+      tryTyped "duration"             v = BoltDuration <$> parseJSON v+      tryTyped "point2d"              v = BoltPoint2D <$> parseJSON v+      tryTyped "point3d"              v = BoltPoint3D <$> parseJSON v+      tryTyped _                      _ = empty  -- unknown key, fall through to <|>++-- | Parse a base64-encoded bytes value.+parseBoltBytes :: Aeson.Value -> Parser Bolt+parseBoltBytes (Aeson.String b64) = case B64.decode (TE.encodeUtf8 b64) of+  Right bs -> pure (BoltBytes bs)+  Left _   -> fail "invalid base64 in bytes"+parseBoltBytes _ = fail "expected base64 string for bytes"++-- | Parse a JSON object as a BoltDictionary.+parseBoltDictionary :: KM.KeyMap Aeson.Value -> Parser Bolt+parseBoltDictionary obj = BoltDictionary . H.fromList <$>+  traverse (\(k, v) -> (,) (Key.toText k) <$> parseJSON v) (KM.toList obj)   -- = Bolt value extractors

@@ -6,7 +6,7 @@ import           Data.Bits                         (shiftL, (.|.)) import           Data.Default                      (def) import           Data.Int                          (Int64)-import           Data.Word                         (Word32)+import           Data.Word                         (Word32, Word64) import qualified Data.HashMap.Lazy                 as H import qualified Data.Text                         as T import qualified Data.Vector                       as V@@ -29,14 +29,28 @@                                                   , DateTime(..), DateTimeZoneId(..), LocalDateTime(..)                                                   , Duration(..), Point2D(..), Point3D(..)) import           Database.Bolty.Message.Request    (Request(..), Hello(..), Route(..), RouteExtra(..)-                                                  , Logon(..), TelemetryApi(..))+                                                  , Logon(..), TelemetryApi(..)+                                                  , Pull(..), defaultPull) 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) +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(..))+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@@ -161,128 +175,6 @@  -- = 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@@ -1621,6 +1513,717 @@         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++-- | Assert a QuickCheck result, failing the sandwich test on property failure.+assertQC r+  | isSuccess r = pure ()+  | otherwise   = expectationFailure $ "QuickCheck: " <> show r++ -- = Main  main :: IO ()@@ -1630,7 +2233,6 @@   version5xTests   extractorTests   recordTests-  packstreamRoundTripTests   messageTests   logonLogoffTests   structureRoundTripTests@@ -1657,3 +2259,9 @@   boltToPsRoundTripTests   patchBoltTests   resultSetTests+  noopChunkTests+  staleConnectionRetryTests+  vectorSnocTests+  batchedPullTests+  maxConnectionLifetimeTests+  aesonTests