Expire terminal mutation identities by configured epoch

src/Nuthatch/Protocol.hs

@@ -1,6 +1,7 @@
 -- | Short Postgres transactions for mutation authority; store I/O stays outside them.
 module Nuthatch.Protocol
   ( AdmitOutcome (..)
+  , ExistingDisposition (..)
   , MutationRecord (..)
   , ObjectObservation (..)
   , admitMutation
@@ -14,9 +15,11 @@ module Nuthatch.Protocol
   , lookupMutation
   , lookupObjectMeta
   , sameFingerprint
+  , existingDisposition
   , growthBytes
   , quotaAllows
   , terminalExpiryEligible
+  , terminalExpired
   , recoveryEligible
   , desiredMatches
   , priorMatches
@@ -59,6 +62,12 @@ data AdmitOutcome
   | AdmitConflict
   deriving stock (Show)
 
+data ExistingDisposition
+  = NewMutationEpoch
+  | ExistingReplay MutationResult MutationRecord
+  | ExistingConflict
+  deriving stock (Show)
+
 type ResultRow =
   ( Text, Text, Text, Text, Text, Text, Integer, Maybe Text
   , Integer, Maybe Text, Integer, Text, Text
@@ -111,6 +120,21 @@ sameFingerprint rec kind key size msha =
     && mrDeclaredSize rec == size
     && mrContentSha256 rec == msha
 
+existingDisposition
+  :: Maybe MutationRecord
+  -> MutationKind
+  -> ObjectKey
+  -> Integer
+  -> Maybe ContentSha256
+  -> ExistingDisposition
+existingDisposition existing kind key size msha =
+  case existing of
+    Nothing -> NewMutationEpoch
+    Just rec
+      | sameFingerprint rec kind key size msha ->
+          ExistingReplay (stateToResult (mrState rec)) rec
+      | otherwise -> ExistingConflict
+
 growthBytes :: Integer -> Integer -> Integer
 growthBytes priorSize desiredSize = max 0 (desiredSize - priorSize)
 
@@ -122,6 +146,10 @@ terminalExpiryEligible :: MutationState -> ExternalState -> Bool
 terminalExpiryEligible state external =
   state `elem` [Succeeded, Failed, Rejected] && external == ExtIdle
 
+terminalExpired :: MutationState -> ExternalState -> Integer -> Integer -> Bool
+terminalExpired state external elapsedSeconds windowSeconds =
+  terminalExpiryEligible state external && elapsedSeconds > windowSeconds
+
 recoveryEligible :: MutationState -> Integer -> Integer -> Bool
 recoveryEligible state elapsedSeconds graceSeconds =
   state `elem` [Prepared, Applying] && elapsedSeconds > graceSeconds
@@ -137,20 +165,26 @@ admitMutation
   -> Integer
   -> Maybe ContentSha256
   -> Integer
+  -> Integer
   -> IO AdmitOutcome
-admitMutation conn uid kind op pool key rel size msha maxObject = do
+admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindow = do
   let identity =
         unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
   _ <- query conn
     "SELECT pg_advisory_xact_lock(hashtextextended(?, 0))"
     (Only identity) :: IO [Only ()]
+  _ <- execute conn
+    "DELETE FROM mutations \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? \
+    \AND state IN ('succeeded', 'failed', 'rejected') \
+    \AND external_state = 'idle' \
+    \AND updated_at < now() - (? * interval '1 second')"
+    (unUserId uid, kindLabel kind, unOperationId op, idempotencyWindow)
   existing <- lookupMutation conn uid kind op
-  case existing of
-    Just rec
-      | sameFingerprint rec kind key size msha ->
-          pure $ AdmitReplay (stateToResult (mrState rec)) rec
-      | otherwise -> pure AdmitConflict
-    Nothing -> do
+  case existingDisposition existing kind key size msha of
+    ExistingReplay result rec -> pure (AdmitReplay result rec)
+    ExistingConflict -> pure AdmitConflict
+    NewMutationEpoch -> do
       priorMeta <- lookupObjectMeta conn key
       let priorSize = maybe 0 fst priorMeta
           priorSha = snd <$> priorMeta