diff --git a/bolty.cabal b/bolty.cabal --- a/bolty.cabal +++ b/bolty.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: bolty -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Haskell driver for Neo4j (BOLT protocol 4.4-5.4) description: Native Haskell driver for Neo4j graph database using the BOLT protocol. Supports BOLT versions 4.4 through 5.4 with connection pooling, @@ -37,6 +37,7 @@ library exposed-modules: Database.Bolty + Database.Bolty.AccessMode Database.Bolty.Decode Database.Bolty.Pool Database.Bolty.Record @@ -45,6 +46,7 @@ Database.Bolty.Session Database.Bolty.Logging Database.Bolty.Notification + Database.Bolty.Admin Database.Bolty.Plan Database.Bolty.Stats Database.Bolty.Connection @@ -196,10 +198,10 @@ ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-safe-haskell-mode -Wno-name-shadowing -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unused-imports -Wno-unused-packages build-depends: QuickCheck - , aeson >=2.1 && <2.3 + , aeson , base >=4.18 && <5 , bolty - , bytestring >=0.11 && <0.13 + , bytestring , crypton-connection >=0.3 && <0.5 , data-default >=0.7 && <0.9 , extra >=1.7 && <1.9 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,24 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.2.0.0 + +- New `Database.Bolty.AccessMode` module: `AccessMode = ReadAccess | WriteAccess` with a single `PackStream` instance. Re-exported from `Database.Bolty`. +- New `Database.Bolty.Admin` module with gated transaction primitives for admin tools, CLIs, and migrations: `withReadOnlyTransaction` and `withConfirmedWriteTransaction` (plus pool variants), `ReadOutcome` / `WriteOutcome` types, `totalAffected`, `describeReadOutcome` / `describeWriteOutcome`. +- New transaction primitives in `Database.Bolty`: `withReadTransaction` and `withReadTransaction'` (un-gated read tx with cluster routing-to-follower and server-side enforcement), public `withTxMode :: AccessMode -> ...`, `withRetryTransactionMode :: AccessMode -> ...`. +- New public Aeson interop: `parsePs`, `psToAeson`, `propsToAeson`, `propsFromAeson`. +- New exports `renderPlan` (from `Database.Bolty.Plan`) and `formatStatsLine` (from `Database.Bolty.Stats`). +- New `Show QueryMeta` instance. +- **Breaking**: `Begin.mode`, `RunExtra.mode`, `RunAutoCommitTransaction.mode` are now `AccessMode` instead of `Char`. Use `ReadAccess` / `WriteAccess` instead of `'r'` / `'w'`. +- **Breaking**: `withTxMode` and `withRetryTransactionMode` take `AccessMode` instead of `Char`. +- **Breaking**: `Database.Bolty.Tx` module renamed to `Database.Bolty.Admin`. `totalAffected` moved from `Database.Bolty.Stats` to `Database.Bolty.Admin` (re-export from `Database.Bolty` is unchanged). +- **Breaking**: `AccessMode(..)` no longer re-exported from `Database.Bolty.Routing`. Import from `Database.Bolty.AccessMode` or `Database.Bolty`. +- **Breaking**: Internal helper `fromPsMode` removed. +- Fix: `Begin.fromPs`, `RunExtra.fromPs`, and the autocommit RUN decoder now accept wire dicts where the optional `mode` key is absent (defaulting to `WriteAccess` per the Bolt spec). Previously bolty rejected spec-compliant peers that omitted the default. +- Fix: `withReadOnlyTransaction` opens BEGIN with `mode='r'` (was `mode='w'`) for cluster read routing and server-side write rejection on Neo4j 5+. +- Fix: pool-variant transaction helpers capture pool-acquire failures in the returned `Either` instead of propagating them as exceptions. +- 15 new direct `AccessMode` unit tests covering encode/decode round-trips, rejection of invalid `Ps` shapes, `Bounded` / `Enum` exhaustion, and parent-message decoders for the spec-default and rejection paths on `Begin`, `RunExtra`, and the autocommit `RUN`. bolty-test: 320 → 335 passing. + ## 0.1.0.2 - Fix pool crash on machines with more than 10 CPU cores (set numStripes to 1) diff --git a/integration/Main.hs b/integration/Main.hs --- a/integration/Main.hs +++ b/integration/Main.hs @@ -252,7 +252,34 @@ Nothing -> expectationFailure "Expected 'alice'" liftIO $ wp $ \p -> queryIO p "MATCH (n:TestTxParam) DELETE n" >> pure () + it "withReadTransaction runs a read query" $ do + -- The un-gated read tx primitive: just opens BEGIN with mode='r', + -- runs the action, commits. No post-hoc stats inspection. + result <- liftIO $ wp $ \p -> + withReadTransaction p $ \conn -> + queryIO conn "RETURN 42 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + it "withReadTransaction rejects writes upfront (AccessMode)" $ do + -- mode='r' makes the server reject any write attempt before it + -- runs. The exception type varies by Neo4j version; we just check + -- that an exception was thrown and no row landed. + r :: Either SomeException () <- liftIO $ try $ + wp $ \p -> + withReadTransaction p $ \conn -> + queryIO conn "CREATE (:TestReadTxReject {tag: 'nope'})" >> pure () + case r of + Left _ -> pure () + Right _ -> expectationFailure "Expected an AccessMode error from server" + count <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestReadTxReject) RETURN count(n) AS c" + case asInt (V.head $ V.head count) of + Just n -> n `shouldBe` 0 + Nothing -> expectationFailure "Expected 0" + + describe (label ++ " - Graph type queries") $ do it "returns a Node" $ do @@ -1373,6 +1400,173 @@ -- ================================================================ +-- Admin / sandbox transaction integration tests (Database.Bolty.Admin) +-- +-- The whole point of these wrappers is the tx-rollback behaviour, which +-- only the bolt server can verify -- a unit test that mocks the +-- connection can't observe whether the writes actually became durable. +-- These cases set up a graph fixture, run the gated tx, then poll the +-- database to assert state. +-- ================================================================ + +adminTestSuite :: TopSpec +adminTestSuite = do + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn neo4j5Config + -- Unique label so this suite doesn't trip over other tests' fixtures. + lbl = "BoltyTxTest" + cleanup = liftIO $ wp $ \p -> + queryIO p ("MATCH (n:" <> lbl <> ") DETACH DELETE n") >> pure () + countNodes = liftIO $ wp $ \p -> do + r <- queryIO p ("MATCH (n:" <> lbl <> ") RETURN count(n) AS c") + case asInt (V.head $ V.head r) of + Just n -> pure n + Nothing -> error "expected an int" + + describe "Database.Bolty.Admin (real Neo4j)" $ do + + it "withReadOnlyTransaction returns ReadOK for read-only Cypher" $ do + cleanup + outcome <- liftIO $ wp $ \conn -> + withReadOnlyTransaction conn "RETURN 1 AS x" H.empty + case outcome of + Right (ReadOK _ _) -> pure () + Right other -> expectationFailure $ + "expected ReadOK, got " <> T.unpack (describeReadOutcome other) + Left e -> expectationFailure $ "tx error: " <> show e + + -- A read tx that attempts a write must never commit. With mode='r', + -- Neo4j 5 rejects the write upfront with an AccessMode error + -- ('Left'). Older versions, or procedure-style writes that bypass + -- access-mode enforcement, would surface as 'ReadAbortedByWrite'. + -- Both outcomes are correct; only an accidental commit would be a bug. + it "CREATE inside read tx never commits" $ do + cleanup + before <- countNodes + before `shouldBe` 0 + outcome <- liftIO $ wp $ \conn -> + withReadOnlyTransaction conn + ("CREATE (:" <> lbl <> " {tag: 'should-not-persist'}) RETURN 1") H.empty + assertReadDidNotCommit outcome + after <- countNodes + after `shouldBe` 0 + + it "DELETE inside read tx leaves the row intact" $ do + cleanup + liftIO $ wp $ \p -> queryIO p ("CREATE (:" <> lbl <> " {a: 1})") >> pure () + before <- countNodes + before `shouldBe` 1 + outcome <- liftIO $ wp $ \conn -> + withReadOnlyTransaction conn + ("MATCH (n:" <> lbl <> ") DELETE n RETURN count(n)") H.empty + assertReadDidNotCommit outcome + after <- countNodes + after `shouldBe` 1 + cleanup + + it "withConfirmedWriteTransaction commits when the count matches" $ do + cleanup + -- CREATE (:X {a:1}) reports affected = node + property + label = 3. + outcome <- liftIO $ wp $ \conn -> + withConfirmedWriteTransaction conn + ("CREATE (:" <> lbl <> " {a: 1})") H.empty 3 + case outcome of + Right (WriteCommitted _ _) -> pure () + Right other -> expectationFailure $ + "expected WriteCommitted, got " <> T.unpack (describeWriteOutcome other) + Left e -> expectationFailure $ show e + after <- countNodes + after `shouldBe` 1 + cleanup + + it "withConfirmedWriteTransaction rolls back on count mismatch" $ do + cleanup + outcome <- liftIO $ wp $ \conn -> + withConfirmedWriteTransaction conn + ("CREATE (:" <> lbl <> " {a: 99})") H.empty 99 + case outcome of + Right (WriteAbortedMismatch ex actual _) -> do + ex `shouldBe` 99 + actual `shouldBe` 3 + Right other -> expectationFailure $ + "expected WriteAbortedMismatch, got " <> T.unpack (describeWriteOutcome other) + Left e -> expectationFailure $ show e + after <- countNodes + after `shouldBe` 0 + + it "pool variant returns a ReadOK for a simple read" $ do + cleanup + cfg <- liftIO $ mkGetConfig neo4j5Config + pool <- liftIO $ createPool cfg defaultPoolConfig + outcome <- liftIO $ withReadOnlyTransaction' pool "RETURN 1 AS x" H.empty + liftIO $ destroyPool pool + case outcome of + Right (ReadOK _ _) -> pure () + Right other -> expectationFailure $ + "expected ReadOK, got " <> T.unpack (describeReadOutcome other) + Left e -> expectationFailure $ show e + + it "pool variant of confirmed write commits when count matches" $ do + cleanup + cfg <- liftIO $ mkGetConfig neo4j5Config + pool <- liftIO $ createPool cfg defaultPoolConfig + outcome <- liftIO $ withConfirmedWriteTransaction' pool + ("CREATE (:" <> lbl <> " {a: 1})") H.empty 3 + liftIO $ destroyPool pool + case outcome of + Right (WriteCommitted _ _) -> pure () + Right other -> expectationFailure $ + "expected WriteCommitted, got " <> T.unpack (describeWriteOutcome other) + Left e -> expectationFailure $ show e + after <- countNodes + after `shouldBe` 1 + cleanup + + it "pool variant captures pool acquire failures in Left" $ do + -- Build a pool pointing at a port nothing's listening on. The + -- subsequent withReadOnlyTransaction' must surface the connect error + -- as Left, not throw -- this is the contract added by the try-wrap. + let badConfig = pure def + { host = "127.0.0.1" + , port = 65500 -- unprivileged port; nothing listening here + , scheme = None + , use_tls = False + } + cfg <- liftIO $ mkGetConfig badConfig + pool <- liftIO $ createPool cfg defaultPoolConfig + outcome <- liftIO $ withReadOnlyTransaction' pool "RETURN 1" H.empty + liftIO $ destroyPool pool + case outcome of + Left _ -> pure () -- expected: pool/connect error captured + Right res -> expectationFailure $ + "expected Left from broken pool, got " <> T.unpack (describeReadOutcome res) + + it "confirm=0 commits a no-op MATCH that affects nothing" $ do + cleanup + -- Boundary case: a query that matches no rows reports affected=0. + -- confirm=0 must commit cleanly rather than rolling back as a mismatch. + outcome <- liftIO $ wp $ \conn -> + withConfirmedWriteTransaction conn + ("MATCH (n:" <> lbl <> "Nonexistent) DETACH DELETE n") H.empty 0 + case outcome of + Right (WriteCommitted _ _) -> pure () + Right other -> expectationFailure $ + "expected WriteCommitted, got " <> T.unpack (describeWriteOutcome other) + Left e -> expectationFailure $ show e + + +-- | Either path that signals "this read tx didn't commit any writes": +-- the post-hoc stats gate (ReadAbortedByWrite) or the server's upfront +-- mode='r' enforcement (Left _). +assertReadDidNotCommit :: Either SomeException ReadOutcome -> ExampleT context IO () +assertReadDidNotCommit outcome = case outcome of + Right (ReadAbortedByWrite _) -> pure () + Left _ -> pure () + Right other -> expectationFailure $ + "expected ReadAbortedByWrite or Left _, got " <> T.unpack (describeReadOutcome other) + + +-- ================================================================ -- Server hints integration tests -- ================================================================ @@ -1704,6 +1898,8 @@ notificationTestSuite -- Query stats tests (Neo4j 5) statsTestSuite + -- Gated transactions (Neo4j 5; covers the rollback semantics) + adminTestSuite -- Server hints tests (Neo4j 5) serverHintTestSuite -- Decode tests (Neo4j 5) diff --git a/src/Database/Bolty.hs b/src/Database/Bolty.hs --- a/src/Database/Bolty.hs +++ b/src/Database/Bolty.hs @@ -43,8 +43,12 @@ , sendTelemetry -- * Transactions , withTransaction - , withRetryTransaction , withTransaction' + , withReadTransaction + , withReadTransaction' + , withTxMode + , withRetryTransaction + , withRetryTransactionMode -- * Retry configuration , RetryConfig(..) , defaultRetryConfig @@ -102,6 +106,7 @@ , ProfileNode(..) , queryExplain , queryProfile + , renderPlan -- * Query logging , QueryLog(..) -- * Notifications @@ -110,6 +115,7 @@ , Position(..) -- * Query statistics , QueryStats(..) + , formatStatsLine -- * BoltM monad , BoltM , runBolt @@ -149,13 +155,30 @@ , groupByField -- * PackStream re-exports , Ps(..) + -- * Aeson interop + , parsePs + , psToAeson + , propsToAeson + , propsFromAeson + -- * Admin / sandbox helpers (Database.Bolty.Admin) + , ReadOutcome(..) + , WriteOutcome(..) + , ReadModeViolation(..) + , WriteCountMismatch(..) + , describeReadOutcome + , describeWriteOutcome + , withReadOnlyTransaction + , withReadOnlyTransaction' + , withConfirmedWriteTransaction + , withConfirmedWriteTransaction' + , totalAffected ) where -import Database.Bolty.Connection (queryPWithFieldsIO, queryPMetaIO) +import Database.Bolty.Connection (queryPWithFieldsIO, queryPMetaIO, withTxMode) import Database.Bolty.Logging (QueryLog(..)) -import Database.Bolty.Plan (PlanNode(..), ProfileNode(..)) +import Database.Bolty.Plan (PlanNode(..), ProfileNode(..), renderPlan) import Database.Bolty.Notification (Notification(..), Severity(..), Position(..)) -import Database.Bolty.Stats (QueryStats(..)) +import Database.Bolty.Stats (QueryStats(..), formatStatsLine) import Database.Bolty.Decode import Database.Bolty.Connection.Config (validateConfig) import qualified Database.Bolty.Connection.Pipe as P @@ -168,7 +191,8 @@ import Database.Bolty.Pool import Database.Bolty.Record import Database.Bolty.ResultSet -import Database.Bolty.Routing (AccessMode(..), RoutingPool, RoutingPoolConfig(..), +import Database.Bolty.AccessMode (AccessMode(..)) +import Database.Bolty.Routing (RoutingPool, RoutingPoolConfig(..), defaultRoutingPoolConfig, createRoutingPool, destroyRoutingPool, withRoutingConnection, acquireRoutingConnection, @@ -179,7 +203,17 @@ readTransaction, writeTransaction, getLastBookmarks) import Database.Bolty.Value.Type (Bolt(..), asNull, asBool, asInt, asFloat , asBytes, asText, asList, asDict - , asNode, asRelationship, asPath) + , asNode, asRelationship, asPath + , parsePs, psToAeson + , propsToAeson, propsFromAeson) +import Database.Bolty.Admin (ReadOutcome(..), WriteOutcome(..) + , ReadModeViolation(..) + , WriteCountMismatch(..) + , describeReadOutcome, describeWriteOutcome + , withReadOnlyTransaction, withReadOnlyTransaction' + , withConfirmedWriteTransaction + , withConfirmedWriteTransaction' + , totalAffected) import Database.Bolty.Connection.Version (Version(..)) import Data.Kind (Type) @@ -320,28 +354,53 @@ Nothing -> error "queryProfile: no profile in response" --- | Run an action inside an explicit transaction. Automatically commits on success --- and rolls back on failure. +-- | Run an action inside an explicit /write/ transaction. Automatically +-- commits on success and rolls back on failure. +-- +-- Equivalent to @'withTxMode' 'WriteAccess'@. Use 'withReadTransaction' +-- for a read-only transaction that can be cluster-routed to a follower +-- and has the server enforce no writes. withTransaction :: HasCallStack => Connection -> (Connection -> IO a) -> IO a -withTransaction conn action = do - P.beginTx conn defaultBegin - result <- action conn `onException` P.tryRollback conn - _ <- P.commitTx conn - pure result - where - defaultBegin = Begin V.empty Nothing H.empty 'w' Nothing Nothing +withTransaction = withTxMode WriteAccess +-- | Run an action inside an explicit /read/ transaction. Automatically +-- commits on success and rolls back on failure. +-- +-- The transaction is opened with 'ReadAccess': in cluster setups the +-- server routes to a follower, and any direct write attempt is rejected +-- upfront with an @AccessMode@ error (a Neo4j 5+ feature). For application +-- code this is the right pair to 'withTransaction'. +-- +-- For an admin-tool variant that additionally inspects 'parsedStats' +-- post-hoc and reports a rollback as a typed 'ReadOutcome' instead of +-- a thrown exception, see 'Database.Bolty.Admin.withReadOnlyTransaction'. +-- +-- /Not the same as/ 'Database.Bolty.Session.readTransaction', which runs +-- a multi-step action against a session with bookmarks. +withReadTransaction :: HasCallStack => Connection -> (Connection -> IO a) -> IO a +withReadTransaction = withTxMode ReadAccess + + -- | Run a transaction with automatic retry on transient failures. -- Uses exponential backoff between retries. withRetryTransaction :: HasCallStack => RetryConfig -> Connection -> (Connection -> IO a) -> IO a -withRetryTransaction RetryConfig{maxRetries, initialDelay, maxDelay} conn action = +withRetryTransaction = withRetryTransactionMode WriteAccess + + +-- | Like 'withRetryTransaction' but parameterised on the 'AccessMode', +-- so the same retry machinery serves both 'withTransaction'' and +-- 'withReadTransaction''. +withRetryTransactionMode + :: HasCallStack + => AccessMode -> RetryConfig -> Connection -> (Connection -> IO a) -> IO a +withRetryTransactionMode mode RetryConfig{maxRetries, initialDelay, maxDelay} conn action = go maxRetries initialDelay where - go 0 _ = withTransaction conn action + go 0 _ = withTxMode mode conn action go n delay = do - result <- try $ withTransaction conn action + result <- try $ withTxMode mode conn action case result of Right x -> pure x Left (e :: SomeException) -> case fromException e :: Maybe Error of @@ -351,10 +410,19 @@ _ -> throwIO e --- | Convenience: acquire a pooled connection, run a retrying transaction, and release. +-- | Convenience: acquire a pooled connection, run a retrying write +-- transaction, and release. withTransaction' :: HasCallStack => BoltPool -> (Connection -> IO a) -> IO a withTransaction' pool@BoltPool{bpRetryConfig} action = withConnection pool $ \conn -> - withRetryTransaction bpRetryConfig conn action + withRetryTransactionMode WriteAccess bpRetryConfig conn action + + +-- | Convenience: acquire a pooled connection, run a retrying read +-- transaction, and release. +withReadTransaction' :: HasCallStack => BoltPool -> (Connection -> IO a) -> IO a +withReadTransaction' pool@BoltPool{bpRetryConfig} action = + withConnection pool $ \conn -> + withRetryTransactionMode ReadAccess bpRetryConfig conn action diff --git a/src/Database/Bolty/AccessMode.hs b/src/Database/Bolty/AccessMode.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/AccessMode.hs @@ -0,0 +1,41 @@ +-- | Access mode for Bolt transactions and routing. +-- +-- The Bolt protocol carries a @mode@ field on BEGIN and RUN messages whose +-- only valid values are @"r"@ (read) and @"w"@ (write). This module hides +-- that wire shape behind a sum type so consumers can't construct invalid +-- modes, and so the read\/write distinction reads as data at use sites +-- (cluster routing, transaction primitives, session management). +-- +-- The 'PackStream' instance is the single point where the wire encoding +-- lives: 'ReadAccess' \<-\> @"r"@, 'WriteAccess' \<-\> @"w"@. +module Database.Bolty.AccessMode + ( AccessMode(..) + ) where + +import Data.Kind (Type) +import Data.PackStream (PackStream(..), Ps(..), Result(..), withString) +import GHC.Generics (Generic) + + +-- | Whether a transaction (or session connection) is intended for reading +-- or writing. The value flows to two distinct layers: +-- +-- * Cluster routing (Session\/Routing layer): 'ReadAccess' picks a follower, +-- 'WriteAccess' picks the leader. No-op on non-clustered connections. +-- * Per-transaction enforcement (BEGIN\/RUN @mode@): 'ReadAccess' instructs +-- the server to reject write attempts upfront (Neo4j 5+); 'WriteAccess' +-- is the default and allows writes. +type AccessMode :: Type +data AccessMode = ReadAccess | WriteAccess + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + + +-- | Wire format: a single-character PackStream string, @"r"@ or @"w"@. +-- @fromPs@ rejects any other string to preserve the invariant on decode. +instance PackStream AccessMode where + toPs ReadAccess = PsString "r" + toPs WriteAccess = PsString "w" + fromPs = withString "AccessMode" $ \t -> case t of + "r" -> Success ReadAccess + "w" -> Success WriteAccess + _ -> Error ("expected mode \"r\" or \"w\", got: " <> t) diff --git a/src/Database/Bolty/Admin.hs b/src/Database/Bolty/Admin.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Admin.hs @@ -0,0 +1,312 @@ +-- | Helpers for admin tools, migration scripts, and sandbox executors -- +-- not intended for application code. +-- +-- The functions here trade flexibility for safety: they wrap a hand-rolled +-- BEGIN\/COMMIT\/ROLLBACK with a server-stat-based gate so the caller can +-- be sure a query either stays within an expected effect or doesn't commit +-- at all. +-- +-- * 'withReadOnlyTransaction' rolls back if the query produced any updates. +-- * 'withConfirmedWriteTransaction' rolls back unless the actual affected +-- count exactly matches the caller-supplied expectation. +-- +-- Both come in two variants: the @Connection@ form takes a connection you +-- already hold, and the primed @'@ form pulls one from a 'BoltPool' for +-- the duration of the call. +-- +-- Application code generally knows whether its queries read or write and +-- doesn't need either gate. Use 'Database.Bolty.withTransaction' or the +-- session-level 'Database.Bolty.Session.readTransaction' \/ 'writeTransaction' +-- instead. +-- +-- This module lives alongside (rather than inside) 'Database.Bolty' to +-- avoid an import cycle: 'Database.Bolty' re-exports the names below. +-- Internals shared with 'Database.Bolty' (the BEGIN/COMMIT/ROLLBACK +-- wrapper) live in 'Database.Bolty.Connection.withTxMode', re-exported +-- from 'Database.Bolty'. +module Database.Bolty.Admin + ( -- * Outcomes + ReadOutcome(..) + , WriteOutcome(..) + , describeReadOutcome + , describeWriteOutcome + -- * Internal exceptions (escape hatches) + , ReadModeViolation(..) + , WriteCountMismatch(..) + -- * Read-only gated transactions + , withReadOnlyTransaction + , withReadOnlyTransaction' + -- * Confirm-gated write transactions + , withConfirmedWriteTransaction + , withConfirmedWriteTransaction' + -- * Affected-count helper used by the gate + , totalAffected + ) where + +import Prelude + +import Control.Exception (Exception, SomeException, fromException, + throwIO, try) +import Data.Int (Int64) +import Data.Kind (Type) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T + +import Data.PackStream.Ps (Ps) +import Database.Bolty.AccessMode (AccessMode(..)) +import Database.Bolty.Connection (queryPMetaIO, withTxMode) +import Database.Bolty.Connection.Type (Connection) +import Database.Bolty.Message.Response (QueryMeta(..)) +import Database.Bolty.Pool (BoltPool, withConnection) +import Database.Bolty.ResultSet (ResultSet(..)) +import Database.Bolty.Stats (QueryStats(..), formatStatsLine) + + +-- ===================================================================== +-- Outcomes +-- ===================================================================== + +-- | Outcome of a 'withReadOnlyTransaction' run that didn't fail with a +-- non-validation error. 'ReadAbortedByWrite' fires when the query produced +-- any updates, which forces the transaction to roll back. +-- +-- No 'Show' instance: 'QueryMeta' has one only via a stock derive in +-- "Database.Bolty.Message.Response", and you generally don't want a +-- multi-kilobyte stat dump in your logs. Use 'describeReadOutcome' for +-- a one-liner. +type ReadOutcome :: Type +data ReadOutcome + = ReadOK !ResultSet !QueryMeta + | ReadAbortedByWrite !QueryStats + + +-- | One-line description of a 'ReadOutcome' suitable for assertion +-- messages and logging. +describeReadOutcome :: ReadOutcome -> T.Text +describeReadOutcome (ReadOK _ _) = "ReadOK" +describeReadOutcome (ReadAbortedByWrite s) = + "ReadAbortedByWrite (" <> formatStatsLine s <> ")" + + +-- | Outcome of a 'withConfirmedWriteTransaction' run. 'WriteAbortedMismatch' +-- fires when the actual affected count doesn't match the caller-supplied +-- confirm number; the transaction is rolled back in that case. +type WriteOutcome :: Type +data WriteOutcome + = WriteCommitted !ResultSet !QueryMeta + | WriteAbortedMismatch !Int64 !Int64 !(Maybe QueryStats) + -- ^ expected, actual, stats (if any) + + +-- | One-line description of a 'WriteOutcome' suitable for assertion +-- messages and logging. +describeWriteOutcome :: WriteOutcome -> T.Text +describeWriteOutcome (WriteCommitted _ _) = "WriteCommitted" +describeWriteOutcome (WriteAbortedMismatch ex actual mStats) = + "WriteAbortedMismatch expected=" <> T.pack (show ex) + <> " actual=" <> T.pack (show actual) + <> maybe "" (\s -> " (" <> formatStatsLine s <> ")") mStats + + +-- ===================================================================== +-- Internal-but-exported rollback exceptions +-- ===================================================================== + +-- | Thrown inside 'withReadOnlyTransaction' to trigger a rollback. Caught +-- and converted to 'ReadAbortedByWrite' before returning, so callers +-- normally don't see it. Exported only as an escape hatch for code that +-- builds its own wrappers around the primitive. +type ReadModeViolation :: Type +data ReadModeViolation = ReadModeViolation !QueryStats + deriving stock (Show) +instance Exception ReadModeViolation + + +-- | Thrown inside 'withConfirmedWriteTransaction' to trigger a rollback. +-- Same exported-as-escape-hatch caveat as 'ReadModeViolation'. +type WriteCountMismatch :: Type +data WriteCountMismatch = WriteCountMismatch !Int64 !Int64 !(Maybe QueryStats) + deriving stock (Show) +instance Exception WriteCountMismatch + + +-- ===================================================================== +-- Read-only query execution (gated) +-- ===================================================================== + +-- | Run a single query in an explicit read transaction on the given +-- connection. The transaction is opened with @mode='r'@, which has two +-- effects: +-- +-- 1. In cluster setups, the server routes the query to a follower. +-- 2. The server enforces read-only access: any direct write attempt +-- (e.g. @CREATE@, @MATCH ... DELETE@) is rejected with +-- @AccessMode@ before it executes, surfacing as 'Left' from this +-- function with a 'ResponseErrorFailure' inside. +-- +-- The function additionally inspects 'parsedStats' post-hoc. If a +-- query slips past the server's mode enforcement and reports +-- 'containsUpdates' (some procedures may bypass enforcement), the +-- transaction is rolled back and the function returns +-- 'ReadAbortedByWrite'. This belt-and-braces gate covers older Neo4j +-- versions and procedure-side mutations that don't trigger +-- @AccessMode@. +-- +-- Either way, no committed writes survive. Callers that want to verify +-- "the database is unchanged" should rely on 'Right' = ('ReadOK' or +-- 'ReadAbortedByWrite') and 'Left' both being acceptable; only an +-- accidentally committed write would be a bug. +-- +-- This is /not/ the same as 'Database.Bolty.Session.readTransaction', +-- which runs a multi-step action against a session in read mode with +-- bookmarks. 'withReadOnlyTransaction' runs a single query, gates on its +-- stats, and returns the outcome; it has no notion of session state. +-- +-- Caveats: +-- +-- * Procedures with external side effects (e.g. @apoc.export.csv@) +-- cannot be undone -- their files are written before either gate +-- fires. Use 'withReadOnlyTransaction' for pure Cypher only. +-- * 'containsSystemUpdates' (CREATE DATABASE etc.) is not gated; in +-- practice Neo4j refuses to mix system and data ops in one tx, so +-- this is rarely observable. +withReadOnlyTransaction + :: Connection + -> T.Text + -> H.HashMap T.Text Ps + -> IO (Either SomeException ReadOutcome) +withReadOnlyTransaction conn query params = do + result <- try $ withTxMode ReadAccess conn $ \tConn -> do + (rs, meta) <- runQuery tConn query params + case parsedStats meta of + Just s | containsUpdates s -> throwIO (ReadModeViolation s) + _ -> pure (rs, meta) + case result of + Right (rs, meta) -> pure $ Right (ReadOK rs meta) + Left e -> case fromException e of + Just (ReadModeViolation s) -> pure $ Right (ReadAbortedByWrite s) + Nothing -> pure $ Left e + + +-- | Pool variant of 'withReadOnlyTransaction'. Acquires a connection from +-- the pool for the duration of the call. Pool-level failures (acquire +-- timeout, validation failure) are captured in the returned 'Either' +-- rather than thrown, matching the contract of 'withReadOnlyTransaction'. +withReadOnlyTransaction' + :: BoltPool + -> T.Text + -> H.HashMap T.Text Ps + -> IO (Either SomeException ReadOutcome) +withReadOnlyTransaction' pool query params = do + result <- try $ withConnection pool $ \conn -> + withReadOnlyTransaction conn query params + pure $ case result of + Right inner -> inner -- already Either + Left e -> Left e -- pool error + + +-- ===================================================================== +-- Confirm-gated write transactions +-- ===================================================================== + +-- | Run a query in an explicit write transaction on the given connection, +-- gated by an expected affected-entity count (see 'totalAffected' for +-- what counts as "affected"). The transaction commits only when the +-- actual count equals @expected@; otherwise it rolls back and the +-- function returns 'WriteAbortedMismatch' with the actual count for the +-- caller to react to. +-- +-- The intended use is ad-hoc administrative writes where the operator +-- wants a deliberate \"I know exactly what this query will affect\" +-- handshake before any change becomes durable. Run once with a +-- deliberately wrong expected count to discover the actual count, then +-- re-run with the correct value to commit. +withConfirmedWriteTransaction + :: Connection + -> T.Text + -> H.HashMap T.Text Ps + -> Int64 -- ^ expected total affected count + -> IO (Either SomeException WriteOutcome) +withConfirmedWriteTransaction conn query params expected = do + result <- try $ withTxMode WriteAccess conn $ \tConn -> do + (rs, meta) <- runQuery tConn query params + let stats = parsedStats meta + actual = totalAffected stats + if actual /= expected + then throwIO (WriteCountMismatch expected actual stats) + else pure (rs, meta) + case result of + Right (rs, meta) -> pure $ Right (WriteCommitted rs meta) + Left e -> case fromException e of + Just (WriteCountMismatch ex ac st) -> + pure $ Right (WriteAbortedMismatch ex ac st) + Nothing -> pure $ Left e + + +-- | Pool variant of 'withConfirmedWriteTransaction'. Acquires a +-- connection from the pool for the duration of the call. Pool-level +-- failures are captured in the returned 'Either' rather than thrown, +-- matching the contract of 'withConfirmedWriteTransaction'. +withConfirmedWriteTransaction' + :: BoltPool + -> T.Text + -> H.HashMap T.Text Ps + -> Int64 + -> IO (Either SomeException WriteOutcome) +withConfirmedWriteTransaction' pool query params expected = do + result <- try $ withConnection pool $ \conn -> + withConfirmedWriteTransaction conn query params expected + pure $ case result of + Right inner -> inner + Left e -> Left e + + +-- ===================================================================== +-- Affected-count helper +-- ===================================================================== + +-- | Sum every mutation counter on a 'QueryStats' record. Used by +-- 'withConfirmedWriteTransaction' to compare actual versus expected +-- effect; lives here rather than in "Database.Bolty.Stats" because the +-- summing semantics are admin-tool-shaped (most application code cares +-- about specific counters, or uses the boolean 'containsUpdates' flag). +-- +-- The total includes both data and schema mutations within the current +-- database -- nodes, relationships, properties, labels, indexes, and +-- constraints, both created and removed. It does not net out: a query +-- that creates 5 nodes and deletes 5 nodes reports 10, not 0. +-- +-- The asymmetry between @CREATE (:X {a:1})@ (3: node + property + label) +-- and @DETACH DELETE n@ (1: node) is intentional: the counters reflect +-- the work the server performed, not just the headline operation. +-- +-- Excluded from the sum: +-- +-- * The 'containsUpdates' / 'containsSystemUpdates' boolean flags, +-- which are derived from the counters. +-- * 'systemUpdates' -- a separate counter for system-level changes +-- (CREATE DATABASE, CREATE USER, etc.) that affect server-wide state +-- rather than the current database. +totalAffected :: Maybe QueryStats -> Int64 +totalAffected Nothing = 0 +totalAffected (Just s) = + nodesCreated s + nodesDeleted s + + relationshipsCreated s + relationshipsDeleted s + + propertiesSet s + + labelsAdded s + labelsRemoved s + + indexesAdded s + indexesRemoved s + + constraintsAdded s + constraintsRemoved s + + +-- ===================================================================== +-- Internals +-- ===================================================================== + +-- Run a query and bundle the result into a 'ResultSet'. Mirrors +-- 'Database.Bolty.queryResultMeta' but at the IO level so we don't +-- depend on the 'BoltM' newtype (which would cycle through +-- 'Database.Bolty'). +runQuery :: Connection -> T.Text -> H.HashMap T.Text Ps -> IO (ResultSet, QueryMeta) +runQuery conn query params = do + (fs, rs, meta) <- queryPMetaIO conn query params + pure (ResultSet fs rs, meta) diff --git a/src/Database/Bolty/Connection.hs b/src/Database/Bolty/Connection.hs --- a/src/Database/Bolty/Connection.hs +++ b/src/Database/Bolty/Connection.hs @@ -9,16 +9,19 @@ , queryPMetaIO , requestResponseRunIO , requestResponsePullIO + , withTxMode ) where import Prelude +import Database.Bolty.AccessMode (AccessMode) import qualified Database.Bolty.Connection.Pipe as P import Database.Bolty.Connection.Type import Database.Bolty.Logging +import Database.Bolty.Message.Request (Begin(Begin)) import Database.Bolty.Record -import Control.Exception (SomeException, throwIO, try) +import Control.Exception (SomeException, onException, throwIO, try) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Kind (Type) import Data.Text (Text) @@ -297,3 +300,20 @@ case notificationHandler of Nothing -> pure () Just handler -> V.mapM_ handler parsedNotifications + + +-- | Run an action inside an explicit transaction opened with the given +-- 'AccessMode'. Automatically commits on success and attempts a rollback +-- on failure. +-- +-- The mode controls cluster routing: 'ReadAccess' routes to a follower +-- and engages the server's read-only enforcement; 'WriteAccess' routes +-- to the leader. Higher-level helpers in "Database.Bolty" +-- ('Database.Bolty.withTransaction' / 'Database.Bolty.withReadTransaction') +-- are thin wrappers over this primitive. +withTxMode :: HasCallStack => AccessMode -> Connection -> (Connection -> IO a) -> IO a +withTxMode mode conn action = do + P.beginTx conn (Begin V.empty Nothing H.empty mode Nothing Nothing) + result <- action conn `onException` P.tryRollback conn + _ <- P.commitTx conn + pure result diff --git a/src/Database/Bolty/Message/Request.hs b/src/Database/Bolty/Message/Request.hs --- a/src/Database/Bolty/Message/Request.hs +++ b/src/Database/Bolty/Message/Request.hs @@ -16,9 +16,9 @@ , RunExtra(..), defaultRunExtra ) where -import Data.HashMap.Lazy (HashMap) import Data.Int (Int64) import Data.Kind (Type) +import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import qualified Data.HashMap.Lazy as H import qualified Data.Text as T @@ -26,6 +26,7 @@ import Data.PackStream import Data.PackStream.Integer (toPSInteger, fromPSInteger) +import Database.Bolty.AccessMode (AccessMode(..)) import Database.Bolty.Connection.Instances () import Database.Bolty.Connection.Type (UserAgent(..), Scheme(..), Routing(..)) @@ -96,7 +97,7 @@ bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in Run Request" tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in Run Request" - mode :: Char <- fromPsMode map + mode :: AccessMode <- lookupMode map db :: Maybe T.Text <- lookupMaybe "db" map imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map pure $ RRunAutoCommitTransaction RunAutoCommitTransaction{query, parameters, extra, bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} @@ -150,7 +151,7 @@ , bookmarks = V.empty , tx_timeout = Nothing , tx_metadata = H.empty - , mode = 'w' + , mode = WriteAccess , db = Nothing , imp_user = Nothing } @@ -164,7 +165,7 @@ , bookmarks = V.empty , tx_timeout = Nothing , tx_metadata = H.empty - , mode = 'w' + , mode = WriteAccess , db = Nothing , imp_user = Nothing } @@ -178,7 +179,7 @@ , bookmarks :: V.Vector T.Text , tx_timeout :: !(Maybe Int64) , tx_metadata :: !(H.HashMap T.Text Ps) - , mode :: !Char + , mode :: !AccessMode , db :: !(Maybe T.Text) , imp_user :: !(Maybe T.Text) } @@ -198,7 +199,7 @@ Just i -> [("imp_user", toPs i)] in [ ("bookmarks", toPs bookmarks) , ("tx_metadata", toPs tx_metadata) - , ("mode", toPs $ T.singleton mode) + , ("mode", toPs mode) , ("db", toPs db) ] <> tx_timeout_list <> imp_user_list ] @@ -226,7 +227,7 @@ { bookmarks :: !(V.Vector T.Text) , tx_timeout :: !(Maybe Int64) , tx_metadata :: !(H.HashMap T.Text Ps) - , mode :: !Char + , mode :: !AccessMode , db :: !(Maybe T.Text) , imp_user :: !(Maybe T.Text) } @@ -236,7 +237,7 @@ [ ("bookmarks", toPs bookmarks) , ("tx_timeout", toPs tx_timeout) , ("tx_metadata", toPs tx_metadata) - , ("mode", toPs $ T.singleton mode) + , ("mode", toPs mode) , ("db", toPs db) , ("imp_user", toPs imp_user) ] @@ -246,7 +247,7 @@ bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in Begin" tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in Begin" - mode :: Char <- fromPsMode map + mode :: AccessMode <- lookupMode map db :: (Maybe T.Text) <- lookupMaybe "db" map imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map pure $ Begin{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} @@ -326,7 +327,7 @@ { bookmarks :: !(V.Vector T.Text) , tx_timeout :: !(Maybe Int64) , tx_metadata :: !(H.HashMap T.Text Ps) - , mode :: !Char + , mode :: !AccessMode , db :: !(Maybe T.Text) , imp_user :: !(Maybe T.Text) } @@ -337,7 +338,7 @@ { bookmarks = V.empty , tx_timeout = Nothing , tx_metadata = H.empty - , mode = 'w' + , mode = WriteAccess , db = Nothing , imp_user = Nothing } @@ -347,7 +348,7 @@ [ ("bookmarks", toPs bookmarks) , ("tx_timeout", toPs tx_timeout) , ("tx_metadata", toPs tx_metadata) - , ("mode", toPs $ T.singleton mode) + , ("mode", toPs mode) , ("db", toPs db) , ("imp_user", toPs imp_user) ] @@ -357,21 +358,12 @@ bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in RunExtra" tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in RunExtra" - mode :: Char <- fromPsMode map + mode :: AccessMode <- lookupMode map db :: Maybe T.Text <- lookupMaybe "db" map imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map pure $ RunExtra{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} -fromPsMode :: HashMap T.Text Ps -> Result Char -fromPsMode map = do - mode :: T.Text <- lookupWithError "mode" map "\"mode\" not found in RunExtra" - if T.length mode == 1 then - Success $ T.head mode - else - Error "\"mode\" in RunExtra should be a single character of either 'r' or 'w'" - - helloToPs :: Hello -> Ps helloToPs Hello{user_agent, scheme, routing, patchBolt} = PsDictionary $ H.fromList $ @@ -524,3 +516,11 @@ Just i -> fmap RTelemetry $ telemetryApiFromInt i Nothing -> Error "telemetry api integer out of Int64 range" _ -> Error "expected integer field for Telemetry" + + +-- | Look up the BEGIN\/RUN @mode@ field, defaulting to 'WriteAccess' when +-- absent. Per the Bolt protocol, @mode@ is an optional field with default +-- @"w"@; spec-compliant peers may omit it on write transactions to save +-- bytes. A bare @lookupWithError@ would reject those messages. +lookupMode :: H.HashMap T.Text Ps -> Result AccessMode +lookupMode m = fromMaybe WriteAccess <$> lookupMaybe "mode" m diff --git a/src/Database/Bolty/Message/Response.hs b/src/Database/Bolty/Message/Response.hs --- a/src/Database/Bolty/Message/Response.hs +++ b/src/Database/Bolty/Message/Response.hs @@ -227,6 +227,7 @@ , db :: !T.Text -- ^ the database name where the query was executed (v4.0+). } + deriving stock (Show) -- | Parsed COMMIT SUCCESS metadata. type SuccessCommit :: Type diff --git a/src/Database/Bolty/Plan.hs b/src/Database/Bolty/Plan.hs --- a/src/Database/Bolty/Plan.hs +++ b/src/Database/Bolty/Plan.hs @@ -4,6 +4,7 @@ , ProfileNode(..) , parsePlan , parseProfile + , renderPlan ) where import Prelude @@ -152,3 +153,35 @@ Just i -> i Nothing -> 0 _ -> 0 + + +-- | Render a 'PlanNode' tree as an indented text block. Each child is +-- indented two spaces deeper than its parent. Identifier vectors (the +-- @vars:@ line) are shown when non-empty so a reader can match +-- variables to operators. +-- +-- Operator arguments ('pnArguments') are intentionally dropped for +-- terseness -- the operator name + estimated rows + identifiers are +-- enough to read most plans, and the args dictionary is verbose. +-- +-- Pass @0@ for the initial @depth@. Suitable for printing the result +-- of 'queryExplain'. +-- +-- Example output: +-- +-- > + ProduceResults (~1.0 rows) +-- > vars: u, name +-- > + Projection (~1.0 rows) +-- > vars: u, name +-- > + NodeUniqueIndexSeek (~1.0 rows) +-- > vars: u +renderPlan :: Int -> PlanNode -> T.Text +renderPlan depth (PlanNode op _args idents est children) = + let indent = T.replicate depth " " + header = indent <> "+ " <> op + <> " (~" <> T.pack (show est) <> " rows)" + idLine = if V.null idents + then "" + else indent <> " vars: " <> T.intercalate ", " (V.toList idents) <> "\n" + kids = T.concat $ V.toList $ V.map (renderPlan (depth + 1)) children + in header <> "\n" <> idLine <> kids diff --git a/src/Database/Bolty/Routing.hs b/src/Database/Bolty/Routing.hs --- a/src/Database/Bolty/Routing.hs +++ b/src/Database/Bolty/Routing.hs @@ -3,8 +3,6 @@ ( -- * Routing table getRoutingTable , RoutingTable(..) - -- * Access mode - , AccessMode(..) -- * Routing pool , RoutingPool(..) , RoutingPoolConfig(..) @@ -36,6 +34,7 @@ import GHC.Clock (getMonotonicTimeNSec) import GHC.Stack (HasCallStack) +import Database.Bolty.AccessMode (AccessMode(..)) import Database.Bolty.Connection.Type import qualified Database.Bolty.Connection.Pipe as P import Database.Bolty.Message.Request (Request(..), Route(..), RouteExtra(..), Begin(..)) @@ -43,12 +42,6 @@ import Database.Bolty.Pool --- | Access mode for routing: determines whether to use reader or writer servers. -type AccessMode :: Type -data AccessMode = ReadAccess | WriteAccess - deriving stock (Show, Eq) - - -- | Fetch a routing table from the server. The connection must be in Ready state. getRoutingTable :: HasCallStack => Connection -> Maybe Text -> IO RoutingTable getRoutingTable conn dbName = do @@ -258,10 +251,6 @@ go (n - 1) (min maxD (delay * 2)) maxD _ -> throwIO e - modeChar = case mode of - ReadAccess -> 'r' - WriteAccess -> 'w' - attempt = do rt <- getOrRefreshTable rp let addrs = case mode of @@ -272,7 +261,7 @@ addr <- roundRobin rp addrs pool <- getOrCreatePool rp addr withConnection pool $ \conn -> do - P.beginTx conn $ Begin V.empty Nothing H.empty modeChar Nothing Nothing + P.beginTx conn $ Begin V.empty Nothing H.empty mode Nothing Nothing result <- action conn `onException` P.tryRollback conn _ <- P.commitTx conn pure result diff --git a/src/Database/Bolty/Session.hs b/src/Database/Bolty/Session.hs --- a/src/Database/Bolty/Session.hs +++ b/src/Database/Bolty/Session.hs @@ -30,11 +30,12 @@ import qualified Data.Vector as V import GHC.Stack (HasCallStack) +import Database.Bolty.AccessMode (AccessMode(..)) import Database.Bolty.Connection.Type import qualified Database.Bolty.Connection.Pipe as P import Database.Bolty.Message.Request (Begin(Begin), TelemetryApi(..)) import Database.Bolty.Pool -import Database.Bolty.Routing (AccessMode(..), RoutingPool(..), withRoutingConnection, +import Database.Bolty.Routing (RoutingPool(..), withRoutingConnection, invalidateRoutingTable) @@ -183,15 +184,11 @@ go (n - 1) (min maxD (delay * 2)) maxD _ -> throwIO e - modeChar = case mode of - ReadAccess -> 'r' - WriteAccess -> 'w' - attempt = withSessionConnection sPool mode $ \conn -> do -- Get current bookmarks and begin the transaction bms <- getBookmarks sBookmarks - P.beginTx conn $ Begin (V.fromList bms) Nothing H.empty modeChar (database sConfig) Nothing + P.beginTx conn $ Begin (V.fromList bms) Nothing H.empty mode (database sConfig) Nothing -- Run the user's action, rollback on error result <- action conn `onException` P.tryRollback conn -- Commit and extract bookmark diff --git a/src/Database/Bolty/Stats.hs b/src/Database/Bolty/Stats.hs --- a/src/Database/Bolty/Stats.hs +++ b/src/Database/Bolty/Stats.hs @@ -2,6 +2,7 @@ module Database.Bolty.Stats ( QueryStats(..) , parseStats + , formatStatsLine ) where import Prelude @@ -73,3 +74,26 @@ boolField key m = case H.lookup key m of Just (PsBoolean b) -> b _ -> False + + +-- | One-line summary of every counter on a 'QueryStats' record. Format: +-- +-- > Stats: +nodes=1 -nodes=0 +rels=0 -rels=0 props=1 +labels=1 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0 +-- +-- Useful for diagnostic logging and CLI rollback messages where you want +-- the whole counter set on one line for terse comparison across runs. +formatStatsLine :: QueryStats -> T.Text +formatStatsLine s = T.concat + [ "Stats: " + , "+nodes=", T.pack (show (nodesCreated s)) + , " -nodes=", T.pack (show (nodesDeleted s)) + , " +rels=", T.pack (show (relationshipsCreated s)) + , " -rels=", T.pack (show (relationshipsDeleted s)) + , " props=", T.pack (show (propertiesSet s)) + , " +labels=", T.pack (show (labelsAdded s)) + , " -labels=", T.pack (show (labelsRemoved s)) + , " +idx=", T.pack (show (indexesAdded s)) + , " -idx=", T.pack (show (indexesRemoved s)) + , " +constr=", T.pack (show (constraintsAdded s)) + , " -constr=", T.pack (show (constraintsRemoved s)) + ] diff --git a/src/Database/Bolty/Value/Type.hs b/src/Database/Bolty/Value/Type.hs --- a/src/Database/Bolty/Value/Type.hs +++ b/src/Database/Bolty/Value/Type.hs @@ -1,6 +1,8 @@ --- | Internal module. Not part of the public API. +-- | Bolt value types: the Haskell representation of Neo4j values returned by queries. -- --- Bolt value types: the Haskell representation of Neo4j values returned by queries. +-- The Aeson interop helpers ('parsePs', 'psToAeson', 'propsToAeson', +-- 'propsFromAeson') are part of the stable public API; everything else +-- is the internal value-type machinery surfaced via 'Database.Bolty'. module Database.Bolty.Value.Type ( Bolt(..) -- * Bolt value extractors @@ -22,6 +24,13 @@ -- * Spatial types , Point2D(..) , Point3D(..) + -- * Aeson interop + -- + -- $aesonInterop + , parsePs + , psToAeson + , propsToAeson + , propsFromAeson ) where import Control.Applicative ((<|>), empty) @@ -384,6 +393,17 @@ -- = Aeson (ToJSON / FromJSON) instances +-- +-- $aesonInterop +-- +-- Helpers for moving values between PackStream's 'Ps' and Aeson's 'Aeson.Value'. +-- Useful when binding query parameters from JSON input (e.g. a CLI) or when +-- rendering query results as JSON. +-- +-- 'parsePs' handles the @{"bytes": ""}@ shape so binary values can +-- round-trip through JSON. Both functions use 'scientificToPs', which falls +-- back to 'PsFloat' when an integer literal exceeds the @[-2^63, 2^64-1]@ +-- range supported by 'PSInteger' rather than silently truncating. -- | Convert a PackStream property value to JSON. psToAeson :: Ps -> Aeson.Value diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,6 +9,7 @@ import Data.Word (Word32, Word64) import qualified Data.HashMap.Lazy as H import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Vector as V import qualified Validation as Val @@ -22,16 +23,21 @@ import qualified Database.Bolty.ResultSet as RS import Database.Bolty.Logging (QueryLog(..)) import Database.Bolty.Notification (Notification(..), Severity(..), Position(..), parseNotifications) -import Database.Bolty.Plan (PlanNode(..), ProfileNode(..), parsePlan, parseProfile) -import Database.Bolty.Stats (QueryStats(..), parseStats) +import Database.Bolty.Plan (PlanNode(..), ProfileNode(..), parsePlan, parseProfile, renderPlan) +import Database.Bolty.Stats (QueryStats(..), parseStats, formatStatsLine) +import Database.Bolty.Admin (totalAffected) import Database.Bolty.Value.Type (Node(..), Relationship(..), UnboundRelationship(..) , Path(..), Date(..), Time(..), LocalTime(..) , DateTime(..), DateTimeZoneId(..), LocalDateTime(..) , Duration(..), Point2D(..), Point3D(..)) import Database.Bolty.Message.Request (Request(..), Hello(..), Route(..), RouteExtra(..) + , Begin(..), RunExtra(..) + , RunAutoCommitTransaction(..) , Logon(..), TelemetryApi(..) , Pull(..), defaultPull) -import Database.Bolty.Message.Response (Response(..), RoutingTable(..), parseRoutingTable, extractBookmark) +import Database.Bolty.Message.Response (Response(..), RoutingTable(..), parseRoutingTable, extractBookmark, QueryMeta(..)) +import qualified Database.Bolty.Message.Response as Resp +import qualified Data.Aeson.KeyMap as KM import Database.Bolty.Routing (parseAddress) import Database.Bolty.Session (newBookmarkManager, getBookmarks, updateBookmark) import Database.Bolty.Decode (psToBolt, boltToPs) @@ -40,7 +46,7 @@ import Control.Exception (IOException, SomeException, fromException, toException) import qualified Data.Aeson as Aeson import Data.Aeson (fromJSON, toJSON) -import qualified Data.Aeson.Types as Aeson (Result(..)) +import qualified Data.Aeson.Types as Aeson (Result(..), parseEither) import qualified Data.ByteString as BS import qualified Data.Vector.Mutable as MV import Test.QuickCheck (Arbitrary(..), Gen, Result, oneof, listOf, @@ -341,6 +347,127 @@ other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other +-- = AccessMode tests + +accessModeTests :: TopSpec +accessModeTests = describe "AccessMode" $ do + it "ReadAccess encodes to PsString \"r\"" $ + toPs ReadAccess `shouldBe` PsString "r" + + it "WriteAccess encodes to PsString \"w\"" $ + toPs WriteAccess `shouldBe` PsString "w" + + it "round-trips ReadAccess" $ + (fromPs (toPs ReadAccess) :: R.Result AccessMode) `shouldBe` R.Success ReadAccess + + it "round-trips WriteAccess" $ + (fromPs (toPs WriteAccess) :: R.Result AccessMode) `shouldBe` R.Success WriteAccess + + it "rejects an unknown single-char string" $ + case (fromPs (PsString "x") :: R.Result AccessMode) of + R.Error _ -> pure () + R.Success a -> expectationFailure $ "Expected Error, got: " <> show a + + it "rejects the empty string" $ + case (fromPs (PsString "") :: R.Result AccessMode) of + R.Error _ -> pure () + R.Success a -> expectationFailure $ "Expected Error, got: " <> show a + + it "rejects a non-string Ps" $ + case (fromPs (PsInteger 1) :: R.Result AccessMode) of + R.Error _ -> pure () + R.Success a -> expectationFailure $ "Expected Error, got: " <> show a + + it "enumerates exhaustively via Bounded + Enum" $ + [minBound .. maxBound] `shouldBe` [ReadAccess, WriteAccess] + + -- Per Bolt spec, "mode" in BEGIN/RUN extra is optional with default "w". + -- A spec-compliant peer may omit it on write transactions. + it "Begin.fromPs accepts absent \"mode\" key and defaults to WriteAccess" $ do + -- Mirror a spec-compliant peer's BEGIN extra dict: required keys + -- present, optional keys (mode, tx_timeout, db, imp_user) omitted. + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + ] + case (fromPs dict :: R.Result Begin) of + R.Success b -> b.mode `shouldBe` WriteAccess + R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e + + it "Begin.fromPs accepts explicit \"mode\" = \"r\"" $ do + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + , ("mode", PsString "r") + ] + case (fromPs dict :: R.Result Begin) of + R.Success b -> b.mode `shouldBe` ReadAccess + R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e + + it "RunExtra.fromPs accepts absent \"mode\" key and defaults to WriteAccess" $ do + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + ] + case (fromPs dict :: R.Result RunExtra) of + R.Success r -> (r :: RunExtra).mode `shouldBe` WriteAccess + R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e + + it "RunExtra.fromPs accepts explicit \"mode\" = \"r\"" $ do + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + , ("mode", PsString "r") + ] + case (fromPs dict :: R.Result RunExtra) of + R.Success r -> (r :: RunExtra).mode `shouldBe` ReadAccess + R.Error e -> expectationFailure $ "Expected Success, got: " <> T.unpack e + + -- Invalid mode values must surface as an Error from the parent decoder, + -- not silently fall back to WriteAccess (which is the absent-key default). + it "Begin.fromPs rejects invalid \"mode\" value" $ do + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + , ("mode", PsString "x") + ] + case (fromPs dict :: R.Result Begin) of + R.Error _ -> pure () + R.Success b -> expectationFailure $ "Expected Error, got mode=" <> show b.mode + + it "RunExtra.fromPs rejects invalid \"mode\" value" $ do + let dict = PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + , ("mode", PsString "X") -- uppercase: a likely human-typo case + ] + case (fromPs dict :: R.Result RunExtra) of + R.Error _ -> pure () + R.Success r -> expectationFailure $ "Expected Error, got mode=" <> show ((r :: RunExtra).mode) + + -- Third lookupMode callsite: the autocommit RUN decoder (fromPsToRunRequest). + -- Routes through PsStructure 0x10 + the metadata-keys gate that picks the + -- autocommit branch over the explicit-tx branch. + it "Autocommit RUN decoder accepts absent \"mode\" and defaults to WriteAccess" $ do + let runDict = PsDictionary $ H.fromList + [ ("query", PsString "RETURN 1") + , ("parameters", PsDictionary H.empty) + , ("extra", PsDictionary $ H.fromList + [ ("bookmarks", toPs (V.empty :: V.Vector T.Text)) + , ("tx_metadata", PsDictionary H.empty) + ]) + , ("bookmarks", toPs (V.empty :: V.Vector T.Text)) -- forces autocommit branch + , ("tx_metadata", PsDictionary H.empty) + ] + case (fromPs (PsStructure 0x10 (V.singleton runDict)) :: R.Result Request) of + R.Success (RRunAutoCommitTransaction rac) -> + (rac :: RunAutoCommitTransaction).mode `shouldBe` WriteAccess + R.Success _ -> + expectationFailure "Expected RRunAutoCommitTransaction, got a different Request constructor" + R.Error e -> + expectationFailure $ "Expected Success, got: " <> T.unpack e + + -- = Pool config tests poolConfigTests :: TopSpec @@ -959,7 +1086,59 @@ nodesCreated qs `shouldBe` 0 containsUpdates qs `shouldBe` False + -- = totalAffected + it "totalAffected Nothing returns 0" $ + totalAffected Nothing `shouldBe` 0 + + it "totalAffected of zeros is 0" $ + totalAffected (Just zeroStats) `shouldBe` 0 + + it "totalAffected counts CREATE side effects (1 node + 1 prop + 1 label = 3)" $ + totalAffected (Just zeroStats { nodesCreated = 1, propertiesSet = 1, labelsAdded = 1 }) + `shouldBe` 3 + + it "totalAffected counts a DETACH DELETE as 1" $ + totalAffected (Just zeroStats { nodesDeleted = 1 }) `shouldBe` 1 + + it "totalAffected sums create + delete (no cancellation)" $ + totalAffected (Just zeroStats { nodesCreated = 5, nodesDeleted = 5 }) `shouldBe` 10 + + it "totalAffected counts indexes and constraints" $ + totalAffected (Just zeroStats + { constraintsAdded = 1, indexesAdded = 2, indexesRemoved = 1 }) + `shouldBe` 4 + + it "totalAffected ignores containsUpdates and systemUpdates" $ + -- System updates are tracked separately and shouldn't bleed into the + -- schema-update tally. + totalAffected (Just zeroStats { containsUpdates = True, systemUpdates = 99 }) + `shouldBe` 0 + + -- = formatStatsLine + + it "formatStatsLine renders every counter for an all-zero stat" $ + formatStatsLine zeroStats `shouldBe` + "Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \ + \+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0" + + it "formatStatsLine renders a CREATE-style breakdown" $ + formatStatsLine zeroStats { nodesCreated = 1, propertiesSet = 1, labelsAdded = 1 } + `shouldBe` "Stats: +nodes=1 -nodes=0 +rels=0 -rels=0 props=1 \ + \+labels=1 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0" + + it "formatStatsLine renders every field with a non-zero value" $ + let allOnes = QueryStats 1 1 1 1 1 1 1 1 1 1 1 False False 0 + in formatStatsLine allOnes `shouldBe` + "Stats: +nodes=1 -nodes=1 +rels=1 -rels=1 props=1 \ + \+labels=1 -labels=1 +idx=1 -idx=1 +constr=1 -constr=1" + + +-- | Helper used by the totalAffected/formatStatsLine cases above. +zeroStats :: QueryStats +zeroStats = QueryStats 0 0 0 0 0 0 0 0 0 0 0 False False 0 + + -- = Plan/Profile parsing tests planTests :: TopSpec @@ -1041,7 +1220,53 @@ Nothing -> expectationFailure "Expected Just PlanNode" Just pn -> V.length (pnChildren pn) `shouldBe` 2 + -- = renderPlan + it "renderPlan emits operator + estimated rows for a leaf" $ + renderPlan 0 (leafPlan "AllNodesScan" 100.0 []) + `shouldBe` "+ AllNodesScan (~100.0 rows)\n" + + it "renderPlan emits a vars: line when identifiers are present" $ + renderPlan 0 (leafPlan "NodeByLabelScan" 5.0 ["u"]) + `shouldBe` "+ NodeByLabelScan (~5.0 rows)\n vars: u\n" + + it "renderPlan indents two spaces per depth level" $ + renderPlan 2 (leafPlan "Limit" 1.0 []) + `shouldBe` " + Limit (~1.0 rows)\n" + + it "renderPlan walks a parent->child tree" $ + let child = leafPlan "Scan" 10.0 ["n"] + parent = (leafPlan "Projection" 10.0 ["n", "x"]) + { pnChildren = V.singleton child } + in renderPlan 0 parent `shouldBe` + "+ Projection (~10.0 rows)\n\ + \ vars: n, x\n\ + \ + Scan (~10.0 rows)\n\ + \ vars: n\n" + + it "renderPlan keeps multiple children in source order" $ + let c1 = leafPlan "L" 1.0 [] + c2 = leafPlan "R" 2.0 [] + parent = (leafPlan "Join" 3.0 []) + { pnChildren = V.fromList [c1, c2] } + in renderPlan 0 parent `shouldBe` + "+ Join (~3.0 rows)\n\ + \ + L (~1.0 rows)\n\ + \ + R (~2.0 rows)\n" + + +-- | Helper: build a childless 'PlanNode' from operator + estimated rows +-- + identifiers. Used by the renderPlan tests. +leafPlan :: T.Text -> Double -> [T.Text] -> PlanNode +leafPlan op est idents = PlanNode + { pnOperatorType = op + , pnArguments = H.empty + , pnIdentifiers = V.fromList idents + , pnEstimatedRows = est + , pnChildren = V.empty + } + + profileTests :: TopSpec profileTests = describe "Profile parsing" $ do @@ -2218,6 +2443,143 @@ fromJSON (toJSON p) == Aeson.Success p assertQC r + describe "parsePs / psToAeson (public Aeson interop)" $ do + + it "parsePs handles every JSON scalar type" $ do + let parse v = Aeson.parseEither parsePs v + parse Aeson.Null `shouldBe` Right PsNull + parse (Aeson.Bool True) `shouldBe` Right (PsBoolean True) + parse (Aeson.String "hi") `shouldBe` Right (PsString "hi") + parse (Aeson.Number 42) `shouldBe` Right (PsInteger (toPSInteger (42 :: Int))) + parse (Aeson.Number 1.5) `shouldBe` Right (PsFloat 1.5) + + it "parsePs handles arrays and nested objects" $ do + let parse v = Aeson.parseEither parsePs v + parse (Aeson.Array (V.fromList [Aeson.Number 1, Aeson.String "two"])) `shouldBe` + Right (PsList (V.fromList [PsInteger (toPSInteger (1 :: Int)), PsString "two"])) + + it "parsePs decodes the {bytes: } shape into PsBytes" $ do + let v = Aeson.Object (KM.fromList [("bytes", Aeson.String "aGVsbG8=")]) -- "hello" + case Aeson.parseEither parsePs v of + Right (PsBytes bs) -> bs `shouldBe` "hello" + Right other -> expectationFailure $ "expected PsBytes, got " <> show other + Left err -> expectationFailure err + + it "parsePs falls back to dictionary when {bytes: ...} value isn't valid base64" $ do + let v = Aeson.Object (KM.fromList [("bytes", Aeson.String "not base 64!!!")]) + case Aeson.parseEither parsePs v of + Right (PsDictionary _) -> pure () + other -> expectationFailure $ "expected PsDictionary fallback, got " <> show other + + it "psToAeson is the inverse of parsePs for plain values" $ do + let original = PsList (V.fromList + [ PsNull + , PsBoolean True + , PsString "x" + , PsInteger (toPSInteger (7 :: Int)) + , PsFloat 1.5 + ]) + let json = psToAeson original + Aeson.parseEither parsePs json `shouldBe` Right original + + it "parsePs handles negative integers" $ do + Aeson.parseEither parsePs (Aeson.Number (-7)) + `shouldBe` Right (PsInteger (toPSInteger (-7 :: Int))) + + it "parsePs falls back to dictionary when {bytes: ...} has extra keys" $ do + -- The bytes shape is a single-key match: {"bytes": ""}. + -- Adding any other key turns the value back into a regular dictionary. + let v = Aeson.Object (KM.fromList + [ ("bytes", Aeson.String "aGVsbG8=") + , ("extra", Aeson.String "noise") + ]) + case Aeson.parseEither parsePs v of + Right (PsDictionary d) -> H.size d `shouldBe` 2 + other -> expectationFailure $ "expected PsDictionary, got " <> show other + + it "parsePs falls back to PsFloat for integers above PSInteger range" $ do + -- PSInteger covers [-2^63, 2^64-1]. 2^64 = 18446744073709551616. + -- Larger than that exceeds the range and must round-trip through PsFloat + -- rather than silently truncate. + let huge = "18446744073709551617" -- 2^64 + 1 + case Aeson.eitherDecodeStrict (TE.encodeUtf8 (T.pack huge)) of + Left err -> expectationFailure $ "JSON parse failed: " <> err + Right v -> case Aeson.parseEither parsePs v of + Right (PsFloat _) -> pure () + Right other -> expectationFailure $ + "expected PsFloat fallback for huge integer, got " <> show other + Left err -> expectationFailure err + + describe "Show QueryMeta (smoke)" $ do + + it "Show QueryMeta produces a non-empty string" $ + -- The data constructor has 13 fields; this just pins that the + -- standalone Show derive landed and doesn't fail at runtime. + let m = QueryMeta + { Resp.bookmark = Nothing + , Resp.t_last = 0 + , Resp.type_ = "r" + , Resp.stats = Nothing + , Resp.parsedStats = Nothing + , Resp.plan = Nothing + , Resp.profile = Nothing + , Resp.notifications = Nothing + , Resp.parsedNotifications = V.empty + , Resp.parsedPlan = Nothing + , Resp.parsedProfile = Nothing + , Resp.db = "neo4j" + } + in (length (show m) > 0) `shouldBe` True + + +adminHelperTests :: TopSpec +adminHelperTests = describe "Database.Bolty.Admin outcome helpers" $ do + + it "describeReadOutcome prints ReadOK without inspecting fields" $ + -- Build a fully-zeroed ReadOK; the helper should not need to print it. + let stub = ReadOK emptyResultSet emptyMeta + in describeReadOutcome stub `shouldBe` "ReadOK" + + it "describeReadOutcome includes the stats line for ReadAbortedByWrite" $ + describeReadOutcome (ReadAbortedByWrite zeroStats) `shouldBe` + "ReadAbortedByWrite (Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \ + \+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0)" + + it "describeWriteOutcome prints WriteCommitted without inspecting fields" $ + describeWriteOutcome (WriteCommitted emptyResultSet emptyMeta) `shouldBe` "WriteCommitted" + + it "describeWriteOutcome shows expected/actual when stats are absent" $ + describeWriteOutcome (WriteAbortedMismatch 5 3 Nothing) `shouldBe` + "WriteAbortedMismatch expected=5 actual=3" + + it "describeWriteOutcome appends the stats line when present" $ + describeWriteOutcome (WriteAbortedMismatch 5 3 (Just zeroStats)) `shouldBe` + "WriteAbortedMismatch expected=5 actual=3 (Stats: +nodes=0 -nodes=0 +rels=0 -rels=0 props=0 \ + \+labels=0 -labels=0 +idx=0 -idx=0 +constr=0 -constr=0)" + + +-- Helpers for the Tx-helper tests above. + +emptyResultSet :: RS.ResultSet +emptyResultSet = RS.ResultSet V.empty V.empty + +emptyMeta :: QueryMeta +emptyMeta = QueryMeta + { Resp.bookmark = Nothing + , Resp.t_last = 0 + , Resp.type_ = "r" + , Resp.stats = Nothing + , Resp.parsedStats = Nothing + , Resp.plan = Nothing + , Resp.profile = Nothing + , Resp.notifications = Nothing + , Resp.parsedNotifications = V.empty + , Resp.parsedPlan = Nothing + , Resp.parsedProfile = Nothing + , Resp.db = "neo4j" + } + + -- | Assert a QuickCheck result, failing the sandwich test on property failure. assertQC r | isSuccess r = pure () @@ -2236,6 +2598,7 @@ messageTests logonLogoffTests structureRoundTripTests + accessModeTests poolConfigTests retryTests routeTests @@ -2265,3 +2628,4 @@ batchedPullTests maxConnectionLifetimeTests aesonTests + adminHelperTests