Admin.hs

-- | 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)