Type protocol persistence around model phases

src/Nuthatch/Mutation/Service.hs

@@ -57,9 +57,20 @@ runPut env user root rel op size sha dispatchPut = do
     available <-
       if existing then pure True else objectStoreAvailable (envS3 env)
     if available
-      then Just <$> admitMutation conn uid Put op pool key rel size (Just sha)
+      then Just <$> admitMutation
-        (cfgMaxObjectBytes (envConfig env))
+        conn
-        (cfgIdempotencyWindowSec (envConfig env))
+        AdmissionRequest
+          { admissionIdentity = AdmissionIdentity uid Put op
+          , admissionPoolId = pool
+          , admissionRelativePath = rel
+          , admissionFingerprint =
+              MutationFingerprint Put key size (Just sha)
+          }
+        AdmissionLimits
+          { admissionMaxObjectBytes = cfgMaxObjectBytes (envConfig env)
+          , admissionIdempotencyWindowSec =
+              cfgIdempotencyWindowSec (envConfig env)
+          }
       else pure Nothing
   case admitted of
     Nothing ->
@@ -103,9 +114,20 @@ runDelete env user root rel op = do
     available <-
       if existing then pure True else objectStoreAvailable (envS3 env)
     if available
-      then Just <$> admitMutation conn uid Delete op pool key rel 0 Nothing
+      then Just <$> admitMutation
-        (cfgMaxObjectBytes (envConfig env))
+        conn
-        (cfgIdempotencyWindowSec (envConfig env))
+        AdmissionRequest
+          { admissionIdentity = AdmissionIdentity uid Delete op
+          , admissionPoolId = pool
+          , admissionRelativePath = rel
+          , admissionFingerprint =
+              MutationFingerprint Delete key 0 Nothing
+          }
+        AdmissionLimits
+          { admissionMaxObjectBytes = cfgMaxObjectBytes (envConfig env)
+          , admissionIdempotencyWindowSec =
+              cfgIdempotencyWindowSec (envConfig env)
+          }
       else pure Nothing
   case admitted of
     Nothing -> pure (Left "object store unavailable")
@@ -143,8 +165,10 @@ dispatchAndFinalize env user root record timeoutFailure dispatch = do
       else markExternalPending
         conn
         record
-        (requestTimeoutSec * 2)
+        DispatchTiming
-        (cfgRecoveryGraceSec cfg)
+          { dispatchSettlementBoundSec = requestTimeoutSec * 2
+          , dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
+          }
   if not prepared
     then pure (Right MutationPending)
     else do

src/Nuthatch/Protocol.hs

@@ -1,8 +1,32 @@
 -- | Short Postgres transactions for mutation authority; store I/O stays outside them.
 module Nuthatch.Protocol
   ( AdmitOutcome (..)
+  , AdmissionIdentity (..)
+  , MutationFingerprint (..)
+  , AdmissionRequest (..)
+  , AdmissionLimits (..)
+  , DispatchTiming (..)
+  , PriorObject (..)
+  , DesiredObject (..)
   , ExistingDisposition (..)
   , MutationRecord (..)
+  , MutationPhase (..)
+  , TerminalResult (..)
+  , mutationState
+  , externalState
+  , encodeMutationPhase
+  , decodeMutationPhase
+  , mrState
+  , mrExternal
+  , mrUserId
+  , mrKind
+  , mrOperationId
+  , mrObjectKey
+  , mrDeclaredSize
+  , mrContentSha256
+  , mrPriorSize
+  , mrPriorSha256
+  , desiredObject
   , ObjectObservation (..)
   , admitMutation
   , markApplying
@@ -27,27 +51,74 @@ module Nuthatch.Protocol
   , finalizeFromObservation
   ) where
 
-import           Data.Maybe (listToMaybe, mapMaybe)
+import           Control.Exception (throwIO)
+import           Data.Maybe (listToMaybe)
 import           Data.Text (Text)
+import qualified Data.Text as T
 import           Database.PostgreSQL.Simple (Connection, Only (..), execute, query)
+import qualified Database.PostgreSQL.Simple.FromField as PG
+import qualified Database.PostgreSQL.Simple.FromRow as PGRow
+import qualified Database.PostgreSQL.Simple.ToField as PGToField
+import qualified Database.PostgreSQL.Simple.ToRow as PGToRow
 import           Nuthatch.Types
 
 data MutationRecord = MutationRecord
-  { mrUserId        :: UserId
+  { mrAdmissionIdentity :: AdmissionIdentity
-  , mrKind          :: MutationKind
+  , mrPoolId            :: PoolId
-  , mrOperationId   :: OperationId
+  , mrRelativePath      :: RelativePath
-  , mrPoolId        :: PoolId
+  , mrFingerprint       :: MutationFingerprint
-  , mrObjectKey     :: ObjectKey
+  , mrPriorObject       :: PriorObject
-  , mrRelativePath  :: RelativePath
+  , mrGrowth            :: Integer
-  , mrDeclaredSize  :: Integer
+  , mrPhase             :: MutationPhase
-  , mrContentSha256 :: Maybe ContentSha256
-  , mrPriorSize     :: Integer
-  , mrPriorSha256   :: Maybe ContentSha256
-  , mrGrowth        :: Integer
-  , mrState         :: MutationState
-  , mrExternal      :: ExternalState
   }
-  deriving stock (Show)
+  deriving stock (Eq, Show)
+
+data MutationPhase
+  = PhasePrepared
+  | PhaseApplying ExternalState
+  | PhaseTerminal TerminalResult
+  deriving stock (Eq, Show)
+
+data TerminalResult
+  = TerminalSucceeded
+  | TerminalFailed
+  | TerminalRejected
+  deriving stock (Eq, Show)
+
+mutationState :: MutationPhase -> MutationState
+mutationState = \case
+  PhasePrepared   -> Prepared
+  PhaseApplying _ -> Applying
+  PhaseTerminal TerminalSucceeded -> Succeeded
+  PhaseTerminal TerminalFailed    -> Failed
+  PhaseTerminal TerminalRejected  -> Rejected
+
+externalState :: MutationPhase -> ExternalState
+externalState = \case
+  PhaseApplying external -> external
+  _                      -> ExtIdle
+
+encodeMutationPhase :: MutationPhase -> (MutationState, ExternalState)
+encodeMutationPhase phase = (mutationState phase, externalState phase)
+
+decodeMutationPhase :: MutationState -> ExternalState -> Maybe MutationPhase
+decodeMutationPhase state external =
+  case (state, external) of
+    (Prepared, ExtIdle)  -> Just PhasePrepared
+    (Applying, value)    -> Just (PhaseApplying value)
+    (Succeeded, ExtIdle) ->
+      Just (PhaseTerminal TerminalSucceeded)
+    (Failed, ExtIdle) ->
+      Just (PhaseTerminal TerminalFailed)
+    (Rejected, ExtIdle) ->
+      Just (PhaseTerminal TerminalRejected)
+    _                    -> Nothing
+
+mrState :: MutationRecord -> MutationState
+mrState = mutationState . mrPhase
+
+mrExternal :: MutationRecord -> ExternalState
+mrExternal = externalState . mrPhase
 
 -- | Unavailable must not drive terminal finalize.
 data ObjectObservation
@@ -63,38 +134,214 @@ data AdmitOutcome
   | AdmitConflict
   deriving stock (Show)
 
+data AdmissionIdentity = AdmissionIdentity
+  { admissionUserId      :: UserId
+  , admissionKind        :: MutationKind
+  , admissionOperationId :: OperationId
+  }
+  deriving stock (Eq, Show)
+
+data MutationFingerprint = MutationFingerprint
+  { fingerprintKind          :: MutationKind
+  , fingerprintObjectKey     :: ObjectKey
+  , fingerprintDeclaredSize  :: Integer
+  , fingerprintContentSha256 :: Maybe ContentSha256
+  }
+  deriving stock (Eq, Show)
+
+data AdmissionRequest = AdmissionRequest
+  { admissionIdentity     :: AdmissionIdentity
+  , admissionPoolId       :: PoolId
+  , admissionRelativePath :: RelativePath
+  , admissionFingerprint  :: MutationFingerprint
+  }
+  deriving stock (Eq, Show)
+
+data AdmissionLimits = AdmissionLimits
+  { admissionMaxObjectBytes       :: Integer
+  , admissionIdempotencyWindowSec :: Integer
+  }
+  deriving stock (Eq, Show)
+
+data DispatchTiming = DispatchTiming
+  { dispatchSettlementBoundSec :: Integer
+  , dispatchWorkerGraceSec     :: Integer
+  }
+  deriving stock (Eq, Show)
+
+data PriorObject = PriorObject
+  { priorObjectSize   :: Integer
+  , priorObjectSha256 :: Maybe ContentSha256
+  }
+  deriving stock (Eq, Show)
+
+data DesiredObject
+  = DesiredPresent Integer (Maybe ContentSha256)
+  | DesiredAbsent
+  deriving stock (Eq, Show)
+
+mrUserId :: MutationRecord -> UserId
+mrUserId = admissionUserId . mrAdmissionIdentity
+
+mrKind :: MutationRecord -> MutationKind
+mrKind = admissionKind . mrAdmissionIdentity
+
+mrOperationId :: MutationRecord -> OperationId
+mrOperationId = admissionOperationId . mrAdmissionIdentity
+
+mrObjectKey :: MutationRecord -> ObjectKey
+mrObjectKey = fingerprintObjectKey . mrFingerprint
+
+mrDeclaredSize :: MutationRecord -> Integer
+mrDeclaredSize = fingerprintDeclaredSize . mrFingerprint
+
+mrContentSha256 :: MutationRecord -> Maybe ContentSha256
+mrContentSha256 = fingerprintContentSha256 . mrFingerprint
+
+mrPriorSize :: MutationRecord -> Integer
+mrPriorSize = priorObjectSize . mrPriorObject
+
+mrPriorSha256 :: MutationRecord -> Maybe ContentSha256
+mrPriorSha256 = priorObjectSha256 . mrPriorObject
+
+desiredObject :: MutationRecord -> DesiredObject
+desiredObject record =
+  case mrKind record of
+    Put -> DesiredPresent
+      (mrDeclaredSize record)
+      (mrContentSha256 record)
+    Delete -> DesiredAbsent
+
 data ExistingDisposition
   = NewMutationEpoch
   | ExistingReplay MutationResult MutationRecord
   | ExistingConflict
   deriving stock (Show)
 
-type ResultRow =
+data MutationRow = MutationRow
-  ( Text, Text, Text, Text, Text, Text, Integer, Maybe Text
+  { rowUserId        :: Text
-  , Integer, Maybe Text, Integer, Text, Text
+  , rowKind          :: DbMutationKind
-  )
+  , rowOperationId   :: Text
+  , rowPoolId        :: Text
+  , rowObjectKey     :: Text
+  , rowRelativePath  :: Text
+  , rowDeclaredSize  :: Integer
+  , rowContentSha256 :: Maybe Text
+  , rowPriorSize     :: Integer
+  , rowPriorSha256   :: Maybe Text
+  , rowGrowth        :: Integer
+  , rowState         :: DbMutationState
+  , rowExternal      :: DbExternalState
+  }
 
-rowToRecord :: ResultRow -> Maybe MutationRecord
+data SettlementRow =
-rowToRecord (user, kindT, op, pool, key, rel, size, csha, prior, psha, growth, stateT, extT) = do
+  SettlementRow DbMutationState DbExternalState Integer Integer
-  kind <- parseKind kindT
+
-  state <- parseState stateT
+newtype DbMutationKind = DbMutationKind MutationKind
-  ext <- parseExternal extT
+
+newtype DbMutationState = DbMutationState MutationState
+
+newtype DbExternalState = DbExternalState ExternalState
+
+newtype MutationInsertRow = MutationInsertRow MutationRecord
+
+instance PG.FromField DbMutationKind where
+  fromField field value = do
+    label <- PG.fromField field value
+    maybe
+      (PG.returnError PG.ConversionFailed field "invalid mutation kind")
+      (pure . DbMutationKind)
+      (parseKind label)
+
+instance PG.FromField DbMutationState where
+  fromField field value = do
+    label <- PG.fromField field value
+    maybe
+      (PG.returnError PG.ConversionFailed field "invalid mutation state")
+      (pure . DbMutationState)
+      (parseState label)
+
+instance PG.FromField DbExternalState where
+  fromField field value = do
+    label <- PG.fromField field value
+    maybe
+      (PG.returnError PG.ConversionFailed field "invalid external state")
+      (pure . DbExternalState)
+      (parseExternal label)
+
+instance PGRow.FromRow MutationRow where
+  fromRow =
+    MutationRow
+      <$> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+
+instance PGRow.FromRow SettlementRow where
+  fromRow =
+    SettlementRow
+      <$> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+      <*> PGRow.field
+
+instance PGToRow.ToRow MutationInsertRow where
+  toRow (MutationInsertRow record) =
+    let (state, external) = encodeMutationPhase (mrPhase record)
+    in
+      [ PGToField.toField (unUserId (mrUserId record))
+      , PGToField.toField (kindLabel (mrKind record))
+      , PGToField.toField (unOperationId (mrOperationId record))
+      , PGToField.toField (unPoolId (mrPoolId record))
+      , PGToField.toField (unObjectKey (mrObjectKey record))
+      , PGToField.toField (unRelativePath (mrRelativePath record))
+      , PGToField.toField (mrDeclaredSize record)
+      , PGToField.toField
+          (unContentSha256 <$> mrContentSha256 record)
+      , PGToField.toField (mrPriorSize record)
+      , PGToField.toField
+          (unContentSha256 <$> mrPriorSha256 record)
+      , PGToField.toField (mrGrowth record)
+      , PGToField.toField (stateLabel state)
+      , PGToField.toField (externalLabel external)
+      ]
+
+rowToRecord :: MutationRow -> Either Text MutationRecord
+rowToRecord MutationRow{..} = do
+  let DbMutationKind kind = rowKind
+      DbMutationState state = rowState
+      DbExternalState ext = rowExternal
+  phase <- maybe (Left "invalid mutation phase") Right (decodeMutationPhase state ext)
   pure MutationRecord
-    { mrUserId = UserId user
+    { mrAdmissionIdentity =
-    , mrKind = kind
+        AdmissionIdentity (UserId rowUserId) kind (OperationId rowOperationId)
-    , mrOperationId = OperationId op
+    , mrPoolId = PoolId rowPoolId
-    , mrPoolId = PoolId pool
+    , mrRelativePath = RelativePath rowRelativePath
-    , mrObjectKey = ObjectKey key
+    , mrFingerprint =
-    , mrRelativePath = RelativePath rel
+        MutationFingerprint
-    , mrDeclaredSize = size
+          kind
-    , mrContentSha256 = ContentSha256 <$> csha
+          (ObjectKey rowObjectKey)
-    , mrPriorSize = prior
+          rowDeclaredSize
-    , mrPriorSha256 = ContentSha256 <$> psha
+          (ContentSha256 <$> rowContentSha256)
-    , mrGrowth = growth
+    , mrPriorObject =
-    , mrState = state
+        PriorObject rowPriorSize (ContentSha256 <$> rowPriorSha256)
-    , mrExternal = ext
+    , mrGrowth = rowGrowth
+    , mrPhase = phase
     }
 
+decodeRows :: [MutationRow] -> IO [MutationRecord]
+decodeRows rows =
+  either (throwIO . userError . T.unpack) pure (traverse rowToRecord rows)
+
 lookupMutation :: Connection -> UserId -> MutationKind -> OperationId -> IO (Maybe MutationRecord)
 lookupMutation conn uid kind op = do
   rows <- query conn
@@ -103,7 +350,7 @@ lookupMutation conn uid kind op = do
     \state, external_state FROM mutations \
     \WHERE user_id = ? AND kind = ? AND operation_id = ?"
     (unUserId uid, kindLabel kind, unOperationId op)
-  pure (listToMaybe rows >>= rowToRecord)
+  listToMaybe <$> decodeRows rows
 
 mutationEpochExists
   :: Connection
@@ -137,25 +384,19 @@ lookupObjectMeta conn (ObjectKey key) = do
     [(sz, sha)] -> Just (sz, ContentSha256 sha)
     _           -> Nothing
 
-sameFingerprint :: MutationRecord -> MutationKind -> ObjectKey -> Integer -> Maybe ContentSha256 -> Bool
+sameFingerprint :: MutationRecord -> MutationFingerprint -> Bool
-sameFingerprint rec kind key size msha =
+sameFingerprint rec fingerprint =
-  mrKind rec == kind
+  mrFingerprint rec == fingerprint
-    && mrObjectKey rec == key
-    && mrDeclaredSize rec == size
-    && mrContentSha256 rec == msha
 
 existingDisposition
   :: Maybe MutationRecord
-  -> MutationKind
+  -> MutationFingerprint
-  -> ObjectKey
-  -> Integer
-  -> Maybe ContentSha256
   -> ExistingDisposition
-existingDisposition existing kind key size msha =
+existingDisposition existing fingerprint =
   case existing of
     Nothing -> NewMutationEpoch
     Just rec
-      | sameFingerprint rec kind key size msha ->
+      | sameFingerprint rec fingerprint ->
           ExistingReplay (stateToResult (mrState rec)) rec
       | otherwise -> ExistingConflict
 
@@ -180,18 +421,38 @@ recoveryEligible state elapsedSeconds graceSeconds =
 
 admitMutation
   :: Connection
-  -> UserId
+  -> AdmissionRequest
-  -> MutationKind
+  -> AdmissionLimits
-  -> OperationId
-  -> PoolId
-  -> ObjectKey
-  -> RelativePath
-  -> Integer
-  -> Maybe ContentSha256
-  -> Integer
-  -> Integer
   -> IO AdmitOutcome
-admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindow = do
+admitMutation conn AdmissionRequest{..} limits =
+  if fingerprintKind admissionFingerprint
+      /= admissionKind admissionIdentity
+    then pure AdmitConflict
+    else admitConsistentMutation
+      conn
+      admissionIdentity
+      admissionPoolId
+      admissionRelativePath
+      admissionFingerprint
+      limits
+
+admitConsistentMutation
+  :: Connection
+  -> AdmissionIdentity
+  -> PoolId
+  -> RelativePath
+  -> MutationFingerprint
+  -> AdmissionLimits
+  -> IO AdmitOutcome
+admitConsistentMutation
+  conn
+  (AdmissionIdentity uid kind op)
+  pool
+  rel
+  fingerprint@(MutationFingerprint _ key size msha)
+  AdmissionLimits{..} = do
+  let maxObject = admissionMaxObjectBytes
+      idempotencyWindow = admissionIdempotencyWindowSec
   let identity =
         unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
   _ <- query conn
@@ -205,7 +466,7 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
     \AND updated_at < now() - (? * interval '1 second')"
     (unUserId uid, kindLabel kind, unOperationId op, idempotencyWindow)
   existing <- lookupMutation conn uid kind op
-  case existingDisposition existing kind key size msha of
+  case existingDisposition existing fingerprint of
     ExistingReplay result rec -> pure (AdmitReplay result rec)
     ExistingConflict -> pure AdmitConflict
     NewMutationEpoch -> do
@@ -216,21 +477,15 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
             Put    -> size
             Delete -> 0
           growth = growthBytes priorSize desiredSize
-          baseRec state =
+          baseRec phase =
             MutationRecord
-              { mrUserId = uid
+              { mrAdmissionIdentity = AdmissionIdentity uid kind op
-              , mrKind = kind
-              , mrOperationId = op
               , mrPoolId = pool
-              , mrObjectKey = key
               , mrRelativePath = rel
-              , mrDeclaredSize = size
+              , mrFingerprint = fingerprint
-              , mrContentSha256 = msha
+              , mrPriorObject = PriorObject priorSize priorSha
-              , mrPriorSize = priorSize
-              , mrPriorSha256 = priorSha
               , mrGrowth = 0
-              , mrState = state
+              , mrPhase = phase
-              , mrExternal = ExtIdle
               }
 
       poolRows <- query conn
@@ -261,24 +516,22 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
                   rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
                   pure (AdmitRejected "quota exceeded" rec)
                 else do
+                  let preparedRecord = MutationRecord
+                        { mrAdmissionIdentity = AdmissionIdentity uid kind op
+                        , mrPoolId = pool
+                        , mrRelativePath = rel
+                        , mrFingerprint = fingerprint
+                        , mrPriorObject = PriorObject priorSize priorSha
+                        , mrGrowth = growth
+                        , mrPhase = PhasePrepared
+                        }
                   n <- execute conn
                     "INSERT INTO mutations \
                     \(user_id, kind, operation_id, pool_id, object_key, relative_path, \
                     \ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
                     \ state, external_state) \
-                    \VALUES (?,?,?,?,?,?,?,?,?,?,?,'prepared','idle')"
+                    \VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
-                    ( unUserId uid
+                    (MutationInsertRow preparedRecord)
-                    , kindLabel kind
-                    , unOperationId op
-                    , unPoolId pool
-                    , unObjectKey key
-                    , unRelativePath rel
-                    , size
-                    , unContentSha256 <$> msha
-                    , priorSize
-                    , unContentSha256 <$> priorSha
-                    , growth
-                    )
                   if n /= 1
                     then pure AdmitConflict
                     else do
@@ -294,26 +547,12 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
                             \WHERE user_id = ? AND kind = ? AND operation_id = ?"
                             (unUserId uid, kindLabel kind, unOperationId op)
                           pure $ AdmitRejected "key locked by another mutation"
-                            (baseRec Rejected)
+                            (baseRec (PhaseTerminal TerminalRejected))
                         else do
                           _ <- execute conn
                             "UPDATE pools SET reserved_bytes = reserved_bytes + ? WHERE pool_id = ?"
                             (growth, unPoolId pool)
-                          pure $ AdmitPrepared MutationRecord
+                          pure (AdmitPrepared preparedRecord)
-                            { mrUserId = uid
-                            , mrKind = kind
-                            , mrOperationId = op
-                            , mrPoolId = pool
-                            , mrObjectKey = key
-                            , mrRelativePath = rel
-                            , mrDeclaredSize = size
-                            , mrContentSha256 = msha
-                            , mrPriorSize = priorSize
-                            , mrPriorSha256 = priorSha
-                            , mrGrowth = growth
-                            , mrState = Prepared
-                            , mrExternal = ExtIdle
-                            }
 
 insertTerminalRejected
   :: Connection
@@ -329,39 +568,25 @@ insertTerminalRejected
   -> Maybe ContentSha256
   -> IO MutationRecord
 insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha = do
+  let record = MutationRecord
+        { mrAdmissionIdentity = AdmissionIdentity uid kind op
+        , mrPoolId = pool
+        , mrRelativePath = rel
+        , mrFingerprint =
+            MutationFingerprint kind key size msha
+        , mrPriorObject = PriorObject priorSize priorSha
+        , mrGrowth = 0
+        , mrPhase = PhaseTerminal TerminalRejected
+        }
   _ <- execute conn
     "INSERT INTO mutations \
     \(user_id, kind, operation_id, pool_id, object_key, relative_path, \
     \ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
     \ state, external_state) \
-    \VALUES (?,?,?,?,?,?,?,?,?,?,0,'rejected','idle') \
+    \VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) \
     \ON CONFLICT DO NOTHING"
-    ( unUserId uid
+    (MutationInsertRow record)
-    , kindLabel kind
+  pure record
-    , unOperationId op
-    , unPoolId pool
-    , unObjectKey key
-    , unRelativePath rel
-    , size
-    , unContentSha256 <$> msha
-    , priorSize
-    , unContentSha256 <$> priorSha
-    )
-  pure MutationRecord
-    { mrUserId = uid
-    , mrKind = kind
-    , mrOperationId = op
-    , mrPoolId = pool
-    , mrObjectKey = key
-    , mrRelativePath = rel
-    , mrDeclaredSize = size
-    , mrContentSha256 = msha
-    , mrPriorSize = priorSize
-    , mrPriorSha256 = priorSha
-    , mrGrowth = 0
-    , mrState = Rejected
-    , mrExternal = ExtIdle
-    }
 
 stateToResult :: MutationState -> MutationResult
 stateToResult Prepared  = MutationPending
@@ -381,10 +606,9 @@ markApplying conn rec = do
 markExternalPending
   :: Connection
   -> MutationRecord
-  -> Integer
+  -> DispatchTiming
-  -> Integer
   -> IO Bool
-markExternalPending conn rec settlementBoundSec workerGraceSec = do
+markExternalPending conn rec DispatchTiming{..} = do
   n <- execute conn
     "UPDATE mutations SET external_state = 'pending', \
     \dispatch_started_at = now(), \
@@ -393,8 +617,8 @@ markExternalPending conn rec settlementBoundSec workerGraceSec = do
     \updated_at = now() \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? \
     \AND state = 'applying' AND external_state = 'idle'"
-    ( settlementBoundSec
+    ( dispatchSettlementBoundSec
-    , workerGraceSec
+    , dispatchWorkerGraceSec
     , unUserId (mrUserId rec)
     , kindLabel (mrKind rec)
     , unOperationId (mrOperationId rec)
@@ -427,10 +651,15 @@ finalizeSuccess conn rec finalSize finalSha = do
     "SELECT state, external_state, growth_bytes, prior_size FROM mutations \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
     (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
-      :: IO [(Text, Text, Integer, Integer)]
+      :: IO [SettlementRow]
   case rows of
-    [(st, ext, growth, prior)]
+    [SettlementRow
-      | st == "applying" && ext == "settled" -> do
+      (DbMutationState state)
+      (DbExternalState external)
+      growth
+      prior]
+      | decodeMutationPhase state external
+          == Just (PhaseApplying ExtSettled) -> do
           let pool = mrPoolId rec
           _ <- execute conn
             "UPDATE pools SET used_bytes = used_bytes - ? + ?, \
@@ -470,13 +699,18 @@ finalizeSuccess conn rec finalSize finalSha = do
 finalizeFailure :: Connection -> MutationRecord -> IO Bool
 finalizeFailure conn rec = do
   rows <- query conn
-    "SELECT state, external_state, growth_bytes FROM mutations \
+    "SELECT state, external_state, growth_bytes, prior_size FROM mutations \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
     (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
-      :: IO [(Text, Text, Integer)]
+      :: IO [SettlementRow]
   case rows of
-    [(st, ext, growth)]
+    [SettlementRow
-      | st == "applying" && ext == "settled" -> do
+      (DbMutationState state)
+      (DbExternalState external)
+      growth
+      _]
+      | decodeMutationPhase state external
+          == Just (PhaseApplying ExtSettled) -> do
           _ <- execute conn
             "UPDATE pools SET reserved_bytes = reserved_bytes - ? WHERE pool_id = ?"
             (growth, unPoolId (mrPoolId rec))
@@ -515,38 +749,35 @@ claimActiveBatch conn limit graceSec = do
     \FOR UPDATE SKIP LOCKED \
     \LIMIT ?"
     (graceSec, graceSec, limit)
-  pure (mapMaybe rowToRecord rows)
+  decodeRows rows
 
 desiredMatches :: MutationRecord -> ObjectObservation -> Bool
-desiredMatches rec = \case
+desiredMatches rec observation =
-  ObjectUnavailable _ -> False
+  case (desiredObject rec, observation) of
-  ObjectAbsent ->
+    (_, ObjectUnavailable _) -> False
-    case mrKind rec of
+    (DesiredAbsent, ObjectAbsent) -> True
-      Delete -> True
+    (DesiredPresent size expectedSha, ObjectPresent observedSize observedSha) ->
-      Put    -> False
+      size == observedSize
-  ObjectPresent sz msha ->
+        && case (expectedSha, observedSha) of
-    case mrKind rec of
+             (Just want, Just got) -> want == got
-      Delete -> False
+             (Just _, Nothing)     -> False
-      Put ->
+             (Nothing, _)          -> True
-        sz == mrDeclaredSize rec
+    _ -> False
-          && case (mrContentSha256 rec, msha) of
-               (Just want, Just got) -> want == got
-               (Just _, Nothing)     -> False
-               (Nothing, _)          -> True
 
 priorMatches :: MutationRecord -> ObjectObservation -> Bool
 priorMatches rec obs =
-  let priorEmpty = mrPriorSize rec == 0 && mrPriorSha256 rec == Nothing
+  let PriorObject priorSize priorSha = mrPriorObject rec
+      priorEmpty = priorSize == 0 && priorSha == Nothing
   in case obs of
        ObjectUnavailable _ -> False
        ObjectAbsent -> priorEmpty
        ObjectPresent sz msha ->
-         sz == mrPriorSize rec
+         sz == priorSize
-           && ( case (mrPriorSha256 rec, msha) of
+           && ( case (priorSha, msha) of
                   (Just want, Just got) -> want == got
                   (Nothing, Nothing)    -> True
                   (Just _, Nothing)     -> False
-                  (Nothing, Just _)     -> mrPriorSize rec == sz
+                  (Nothing, Just _)     -> priorSize == sz
               )
 
 finalizeFromObservation

test/Integration.hs

@@ -38,6 +38,7 @@ main = do
     migrate database "sql" config
     verifySchema database
     verifyAdmission database config
+    verifyRowDecoder database
   store <- newS3 config
   verifyStorage config store
   putStrLn "Storage foundation integration gate passed"
@@ -160,7 +161,8 @@ verifyAdmission database config = do
             "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
   settled <- withTransaction database $ \connection -> do
     applying <- markApplying connection observationRecord
-    pending <- markExternalPending connection observationRecord 600 90
+    pending <- markExternalPending
+      connection observationRecord (DispatchTiming 600 90)
     externalSettled <- markExternalSettled connection observationRecord
     pure (applying && pending && externalSettled)
   assert "observation fixture reached applying/settled" settled
@@ -193,7 +195,7 @@ verifyIdempotencyExpiry database = do
   let rec = preparedRecord [first]
   finalized <- withTransaction database $ \connection -> do
     applying <- markApplying connection rec
-    pending <- markExternalPending connection rec 600 90
+    pending <- markExternalPending connection rec (DispatchTiming 600 90)
     settled <- markExternalSettled connection rec
     succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
     pure (applying && pending && settled && succeeded)
@@ -230,6 +232,40 @@ verifyIdempotencyExpiry database = do
   assertEqual "aged active key remains locked" 1 (countRejected [blocked])
   assertAuthority database 1 10
 
+verifyRowDecoder :: Db -> IO ()
+verifyRowDecoder database = do
+  resetAuthority database 100
+  outcome <- admit database "invalid-phase-operation" "invalid-phase-key" 10
+  let record = preparedRecord [outcome]
+  roundTripped <- withTransaction database $ \connection ->
+    lookupMutation
+      connection
+      (mrUserId record)
+      (mrKind record)
+      (mrOperationId record)
+  assertEqual "typed mutation row round-trip" (Just record) roundTripped
+  _ <- Db.execute database
+    "UPDATE mutations SET external_state = 'pending', \
+    \dispatch_started_at = now(), request_deadline_at = now(), \
+    \worker_lease_until = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+    ( unUserId (mrUserId record)
+    , kindLabel (mrKind record)
+    , unOperationId (mrOperationId record)
+    )
+  invalidDecode <-
+    ( try $ withTransaction database $ \connection ->
+        lookupMutation
+          connection
+          (mrUserId record)
+          (mrKind record)
+          (mrOperationId record)
+    ) :: IO (Either SomeException (Maybe MutationRecord))
+  case invalidDecode of
+    Left _ -> pure ()
+    Right value ->
+      fail ("invalid persisted mutation phase decoded as " <> show value)
+
 verifyStorage :: Config -> S3 -> IO ()
 verifyStorage config store = do
   let fallbackKey = ObjectKey "shared/fallback.bin"
@@ -322,16 +358,21 @@ admitWithWindow database operation key size window =
   withTransaction database $ \connection ->
     admitMutation
       connection
-      (UserId "integration-user")
+      AdmissionRequest
-      Put
+        { admissionIdentity =
-      (OperationId operation)
+            AdmissionIdentity (UserId "integration-user") Put
-      sharedPool
+              (OperationId operation)
-      (ObjectKey ("shared/" <> key))
+        , admissionPoolId = sharedPool
-      (RelativePath key)
+        , admissionRelativePath = RelativePath key
-      size
+        , admissionFingerprint =
-      (Just fixedIdentity)
+            MutationFingerprint
-      1000
+              Put
-      window
+              (ObjectKey ("shared/" <> key)) size (Just fixedIdentity)
+        }
+      AdmissionLimits
+        { admissionMaxObjectBytes = 1000
+        , admissionIdempotencyWindowSec = window
+        }
 
 resetAuthority :: Db -> Integer -> IO ()
 resetAuthority database limitBytes = do

test/ProtocolConformance.hs

@@ -457,7 +457,7 @@ dispatch :: Db -> MutationRecord -> IO ()
 dispatch database record = do
   ok <- withTransaction database $ \connection -> do
     applying <- markApplying connection record
-    pending <- markExternalPending connection record 10 5
+    pending <- markExternalPending connection record (DispatchTiming 10 5)
     pure (applying && pending)
   assert "PrepareEffect/DispatchEffect" ok
   coveredAction "PrepareEffect"
@@ -498,48 +498,59 @@ admitPut cfg database operation path size identity =
   withTransaction database $ \connection ->
     admitMutation
       connection
-      protocolUser
+      AdmissionRequest
-      Put
+        { admissionIdentity =
-      (OperationId operation)
+            AdmissionIdentity protocolUser Put (OperationId operation)
-      sharedPool
+        , admissionPoolId = sharedPool
-      (ObjectKey ("shared/" <> path))
+        , admissionRelativePath = RelativePath path
-      (RelativePath path)
+        , admissionFingerprint =
-      size
+            MutationFingerprint Put (ObjectKey ("shared/" <> path)) size
-      (Just identity)
+              (Just identity)
-      (cfgMaxObjectBytes cfg)
+        }
-      (cfgIdempotencyWindowSec cfg)
+      AdmissionLimits
+        { admissionMaxObjectBytes = cfgMaxObjectBytes cfg
+        , admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
+        }
 
 admitDelete :: Config -> Db -> Text -> Text -> IO AdmitOutcome
 admitDelete cfg database operation path =
   withTransaction database $ \connection ->
     admitMutation
       connection
-      protocolUser
+      AdmissionRequest
-      Delete
+        { admissionIdentity =
-      (OperationId operation)
+            AdmissionIdentity protocolUser Delete (OperationId operation)
-      sharedPool
+        , admissionPoolId = sharedPool
-      (ObjectKey ("shared/" <> path))
+        , admissionRelativePath = RelativePath path
-      (RelativePath path)
+        , admissionFingerprint =
-      0
+            MutationFingerprint Delete (ObjectKey ("shared/" <> path)) 0 Nothing
-      Nothing
+        }
-      (cfgMaxObjectBytes cfg)
+      AdmissionLimits
-      (cfgIdempotencyWindowSec cfg)
+        { admissionMaxObjectBytes = cfgMaxObjectBytes cfg
+        , admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
+        }
 
 admitPersonal :: Config -> Db -> UserId -> Text -> IO AdmitOutcome
 admitPersonal cfg database user operation =
   withTransaction database $ \connection ->
     admitMutation
       connection
-      user
+      AdmissionRequest
-      Put
+        { admissionIdentity =
-      (OperationId operation)
+            AdmissionIdentity user Put (OperationId operation)
-      (personalPool user)
+        , admissionPoolId = personalPool user
-      (ObjectKey ("users/" <> unUserId user <> "/file.bin"))
+        , admissionRelativePath = RelativePath "file.bin"
-      (RelativePath "file.bin")
+        , admissionFingerprint =
-      9
+            MutationFingerprint
-      (Just identityA)
+              Put
-      (cfgMaxObjectBytes cfg)
+              (ObjectKey ("users/" <> unUserId user <> "/file.bin"))
-      (cfgIdempotencyWindowSec cfg)
+              9
+              (Just identityA)
+        }
+      AdmissionLimits
+        { admissionMaxObjectBytes = cfgMaxObjectBytes cfg
+        , admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
+        }
 
 seedObject :: Db -> S3 -> Text -> BL.ByteString -> IO ()
 seedObject database store path body = do

test/RecoveryPhase.hs

@@ -112,16 +112,15 @@ preparePut database redis name size identity = do
   outcome <- withTransaction database $ \connection ->
     admitMutation
       connection
-      recoveryUser
+      AdmissionRequest
-      Put
+        { admissionIdentity =
-      (phaseOperation name)
+            AdmissionIdentity recoveryUser Put (phaseOperation name)
-      sharedPool
+        , admissionPoolId = sharedPool
-      (phaseKey name)
+        , admissionRelativePath = RelativePath (name <> ".bin")
-      (RelativePath (name <> ".bin"))
+        , admissionFingerprint =
-      size
+            MutationFingerprint Put (phaseKey name) size (Just identity)
-      (Just identity)
+        }
-      (1024 * 1024 * 1024)
+      (AdmissionLimits (1024 * 1024 * 1024) 3600)
-      3600
   prepared outcome
 
 prepareDelete :: Config -> Db -> Redis -> S3 -> IO MutationRecord
@@ -146,16 +145,18 @@ prepareDelete cfg database redis store = do
   outcome <- withTransaction database $ \connection ->
     admitMutation
       connection
-      recoveryUser
+      AdmissionRequest
-      Delete
+        { admissionIdentity =
-      (phaseOperation name)
+            AdmissionIdentity recoveryUser Delete (phaseOperation name)
-      sharedPool
+        , admissionPoolId = sharedPool
-      key
+        , admissionRelativePath = RelativePath (name <> ".bin")
-      (RelativePath (name <> ".bin"))
+        , admissionFingerprint =
-      0
+            MutationFingerprint Delete key 0 Nothing
-      Nothing
+        }
-      (cfgMaxObjectBytes cfg)
+      AdmissionLimits
-      (cfgIdempotencyWindowSec cfg)
+        { admissionMaxObjectBytes = cfgMaxObjectBytes cfg
+        , admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
+        }
   prepared outcome
 
 beginDispatch :: Config -> Db -> MutationRecord -> IO ()
@@ -165,8 +166,10 @@ beginDispatch cfg database rec = do
     pending <- markExternalPending
       connection
       rec
-      (cfgObjectRequestTimeoutSec cfg * 2)
+      DispatchTiming
-      (cfgRecoveryGraceSec cfg)
+        { dispatchSettlementBoundSec = cfgObjectRequestTimeoutSec cfg * 2
+        , dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
+        }
     pure (applying && pending)
   unless started (fail "could not begin dispatch")
 

test/Spec.hs

@@ -101,12 +101,21 @@ import           Nuthatch.Paths
   , listCacheAncestorPrefixes
   )
 import           Nuthatch.Protocol
-  ( ExistingDisposition (..)
+  ( AdmissionIdentity (..)
+  , ExistingDisposition (..)
+  , MutationFingerprint (..)
+  , MutationPhase (..)
   , MutationRecord (..)
   , ObjectObservation (..)
+  , PriorObject (..)
+  , TerminalResult (..)
+  , decodeMutationPhase
   , desiredMatches
+  , encodeMutationPhase
   , existingDisposition
   , growthBytes
+  , mrContentSha256
+  , mrObjectKey
   , priorMatches
   , quotaAllows
   , recoveryEligible
@@ -307,20 +316,50 @@ identityTests = testGroup "identities"
 
 protocolTests :: TestTree
 protocolTests = testGroup "mutation protocol decisions"
-  [ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
+  [ testCase "protocol phases round-trip through persisted state labels" $
+      mapM_
+        (\phase -> do
+          let (state, external) = encodeMutationPhase phase
+          decodeMutationPhase state external @?= Just phase)
+        [ PhasePrepared
+        , PhaseApplying ExtIdle
+        , PhaseApplying ExtPending
+        , PhaseApplying ExtSettled
+        , PhaseTerminal TerminalSucceeded
+        , PhaseTerminal TerminalFailed
+        , PhaseTerminal TerminalRejected
+        ]
+  , testCase "invalid persisted protocol phase combinations are rejected" $
+      mapM_
+        (\(state, external) ->
+          decodeMutationPhase state external @?= Nothing)
+        [ (Prepared, ExtPending)
+        , (Prepared, ExtSettled)
+        , (Succeeded, ExtPending)
+        , (Succeeded, ExtSettled)
+        , (Failed, ExtPending)
+        , (Failed, ExtSettled)
+        , (Rejected, ExtPending)
+        , (Rejected, ExtSettled)
+        ]
+  , testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
   , testCase "removed terminal identity starts a new mutation epoch" $ do
       let rec = sampleMutation
             Put
             (ObjectKey "users/u/file")
             4
             (Just (ContentSha256 "content"))
-      case existingDisposition Nothing Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
+      let fingerprint =
+            MutationFingerprint Put (mrObjectKey rec) 4 (mrContentSha256 rec)
+      case existingDisposition Nothing fingerprint of
         NewMutationEpoch -> pure ()
         other -> assertFailure ("expected new epoch, got " <> show other)
-      case existingDisposition (Just rec) Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
+      case existingDisposition (Just rec) fingerprint of
         ExistingReplay MutationPending _ -> pure ()
         other -> assertFailure ("expected replay, got " <> show other)
-      case existingDisposition (Just rec) Put (mrObjectKey rec) 5 (mrContentSha256 rec) of
+      case existingDisposition
+          (Just rec)
+          (fingerprint { fingerprintDeclaredSize = 5 }) of
         ExistingConflict -> pure ()
         other -> assertFailure ("expected conflict, got " <> show other)
   , testProperty "quota growth and admission preserve the limit" propQuotaInvariant
@@ -334,8 +373,8 @@ protocolTests = testGroup "mutation protocol decisions"
   , testCase "ambiguous same-size content matches no terminal state" $ do
       let rec = (sampleMutation Put (ObjectKey "shared/file") 10
             (Just (ContentSha256 "desired")))
-            { mrPriorSize = 10
+            { mrPriorObject =
-            , mrPriorSha256 = Just (ContentSha256 "prior")
+                PriorObject 10 (Just (ContentSha256 "prior"))
             }
           observation = ObjectPresent 10 (Just (ContentSha256 "other"))
       desiredMatches rec observation @?= False
@@ -1105,12 +1144,19 @@ propFingerprintDistinction = property $ do
       otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
       sha = Just (ContentSha256 "content-a")
       rec = sampleMutation Put key size sha
-  assert (sameFingerprint rec Put key size sha)
+  let fingerprint = MutationFingerprint Put key size sha
-  assert (not (sameFingerprint rec Delete key size sha))
+  assert (sameFingerprint rec fingerprint)
-  assert (not (sameFingerprint rec Put otherRootKey size sha))
+  assert (not (sameFingerprint rec
-  assert (not (sameFingerprint rec Put otherPathKey size sha))
+    (fingerprint { fingerprintKind = Delete })))
-  assert (not (sameFingerprint rec Put key (size + 1) sha))
+  assert (not (sameFingerprint rec
-  assert (not (sameFingerprint rec Put key size (Just (ContentSha256 "content-b"))))
+    (fingerprint { fingerprintObjectKey = otherRootKey })))
+  assert (not (sameFingerprint rec
+    (fingerprint { fingerprintObjectKey = otherPathKey })))
+  assert (not (sameFingerprint rec
+    (fingerprint { fingerprintDeclaredSize = size + 1 })))
+  assert (not (sameFingerprint rec
+    (fingerprint
+      { fingerprintContentSha256 = Just (ContentSha256 "content-b") })))
 
 propQuotaInvariant :: Property
 propQuotaInvariant = property $ do
@@ -1140,9 +1186,7 @@ propObservations = property $ do
   let desiredSha = Just (ContentSha256 "desired")
       priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
       rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
-        { mrPriorSize = priorSize
+        { mrPriorObject = PriorObject priorSize priorSha }
-        , mrPriorSha256 = priorSha
-        }
   desiredMatches rec observation === modelDesired kind desiredSize desiredSha observation
   priorMatches rec observation === modelPrior priorSize priorSha observation
 
@@ -1257,17 +1301,12 @@ sampleMutation
   -> Maybe ContentSha256
   -> MutationRecord
 sampleMutation kind key size sha = MutationRecord
-  { mrUserId = UserId "u"
+  { mrAdmissionIdentity =
-  , mrKind = kind
+      AdmissionIdentity (UserId "u") kind (OperationId "op")
-  , mrOperationId = OperationId "op"
   , mrPoolId = PoolId "personal:u"
-  , mrObjectKey = key
   , mrRelativePath = RelativePath "file"
-  , mrDeclaredSize = size
+  , mrFingerprint = MutationFingerprint kind key size sha
-  , mrContentSha256 = sha
+  , mrPriorObject = PriorObject 0 Nothing
-  , mrPriorSize = 0
-  , mrPriorSha256 = Nothing
   , mrGrowth = size
-  , mrState = Applying
+  , mrPhase = PhaseApplying ExtSettled
-  , mrExternal = ExtSettled
   }