Postgres.hs

-- | PostgreSQL interpreter for the 'AuthUnitOfWork' port: each operation is exactly one
-- @BEGIN … COMMIT@.
--
-- This module uses 'Shomei.Persistence.Database.Postgres.runTransaction' for workflow write
-- tails. 'Shomei.Session.LoginAttempt.Postgres' also owns one transaction because its
-- transaction-scoped advisory lock must enclose the corresponding insert and count; that is a
-- serialized store operation rather than a workflow tail. Other interpreters issue one statement
-- per 'Shomei.Persistence.Database.Postgres.runSession', which is one pool checkout per statement.
--
-- No SQL is written here. Every statement is the prepared 'Statement' its own store
-- interpreter already uses, lifted into the transaction with 'Tx.statement'. That matters most
-- for 'markUsedStmt', the refresh-token compare-and-swap whose shape is owned by
-- @docs/plans/28-enforce-absolute-session-expiry-and-atomic-token-state-transitions.md@: this
-- module moves it inside a transaction and reads its result, but never alters it.
module Shomei.Session.UnitOfWork.Postgres
  ( runAuthUnitOfWorkPostgres,
  )
where

import Data.Foldable (traverse_)
import Data.Set qualified as Set
import Data.UUID.V4 qualified as UUIDv4
import Effectful (Eff, IOE, (:>))
import Effectful.Dispatch.Dynamic (interpret_)
import Effectful.Error.Static (Error, throwError)
import Hasql.Transaction qualified as Tx
import Shomei.Account.Credential.Postgres (updatePasswordHashStmt)
import Shomei.Account.Password.Domain (PasswordHash (..))
import Shomei.Account.PasswordReset.Postgres qualified as PR
import Shomei.Audit.Event.Codec (projectAuthEvent)
import Shomei.Audit.Event.Domain (AuthEvent)
import Shomei.Audit.Publisher.Postgres (AuthEventRow, insertAuthEventStmt)
import Shomei.Authorization.Claims.Domain (Scope (..))
import Shomei.Error (AuthError (..))
import Shomei.Id
  ( RefreshTokenId,
    genRefreshTokenId,
    genSessionId,
    passwordResetTokenIdToUUID,
    refreshTokenIdToUUID,
    sessionIdToUUID,
    userIdToUUID,
  )
import Shomei.Persistence.Codec.Postgres (refreshTokenStatusToText, sessionKindToText, sessionStatusToText)
import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runTransaction)
import Shomei.Prelude
import Shomei.Session.Domain (Session (..), SessionStatus (SessionActive))
import Shomei.Session.Postgres
  ( SessionRow,
    insertSessionStmt,
    mkSession,
    revokeAllUserSessionsStmt,
    revokeSessionStmt,
  )
import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..))
import Shomei.Session.RefreshToken.Domain qualified as RT
import Shomei.Session.RefreshToken.Postgres
  ( RefreshTokenRow,
    insertRefreshTokenStmt,
    markUsedStmt,
    mkPersisted,
    refreshTokenHashText,
  )
import Shomei.Session.RefreshToken.Postgres qualified as RTP
import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork (..), NewSessionToken (..), RotationOutcome (..))

runAuthUnitOfWorkPostgres ::
  (Database :> es, IOE :> es, Error AuthError :> es) =>
  Eff (AuthUnitOfWork : es) a ->
  Eff es a
runAuthUnitOfWorkPostgres = interpret_ \case
  PersistNewSession ns nst mkEvents -> do
    -- The ids are generated here, before the transaction opens, exactly as the per-table
    -- interpreters generate them: they are client-side (TypeID/UUIDv7-style) values, so no
    -- round-trip is needed and the events can name the session id.
    sid <- genSessionId
    rid <- genRefreshTokenId
    let session = mkSession sid ns
        newToken =
          NewRefreshToken
            { sessionId = sid,
              tokenHash = nst.tokenHash,
              parentTokenId = Nothing,
              createdAt = nst.createdAt,
              expiresAt = nst.expiresAt
            }
        persisted = mkPersisted rid newToken
    eventRows <- traverse toEventRow (mkEvents sid)
    res <- runTransaction do
      Tx.statement (sessionRow session) insertSessionStmt
      Tx.statement (tokenRow rid newToken) insertRefreshTokenStmt
      traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows
    either dbFail (const (pure (session, persisted))) res
  RotateRefreshToken presentedId usedAt newToken ev -> do
    rid <- genRefreshTokenId
    eventRow <- toEventRow ev
    let persisted = mkPersisted rid newToken
    res <- runTransaction do
      -- The compare-and-swap runs first and its result decides the rest. A conflict leaves the
      -- transaction with nothing but a no-op UPDATE to commit; there is no need to abort it,
      -- and nothing to roll back.
      won <- Tx.statement (refreshTokenIdToUUID presentedId, usedAt) markUsedStmt
      case won of
        Nothing -> pure RotationConflict
        Just _ -> do
          Tx.statement (tokenRow rid newToken) insertRefreshTokenStmt
          Tx.statement eventRow insertAuthEventStmt
          pure (Rotated persisted)
    either dbFail pure res
  CompletePasswordReset tid uid newHash ts events -> do
    eventRows <- traverse toEventRow events
    res <- runTransaction do
      won <- Tx.statement (passwordResetTokenIdToUUID tid, ts) PR.markConsumedStmt
      case won of
        Nothing -> pure False
        Just _ -> do
          Tx.statement (userIdToUUID uid, passwordHashText newHash) updatePasswordHashStmt
          Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt
          Tx.statement (userIdToUUID uid, ts) RTP.revokeUserTokensStmt
          -- The consumed token is no longer active, so this revokes only its live siblings.
          Tx.statement (userIdToUUID uid, ts) PR.revokeUserTokensStmt
          True <$ traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows
    either dbFail pure res
  CompletePasswordChange uid newHash ts events -> do
    eventRows <- traverse toEventRow events
    res <- runTransaction do
      Tx.statement (userIdToUUID uid, passwordHashText newHash) updatePasswordHashStmt
      Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt
      Tx.statement (userIdToUUID uid, ts) RTP.revokeUserTokensStmt
      traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows
    either dbFail pure res
  RevokeSessionWithTokens sid ts events -> do
    eventRows <- traverse toEventRow events
    res <- runTransaction do
      won <- Tx.statement (sessionIdToUUID sid, ts) revokeSessionStmt
      case won of
        Nothing -> pure False
        Just _ -> do
          Tx.statement (sessionIdToUUID sid, ts) RTP.revokeSessionTokensStmt
          True <$ traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows
    either dbFail pure res
  where
    dbFail = throwError . postgresUnavailable

passwordHashText :: PasswordHash -> Text
passwordHashText (PasswordHash t) = t

-- | Mint the event's row id outside the transaction (it is a random UUID, not a database
-- default), and project the event exactly as 'Shomei.Audit.Publisher.Postgres' does.
toEventRow :: (IOE :> es) => AuthEvent -> Eff es AuthEventRow
toEventRow ev = do
  eid <- liftIO UUIDv4.nextRandom
  let (mUser, mSession, etype, payload, ts) = projectAuthEvent ev
  pure (eid, mUser, mSession, etype, payload, ts)

-- | The column tuple 'insertSessionStmt' encodes, built from the session this interpreter just
-- constructed. A fresh session is always active and never revoked.
sessionRow :: Session -> SessionRow
sessionRow session =
  ( sessionIdToUUID session.sessionId,
    userIdToUUID session.userId,
    sessionStatusToText SessionActive,
    session.createdAt,
    session.expiresAt,
    Nothing,
    userIdToUUID <$> session.actor,
    session.oauthClientId,
    Just (sessionKindToText session.kind),
    [scope | Scope scope <- Set.toList session.grantedScopes],
    Just session.authenticatedAt
  )

-- | The column tuple 'insertRefreshTokenStmt' encodes. A freshly inserted token is always
-- active, never used, never revoked.
tokenRow :: RefreshTokenId -> NewRefreshToken -> RefreshTokenRow
tokenRow rid nrt =
  ( refreshTokenIdToUUID rid,
    sessionIdToUUID nrt.sessionId,
    refreshTokenHashText nrt.tokenHash,
    fmap refreshTokenIdToUUID nrt.parentTokenId,
    refreshTokenStatusToText RT.RefreshTokenActive,
    nrt.createdAt,
    nrt.expiresAt,
    Nothing,
    Nothing
  )