diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 6a2633b..7ec86bb 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,21 +8,16 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20250917 +# version: 0.19.20260209 # -# REGENDATA ("0.19.20250917",["github","hasbolt.cabal"]) +# REGENDATA ("0.19.20260209",["github","hasbolt.cabal"]) # name: Haskell-CI on: - push: - branches: - - master - pull_request: - branches: - - master - merge_group: - branches: - - master + - push + - pull_request + - merge_group + - workflow_dispatch jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} @@ -30,36 +25,41 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:focal + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: + - compiler: ghc-9.12.2 + compilerKind: ghc + compilerVersion: 9.12.2 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.10.3 compilerKind: ghc compilerVersion: 9.10.3 setup-method: ghcup - allow-failure: true + allow-failure: false - compiler: ghc-9.8.4 compilerKind: ghc compilerVersion: 9.8.4 setup-method: ghcup - allow-failure: true + allow-failure: false - compiler: ghc-9.6.7 compilerKind: ghc compilerVersion: 9.6.7 setup-method: ghcup - allow-failure: true + allow-failure: false - compiler: ghc-9.4.8 compilerKind: ghc compilerVersion: 9.4.8 setup-method: ghcup - allow-failure: true + allow-failure: false - compiler: ghc-9.2.8 compilerKind: ghc compilerVersion: 9.2.8 setup-method: ghcup - allow-failure: true + allow-failure: false fail-fast: false steps: - name: apt-get install diff --git a/README.md b/README.md index bfb0f52..1ad2110 100644 --- a/README.md +++ b/README.md @@ -1,12 +1,13 @@ HasBOLT ======= -[![Travis](https://img.shields.io/travis/zmactep/hasbolt.svg)](https://travis-ci.org/zmactep/hasbolt) -[![GitHub Build](https://github.com/zmactep/hasbolt/workflows/build/badge.svg)](https://github.com/zmactep/hasbolt/actions?query=workflow%3A%22build%22) +[![GitHub Build](https://github.com/zmactep/hasbolt/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/zmactep/hasbolt/actions/workflows/haskell-ci.yml) [![hackage](https://img.shields.io/hackage/v/hasbolt.svg)](https://hackage.haskell.org/package/hasbolt) -[![hackage-deps](https://img.shields.io/hackage-deps/v/hasbolt.svg)](https://hackage.haskell.org/package/hasbolt) -Haskell driver for Neo4j 3+ (BOLT protocol) +Haskell driver for Neo4j, BOLT protocol versions 3 and 5.6+. + +This library skips BOLT 4 entirely and doesn't implement differences between various 5.x minor +versions, so connection will fail if the server does not accept version proposal. Documentation ------------- @@ -42,7 +43,7 @@ nineties = do records <- query "MATCH (nineties:Movie) WHERE nineties.released > -- you can use 'queryP' function that takes not only the Cypher request but also -- a parameters dictionary. genericABN :: RecordValue a => Text -> BoltActionT IO [a] -genericABN name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS {name} RETURN tom" +genericABN name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS $name RETURN tom" (props ["name" =: name]) nodes <- forM toms' $ \record -> record `at` "tom" forM nodes $ \node -> nodeProps node `at` "name" @@ -50,8 +51,8 @@ genericABN name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS -- Hasbolt has a special 'Node' type to unpack graph nodes. You also can find 'Relationship', -- 'URelationship' and 'Path' as built-in types. actorsByNameYear :: Text -> Int -> BoltActionT IO [Node] -actorsByNameYear name year = do toms' <- queryP "MATCH (n:Person {name: {props}.name, born: {props}.born}) RETURN n" - (props ["props" =: props ["name" =: name, "born" =: year]]) +actorsByNameYear name year = do toms' <- queryP "MATCH (n:Person {name: $name, born: $born}) RETURN n" + (props ["name" =: name, "born" =: year]) forM toms' $ \record -> record `at` "n" actorsByName :: Text -> BoltActionT IO [Text] @@ -63,14 +64,14 @@ wrongType = genericABN -- Database server answers with a 'ResponseError' exception on any syntax error or internal database problem. typoInRequest :: Text -> BoltActionT IO [Text] -typoInRequest name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS {name} RETURN not_tom" +typoInRequest name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS $name RETURN not_tom" (props ["name" =: name]) nodes <- forM toms' $ \record -> record `at` "tom" forM nodes $ \node -> nodeProps node `at` "name" -- 'RecordHasNoKey' is thrown in case of a wrong key usage in 'at'. typoInField :: Text -> BoltActionT IO [Text] -typoInField name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS {name} RETURN tom" +typoInField name = do toms' <- queryP "MATCH (tom:Person) WHERE tom.name CONTAINS $name RETURN tom" (props ["name" =: name]) nodes <- forM toms' $ \record -> record `at` "not_tom" forM nodes $ \node -> nodeProps node `at` "name" @@ -112,18 +113,25 @@ Notes * Do not forget to import `Data.Default` to use default connection configuration. * `OverloadedStrings` are very welcome, as the library doesn't use `String`s at all. -* You can use `Database.Bolt.Lazy` to work with lazy IO. In this case do not forget to read all the records before you send a next query. +* You can use `Database.Bolt.Lazy` to work with lazy IO. In this case do not forget to read all the + records before you send a next query. *Important*: not compatible with RouterPool. * See [`test/TransactionSpec.hs`](https://github.com/zmactep/hasbolt/blob/master/test/TransactionSpec.hs) for an example of transactions usage. * Feel free to implement your own serialization procedures with `Database.Bolt.Serialization` module import. -* Pipes work great with [resource-pool](https://hackage.haskell.org/package/resource-pool). -* For neo4j 3.4+ use `version = 2` in connection configuration. This allows you to use [new datatypes](#new-types). +* For Neo4j clusters, use the built-in `RouterPool` (`connectRouterPool`/`runRouterPool`) which handles topology discovery, connection pooling, and read/write routing. For single-server setups, pipes work great with [resource-pool](https://hackage.haskell.org/package/resource-pool). +* The default BOLT protocol version is v5 (5.6–5.8), which works with Neo4j 5.x. The driver also supports older servers — the handshake will negotiate v3 if the server doesn't support v5. +* For neo4j 3.4+ spatial/temporal types, see [new datatypes](#new-types). * You can use both syntax variants to create properties dictionaries: `fromList [("born", I 1962)]` or `props ["born" =: 1962]`. * Note that you have to make a type hint for `Text` values in the second construction, as Haskell cannot deduce it on its own. +* Use `$param` syntax for Cypher parameters (the old `{param}` syntax was removed in Neo4j 5). New types --------- -Neo4j 3.4+ implements BOLT v2 protocol (that still doesn't have any specification). Code inspection of [neo4j sources](https://github.com/neo4j/neo4j) led me to these new data types in v2. All of them are just structures with different signatures and fields. +Neo4j 3.4+ implements BOLT v2 protocol with spatial and temporal data types. They are already +available in `hasbolt`, since lowest supported version is BOLT v3. + +All of them are just structures with different signatures and fields. + * Point2D ```haskell signature = 'X' @@ -203,7 +211,7 @@ Codes of Coordinate Reference Systems: ```haskell λ> :set -XScopedTypeVariables -λ> pipe <- connect $ def { user = "neo4j", password = "neo4j", version = 2 } +λ> pipe <- connect $ def { user = "neo4j", password = "neo4j" } λ> point :: Value <- run pipe $ do records <- query "RETURN point({x: 1, y: 2, z: 3}) as point" (head records) `at` "point" λ> point diff --git a/hasbolt.cabal b/hasbolt.cabal index 67c5a1b..a4a2e48 100644 --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,5 +1,5 @@ name: hasbolt -version: 0.1.7.2 +version: 0.1.8.0 synopsis: Haskell driver for Neo4j 3+ (BOLT protocol) description: Haskell driver for Neo4j 3+ (BOLT protocol). @@ -20,7 +20,7 @@ description: . -Bolt protocol version 3 initial support . - The code was tested with neo4j versions 3.0 — 3.5 and GrapheneDB service + The code was tested with neo4j versions 3.0 — 5.26 and GrapheneDB service homepage: https://github.com/zmactep/hasbolt#readme @@ -40,6 +40,7 @@ tested-with: || ==9.6.7 || ==9.8.4 || ==9.10.3 + || ==9.12.2 library hs-source-dirs: src @@ -47,20 +48,22 @@ library , Database.Bolt.Lazy , Database.Bolt.Lens , Database.Bolt.Serialization - other-modules: Database.Bolt.Value.Type , Database.Bolt.Value.Helpers - , Database.Bolt.Value.Instances - , Database.Bolt.Connection.Connection , Database.Bolt.Connection.Type , Database.Bolt.Connection.Instances + , Database.Bolt.Connection.RouterPool + other-modules: Database.Bolt.Value.Type + , Database.Bolt.Value.Instances + , Database.Bolt.Connection.Connection , Database.Bolt.Connection.Pipe , Database.Bolt.Connection + , Database.Bolt.Connection.RoutingTable , Database.Bolt.Record , Database.Bolt.Transaction build-depends: base >= 4.7 && < 5 , bytestring >= 0.10.8.1 && < 0.13 , text >= 1.2.2.1 && < 2.2 - , containers >= 0.5.7.1 && < 0.9 + , containers >= 0.6.0.1 && < 0.9 , binary >= 0.8.3.0 && < 1.0 , data-binary-ieee754 >= 0.4.4 && < 0.5 , mtl >= 2.2.0 && < 2.4 @@ -68,6 +71,9 @@ library , crypton-connection >= 0.3.1 && < 0.5 , data-default >= 0.7.1.1 && < 0.9 , deepseq >= 1.4 && < 1.6 + , exceptions >= 0.10 && < 0.11 + , time >= 1.9 && < 1.16 + , async >= 2.2 && < 2.3 if impl(ghc < 8.6) build-depends: contravariant >= 1.4.1 && < 1.6 if impl(ghc < 8.0) @@ -100,6 +106,8 @@ test-suite hasbolt-test , containers , binary , bytestring + , data-default + , time ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Database/Bolt.hs b/src/Database/Bolt.hs index 08dd3fd..efd8c39 100644 --- a/src/Database/Bolt.hs +++ b/src/Database/Bolt.hs @@ -3,16 +3,24 @@ module Database.Bolt , BoltError (..), UnpackError (..) , connect, close, reset , run, runE, queryP, query, queryP_, query_ - , transact + , transact, transactRead , (=:), props , Pipe , BoltCfg (..) , Value (..), IsValue (..), Structure (..), Record, RecordValue (..), exact, exactMaybe, at , maybeAt, Node (..), Relationship (..), URelationship (..), Path (..) + , AccessMode(..), RoutingTable(..), ServerAddress(..) + , parseRoutingTable, parseAddress, isExpired + , RouterPool, RouterPoolCfg(..) + , connectRouterPool, closeRouterPool + , runRouterPool, runRouterPoolE, runRouterPoolRead, runRouterPoolReadE + , getRoutingTable ) where import Database.Bolt.Connection hiding (query, queryP) import Database.Bolt.Connection.Pipe +import Database.Bolt.Connection.RouterPool +import Database.Bolt.Connection.RoutingTable import Database.Bolt.Connection.Type import Database.Bolt.Record import Database.Bolt.Transaction diff --git a/src/Database/Bolt/Connection.hs b/src/Database/Bolt/Connection.hs index 39e5f13..9edaceb 100644 --- a/src/Database/Bolt/Connection.hs +++ b/src/Database/Bolt/Connection.hs @@ -1,5 +1,5 @@ -{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Database.Bolt.Connection @@ -27,7 +27,7 @@ import Control.Monad (void) import Control.Monad.Except (MonadError (..), runExceptT) import Control.Monad.Reader (MonadReader (..), runReaderT) import Control.Monad.Trans (MonadIO (..)) -import Data.Map.Strict (Map, empty, fromList) +import Data.Map.Strict (Map, empty, fromList, union) import Data.Text (Text) import GHC.Stack (HasCallStack) @@ -62,8 +62,13 @@ query' cypher = queryP' cypher empty -- |Runs Cypher query with parameters and ignores response queryP_ :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m () -queryP_ cypher params = do void $ sendRequest cypher params empty - ask >>= liftE . discardAll +queryP_ cypher params = do pipe <- ask + void $ sendRequest cypher params empty + let discardReq = if isV5_6 (pipe_version pipe) + then RequestDiscard (fromList ["n" =: (-1 :: Int)]) + else RequestDiscardAll + liftE $ do flush pipe discardReq + void $ fetch pipe -- |Runs Cypher query and ignores response query_ :: MonadIO m => HasCallStack => Text -> BoltActionT m () @@ -78,11 +83,16 @@ querySL strict cypher params = do keys <- pullKeys cypher params empty pullKeys :: MonadIO m => HasCallStack => Text -> Map Text Value -> Map Text Value -> BoltActionT m [Text] pullKeys cypher params ext = do pipe <- ask status <- sendRequest cypher params ext - liftE $ flush pipe RequestPullAll + let pullReq = if isV5_6 (pipe_version pipe) + then RequestPull (fromList ["n" =: (-1 :: Int)]) + else RequestPullAll + liftE $ flush pipe pullReq mkKeys status where mkKeys :: MonadIO m => Response -> BoltActionT m [Text] - mkKeys (ResponseSuccess response) = response `at` "fields" `catchError` \(RecordHasNoKey _) -> pure [] + mkKeys (ResponseSuccess response) = response `at` "fields" `catchError` \case + RecordHasNoKey _ -> pure [] + e -> throwError e mkKeys x = throwError $ ResponseError (mkFailure x) pullRecords :: MonadIO m => HasCallStack => Bool -> [Text] -> BoltActionT m [Record] @@ -121,6 +131,7 @@ sendRawRequest req = do sendRequest :: MonadIO m => HasCallStack => Text -> Map Text Value -> Map Text Value -> BoltActionT m Response sendRequest cypher params ext = do pipe <- ask - if isNewVersion (pipe_version pipe) - then sendRawRequest $ RequestRunV3 cypher params ext + if isV3 (pipe_version pipe) + then let nExtra = notifExtra (pipe_version pipe) (pipeNotificationsMinimumSeverity pipe) (pipeNotificationsDisabledCategories pipe) + in sendRawRequest $ RequestRunV3 cypher params (ext `union` nExtra `union` dbExtra (pipeDatabase pipe)) else sendRawRequest $ RequestRun cypher params diff --git a/src/Database/Bolt/Connection/Instances.hs b/src/Database/Bolt/Connection/Instances.hs index bec4c91..601868e 100644 --- a/src/Database/Bolt/Connection/Instances.hs +++ b/src/Database/Bolt/Connection/Instances.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-orphans -Wwarn=incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} @@ -9,24 +9,37 @@ import Database.Bolt.Connection.Type import Database.Bolt.Value.Helpers import Database.Bolt.Value.Type -import Control.Monad.Except (MonadError (..)) -import Data.Map.Strict (Map, insert, fromList, empty, (!)) -import Data.Text (Text) -import GHC.Stack (HasCallStack) +import Control.Monad.Except (MonadError (..)) +import Data.Map.Strict (Map, empty, fromList, insert, union) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Version (showVersion) +import Data.Word (Word32) +import GHC.Stack (HasCallStack) +import System.Info (arch, compilerName, compilerVersion, os) instance ToStructure Request where - toStructure RequestInit{..} = Structure sigInit $ if isHello then [M $ helloMap agent token] - else [T agent, M $ tokenMap token] - toStructure RequestRun{..} = Structure sigRun [T statement, M parameters] - toStructure RequestRunV3{..} = Structure sigRun [T statement, M parameters, M extra] - toStructure RequestReset = Structure sigReset [] - toStructure RequestAckFailure = Structure sigAFail [] - toStructure RequestPullAll = Structure sigPAll [] - toStructure RequestDiscardAll = Structure sigDAll [] - toStructure RequestGoodbye = Structure sigGBye [] - toStructure RequestBegin{..} = Structure sigBegin [M extra] - toStructure RequestCommit = Structure sigCommit [] - toStructure RequestRollback = Structure sigRollback [] + toStructure RequestInit{..} = Structure sigInit $ + if isV3 initVersion + then [M $ helloMap agent token initVersion initRouting] + else [T agent, M $ tokenMap token] + toStructure RequestRun{..} = Structure sigRun [T statement, M parameters] + toStructure RequestRunV3{..} = Structure sigRun [T statement, M parameters, M extra] + toStructure RequestReset = Structure sigReset [] + toStructure RequestAckFailure = Structure sigAFail [] + toStructure RequestPullAll = Structure sigPAll [] + toStructure RequestDiscardAll = Structure sigDAll [] + toStructure RequestGoodbye = Structure sigGBye [] + toStructure RequestBegin{..} = Structure sigBegin [M extra] + toStructure RequestCommit = Structure sigCommit [] + toStructure RequestRollback = Structure sigRollback [] + toStructure RequestLogon{..} = Structure sigLogon [M (tokenMap logonToken)] + toStructure RequestLogoff = Structure sigLogoff [] + toStructure RequestTelemetry{..} = Structure sigTelemetry [I telemetryApi] + toStructure RequestPull{..} = Structure sigPAll [M pullExtra] + toStructure RequestDiscard{..} = Structure sigDAll [M discardExtra] + toStructure RequestRoute{..} = Structure sigRoute [M routeContext, L (map T routeBookmarks), M routeExtra] instance FromStructure Response where fromStructure Structure{..} @@ -49,44 +62,82 @@ isFailure :: Response -> Bool isFailure (ResponseFailure _) = True isFailure _ = False -isIgnored :: Response -> Bool -isIgnored ResponseIgnored = True -isIgnored _ = False - -isRecord :: Response -> Bool -isRecord (ResponseRecord _) = True -isRecord _ = False - -- Helper functions -createInit :: BoltCfg -> Request -createInit BoltCfg{..} = RequestInit userAgent - AuthToken { scheme = authType - , principal = user - , credentials = password - } - (isNewVersion version) - -createRun :: Text -> Request -createRun stmt = RequestRun stmt empty - - -helloMap :: Text -> AuthToken -> Map Text Value -helloMap a = insert "user_agent" (T a) . tokenMap - +createInit :: BoltCfg -> Word32 -> Maybe (Map Text Value) -> Request +createInit BoltCfg{..} serverVer mRouting = RequestInit userAgent + AuthToken { scheme = authType + , principal = user + , credentials = password + } + serverVer + mRouting + +createAuthToken :: BoltCfg -> AuthToken +createAuthToken BoltCfg{..} = AuthToken { scheme = authType + , principal = user + , credentials = password + } + +-- |Build the extras map for a HELLO message. +-- +-- * BOLT v3:: includes @user_agent@ and inline authentication credentials. +-- * BOLT v5.6+: includes @user_agent@ and optional @routing@ context, but omits +-- credentials (authentication is handled by a separate LOGON message), +-- and additionally includes @bolt_agent@ with a structured product identifier. +helloMap :: Text -> AuthToken -> Word32 -> Maybe (Map Text Value) -> Map Text Value +helloMap userAgent authToken serverVersion mRouting + | isV5_6 serverVersion = + let base = fromList + [ "user_agent" =: userAgent + , "bolt_agent" =: (fromList + [ "product" =: userAgent + , "platform" =: (arch <> "-" <> os) + , "language" =: ("Haskell/2010" :: Text) + , "language_details" =: (compilerName <> "-" <> showVersion compilerVersion) + ]) + ] + in case mRouting of + Just ctx -> insert "routing" (M ctx) base + Nothing -> base + | otherwise = insert "user_agent" (T userAgent) (tokenMap authToken) + +-- |Credentials for @HELLO@ message in BOLT v3 protocol. tokenMap :: AuthToken -> Map Text Value tokenMap at = fromList [ "scheme" =: scheme at , "principal" =: principal at , "credentials" =: credentials at ] +-- |For BOLT v5.6+: map with @notifications_minimum_severity@ and +-- @notifications_disabled_classifications@ parameters. +notifExtra :: Word32 -> Maybe Text -> [Text] -> Map Text Value +notifExtra ver msev disabled + | not (isV5_6 ver) = empty + | otherwise = + let sevEntry = case msev of + Just s -> fromList ["notifications_minimum_severity" =: s] + Nothing -> empty + disKey = "notifications_disabled_classifications" + disEntry = if null disabled then empty + else fromList [(disKey, L (map T disabled))] + in sevEntry `union` disEntry + +-- | Build the routing context map from a 'BoltCfg'. +routingContext :: BoltCfg -> Map Text Value +routingContext cfg = fromList ["address" =: (T.pack (host cfg) <> ":" <> T.pack (show (port cfg)))] + +-- | Build the @db@ extra map from an optional database name. +dbExtra :: Maybe Text -> Map Text Value +dbExtra = maybe empty (\db -> fromList ["db" =: db]) + extractMap :: MonadError UnpackError m => [Value] -> m (Map Text Value) extractMap [M mp] = pure mp extractMap _ = throwError NotDict mkFailure :: Response -> ResponseError mkFailure ResponseFailure{..} = - let (T code) = failMap ! "code" - (T msg) = failMap ! "message" + let code = case M.lookup "code" failMap of { Just (T c) -> c; _ -> "" } + msg = case M.lookup "message" failMap of { Just (T m) -> m; _ -> "" } in KnownResponseFailure code msg mkFailure _ = UnknownResponseFailure diff --git a/src/Database/Bolt/Connection/Pipe.hs b/src/Database/Bolt/Connection/Pipe.hs index f2104bc..e9520d6 100644 --- a/src/Database/Bolt/Connection/Pipe.hs +++ b/src/Database/Bolt/Connection/Pipe.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Database.Bolt.Connection.Pipe where @@ -10,9 +11,10 @@ import Database.Bolt.Value.Helpers import Database.Bolt.Value.Instances import Database.Bolt.Value.Type (BoltValue (pack, unpackT), FromStructure (fromStructure), - ToStructure (toStructure), unpackAction) + ToStructure (toStructure), Value, + unpackAction, (=:)) -import Control.Exception (throwIO) +import Control.Exception (SomeException, catch, throwIO) import Control.Monad (forM_, unless, void, when) import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) import Control.Monad.Trans (MonadIO (..)) @@ -23,25 +25,37 @@ import qualified Data.ByteString as B (concat, length) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Internal as BSL import Data.Int (Int64) -import Data.Word (Word16) +import Data.Map.Strict (Map, fromList) +import Data.Text (Text) +import Data.Word (Word16, Word32) import GHC.Stack (HasCallStack) type MonadPipe m = (MonadIO m, MonadError BoltError m) -- |Creates new 'Pipe' instance to use all requests through connect :: MonadIO m => HasCallStack => BoltCfg -> m Pipe -connect = makeIO connect' +connect cfg = connectWithRouting cfg Nothing + +-- |Like 'connect' but passes routing context in HELLO. +connectWithRouting :: MonadIO m => HasCallStack => BoltCfg -> Maybe (Map Text Value) -> m Pipe +connectWithRouting cfg mRouting = makeIO connectWithRouting' cfg where - connect' :: MonadPipe m => BoltCfg -> m Pipe - connect' bcfg = do conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg) (socketTimeout bcfg) - let pipe = Pipe conn (maxChunkSize bcfg) (version bcfg) - handshake pipe bcfg - pure pipe + connectWithRouting' :: MonadPipe m => BoltCfg -> m Pipe + connectWithRouting' bcfg = do + conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg) (socketTimeout bcfg) + let pipe = Pipe conn (maxChunkSize bcfg) 0 + (notifMinSeverity bcfg) (notifDisabledClass bcfg) + (database bcfg) + handshake pipe bcfg mRouting -- |Closes 'Pipe' close :: MonadIO m => HasCallStack => Pipe -> m () -close pipe = do when (isNewVersion $ pipe_version pipe) $ makeIO (`flush` RequestGoodbye) pipe - C.close $ connection pipe +close pipe = liftIO $ do + makeIO (`flush` RequestGoodbye) pipe `catch` ignoreAll + C.close $ connection pipe + where + ignoreAll :: SomeException -> IO () + ignoreAll _ = pure () -- |Resets current sessions reset :: MonadIO m => HasCallStack => Pipe -> m () @@ -64,16 +78,13 @@ makeIO action arg = do actionIO <- runExceptT (action arg) -- |Processes error via ackFailure or reset processError :: MonadIO m => HasCallStack => Pipe -> m () -processError pipe@Pipe{..} = if isNewVersion pipe_version +processError pipe@Pipe{..} = if isV3 pipe_version then reset pipe else makeIO ackFailure pipe ackFailure :: MonadPipe m => HasCallStack => Pipe -> m () ackFailure pipe = flush pipe RequestAckFailure >> void (fetch pipe) -discardAll :: MonadPipe m => HasCallStack => Pipe -> m () -discardAll pipe = flush pipe RequestDiscardAll >> void (fetch pipe) - flush :: MonadPipe m => HasCallStack => Pipe -> Request -> m () flush pipe request = do forM_ chunks $ C.sendMany conn . mkChunk C.send conn terminal @@ -106,20 +117,58 @@ fetch pipe = do bs <- chunks -- Helper functions -handshake :: MonadPipe m => HasCallStack => Pipe -> BoltCfg -> m () -handshake pipe bcfg = do let conn = connection pipe - C.send conn (encodeStrict $ magic bcfg) - C.send conn (boltVersionProposal bcfg) - serverVersion <- decode <$> recvChunk conn 4 - when (serverVersion /= version bcfg) $ - throwError UnsupportedServerVersion - flush pipe (createInit bcfg) - response <- fetch pipe - unless (isSuccess response) $ - throwError AuthentificationFailed - +-- |Perform the BOLT handshake: version negotiation, authentication, and session init. +-- +-- The flow differs by protocol version: +-- +-- __All versions:__ send magic preamble and version proposal, receive negotiated version. +-- +-- __BOLT v3:__ send @HELLO@ with @user_agent@ and inline credentials (@scheme@, +-- @principal@, @credentials@). A single @SUCCESS@ completes authentication. +-- +-- __BOLT v5.6+:__ send @HELLO@ with @user_agent@ (and optional @routing@ context, +-- @bolt_agent@ from v5.3) but /without/ credentials. Then send a separate @LOGON@ +-- message carrying the credentials. Both must return @SUCCESS@. +-- +-- When the client proposes v5+, a fallback to v3 is also offered in the version +-- proposal so the server can downgrade if it doesn't support v5. +-- +-- BOLT v2, v4 and versions of BOLT 5 lower than 5.6 are not supported. +handshake :: MonadPipe m => HasCallStack => Pipe -> BoltCfg -> Maybe (Map Text Value) -> m Pipe +handshake pipe bcfg mRouting = do let conn = connection pipe + C.send conn (encodeStrict $ magic bcfg) + C.send conn (boltVersionProposal bcfg) + + serverVersion <- decode <$> recvChunk conn 4 + unless (versionAccepted serverVersion) $ + throwError UnsupportedServerVersion + + let pipe' = pipe { pipe_version = serverVersion } + flush pipe' (createInit bcfg serverVersion mRouting) + + response <- fetch pipe' + + unless (isSuccess response) $ + throwError AuthentificationFailed + + when (isV5_6 serverVersion) $ do + flush pipe' (RequestLogon (createAuthToken bcfg)) + logonResp <- fetch pipe' + unless (isSuccess logonResp) $ + throwError AuthentificationFailed + + pure pipe' + +-- |Check if server version is acceptable given our supported range. +versionAccepted :: Word32 -> Bool +versionAccepted server = server /= 0 && (server == 3 || isV5_6 server) + +-- | Propose default version from 'BoltCfg' instance, but also propose version 3 +-- to support old servers. +-- +-- Routing connection will fail if server negotiates version lower than 5.6. boltVersionProposal :: BoltCfg -> ByteString -boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] +boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 3, 0, 0 :: Word32] recvChunk :: MonadPipe m => HasCallStack => ConnectionWithTimeout -> Word16 -> m BSL.ByteString recvChunk conn size = helper (fromIntegral size) diff --git a/src/Database/Bolt/Connection/RouterPool.hs b/src/Database/Bolt/Connection/RouterPool.hs new file mode 100644 index 0000000..77980c6 --- /dev/null +++ b/src/Database/Bolt/Connection/RouterPool.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- A connection pool for Neo4j clusters that automatically discovers cluster +-- topology via the BOLT routing protocol and manages pooled connections to +-- individual servers. +-- +-- == Usage +-- +-- @ +-- import Database.Bolt (BoltCfg(..), BoltActionT) +-- import Database.Bolt.Connection.RouterPool +-- import Data.Default (def) +-- +-- main :: IO () +-- main = do +-- let cfg = def { rpcBoltCfg = def { host = \"neo4j-core-1\", port = 7687 +-- , user = \"neo4j\", password = \"secret\" } } +-- pool <- connectRouterPool cfg +-- -- Write query (routed to a writer) +-- runRouterPool pool $ query \"CREATE (n:Person {name: \$name})\" (props [\"name\" =: \"Alice\"]) +-- -- Read query (routed to a reader replica) +-- records <- runRouterPoolRead pool $ query \"MATCH (n:Person) RETURN n\" mempty +-- closeRouterPool pool +-- @ +-- +-- == Configuration +-- +-- Use 'RouterPoolCfg' (has a 'Default' instance) to control pool behaviour: +-- +-- * 'rpcBoltCfg' — the 'BoltCfg' used for all connections. The @host@ and @port@ +-- serve as the bootstrap address for initial topology discovery. +-- * 'rpcMaxPerServer' — soft cap on connections per server (default 10). Excess +-- pipes are closed on release rather than returned to the idle list. +-- * 'rpcIdleTimeout' — seconds before an idle pipe is reaped (default 30). +-- * 'rpcReapInterval' — seconds between background reaper sweeps (default 10). +-- +-- == Caveats +-- +-- * Requires BOLT v5+ (the pool sends @ROUTE@ requests for topology discovery). +-- * The bootstrap address must be reachable at pool creation time; if the initial +-- @ROUTE@ request fails, 'connectRouterPool' throws immediately. +-- * In-use pipes are not closed by 'closeRouterPool' — they are closed when the +-- 'BoltActionT' that holds them completes (successfully or not). +-- * Routing table refresh failures are silently ignored; the pool continues with +-- the stale table until the next refresh attempt succeeds. +-- +-- == Internals +-- +-- The pool maintains a 'Map' from 'ServerAddress' to per-server state (idle pipe +-- list and in-use count). Pipe acquisition uses __least-connections__ selection +-- with __round-robin tie-breaking__: the eligible server list is rotated by a +-- monotonically increasing index before sorting by in-use count, so servers with +-- equal load are picked in round-robin order. +-- +-- On connect failure during acquisition, the pool falls back through the ranked +-- server list, shifting the in-use reservation from the failed server to the next +-- candidate. Async exceptions are always re-thrown immediately. +-- +-- A background __reaper__ thread periodically closes idle pipes that have exceeded +-- 'rpcIdleTimeout'. Routing table __refresh__ is triggered on each 'acquirePipe' +-- when the TTL has expired, with a non-blocking lock so that at most one thread +-- fetches a new table while others proceed with the current (stale) table. +-- When a new routing table arrives, the pool reconciles its server map: pipes to +-- removed servers are closed, new servers get empty pools, and existing servers +-- retain their pipes. +module Database.Bolt.Connection.RouterPool + ( RouterPool + , RouterPoolCfg(..) + , connectRouterPool, closeRouterPool + , runRouterPool, runRouterPoolE + , runRouterPoolRead, runRouterPoolReadE + , getRoutingTable + -- * Internals exported for testing + , isConnectionError + , reconcileState + , PoolState(..), ServerPool(..), IdlePipe(..) + ) where + +import Database.Bolt.Connection (runE, sendRawRequest) +import Database.Bolt.Connection.Instances (dbExtra, routingContext) +import Database.Bolt.Connection.Pipe (close, connectWithRouting) +import Database.Bolt.Connection.RoutingTable +import Database.Bolt.Connection.Type + +import Database.Bolt.Value.Helpers (isV5_6) +import Database.Bolt.Value.Type (Value) + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, cancel) +import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, takeMVar, + tryPutMVar, withMVar) +import Control.Exception (IOException, SomeAsyncException, SomeException, + bracket, finally, fromException, onException, + throwIO, tryJust) +import Control.Monad (forM_, when) +import Control.Monad.Catch (MonadMask) +import qualified Control.Monad.Catch as MC (generalBracket, ExitCase(..)) +import Control.Monad.Trans (MonadIO (..)) +import Data.Containers.ListUtils (nubOrd) +import Data.Default (Default (..)) +import Data.List (partition, sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime) +import GHC.Stack (HasCallStack) + +-- | Connection pool for Neo4j cluster routing with least-connections selection. +data RouterPool = RouterPool + { rpPoolCfg :: RouterPoolCfg + , rpRoutingCtx :: Map Text Value + -- ^ Routing context sent in HELLO and ROUTE requests, built from the + -- initial 'BoltCfg' (contains @"address"@ key with @host:port@). + -- Immutable for the lifetime of the pool. + , rpState :: MVar PoolState + , rpRefreshLock :: MVar () + -- ^ empty = available; full = a thread is refreshing the routing table + , rpReaper :: Async () + } + +data PoolState = PoolState + { psServers :: Map ServerAddress ServerPool + , psTable :: RoutingTable + , psRRIndex :: !Int + -- ^ incremented each acquire; rotates the server list before + -- sorting by spInUse so equal-count servers are picked in + -- round-robin order + } + +data ServerPool = ServerPool + { spIdle :: [IdlePipe] + -- ^ idle pipes, most-recently-used first + , spInUse :: !Int + -- ^ count of checked-out pipes + } + +data IdlePipe = IdlePipe + { ipPipe :: !Pipe + , ipIdleSince :: !UTCTime + } + +-- | Configuration for 'RouterPool'. +data RouterPoolCfg = RouterPoolCfg + { rpcBoltCfg :: BoltCfg + , rpcIdleTimeout :: Double + -- ^ Idle timeout in seconds (default 30) + , rpcMaxPerServer :: Int + -- ^ Max connections per server (default 10, soft limit) + , rpcReapInterval :: Int + -- ^ Seconds between reaper runs (default 10) + } + +instance Default RouterPoolCfg where + def = RouterPoolCfg + { rpcBoltCfg = def + , rpcIdleTimeout = 30 + , rpcMaxPerServer = 10 + , rpcReapInterval = 10 + } + +emptyServerPool :: ServerPool +emptyServerPool = ServerPool { spIdle = [], spInUse = 0 } + +-- | Connect to a Neo4j cluster and create a router pool. +connectRouterPool :: (MonadIO m, HasCallStack) => RouterPoolCfg -> m RouterPool +connectRouterPool poolCfg@RouterPoolCfg{..} = liftIO $ do + let cfg = rpcBoltCfg + routingCtx = routingContext cfg + + -- Bootstrap: get initial routing table + bootstrapPipe <- connectWithRouting cfg (Just routingCtx) + + -- ROUTE message requires BOLT v4.3+; fail clearly if server negotiated older version. + -- We check for 5.6+, because we do not support older versions anyway. + when (not (isV5_6 (pipe_version bootstrapPipe))) $ do + close bootstrapPipe + throwIO $ RoutingError "hasbolt supports Router pool with BOLT v5.6+ but server negotiated an older version" + + rtResult <- runE bootstrapPipe $ + sendRawRequest (RequestRoute routingCtx [] (dbExtra (database cfg))) + + -- Close the bootstrap pipe — the pool creates connections on demand + close bootstrapPipe + + case rtResult of + Left err -> throwIO err + Right resp -> do + now <- getCurrentTime + case parseRoutingTable now (succMap resp) of + Left msg -> throwIO (RoutingError msg) + Right table -> do + let allAddrs = nubOrd (rtReaders table <> rtWriters table <> rtRouters table) + servers = M.fromList [(addr, emptyServerPool) | addr <- allAddrs] + ps = PoolState { psServers = servers, psTable = table, psRRIndex = 0 } + + stVar <- newMVar ps + refreshLock <- newEmptyMVar + reaper <- async (reaperLoop poolCfg stVar) + + pure RouterPool + { rpPoolCfg = poolCfg + , rpRoutingCtx = routingCtx + , rpState = stVar + , rpRefreshLock = refreshLock + , rpReaper = reaper + } + +-- | Get the current routing table from the pool. +getRoutingTable :: MonadIO m => RouterPool -> m RoutingTable +getRoutingTable RouterPool{..} = liftIO $ withMVar rpState (pure . psTable) + +-- | Close a router pool. Cancels the reaper thread and closes all idle pipes. +-- In-use pipes cannot be closed here; they will be closed when released. +closeRouterPool :: MonadIO m => RouterPool -> m () +closeRouterPool RouterPool{..} = liftIO $ do + cancel rpReaper + let distantPast = UTCTime (toEnum 0) 0 -- 1858-11-17, always expired + emptyPS = PoolState { psServers = M.empty + , psTable = RoutingTable [] [] [] 0 distantPast + , psRRIndex = 0 + } + + old <- modifyMVar rpState $ \ps -> pure (emptyPS, ps) + + -- Close all idle pipes outside the lock + forM_ (M.elems (psServers old)) $ \sp -> + forM_ (spIdle sp) $ \ip -> + close (ipPipe ip) + +-- | Run a 'BoltActionT' on a writer pipe from the pool. +runRouterPool :: (MonadIO m, MonadMask m, HasCallStack) => RouterPool -> BoltActionT m a -> m a +runRouterPool rp action = do + result <- runRouterPoolE rp action + case result of + Right x -> pure x + Left e -> liftIO $ throwIO e + +-- | Run a 'BoltActionT' on a writer pipe, returning errors as 'Left'. +runRouterPoolE :: (MonadIO m, MonadMask m) => RouterPool -> BoltActionT m a -> m (Either BoltError a) +runRouterPoolE rp action = runPoolAction rp WriteMode action + +-- | Run a 'BoltActionT' on a reader pipe from the pool. +runRouterPoolRead :: (MonadIO m, MonadMask m, HasCallStack) => RouterPool -> BoltActionT m a -> m a +runRouterPoolRead rp action = do + result <- runRouterPoolReadE rp action + case result of + Right x -> pure x + Left e -> liftIO $ throwIO e + +-- | Run a 'BoltActionT' on a reader pipe, returning errors as 'Left'. +runRouterPoolReadE :: (MonadIO m, MonadMask m) => RouterPool -> BoltActionT m a -> m (Either BoltError a) +runRouterPoolReadE rp action = runPoolAction rp ReadMode action + +-- Internal helpers + +-- | Run a BoltActionT with proper pipe lifecycle management. +-- On success or application error: pipe is returned to the pool. +-- On connection error or exception: pipe is destroyed. +runPoolAction :: (MonadIO m, MonadMask m) => RouterPool -> AccessMode -> BoltActionT m a -> m (Either BoltError a) +runPoolAction rp mode action = do + (result, _) <- MC.generalBracket + (liftIO $ acquirePipe rp mode) + (\(pipe, addr) exitCase -> liftIO $ case exitCase of + MC.ExitCaseSuccess (Right _) -> releasePipe rp addr pipe + MC.ExitCaseSuccess (Left err) + | isConnectionError err -> destroyPipe rp addr pipe + | otherwise -> releasePipe rp addr pipe + _ -> destroyPipe rp addr pipe) + (\(pipe, _) -> runE pipe action) + pure result + +-- | Acquire a pipe using least-connections selection with round-robin tie-breaking. +-- +-- 1. Refresh the routing table if expired (see 'maybeRefresh'). +-- 2. Under rpState: pick the best server (fewest in-use connections, rotated by +-- round-robin index). If it has an idle pipe, take it; otherwise reserve a +-- slot (bump spInUse) and release the lock. +-- 3. Outside the lock: connect to the best server. On failure, fall back through +-- the ranked list, adjusting counters under rpState between attempts. +acquirePipe :: RouterPool -> AccessMode -> IO (Pipe, ServerAddress) +acquirePipe rp@RouterPool{..} mode = do + maybeRefresh rp + + result <- modifyMVar rpState $ \ps -> do + let eligible = case mode of + WriteMode -> rtWriters (psTable ps) + ReadMode -> rtReaders (psTable ps) + + when (null eligible) $ + throwIO $ NoServersAvailable mode + + -- Rotate eligible list by round-robin index before sorting, so that + -- servers with equal spInUse are visited in round-robin order. + let n = length eligible + idx = psRRIndex ps `mod` max 1 n + rotated = drop idx eligible <> take idx eligible + ranked = sortOn (\addr -> maybe 0 spInUse (M.lookup addr (psServers ps))) rotated + ps1 = ps { psRRIndex = psRRIndex ps + 1 } + + pickFromRanked ps1 ranked + + case result of + Right (pipe, addr) -> pure (pipe, addr) + Left addrs -> connectWithFallback addrs + where + -- Under the lock: try to grab an idle pipe from the best server. + -- If none available, reserve a slot (bump spInUse) and return the ranked + -- address list so the caller can connect outside the lock with fallback. + pickFromRanked ps ranked = + case ranked of + [] -> throwIO $ NoServersAvailable mode + (best:_) -> + case M.lookup best (psServers ps) of + Just sp | (ip:rest) <- spIdle sp -> do + -- Found an idle pipe on the best server + let sp' = sp { spIdle = rest, spInUse = spInUse sp + 1 } + ps' = ps { psServers = M.insert best sp' (psServers ps) } + + pure (ps', Right (ipPipe ip, best)) + _ -> do + -- No idle pipe - reserve a slot on the best server, return full + -- ranked list so caller can fall back to others on connect failure. + let sp = M.findWithDefault emptyServerPool best (psServers ps) + sp' = sp { spInUse = spInUse sp + 1 } + ps' = ps { psServers = M.insert best sp' (psServers ps) } + + pure (ps', Left ranked) + + -- Connect outside the lock, falling back through ranked servers. + -- The first server already has its spInUse bumped from pickFromRanked. + -- On failure: decrement the failed server's count and bump the next one. + connectWithFallback [] = throwIO $ NoServersAvailable mode + connectWithFallback [addr] = do + -- Last server: no fallback, just throw on failure (slot already reserved) + pipe <- openSinglePipeIO (rpcBoltCfg rpPoolCfg) rpRoutingCtx addr + `onException` decrementInUse addr + pure (pipe, addr) + connectWithFallback (addr:rest@(next:_)) = do + connectResult <- tryJust syncException (openSinglePipeIO (rpcBoltCfg rpPoolCfg) rpRoutingCtx addr) + case connectResult of + Right pipe -> pure (pipe, addr) + Left _ -> do + -- Shift the reservation: decrement failed, bump next + modifyMVar rpState $ \ps -> do + let ps' = adjustServer addr decrementSP $ + adjustServer next bumpSP ps + pure (ps', ()) + connectWithFallback rest + + decrementInUse addr = + modifyMVar rpState $ \ps -> do + let ps' = adjustServer addr decrementSP ps + pure (ps', ()) + + adjustServer addr f ps = + ps { psServers = M.adjust f addr (psServers ps) } + + decrementSP sp = sp { spInUse = max 0 (spInUse sp - 1) } + bumpSP sp = sp { spInUse = spInUse sp + 1 } + +-- | Return a pipe to the idle list (or close it if excess). +releasePipe :: RouterPool -> ServerAddress -> Pipe -> IO () +releasePipe RouterPool{..} addr pipe = do + now <- getCurrentTime + excess <- modifyMVar rpState $ \ps -> do + case M.lookup addr (psServers ps) of + Nothing -> do + -- Server was removed from routing table; close the pipe + pure (ps, True) + Just sp -> do + let inUse' = max 0 (spInUse sp - 1) + totalAfter = length (spIdle sp) + 1 + inUse' + if totalAfter > rpcMaxPerServer rpPoolCfg + then do + -- Excess pipe - just decrement inUse, mark for close + let sp' = sp { spInUse = inUse' } + pure (ps { psServers = M.insert addr sp' (psServers ps) }, True) + else do + -- Return to idle list (MRU order: prepend) + let ip = IdlePipe { ipPipe = pipe, ipIdleSince = now } + sp' = sp { spIdle = ip : spIdle sp, spInUse = inUse' } + pure (ps { psServers = M.insert addr sp' (psServers ps) }, False) + when excess $ close pipe + +-- | Destroy a broken pipe (decrement inUse, close outside lock). +destroyPipe :: RouterPool -> ServerAddress -> Pipe -> IO () +destroyPipe RouterPool{..} addr pipe = do + modifyMVar rpState $ \ps -> do + let servers' = M.adjust (\sp -> sp { spInUse = max 0 (spInUse sp - 1) }) addr (psServers ps) + pure (ps { psServers = servers' }, ()) + close pipe + +-- | Background reaper thread that closes idle pipes past the timeout. +reaperLoop :: RouterPoolCfg -> MVar PoolState -> IO () +reaperLoop RouterPoolCfg{..} stVar = go + where + go = do + threadDelay (rpcReapInterval * 1000000) + _ <- tryJust syncException reapOnce + go + + reapOnce = do + expired <- modifyMVar stVar $ \ps -> do + now <- getCurrentTime + let cutoff = realToFrac rpcIdleTimeout + (collected, servers') = M.mapAccumWithKey (reapServer now cutoff) [] (psServers ps) + pure (ps { psServers = servers' }, collected) + + -- Close expired pipes outside the lock + forM_ expired $ \ip -> close (ipPipe ip) + + reapServer now cutoff acc _addr sp = + let (keep, expired) = partition (\ip -> diffUTCTime now (ipIdleSince ip) < cutoff) (spIdle sp) + in (acc ++ expired, sp { spIdle = keep }) + +-- | Refresh the routing table if its TTL has expired. +-- +-- Concurrency design: +-- * rpRefreshLock (MVar): at most one thread fetches a new table at a time. +-- Other threads that see an expired table will skip the refresh and proceed +-- with the current (stale) table — the refreshing thread's update will be +-- visible on their next acquirePipe call. +-- * rpState (MVar): held only briefly for reads and reconciliation, never +-- during network I/O, so other threads can continue acquiring pipes. +maybeRefresh :: RouterPool -> IO () +maybeRefresh RouterPool{..} = do + -- Check TTL without blocking other threads for long + now <- getCurrentTime + needsRefresh <- withMVar rpState $ \ps -> + pure (isExpired now (psTable ps)) + + when needsRefresh $ do + -- Non-blocking: if another thread is already refreshing, we skip rather + -- than wait. The stale table is still usable (servers don't vanish + -- instantly), and blocking all acquirePipe callers on a network fetch + -- would add latency for no benefit. The refreshed table will be picked + -- up on subsequent calls. + acquired <- tryPutMVar rpRefreshLock () + when acquired $ flip finally (takeMVar rpRefreshLock) $ do + routers <- withMVar rpState $ \ps -> pure (rtRouters (psTable ps)) + -- Network I/O — no locks held, other threads freely acquire pipes + mbNewTable <- tryJust syncException (fetchRoutingTable (rpcBoltCfg rpPoolCfg) rpRoutingCtx routers) + case mbNewTable of + Left _ -> pure () -- sync failure: proceed with stale table + Right newTable -> do + pipesToClose <- modifyMVar rpState $ \ps -> do + -- Re-check expiry: another thread may have refreshed while we + -- were fetching (shouldn't happen with the lock, but defensive) + now' <- getCurrentTime + if not (isExpired now' (psTable ps)) + then pure (ps, []) + else do + let (ps', removed) = reconcileState ps newTable + pure (ps', removed) + -- Close removed pipes outside the lock + forM_ pipesToClose $ \ip -> close (ipPipe ip) + +-- | Reconcile pool state with a new routing table. +-- Returns updated state and list of idle pipes from removed servers to close. +reconcileState :: PoolState -> RoutingTable -> (PoolState, [IdlePipe]) +reconcileState ps newTable = + let newAddrList = nubOrd (rtReaders newTable <> rtWriters newTable <> rtRouters newTable) + newAddrSet = M.fromList [(a, ()) | a <- newAddrList] + keptServers = M.intersectionWith (\sp _ -> sp) (psServers ps) newAddrSet + newServers = M.fromList [(a, emptyServerPool) | a <- newAddrList, not (M.member a (psServers ps))] + removedServers = M.difference (psServers ps) newAddrSet + removedPipes = concatMap spIdle (M.elems removedServers) + + ps' = PoolState + { psServers = M.union keptServers newServers + , psTable = newTable + , psRRIndex = psRRIndex ps + } + + in (ps', removedPipes) + +-- | Fetch a new routing table by trying each router in sequence. +-- Each attempt opens an ephemeral pipe, sends RequestRoute, and closes the pipe. +-- No pool locks are held — this is pure network I/O. +fetchRoutingTable :: BoltCfg -> Map Text Value -> [ServerAddress] -> IO RoutingTable +fetchRoutingTable cfg routingCtx routers = tryRouters routers + where + tryRouters [] = throwIO RoutingTableUnavailable + tryRouters (addr:rest) = do + result <- tryJust syncException $ + bracket (openSinglePipeIO cfg routingCtx addr) close $ \pipe -> + runE pipe $ sendRawRequest (RequestRoute routingCtx [] (dbExtra (database cfg))) + case result of + Left _ -> tryRouters rest + Right (Left _) -> tryRouters rest + Right (Right resp) -> do + now <- getCurrentTime + case parseRoutingTable now (succMap resp) of + Left _ -> tryRouters rest + Right newTable -> pure newTable + +openSinglePipeIO :: BoltCfg -> Map Text Value -> ServerAddress -> IO Pipe +openSinglePipeIO cfg routingCtx ServerAddress{..} = + connectWithRouting (cfg { host = serverHost, port = serverPort }) (Just routingCtx) + +isConnectionError :: BoltError -> Bool +isConnectionError CannotReadChunk = True +isConnectionError TimeOut = True +isConnectionError (NonHasboltError e) = case fromException e of + Just (_ :: IOException) -> True + Nothing -> False +isConnectionError _ = False + +-- | 'tryJust' filter that lets async exceptions propagate and catches everything else. +syncException :: SomeException -> Maybe SomeException +syncException e = case fromException e of + Just (_ :: SomeAsyncException) -> Nothing + Nothing -> Just e diff --git a/src/Database/Bolt/Connection/RoutingTable.hs b/src/Database/Bolt/Connection/RoutingTable.hs new file mode 100644 index 0000000..b119630 --- /dev/null +++ b/src/Database/Bolt/Connection/RoutingTable.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Connection.RoutingTable + ( ServerAddress(..), AccessMode(..), RoutingTable(..) + , parseRoutingTable, parseAddress, isExpired + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) + +import Database.Bolt.Value.Type (Value(..)) + +-- | A server address consisting of host and port. +data ServerAddress = ServerAddress + { serverHost :: String + , serverPort :: Int + } deriving (Eq, Ord, Show) + +-- | Access mode for routing queries. +data AccessMode = ReadMode | WriteMode + deriving (Eq, Show) + +-- | Routing table obtained from the cluster. +data RoutingTable = RoutingTable + { rtReaders :: [ServerAddress] + , rtWriters :: [ServerAddress] + , rtRouters :: [ServerAddress] + , rtTTL :: Int -- ^ TTL in seconds + , rtExpiry :: UTCTime -- ^ creation time + TTL + } deriving (Show) + +-- | Parse a routing table from a ROUTE response map. +-- Looks for @\"rt\"@ key first (Bolt 4.4+), falls back to top-level @\"ttl\"@/@\"servers\"@ (Bolt 4.3). +parseRoutingTable :: UTCTime -> Map Text Value -> Either Text RoutingTable +parseRoutingTable now m = + case M.lookup "rt" m of + Just (M inner) -> parseInner now inner + _ -> parseInner now m + +parseInner :: UTCTime -> Map Text Value -> Either Text RoutingTable +parseInner now m = do + ttl <- case M.lookup "ttl" m of + Just (I n) -> Right n + _ -> Left "Missing or invalid 'ttl' in routing table" + servers <- case M.lookup "servers" m of + Just (L xs) -> mapM parseServerGroup xs + _ -> Left "Missing or invalid 'servers' in routing table" + let (readers, writers, routers) = partitionServers servers + if null writers + then Left "Routing table has no writers" + else Right RoutingTable + { rtReaders = readers + , rtWriters = writers + , rtRouters = routers + , rtTTL = ttl + , rtExpiry = addUTCTime (fromIntegral ttl :: NominalDiffTime) now + } + +partitionServers :: [(Text, [ServerAddress])] -> ([ServerAddress], [ServerAddress], [ServerAddress]) +partitionServers = foldr go ([], [], []) + where + go ("READ", addrs) (rs, ws, rts) = (addrs ++ rs, ws, rts) + go ("WRITE", addrs) (rs, ws, rts) = (rs, addrs ++ ws, rts) + go ("ROUTE", addrs) (rs, ws, rts) = (rs, ws, addrs ++ rts) + go (_, _ ) acc = acc + +parseServerGroup :: Value -> Either Text (Text, [ServerAddress]) +parseServerGroup (M m) = do + role <- case M.lookup "role" m of + Just (T r) -> Right r + _ -> Left "Missing 'role' in server entry" + addrs <- case M.lookup "addresses" m of + Just (L xs) -> mapM parseAddrValue xs + _ -> Left "Missing 'addresses' in server entry" + Right (role, addrs) +parseServerGroup _ = Left "Server entry is not a map" + +parseAddrValue :: Value -> Either Text ServerAddress +parseAddrValue (T t) = parseAddress t +parseAddrValue _ = Left "Address is not a text value" + +-- | Parse an address string like @\"host:port\"@ or @\"[::1]:port\"@ (IPv6). +parseAddress :: Text -> Either Text ServerAddress +parseAddress addr + | T.null addr = Left "Empty address" + | T.head addr == '[' = + -- IPv6: [host]:port + case T.breakOn "]:" (T.tail addr) of + (h, rest) + | T.null rest -> Left ("Invalid IPv6 address: " <> addr) + | otherwise -> + let portStr = T.drop 2 rest -- drop "]:" + in case readPort portStr of + Just p -> Right (ServerAddress (T.unpack h) p) + Nothing -> Left ("Invalid port in address: " <> addr) + | otherwise = + -- Regular: host:port — split on last ':' + case T.breakOnEnd ":" addr of + (_, portPart) | T.null portPart -> Left ("No port in address: " <> addr) + (hostColon, portPart) -> + case readPort portPart of + Just p -> Right (ServerAddress (T.unpack (T.dropEnd 1 hostColon)) p) + Nothing -> Left ("Invalid port in address: " <> addr) + +readPort :: Text -> Maybe Int +readPort t = case reads (T.unpack t) of + [(n, "")] | n > 0 && n <= 65535 -> Just n + _ -> Nothing + +-- | Check if a routing table has expired. +isExpired :: UTCTime -> RoutingTable -> Bool +isExpired now rt = diffUTCTime now (rtExpiry rt) >= 0 diff --git a/src/Database/Bolt/Connection/Type.hs b/src/Database/Bolt/Connection/Type.hs index 48afe81..10f3d29 100644 --- a/src/Database/Bolt/Connection/Type.hs +++ b/src/Database/Bolt/Connection/Type.hs @@ -5,10 +5,12 @@ module Database.Bolt.Connection.Type where -import Database.Bolt.Value.Type hiding (unpack) +import Database.Bolt.Connection.RoutingTable (AccessMode(..)) +import Database.Bolt.Value.Type hiding (unpack) import Control.DeepSeq (NFData(..), rwhnf) import Control.Exception (Exception (..), SomeException, handle) +import Control.Monad.Catch (MonadCatch (..), MonadThrow (..)) import Control.Monad.Trans (MonadTrans (..), MonadIO (..)) import Control.Monad.Reader (MonadReader (..), ReaderT) import Control.Monad.Except (MonadError (..), ExceptT (..)) @@ -41,25 +43,32 @@ data BoltError = UnsupportedServerVersion | ResponseError ResponseError | RecordHasNoKey Text | NonHasboltError SomeException + | RoutingTableUnavailable + | NoServersAvailable AccessMode + | RoutingError Text | HasCallStack => TimeOut instance Show BoltError where - show UnsupportedServerVersion = "Cannot connect: unsupported server version" - show AuthentificationFailed = "Cannot connect: authentification failed" - show ResetFailed = "Cannot reset current pipe: recieved failure from server" - show CannotReadChunk = "Cannot fetch: chunk read failed" - show (WrongMessageFormat msg) = "Cannot fetch: wrong message format (" <> show msg <> ")" - show NoStructureInResponse = "Cannot fetch: no structure in response" - show (ResponseError re) = show re - show (RecordHasNoKey key) = "Cannot unpack record: key '" <> unpack key <> "' is not presented" - show (NonHasboltError msg) = "User error: " <> show msg - show TimeOut = "Operation timeout\n" <> prettyCallStack callStack + show UnsupportedServerVersion = "Cannot connect: unsupported server version" + show AuthentificationFailed = "Cannot connect: authentification failed" + show ResetFailed = "Cannot reset current pipe: recieved failure from server" + show CannotReadChunk = "Cannot fetch: chunk read failed" + show (WrongMessageFormat msg) = "Cannot fetch: wrong message format (" <> show msg <> ")" + show NoStructureInResponse = "Cannot fetch: no structure in response" + show (ResponseError re) = show re + show (RecordHasNoKey key) = "Cannot unpack record: key '" <> unpack key <> "' is not presented" + show (NonHasboltError msg) = "User error: " <> show msg + show RoutingTableUnavailable = "Routing table could not be obtained from server" + show (NoServersAvailable ReadMode) = "No servers available for read operations" + show (NoServersAvailable WriteMode) = "No servers available for write operations" + show (RoutingError msg) = "Routing error: " <> unpack msg + show TimeOut = "Operation timeout\n" <> prettyCallStack callStack instance Exception BoltError -- |Monad Transformer to do all BOLT actions in newtype BoltActionT m a = BoltActionT { runBoltActionT :: ReaderT Pipe (ExceptT BoltError m) a } - deriving (Functor, Applicative, Monad, MonadError BoltError, MonadReader Pipe) + deriving (Functor, Applicative, Monad, MonadError BoltError, MonadReader Pipe, MonadThrow, MonadCatch) instance MonadTrans BoltActionT where lift = BoltActionT . lift . lift @@ -71,32 +80,38 @@ liftE :: Monad m => ExceptT BoltError m a -> BoltActionT m a liftE = BoltActionT . lift -- |Configuration of driver connection -data BoltCfg = BoltCfg { magic :: Word32 -- ^'6060B017' value - , version :: Word32 -- ^Major version number (e.g. '00000104' for 4.1) - , userAgent :: Text -- ^Driver user agent - , maxChunkSize :: Word16 -- ^Maximum chunk size of request - , socketTimeout :: Int -- ^Driver socket timeout in seconds - , host :: String -- ^Neo4j server hostname - , port :: Int -- ^Neo4j server port - , authType :: Text -- ^Neo4j auth schema - , user :: Text -- ^Neo4j user - , password :: Text -- ^Neo4j password - , secure :: Bool -- ^Use TLS or not +data BoltCfg = BoltCfg { magic :: Word32 -- ^'6060B017' value + , version :: Word32 -- ^Major version number (default 0x00020805 for 5.6 through 5.8) + , userAgent :: Text -- ^Driver user agent (default "hasbolt/1.8") + , maxChunkSize :: Word16 -- ^Maximum chunk size of request + , socketTimeout :: Int -- ^Driver socket timeout in seconds + , host :: String -- ^Neo4j server hostname + , port :: Int -- ^Neo4j server port + , authType :: Text -- ^Neo4j auth schema (@none@, @basic@, @bearer@ or @kerberos@, default: @basic). Currently only @basic@ is tested. + , user :: Text -- ^Neo4j user + , password :: Text -- ^Neo4j password + , secure :: Bool -- ^Use TLS or not + , notifMinSeverity :: Maybe Text -- ^Min notification severity: @"OFF"@, @"WARNING"@, @"INFORMATION"@ + , notifDisabledClass :: [Text] -- ^Disabled notification categories\/classifications + , database :: Maybe Text -- ^Target database name (Nothing = default) } deriving (Eq, Show, Read) instance Default BoltCfg where - def = BoltCfg { magic = 1616949271 - , version = 3 - , userAgent = "hasbolt/1.5" - , maxChunkSize = 65535 - , socketTimeout = 5 - , host = "127.0.0.1" - , port = 7687 - , authType = "basic" - , user = "" - , password = "" - , secure = False + def = BoltCfg { magic = 1616949271 + , version = 0x00020805 + , userAgent = "hasbolt/1.8" + , maxChunkSize = 65535 + , socketTimeout = 5 + , host = "127.0.0.1" + , port = 7687 + , authType = "basic" + , user = "" + , password = "" + , secure = False + , notifMinSeverity = Nothing + , notifDisabledClass = [] + , database = Nothing } data ConnectionWithTimeout @@ -106,9 +121,18 @@ data ConnectionWithTimeout -- ^ Timeout in microseconds } -data Pipe = Pipe { connection :: ConnectionWithTimeout -- ^Driver connection socket - , mcs :: Word16 -- ^Driver maximum chunk size of request - , pipe_version :: Word32 -- ^Connection version 0000mnMJ +data Pipe = Pipe { connection :: ConnectionWithTimeout + -- ^ Driver connection socket + , mcs :: Word16 + -- ^ Driver maximum chunk size of request + , pipe_version :: Word32 + -- ^ Connection version 0000mnMJ + , pipeNotificationsMinimumSeverity :: Maybe Text + -- ^ Notification minimum severity + , pipeNotificationsDisabledCategories :: [Text] + -- ^ Disabled notification categories\/classifications + , pipeDatabase :: Maybe Text + -- ^ Target database name } instance NFData Pipe where @@ -118,7 +142,12 @@ data AuthToken = AuthToken { scheme :: Text , principal :: Text , credentials :: Text } - deriving (Eq, Show) + deriving (Eq) + +instance Show AuthToken where + show at = "AuthToken {scheme = " <> show (scheme at) + <> ", principal = " <> show (principal at) + <> ", credentials = \"\"}" data Response = ResponseSuccess { succMap :: Map Text Value } | ResponseRecord { recsList :: [Value] } @@ -127,9 +156,10 @@ data Response = ResponseSuccess { succMap :: Map Text Value } deriving (Eq, Show) data Request = RequestInit - { agent :: Text - , token :: AuthToken - , isHello :: Bool + { agent :: Text + , token :: AuthToken + , initVersion :: Word32 + , initRouting :: Maybe (Map Text Value) -- ^Optional routing context for HELLO } | RequestRun { statement :: Text @@ -153,4 +183,28 @@ data Request = RequestInit | RequestCommit -- | Introduced in v3. | RequestRollback + -- | Introduced in v5.1. Sends auth credentials separately from HELLO. + | RequestLogon + { logonToken :: AuthToken + } + -- | Introduced in v5.1. + | RequestLogoff + -- | Introduced in v5.4. Reports driver API usage. + | RequestTelemetry + { telemetryApi :: Int + } + -- | Introduced in v4/v5. PULL with extra dict (e.g. @{n: -1}@). + | RequestPull + { pullExtra :: Map Text Value + } + -- | Introduced in v4/v5. DISCARD with extra dict (e.g. @{n: -1}@). + | RequestDiscard + { discardExtra :: Map Text Value + } + -- | Introduced in v4.3. Requests routing table from server. + | RequestRoute + { routeContext :: Map Text Value -- routing context dict + , routeBookmarks :: [Text] -- transaction bookmarks + , routeExtra :: Map Text Value -- e.g. @{\"db\": \"neo4j\"}@ + } deriving (Eq, Show) diff --git a/src/Database/Bolt/Lazy.hs b/src/Database/Bolt/Lazy.hs index 1a6f4b7..cfe17a7 100644 --- a/src/Database/Bolt/Lazy.hs +++ b/src/Database/Bolt/Lazy.hs @@ -1,9 +1,18 @@ +{- | Lazy API + +This module exposes various query functions that use 'System.IO.Unsafe.unsafeInterleaveIO' +to make fetching result lazy. + +When using them, do not forget to read all the records before you send a next query. + +__Important__: this is not compatible with t'Database.Bolt.RouterPool'. +-} module Database.Bolt.Lazy ( BoltActionT , BoltError (..), UnpackError (..) , connect, close, reset , run, runE, queryP, query, queryP_, query_ - , transact + , transact, transactRead , (=:), props , Pipe , BoltCfg (..) diff --git a/src/Database/Bolt/Transaction.hs b/src/Database/Bolt/Transaction.hs index f5cb41d..886cb16 100644 --- a/src/Database/Bolt/Transaction.hs +++ b/src/Database/Bolt/Transaction.hs @@ -1,48 +1,68 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Bolt.Transaction ( transact + , transactRead ) where import Control.Monad ( void ) import Control.Monad.Reader ( ask ) import Control.Monad.Trans ( MonadIO(..) ) import Control.Monad.Except ( MonadError(..) ) +import qualified Control.Monad.Catch as MC (MonadCatch, onException) -import Database.Bolt.Connection ( BoltActionT - , query', sendRawRequest - ) -import Database.Bolt.Connection.Type ( Request(..) - , pipe_version - ) -import Database.Bolt.Value.Helpers ( isNewVersion ) +import Data.Map.Strict ( Map, empty, fromList, union ) +import Data.Text ( Text ) + +import Database.Bolt.Connection ( BoltActionT + , query', sendRawRequest + ) +import Database.Bolt.Connection.Instances ( dbExtra, notifExtra ) +import Database.Bolt.Connection.Type ( Request(..) + , pipe_version, pipeNotificationsMinimumSeverity, pipeNotificationsDisabledCategories + , pipeDatabase + ) +import Database.Bolt.Value.Helpers ( isV3 ) +import Database.Bolt.Value.Type ( Value, (=:) ) -- |Runs a sequence of actions as transaction. All queries would be rolled back -- in case of any exception inside the block. -transact :: MonadIO m => BoltActionT m a -> BoltActionT m a +transact :: (MonadIO m, MC.MonadCatch m) => BoltActionT m a -> BoltActionT m a transact actions = do - txBegin - let processErrors = flip catchError $ \e -> txRollback >> throwError e - result <- processErrors actions + txBegin empty + result <- actions `MC.onException` txRollback + `catchError` \e -> txRollback >> throwError e + txCommit + pure result + +-- |Runs a sequence of actions as a read transaction. Uses @mode: \"r\"@ in BEGIN +-- to route queries to read replicas in a cluster. All queries would be rolled back +-- in case of any exception inside the block. +transactRead :: (MonadIO m, MC.MonadCatch m) => BoltActionT m a -> BoltActionT m a +transactRead actions = do + txBegin (fromList ["mode" =: ("r" :: Text)]) + result <- actions `MC.onException` txRollback + `catchError` \e -> txRollback >> throwError e txCommit pure result -txBegin :: MonadIO m => BoltActionT m () -txBegin = do +txBegin :: MonadIO m => Map Text Value -> BoltActionT m () +txBegin modeExtra = do pipe <- ask - if isNewVersion $ pipe_version pipe - then void $ sendRawRequest $ RequestBegin mempty + if isV3 $ pipe_version pipe + then let nExtra = notifExtra (pipe_version pipe) (pipeNotificationsMinimumSeverity pipe) (pipeNotificationsDisabledCategories pipe) + in void $ sendRawRequest $ RequestBegin (nExtra `union` dbExtra (pipeDatabase pipe) `union` modeExtra) else void $ query' "BEGIN" txCommit :: MonadIO m => BoltActionT m () txCommit = do pipe <- ask - if isNewVersion $ pipe_version pipe + if isV3 $ pipe_version pipe then void $ sendRawRequest RequestCommit else void $ query' "COMMIT" txRollback :: MonadIO m => BoltActionT m () txRollback = do pipe <- ask - if isNewVersion $ pipe_version pipe + if isV3 $ pipe_version pipe then void $ sendRawRequest RequestRollback else void $ query' "ROLLBACK" diff --git a/src/Database/Bolt/Value/Helpers.hs b/src/Database/Bolt/Value/Helpers.hs index aa30af1..5a90053 100644 --- a/src/Database/Bolt/Value/Helpers.hs +++ b/src/Database/Bolt/Value/Helpers.hs @@ -6,7 +6,7 @@ import Control.Applicative (liftA3) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -import Data.Bits ((.&.)) +import Data.Bits ((.&.), shiftR) import Data.Word (Word8, Word32) -- = Checkers @@ -59,11 +59,41 @@ isList = do x <- liftA2 (||) (== list8Code) (== list16Code) y <- liftA2 (||) (== list32Code) isTinyList pure $ x || y +-- |Checks whether a marker byte indicates a PackStream Bytes value (0xCC, 0xCD, 0xCE). +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +isBytes :: Word8 -> Bool +isBytes = liftA3 (\x y z -> x || y || z) (== bytes8Code) (== bytes16Code) (== bytes32Code) + isStruct :: Word8 -> Bool isStruct = liftA3 (\x y z -> x || y || z) (== struct8Code) (== struct16Code) isTinyStruct -isNewVersion :: Word32 -> Bool -isNewVersion v = (v .&. 255) >= 3 +-- Version check functions +-- +-- The negotiated BOLT protocol version is stored as a 'Word32' with the major +-- version in the low byte and the minor version in the next byte: +-- +-- @ +-- version = (minor << 8) | major +-- @ +-- +-- For example, BOLT 5.3 is stored as @0x0305@. + +-- |Checks for BOLT v3+, which introduced Hello\/Goodbye and explicit transactions. +isV3 :: Word32 -> Bool +isV3 v = (v .&. 255) >= 3 + +versionMinor :: Word32 -> Word32 +versionMinor v = (v `shiftR` 8) .&. 0xFF + +-- |Checks for BOLT v5.N+ (major > 5, or major == 5 with minor >= N). +isV5_N :: Word32 -> Word32 -> Bool +isV5_N n v = let major = v .&. 0xFF + minor = versionMinor v + in major > 5 || (major == 5 && minor >= n) + +-- |Checks for BOLT v5.6+, which is the minimal supported 5.x version. +isV5_6 :: Word32 -> Bool +isV5_6 = isV5_N 6 -- = Constants @@ -139,6 +169,23 @@ dict16Code = 217 dict32Code :: Word8 dict32Code = 218 +-- == Bytes + +-- |Marker for Bytes8: up to 2^8-1 bytes. PackStream marker 0xCC. +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +bytes8Code :: Word8 +bytes8Code = 0xCC + +-- |Marker for Bytes16: up to 2^16-1 bytes. PackStream marker 0xCD. +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +bytes16Code :: Word8 +bytes16Code = 0xCD + +-- |Marker for Bytes32: up to 2^32-1 bytes. PackStream marker 0xCE. +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +bytes32Code :: Word8 +bytes32Code = 0xCE + -- == Structure structConst :: Word8 @@ -195,6 +242,18 @@ sigPAll = 0x3f sigGBye :: Word8 sigGBye = 0x02 +-- @LOGON@, introduced in v5.1. +sigLogon :: Word8 +sigLogon = 0x6A + +-- @LOGOFF@, introduced in v5.1. +sigLogoff :: Word8 +sigLogoff = 0x6B + +-- @TELEMETRY@, introduced in v5.4. +sigTelemetry :: Word8 +sigTelemetry = 0x54 + -- @BEGIN@, introduced in v3. sigBegin :: Word8 sigBegin = 0x11 @@ -207,6 +266,10 @@ sigCommit = 0x12 sigRollback :: Word8 sigRollback = 0x13 +-- @ROUTE@, introduced in v4.3. +sigRoute :: Word8 +sigRoute = 0x66 + -- == BOLT responses signatures sigSucc :: Word8 diff --git a/src/Database/Bolt/Value/Instances.hs b/src/Database/Bolt/Value/Instances.hs index fb1f351..d950282 100644 --- a/src/Database/Bolt/Value/Instances.hs +++ b/src/Database/Bolt/Value/Instances.hs @@ -27,6 +27,10 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word import GHC.Stack (HasCallStack, callStack, prettyCallStack) +-- Note: All PackStream collection/text/bytes size fields use unsigned integer encoding +-- (getWord8, getWord16be, getWord32be). Only integer *values* use signed encoding. +-- See: https://neo4j.com/docs/bolt/current/packstream/ + instance BoltValue () where pack () = putWord8 nullCode @@ -73,9 +77,9 @@ instance BoltValue Text where unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyText m = unpackTextBySize (getSize m) - | m == text8Code = toInt <$> getInt8 >>= unpackTextBySize - | m == text16Code = toInt <$> getInt16be >>= unpackTextBySize - | m == text32Code = toInt <$> getInt32be >>= unpackTextBySize + | m == text8Code = toInt <$> getWord8 >>= unpackTextBySize + | m == text16Code = toInt <$> getWord16be >>= unpackTextBySize + | m == text32Code = toInt <$> getWord32be >>= unpackTextBySize | otherwise = failUnpack "text" m unpackTextBySize size = do str <- getByteString size pure $! decodeUtf8 str @@ -86,9 +90,9 @@ instance BoltValue a => BoltValue [a] where unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyList m = unpackListBySize (getSize m) - | m == list8Code = toInt <$> getInt8 >>= unpackListBySize - | m == list16Code = toInt <$> getInt16be >>= unpackListBySize - | m == list32Code = toInt <$> getInt32be >>= unpackListBySize + | m == list8Code = toInt <$> getWord8 >>= unpackListBySize + | m == list16Code = toInt <$> getWord16be >>= unpackListBySize + | m == list32Code = toInt <$> getWord32be >>= unpackListBySize | otherwise = failUnpack "list" m unpackListBySize size = forM [1..size] $ const unpackT @@ -99,9 +103,9 @@ instance BoltValue a => BoltValue (Map Text a) where unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyDict m = unpackDictBySize (getSize m) - | m == dict8Code = toInt <$> getInt8 >>= unpackDictBySize - | m == dict16Code = toInt <$> getInt16be >>= unpackDictBySize - | m == dict32Code = toInt <$> getInt32be >>= unpackDictBySize + | m == dict8Code = toInt <$> getWord8 >>= unpackDictBySize + | m == dict16Code = toInt <$> getWord16be >>= unpackDictBySize + | m == dict32Code = toInt <$> getWord32be >>= unpackDictBySize | otherwise = failUnpack "dict" m unpackDictBySize = (M.fromList <$>) . unpackPairsBySize unpackPairsBySize size = forM [1..size] $ const $ do @@ -109,6 +113,22 @@ instance BoltValue a => BoltValue (Map Text a) where !value <- unpackT pure (key, value) +-- |Pack\/unpack raw byte arrays using PackStream Bytes format (markers 0xCC\/0xCD\/0xCE). +-- Unlike Text\/List\/Dict, Bytes has no "tiny" variant — sizes always use an explicit length prefix. +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +instance BoltValue ByteString where + pack bs | len < size8 = putWord8 bytes8Code >> putWord8 (fromIntegral len) >> putByteString bs + | len < size16 = putWord8 bytes16Code >> putWord16be (fromIntegral len) >> putByteString bs + | len < size32 = putWord8 bytes32Code >> putWord32be (fromIntegral len) >> putByteString bs + | otherwise = error "Cannot pack so large byte array" + where len = B.length bs + + unpackT = getWord8 >>= unpackByMarker + where unpackByMarker m | m == bytes8Code = toInt <$> getWord8 >>= getByteString + | m == bytes16Code = toInt <$> getWord16be >>= getByteString + | m == bytes32Code = toInt <$> getWord32be >>= getByteString + | otherwise = failUnpack "bytes" m + instance BoltValue Structure where pack (Structure sig lst) | size < size4 = putWord8 (structConst + fromIntegral size) >> pData | size < size8 = putWord8 struct8Code >> putWord8 (fromIntegral size) >> pData @@ -119,30 +139,32 @@ instance BoltValue Structure where unpackT = getWord8 >>= unpackByMarker where unpackByMarker m | isTinyStruct m = unpackStructureBySize (getSize m) - | m == struct8Code = toInt <$> getInt8 >>= unpackStructureBySize - | m == struct16Code = toInt <$> getInt16be >>= unpackStructureBySize + | m == struct8Code = toInt <$> getWord8 >>= unpackStructureBySize + | m == struct16Code = toInt <$> getWord16be >>= unpackStructureBySize | otherwise = failUnpack "structure" m unpackStructureBySize size = Structure <$> getWord8 <*> replicateM size unpackT instance BoltValue Value where - pack (N n) = pack n - pack (B b) = pack b - pack (I i) = pack i - pack (F d) = pack d - pack (T t) = pack t - pack (L l) = pack l - pack (M m) = pack m - pack (S s) = pack s + pack (N n) = pack n + pack (B b) = pack b + pack (I i) = pack i + pack (F d) = pack d + pack (T t) = pack t + pack (L l) = pack l + pack (M m) = pack m + pack (S s) = pack s + pack (Bytes b) = pack b unpackT = lookAhead getWord8 >>= unpackByMarker - where unpackByMarker m | isNull m = N <$> unpackT - | isBool m = B <$> unpackT - | isInt m = I <$> unpackT - | isDouble m = F <$> unpackT - | isText m = T <$> unpackT - | isList m = L <$> unpackT - | isDict m = M <$> unpackT - | isStruct m = S <$> unpackT + where unpackByMarker m | isNull m = N <$> unpackT + | isBool m = B <$> unpackT + | isInt m = I <$> unpackT + | isDouble m = F <$> unpackT + | isText m = T <$> unpackT + | isList m = L <$> unpackT + | isDict m = M <$> unpackT + | isBytes m = Bytes <$> unpackT + | isStruct m = S <$> unpackT | otherwise = failUnpack "value" m -- = Structure instances for Neo4j structures @@ -150,9 +172,11 @@ instance BoltValue Value where instance FromStructure Node where fromStructure struct = case struct of - (Structure sig [I nid, L vlbls, M prps]) | sig == sigNode -> flip (Node nid) prps <$> cnvT vlbls - _ -> throwError $ Not "Node" + (Structure sig [I nid, L vlbls, M prps, T eid]) | sig == sigNode -> mkNode nid prps eid <$> cnvT vlbls + (Structure sig [I nid, L vlbls, M prps]) | sig == sigNode -> mkNode nid prps "" <$> cnvT vlbls + _ -> throwError $ Not "Node" where + mkNode nid prps eid lbls = Node nid lbls prps eid cnvT [] = pure [] cnvT (T x:xs) = (x:) <$> cnvT xs cnvT _ = throwError NotString @@ -160,14 +184,16 @@ instance FromStructure Node where instance FromStructure Relationship where fromStructure struct = case struct of - (Structure sig [I rid, I sni, I eni, T rt, M rp]) | sig == sigRel -> pure $ Relationship rid sni eni rt rp - _ -> throwError $ Not "Relationship" + (Structure sig [I rid, I sni, I eni, T rt, M rp, T eid, T sneid, T eneid]) | sig == sigRel -> pure $ Relationship rid sni eni rt rp eid sneid eneid + (Structure sig [I rid, I sni, I eni, T rt, M rp]) | sig == sigRel -> pure $ Relationship rid sni eni rt rp "" "" "" + _ -> throwError $ Not "Relationship" instance FromStructure URelationship where fromStructure struct = case struct of - (Structure sig [I rid, T rt, M rp]) | sig == sigURel -> pure $ URelationship rid rt rp - _ -> throwError $ Not "URelationship" + (Structure sig [I rid, T rt, M rp, T eid]) | sig == sigURel -> pure $ URelationship rid rt rp eid + (Structure sig [I rid, T rt, M rp]) | sig == sigURel -> pure $ URelationship rid rt rp "" + _ -> throwError $ Not "URelationship" instance FromStructure Path where fromStructure struct = diff --git a/src/Database/Bolt/Value/Type.hs b/src/Database/Bolt/Value/Type.hs index 8fb25ac..6742734 100644 --- a/src/Database/Bolt/Value/Type.hs +++ b/src/Database/Bolt/Value/Type.hs @@ -104,6 +104,8 @@ data Value = N () | L [Value] | M (Map Text Value) | S Structure + | Bytes ByteString -- ^Raw byte data. PackStream Bytes type. + -- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes deriving stock (Show, Eq, Generic) deriving anyclass (NFData) @@ -150,9 +152,67 @@ instance IsValue a => IsValue (Maybe a) where toValue (Just a) = toValue a toValue _ = N () +-- |Allows 'ByteString' to be used as a BOLT value via the 'Bytes' constructor. +-- See: https://neo4j.com/docs/bolt/current/packstream/#data-type-bytes +instance IsValue ByteString where + toValue = Bytes + instance IsValue (Map Text Value) where toValue = M +-- | IsValue instances for tuples (2-15 elements) +-- Tuples are converted to BOLT lists. + +instance (IsValue a, IsValue b) => IsValue (a, b) where + toValue (a, b) = L [toValue a, toValue b] + +instance (IsValue a, IsValue b, IsValue c) => IsValue (a, b, c) where + toValue (a, b, c) = L [toValue a, toValue b, toValue c] + +instance (IsValue a, IsValue b, IsValue c, IsValue d) => IsValue (a, b, c, d) where + toValue (a, b, c, d) = L [toValue a, toValue b, toValue c, toValue d] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e) => IsValue (a, b, c, d, e) where + toValue (a, b, c, d, e) = L [toValue a, toValue b, toValue c, toValue d, toValue e] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f) => IsValue (a, b, c, d, e, f) where + toValue (a, b, c, d, e, f) = L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g) => IsValue (a, b, c, d, e, f, g) where + toValue (a, b, c, d, e, f, g) = L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h) => IsValue (a, b, c, d, e, f, g, h) where + toValue (a, b, c, d, e, f, g, h) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i) => IsValue (a, b, c, d, e, f, g, h, i) where + toValue (a, b, c, d, e, f, g, h, i) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j) => IsValue (a, b, c, d, e, f, g, h, i, j) where + toValue (a, b, c, d, e, f, g, h, i, j) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j, IsValue k) => IsValue (a, b, c, d, e, f, g, h, i, j, k) where + toValue (a, b, c, d, e, f, g, h, i, j, k) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j, toValue k] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j, IsValue k, IsValue l) => IsValue (a, b, c, d, e, f, g, h, i, j, k, l) where + toValue (a, b, c, d, e, f, g, h, i, j, k, l) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j, toValue k, toValue l] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j, IsValue k, IsValue l, IsValue m) => IsValue (a, b, c, d, e, f, g, h, i, j, k, l, m) where + toValue (a, b, c, d, e, f, g, h, i, j, k, l, m) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j, toValue k, toValue l, toValue m] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j, IsValue k, IsValue l, IsValue m, IsValue n) => IsValue (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where + toValue (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j, toValue k, toValue l, toValue m, toValue n] + +instance (IsValue a, IsValue b, IsValue c, IsValue d, IsValue e, IsValue f, IsValue g, IsValue h, IsValue i, IsValue j, IsValue k, IsValue l, IsValue m, IsValue n, IsValue o) => IsValue (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where + toValue (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = + L [toValue a, toValue b, toValue c, toValue d, toValue e, toValue f, toValue g, toValue h, toValue i, toValue j, toValue k, toValue l, toValue m, toValue n, toValue o] + -- |Wrap key-value pair with 'Value' datatype (=:) :: IsValue a => Text -> a -> (Text, Value) (=:) key val = (key, toValue val) @@ -165,23 +225,28 @@ props = fromList -- == Neo4j subjects -data Node = Node { nodeIdentity :: Int -- ^Neo4j node identifier - , labels :: [Text] -- ^Set of node labels (types) - , nodeProps :: Map Text Value -- ^Dict of node properties +data Node = Node { nodeIdentity :: Int -- ^Neo4j node identifier + , labels :: [Text] -- ^Set of node labels (types) + , nodeProps :: Map Text Value -- ^Dict of node properties + , nodeElementId :: Text -- ^Element ID string (v5+, empty for v3) } deriving (Show, Eq) -data Relationship = Relationship { relIdentity :: Int -- ^Neo4j relationship identifier - , startNodeId :: Int -- ^Identifier of start node - , endNodeId :: Int -- ^Identifier of end node - , relType :: Text -- ^Relationship type - , relProps :: Map Text Value -- ^Dict of relationship properties +data Relationship = Relationship { relIdentity :: Int -- ^Neo4j relationship identifier + , startNodeId :: Int -- ^Identifier of start node + , endNodeId :: Int -- ^Identifier of end node + , relType :: Text -- ^Relationship type + , relProps :: Map Text Value -- ^Dict of relationship properties + , relElementId :: Text -- ^Element ID string (v5+, empty for v3) + , startNodeElementId :: Text -- ^Start node element ID (v5+, empty for v3) + , endNodeElementId :: Text -- ^End node element ID (v5+, empty for v3) } deriving (Show, Eq) -data URelationship = URelationship { urelIdentity :: Int -- ^Neo4j relationship identifier - , urelType :: Text -- ^Relationship type - , urelProps :: Map Text Value -- ^Dict of relationship properties +data URelationship = URelationship { urelIdentity :: Int -- ^Neo4j relationship identifier + , urelType :: Text -- ^Relationship type + , urelProps :: Map Text Value -- ^Dict of relationship properties + , urelElementId :: Text -- ^Element ID string (v5+, empty for v3) } deriving (Show, Eq) diff --git a/stack.yaml b/stack.yaml index 9e677dc..531badb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-22.0 +resolver: lts-24.31 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/test/Spec.hs b/test/Spec.hs index e09fbda..fc28b97 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,27 +1,53 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative ((<$>)) -import Data.Binary.Put (runPut) -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (fromStrict, toStrict) +import Control.Applicative ((<$>)) +import Data.Binary.Put (runPut) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Either (isLeft) +import Data.Map (Map) +import qualified Data.Map as M (empty, fromList, lookup) +import Data.Text (Text) +import qualified Data.Text as T (pack, unpack) import Hex -import Data.Map (Map) -import qualified Data.Map as M (empty, fromList) -import Data.Text (Text) -import qualified Data.Text as T (pack) import Test.Hspec #if !MIN_VERSION_base(4, 13, 0) -import Control.Monad.Fail (MonadFail) +import Control.Monad.Fail (MonadFail) #endif -import Database.Bolt () -import Database.Bolt.Serialization +import Database.Bolt +import Database.Bolt.Connection.Instances (dbExtra, helloMap, notifExtra) +import Database.Bolt.Connection.RouterPool (IdlePipe (..), PoolState (..), ServerPool (..), + isConnectionError, reconcileState) +import Database.Bolt.Connection.Type (AuthToken (..), Request (..), Response (..), + ResponseError (..)) +import Database.Bolt.Serialization +import Database.Bolt.Value.Helpers (isV3, isV5_6) + +import Data.Bits (shiftR, (.&.)) +import Data.Default (def) +import qualified Data.Map.Strict as MS +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, secondsToDiffTime) +import Data.Word (Word32) main :: IO () main = hspec $ do packStreamTests unpackStreamTests + v5Tests + v58Tests + routingTests + routerTests + helloMapTests + notifExtraTests + toStructureRequestTests + isConnectionErrorTests + reconcileStateTests + largerBytesTests + parseAddressEdgeCaseTests pack' :: BoltValue a => a -> ByteString pack' = toStrict . runPut . pack @@ -99,3 +125,659 @@ packStreamTests = prepareData :: MonadFail m => ByteString -> m ByteString prepareData = (toStrict <$>) . unhex . fromStrict + +-- | Helper to unpack a Structure from a ByteString +unpackStruct :: ByteString -> Either UnpackError Structure +unpackStruct bs = case unpackAction unpackT (fromStrict bs) of + Left e -> Left e + Right s -> Right s + +v5Tests :: Spec +v5Tests = + describe "Bolt v5" $ do + it "unpacks Node with 4 fields (v5 element_id)" $ do + -- Structure with sig=0x4E (78), 4 fields: I 42, L ["Person"], M {}, T "4:xxx:42" + let nodeStruct = Structure 78 [I 42, L [T (T.pack "Person")], M M.empty, T (T.pack "4:xxx:42")] + bs = pack' nodeStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError Node + case result of + Right n -> do + nodeIdentity n `shouldBe` 42 + labels n `shouldBe` [T.pack "Person"] + nodeProps n `shouldBe` M.empty + nodeElementId n `shouldBe` T.pack "4:xxx:42" + Left e -> expectationFailure (show e) + + it "unpacks Node with 3 fields (v3 compat)" $ do + let nodeStruct = Structure 78 [I 1, L [T (T.pack "A")], M M.empty] + bs = pack' nodeStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError Node + case result of + Right n -> do + nodeIdentity n `shouldBe` 1 + nodeElementId n `shouldBe` T.pack "" + Left e -> expectationFailure (show e) + + it "unpacks Relationship with 8 fields (v5)" $ do + let relStruct = Structure 82 [ I 10, I 1, I 2 + , T (T.pack "KNOWS"), M M.empty + , T (T.pack "5:xxx:10") + , T (T.pack "5:xxx:1") + , T (T.pack "5:xxx:2") + ] + bs = pack' relStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError Relationship + case result of + Right r -> do + relIdentity r `shouldBe` 10 + startNodeId r `shouldBe` 1 + endNodeId r `shouldBe` 2 + relType r `shouldBe` T.pack "KNOWS" + relElementId r `shouldBe` T.pack "5:xxx:10" + startNodeElementId r `shouldBe` T.pack "5:xxx:1" + endNodeElementId r `shouldBe` T.pack "5:xxx:2" + Left e -> expectationFailure (show e) + + it "unpacks Relationship with 5 fields (v3 compat)" $ do + let relStruct = Structure 82 [I 10, I 1, I 2, T (T.pack "KNOWS"), M M.empty] + bs = pack' relStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError Relationship + case result of + Right r -> do + relIdentity r `shouldBe` 10 + relElementId r `shouldBe` T.pack "" + Left e -> expectationFailure (show e) + + it "unpacks URelationship with 4 fields (v5)" $ do + let urelStruct = Structure 114 [I 7, T (T.pack "LIKES"), M M.empty, T (T.pack "5:xxx:7")] + bs = pack' urelStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError URelationship + case result of + Right r -> do + urelIdentity r `shouldBe` 7 + urelElementId r `shouldBe` T.pack "5:xxx:7" + Left e -> expectationFailure (show e) + + it "unpacks URelationship with 3 fields (v3 compat)" $ do + let urelStruct = Structure 114 [I 7, T (T.pack "LIKES"), M M.empty] + bs = pack' urelStruct + result = unpackStruct bs >>= fromStructure :: Either UnpackError URelationship + case result of + Right r -> do + urelIdentity r `shouldBe` 7 + urelElementId r `shouldBe` T.pack "" + Left e -> expectationFailure (show e) + + it "packs LOGON request as structure" $ do + -- sigLogon = 0x6A, one field: dict with auth info + let logonStruct = Structure 0x6A [M (M.fromList [ (T.pack "scheme", T (T.pack "basic")) + , (T.pack "principal", T (T.pack "neo4j")) + , (T.pack "credentials", T (T.pack "pass")) + ])] + bs = pack' logonStruct + result = unpackStruct bs + case result of + Right (Structure sig [M _m]) -> sig `shouldBe` 0x6A + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + it "packs LOGOFF request as structure" $ do + let logoffStruct = Structure 0x6B [] + bs = pack' logoffStruct + result = unpackStruct bs + case result of + Right (Structure sig []) -> sig `shouldBe` 0x6B + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + it "packs PULL with extra dict as structure" $ do + let pullStruct = Structure 0x3F [M (M.fromList [(T.pack "n", I (-1))])] + bs = pack' pullStruct + result = unpackStruct bs + case result of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x3F + M.lookup (T.pack "n") m `shouldBe` Just (I (-1)) + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + it "packs DISCARD with extra dict as structure" $ do + let discardStruct = Structure 0x2F [M (M.fromList [(T.pack "n", I (-1))])] + bs = pack' discardStruct + result = unpackStruct bs + case result of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x2F + M.lookup (T.pack "n") m `shouldBe` Just (I (-1)) + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + +v58Tests :: Spec +v58Tests = + describe "Bolt version checks" $ do + describe "version checks (real library functions)" $ do + it "isV3 returns True for v3" $ + isV3 3 `shouldBe` True + it "isV3 returns False for v2" $ + isV3 2 `shouldBe` False + it "isV3 returns True for v5.1" $ + isV3 0x0105 `shouldBe` True + it "isV5_6 returns False for v5.3" $ + isV5_6 0x0305 `shouldBe` False + it "isV5_6 returns True for v5.6" $ + isV5_6 0x0605 `shouldBe` True + + describe "large size roundtrips (unsigned size bytes)" $ do + it "roundtrips text >= 128 bytes (TEXT_8 with size >= 0x80)" $ do + let longText = T.pack (replicate 200 'x') + packed = pack' longText + result <- unpackF packed :: IO Text + result `shouldBe` longText + + it "roundtrips list >= 128 elements (LIST_8 with size >= 0x80)" $ do + let longList = [1..200] :: [Int] + packed = pack' longList + result <- unpackF packed :: IO [Int] + result `shouldBe` longList + + describe "TELEMETRY message (sig 0x54)" $ do + it "packs and unpacks TELEMETRY structure" $ do + let telStruct = Structure 0x54 [I 7] + bs = pack' telStruct + result = unpackStruct bs + case result of + Right (Structure sig [I n]) -> do + sig `shouldBe` 0x54 + n `shouldBe` 7 + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + describe "Bytes value support" $ do + it "packs and unpacks Bytes value" $ do + let bsVal = Bytes (BS.pack [0x01, 0x02, 0x03]) + packed = pack' bsVal + result = unpackAction unpackT (fromStrict packed) :: Either UnpackError Value + result `shouldBe` Right bsVal + + it "roundtrips empty Bytes" $ do + let bsVal = Bytes BS.empty + packed = pack' bsVal + result = unpackAction unpackT (fromStrict packed) :: Either UnpackError Value + result `shouldBe` Right bsVal + + describe "BoltCfg defaults" $ do + it "default version is 5.6-5.8 range" $ do + let cfg = def :: BoltCfg + version cfg `shouldBe` (0x00020805 :: Word32) + it "default userAgent is hasbolt/1.8" $ do + let cfg = def :: BoltCfg + userAgent cfg `shouldBe` T.pack "hasbolt/1.8" + it "default notifMinSeverity is Nothing" $ do + let cfg = def :: BoltCfg + notifMinSeverity cfg `shouldBe` Nothing + it "default notifDisabledClass is empty" $ do + let cfg = def :: BoltCfg + notifDisabledClass cfg `shouldBe` [] + it "default database is Nothing" $ do + let cfg = def :: BoltCfg + database cfg `shouldBe` Nothing + +routingTests :: Spec +routingTests = + describe "Routing primitives" $ do + describe "ROUTE message (sig 0x66)" $ do + it "packs and unpacks ROUTE with 3 fields" $ do + let ctx = M.fromList [(T.pack "address", T (T.pack "localhost:7687"))] + bmarks = L [T (T.pack "bm1"), T (T.pack "bm2")] + extra = M.fromList [(T.pack "db", T (T.pack "neo4j"))] + routeStruct = Structure 0x66 [M ctx, bmarks, M extra] + bs = pack' routeStruct + result = unpackStruct bs + case result of + Right (Structure sig [M ctx', L bmarks', M extra']) -> do + sig `shouldBe` 0x66 + M.lookup (T.pack "address") ctx' `shouldBe` Just (T (T.pack "localhost:7687")) + bmarks' `shouldBe` [T (T.pack "bm1"), T (T.pack "bm2")] + M.lookup (T.pack "db") extra' `shouldBe` Just (T (T.pack "neo4j")) + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + it "packs ROUTE with empty context and bookmarks" $ do + let routeStruct = Structure 0x66 [M M.empty, L [], M M.empty] + bs = pack' routeStruct + result = unpackStruct bs + case result of + Right (Structure sig [M ctx, L bmarks, M extra]) -> do + sig `shouldBe` 0x66 + ctx `shouldBe` M.empty + bmarks `shouldBe` [] + extra `shouldBe` M.empty + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + describe "HELLO with routing context" $ do + it "includes routing key in HELLO dict" $ do + -- Simulate a HELLO dict that includes a routing key + let routingCtx = M.fromList [(T.pack "address", T (T.pack "localhost:7687"))] + helloDict = M.fromList [ (T.pack "user_agent", T (T.pack "hasbolt/1.8")) + , (T.pack "routing", M routingCtx) + ] + helloStruct = Structure 0x01 [M helloDict] + bs = pack' helloStruct + result = unpackStruct bs + case result of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x01 + case M.lookup (T.pack "routing") m of + Just (M r) -> M.lookup (T.pack "address") r `shouldBe` Just (T (T.pack "localhost:7687")) + _ -> expectationFailure "routing key missing or wrong type" + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + + describe "BEGIN with db and mode" $ do + it "serializes BEGIN with db and mode keys" $ do + let extra = M.fromList [(T.pack "db", T (T.pack "mydb")), (T.pack "mode", T (T.pack "r"))] + beginStruct = Structure 0x11 [M extra] + bs = pack' beginStruct + result = unpackStruct bs + case result of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x11 + M.lookup (T.pack "db") m `shouldBe` Just (T (T.pack "mydb")) + M.lookup (T.pack "mode") m `shouldBe` Just (T (T.pack "r")) + Right _ -> expectationFailure "unexpected structure shape" + Left e -> expectationFailure (show e) + +-- | A fixed time for testing. +testTime :: UTCTime +testTime = UTCTime (fromGregorian 2026 1 1) (secondsToDiffTime 0) + +routerTests :: Spec +routerTests = + describe "Router" $ do + describe "parseAddress" $ do + it "parses localhost:7687" $ + parseAddress (T.pack "localhost:7687") `shouldBe` Right (ServerAddress "localhost" 7687) + + it "parses IP address:port" $ + parseAddress (T.pack "192.168.1.1:7474") `shouldBe` Right (ServerAddress "192.168.1.1" 7474) + + it "parses IPv6 address [::1]:7687" $ + parseAddress (T.pack "[::1]:7687") `shouldBe` Right (ServerAddress "::1" 7687) + + it "rejects address without port" $ + case parseAddress (T.pack "badaddress") of + Left _ -> pure () + Right _ -> expectationFailure "expected Left for invalid address" + + it "rejects empty address" $ + case parseAddress (T.pack "") of + Left _ -> pure () + Right _ -> expectationFailure "expected Left for empty address" + + describe "parseRoutingTable" $ do + it "parses a valid routing table" $ do + let rtMap = M.fromList + [ (T.pack "ttl", I 300) + , (T.pack "servers", L + [ M (M.fromList [(T.pack "role", T (T.pack "WRITE")), (T.pack "addresses", L [T (T.pack "w1:7687")])]) + , M (M.fromList [(T.pack "role", T (T.pack "READ")), (T.pack "addresses", L [T (T.pack "r1:7687"), T (T.pack "r2:7687")])]) + , M (M.fromList [(T.pack "role", T (T.pack "ROUTE")), (T.pack "addresses", L [T (T.pack "rt1:7687")])]) + ]) + ] + case parseRoutingTable testTime rtMap of + Right rt -> do + length (rtReaders rt) `shouldBe` 2 + length (rtWriters rt) `shouldBe` 1 + length (rtRouters rt) `shouldBe` 1 + rtTTL rt `shouldBe` 300 + Left err -> expectationFailure (T.unpack err) + + it "rejects missing servers" $ do + let rtMap = M.fromList [(T.pack "ttl", I 300)] + case parseRoutingTable testTime rtMap of + Left _ -> pure () + Right _ -> expectationFailure "expected Left for missing servers" + + it "rejects empty writers" $ do + let rtMap = M.fromList + [ (T.pack "ttl", I 300) + , (T.pack "servers", L + [ M (M.fromList [(T.pack "role", T (T.pack "READ")), (T.pack "addresses", L [T (T.pack "r1:7687")])]) + , M (M.fromList [(T.pack "role", T (T.pack "ROUTE")), (T.pack "addresses", L [T (T.pack "rt1:7687")])]) + ]) + ] + case parseRoutingTable testTime rtMap of + Left _ -> pure () + Right _ -> expectationFailure "expected Left for empty writers" + + it "parses routing table nested under rt key" $ do + let inner = M.fromList + [ (T.pack "ttl", I 600) + , (T.pack "servers", L + [ M (M.fromList [(T.pack "role", T (T.pack "WRITE")), (T.pack "addresses", L [T (T.pack "w1:7687")])]) + , M (M.fromList [(T.pack "role", T (T.pack "READ")), (T.pack "addresses", L [T (T.pack "r1:7687")])]) + , M (M.fromList [(T.pack "role", T (T.pack "ROUTE")), (T.pack "addresses", L [T (T.pack "rt1:7687")])]) + ]) + ] + rtMap = M.fromList [(T.pack "rt", M inner)] + case parseRoutingTable testTime rtMap of + Right rt -> do + rtTTL rt `shouldBe` 600 + length (rtWriters rt) `shouldBe` 1 + Left err -> expectationFailure (T.unpack err) + + describe "isExpired" $ do + it "returns False when expiry is in the future" $ do + let rt = RoutingTable [] [] [] 300 + (addUTCTime (600 :: NominalDiffTime) testTime) + isExpired testTime rt `shouldBe` False + + it "returns True when expiry is in the past" $ do + let rt = RoutingTable [] [] [] 300 + (addUTCTime (-1 :: NominalDiffTime) testTime) + isExpired testTime rt `shouldBe` True + + it "returns True when now == expiry (boundary)" $ do + let rt = RoutingTable [] [] [] 300 testTime + isExpired testTime rt `shouldBe` True + +-- | Tests for helloMap (issue #1: zero coverage) +helloMapTests :: Spec +helloMapTests = + describe "helloMap" $ do + let auth = AuthToken "basic" "neo4j" "secret" + routingCtx = M.fromList [("address", T "localhost:7687")] + + it "v3: includes user_agent and credentials inline" $ do + let m = helloMap "hasbolt/1.8" auth 3 Nothing + M.lookup "user_agent" m `shouldBe` Just (T "hasbolt/1.8") + M.lookup "scheme" m `shouldBe` Just (T "basic") + M.lookup "principal" m `shouldBe` Just (T "neo4j") + M.lookup "credentials" m `shouldBe` Just (T "secret") + -- v3 should not have routing or bolt_agent + M.lookup "routing" m `shouldBe` Nothing + M.lookup "bolt_agent" m `shouldBe` Nothing + + it "v5.6: includes user_agent, omits credentials" $ do + let m = helloMap "hasbolt/1.8" auth 0x0605 Nothing + M.lookup "user_agent" m `shouldBe` Just (T "hasbolt/1.8") + M.lookup "scheme" m `shouldBe` Nothing + M.lookup "credentials" m `shouldBe` Nothing + + it "v5.6 with routing context" $ do + let m = helloMap "hasbolt/1.8" auth 0x0605 (Just routingCtx) + M.lookup "routing" m `shouldBe` Just (M routingCtx) + M.lookup "credentials" m `shouldBe` Nothing + + it "v5.6: includes bolt_agent" $ do + let m = helloMap "hasbolt/1.8" auth 0x0605 Nothing + case M.lookup "bolt_agent" m of + Just (M agent) -> M.lookup "product" agent `shouldBe` Just (T "hasbolt/1.8") + _ -> expectationFailure "bolt_agent missing or wrong type" + M.lookup "credentials" m `shouldBe` Nothing + + it "v5.6 with routing context includes both bolt_agent and routing" $ do + let m = helloMap "hasbolt/1.8" auth 0x0605 (Just routingCtx) + M.lookup "bolt_agent" m `shouldSatisfy` (/= Nothing) + M.lookup "routing" m `shouldBe` Just (M routingCtx) + + it "v3: routing context is ignored" $ do + let m = helloMap "hasbolt/1.8" auth 3 (Just routingCtx) + -- v3 path ignores mRouting, just inlines creds + M.lookup "routing" m `shouldBe` Nothing + M.lookup "credentials" m `shouldBe` Just (T "secret") + +-- | Tests for notifExtra (issue #2: zero coverage) +notifExtraTests :: Spec +notifExtraTests = + describe "notifExtra" $ do + it "returns empty for pre-v5.6" $ do + notifExtra 0x0105 (Just "WARNING") ["HINT"] `shouldBe` M.empty + notifExtra 3 (Just "OFF") [] `shouldBe` M.empty + notifExtra 0x0205 (Just "WARNING") [] `shouldBe` M.empty + + it "v5.6: includes severity when present" $ do + let m = notifExtra 0x0605 (Just "WARNING") [] + M.lookup "notifications_minimum_severity" m `shouldBe` Just (T "WARNING") + + it "v5.6: omits severity when Nothing" $ do + let m = notifExtra 0x0605 Nothing [] + M.lookup "notifications_minimum_severity" m `shouldBe` Nothing + + it "v5.6: uses notifications_disabled_classifications key" $ do + let m = notifExtra 0x0605 Nothing ["HINT"] + M.lookup "notifications_disabled_classifications" m `shouldBe` Just (L [T "HINT"]) + M.lookup "notifications_disabled_categories" m `shouldBe` Nothing + + it "v5.6: includes both severity and disabled" $ do + let m = notifExtra 0x0605 (Just "OFF") ["HINT"] + M.lookup "notifications_minimum_severity" m `shouldBe` Just (T "OFF") + M.lookup "notifications_disabled_classifications" m `shouldBe` Just (L [T "HINT"]) + + it "v5.6: empty disabled list produces no key" $ do + let m = notifExtra 0x0605 Nothing [] + M.lookup "notifications_disabled_classifications" m `shouldBe` Nothing + +-- | Tests for ToStructure Request instances (issue #4) +toStructureRequestTests :: Spec +toStructureRequestTests = + describe "ToStructure Request" $ do + let auth = AuthToken "basic" "neo4j" "pass" + routingCtx = M.fromList [("address", T "localhost:7687")] + roundtrip req = unpackStruct (pack' (toStructure req)) + + it "RequestLogon produces sig 0x6A with token map" $ do + case roundtrip (RequestLogon auth) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x6A + M.lookup "scheme" m `shouldBe` Just (T "basic") + M.lookup "principal" m `shouldBe` Just (T "neo4j") + M.lookup "credentials" m `shouldBe` Just (T "pass") + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestLogoff produces sig 0x6B with no fields" $ do + case roundtrip RequestLogoff of + Right (Structure sig []) -> sig `shouldBe` 0x6B + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestTelemetry produces sig 0x54 with api int" $ do + case roundtrip (RequestTelemetry 7) of + Right (Structure sig [I n]) -> do + sig `shouldBe` 0x54 + n `shouldBe` 7 + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestPull produces sig 0x3F with extra dict" $ do + let extra = M.fromList ["n" =: (-1 :: Int)] + case roundtrip (RequestPull extra) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x3F + M.lookup "n" m `shouldBe` Just (I (-1)) + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestDiscard produces sig 0x2F with extra dict" $ do + let extra = M.fromList ["n" =: (-1 :: Int)] + case roundtrip (RequestDiscard extra) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x2F + M.lookup "n" m `shouldBe` Just (I (-1)) + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestRoute produces sig 0x66 with context, bookmarks, extra" $ do + let extra = M.fromList ["db" =: ("neo4j" :: Text)] + case roundtrip (RequestRoute routingCtx ["bm1"] extra) of + Right (Structure sig [M ctx, L bmarks, M ext]) -> do + sig `shouldBe` 0x66 + M.lookup "address" ctx `shouldBe` Just (T "localhost:7687") + bmarks `shouldBe` [T "bm1"] + M.lookup "db" ext `shouldBe` Just (T "neo4j") + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestInit v3 produces sig 0x01 with creds inline" $ do + case roundtrip (RequestInit "hasbolt/1.8" auth 3 Nothing) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x01 + M.lookup "user_agent" m `shouldBe` Just (T "hasbolt/1.8") + M.lookup "scheme" m `shouldBe` Just (T "basic") + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestInit v5.6 produces sig 0x01 without creds" $ do + case roundtrip (RequestInit "hasbolt/1.8" auth 0x0605 Nothing) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x01 + M.lookup "user_agent" m `shouldBe` Just (T "hasbolt/1.8") + M.lookup "scheme" m `shouldBe` Nothing + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestInit v5.6 with routing includes routing key" $ do + case roundtrip (RequestInit "hasbolt/1.8" auth 0x0605 (Just routingCtx)) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x01 + M.lookup "routing" m `shouldBe` Just (M routingCtx) + other -> expectationFailure ("unexpected: " <> show other) + + it "RequestBegin produces sig 0x11 with extra" $ do + let extra = M.fromList ["mode" =: ("r" :: Text), "db" =: ("mydb" :: Text)] + case roundtrip (RequestBegin extra) of + Right (Structure sig [M m]) -> do + sig `shouldBe` 0x11 + M.lookup "mode" m `shouldBe` Just (T "r") + M.lookup "db" m `shouldBe` Just (T "mydb") + other -> expectationFailure ("unexpected: " <> show other) + +-- | Tests for isConnectionError (issue #5) +isConnectionErrorTests :: Spec +isConnectionErrorTests = + describe "isConnectionError" $ do + it "CannotReadChunk is a connection error" $ + isConnectionError CannotReadChunk `shouldBe` True + it "ResponseError is not a connection error" $ + isConnectionError (ResponseError UnknownResponseFailure) `shouldBe` False + it "RoutingTableUnavailable is not a connection error" $ + isConnectionError RoutingTableUnavailable `shouldBe` False + it "UnsupportedServerVersion is not a connection error" $ + isConnectionError UnsupportedServerVersion `shouldBe` False + it "AuthentificationFailed is not a connection error" $ + isConnectionError AuthentificationFailed `shouldBe` False + +-- | Tests for reconcileState (issue #6) +reconcileStateTests :: Spec +reconcileStateTests = + describe "reconcileState" $ do + let mkAddr h p = ServerAddress h p + addrA = mkAddr "a" 7687 + addrB = mkAddr "b" 7687 + addrC = mkAddr "c" 7687 + emptyPool = ServerPool [] 0 + + it "keeps existing servers that remain in new table" $ do + let pool = ServerPool { spIdle = [], spInUse = 3 } + ps = PoolState { psServers = MS.fromList [(addrA, pool)], psTable = undefined, psRRIndex = 5 } + newTable = RoutingTable [addrA] [addrA] [addrA] 300 testTime + (ps', removed) = reconcileState ps newTable + MS.member addrA (psServers ps') `shouldBe` True + -- in-use count preserved + case MS.lookup addrA (psServers ps') of + Just sp -> spInUse sp `shouldBe` 3 + Nothing -> expectationFailure "server A missing" + length removed `shouldBe` 0 + psRRIndex ps' `shouldBe` 5 + + it "adds new servers with empty pools" $ do + let ps = PoolState { psServers = MS.fromList [(addrA, emptyPool)], psTable = undefined, psRRIndex = 0 } + newTable = RoutingTable [] [addrA, addrB] [] 300 testTime + (ps', removed) = reconcileState ps newTable + MS.member addrB (psServers ps') `shouldBe` True + case MS.lookup addrB (psServers ps') of + Just sp -> do length (spIdle sp) `shouldBe` 0 + spInUse sp `shouldBe` 0 + Nothing -> expectationFailure "server B missing" + length removed `shouldBe` 0 + + it "removes servers not in new table, returning their idle pipes" $ do + let dummyPipe = undefined -- we won't actually close it, just check the list + idlePipe = IdlePipe dummyPipe testTime + pool = ServerPool { spIdle = [idlePipe], spInUse = 0 } + ps = PoolState { psServers = MS.fromList [(addrA, emptyPool), (addrB, pool)] + , psTable = undefined, psRRIndex = 0 } + newTable = RoutingTable [] [addrA] [] 300 testTime + (ps', removed) = reconcileState ps newTable + MS.member addrB (psServers ps') `shouldBe` False + length removed `shouldBe` 1 + + it "handles complete server set replacement" $ do + let ps = PoolState { psServers = MS.fromList [(addrA, emptyPool), (addrB, emptyPool)] + , psTable = undefined, psRRIndex = 0 } + newTable = RoutingTable [addrC] [addrC] [addrC] 300 testTime + (ps', removed) = reconcileState ps newTable + MS.member addrA (psServers ps') `shouldBe` False + MS.member addrB (psServers ps') `shouldBe` False + MS.member addrC (psServers ps') `shouldBe` True + length removed `shouldBe` 0 -- old pools had no idle pipes + +-- | Tests for larger Bytes pack/unpack (issue #7) +largerBytesTests :: Spec +largerBytesTests = + describe "Bytes larger sizes" $ do + it "roundtrips Bytes with 256 bytes (bytes16 marker 0xCD)" $ do + let bs = BS.pack (take 256 (cycle [0..255])) + bsVal = Bytes bs + packed = pack' bsVal + result = unpackAction unpackT (fromStrict packed) :: Either UnpackError Value + result `shouldBe` Right bsVal + + it "roundtrips Bytes with 300 bytes" $ do + let bs = BS.replicate 300 0xAB + bsVal = Bytes bs + packed = pack' bsVal + result = unpackAction unpackT (fromStrict packed) :: Either UnpackError Value + result `shouldBe` Right bsVal + + it "roundtrips dict with > 15 entries (dict8 marker)" $ do + let entries = [(T.pack ("key" <> show i), I i) | i <- [1..20 :: Int]] + dict = M.fromList entries + packed = pack' dict + result <- unpackF packed :: IO (Map Text Value) + result `shouldBe` dict + + it "roundtrips Bytes with 200 bytes (bytes8 boundary)" $ do + let bs = BS.replicate 200 0xFF + bsVal = Bytes bs + packed = pack' bsVal + result = unpackAction unpackT (fromStrict packed) :: Either UnpackError Value + result `shouldBe` Right bsVal + +-- | Tests for parseAddress edge cases (issue #8) +parseAddressEdgeCaseTests :: Spec +parseAddressEdgeCaseTests = + describe "parseAddress edge cases" $ do + it "rejects port 0" $ + parseAddress "localhost:0" `shouldSatisfy` isLeft + + it "rejects port 65536" $ + parseAddress "localhost:65536" `shouldSatisfy` isLeft + + it "rejects non-numeric port" $ + parseAddress "localhost:abc" `shouldSatisfy` isLeft + + it "rejects trailing text after port" $ + parseAddress "localhost:7687x" `shouldSatisfy` isLeft + + it "parses max valid port 65535" $ + parseAddress "localhost:65535" `shouldBe` Right (ServerAddress "localhost" 65535) + + it "parses port 1 (min valid)" $ + parseAddress "localhost:1" `shouldBe` Right (ServerAddress "localhost" 1) + + it "rejects address with only colon" $ + parseAddress ":" `shouldSatisfy` isLeft + + it "parses hostname with dots" $ + parseAddress "neo4j.example.com:7687" `shouldBe` Right (ServerAddress "neo4j.example.com" 7687) + + it "rejects IPv6 without closing bracket-colon" $ + parseAddress "[::1]7687" `shouldSatisfy` isLeft + + it "parses full IPv6 address" $ + parseAddress "[2001:db8::1]:7687" `shouldBe` Right (ServerAddress "2001:db8::1" 7687)