diff --git a/bolty.cabal b/bolty.cabal --- a/bolty.cabal +++ b/bolty.cabal @@ -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 diff --git a/src/Database/Bolty/Connection.hs b/src/Database/Bolty/Connection.hs --- a/src/Database/Bolty/Connection.hs +++ b/src/Database/Bolty/Connection.hs @@ -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 () diff --git a/src/Database/Bolty/Connection/Config.hs b/src/Database/Bolty/Connection/Config.hs --- a/src/Database/Bolty/Connection/Config.hs +++ b/src/Database/Bolty/Connection/Config.hs @@ -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 diff --git a/src/Database/Bolty/Connection/Pipe.hs b/src/Database/Bolty/Connection/Pipe.hs --- a/src/Database/Bolty/Connection/Pipe.hs +++ b/src/Database/Bolty/Connection/Pipe.hs @@ -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 -- --------------------------------------------------------------------------- diff --git a/src/Database/Bolty/Connection/Type.hs b/src/Database/Bolty/Connection/Type.hs --- a/src/Database/Bolty/Connection/Type.hs +++ b/src/Database/Bolty/Connection/Type.hs @@ -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'. } diff --git a/src/Database/Bolty/Decode.hs b/src/Database/Bolty/Decode.hs --- a/src/Database/Bolty/Decode.hs +++ b/src/Database/Bolty/Decode.hs @@ -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 diff --git a/src/Database/Bolty/Message/Request.hs b/src/Database/Bolty/Message/Request.hs --- a/src/Database/Bolty/Message/Request.hs +++ b/src/Database/Bolty/Message/Request.hs @@ -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 diff --git a/src/Database/Bolty/Pool.hs b/src/Database/Bolty/Pool.hs --- a/src/Database/Bolty/Pool.hs +++ b/src/Database/Bolty/Pool.hs @@ -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. diff --git a/src/Database/Bolty/Value/Type.hs b/src/Database/Bolty/Value/Type.hs --- a/src/Database/Bolty/Value/Type.hs +++ b/src/Database/Bolty/Value/Type.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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