Expire terminal mutation identities by configured epoch

src/Nuthatch/Api.hs

@@ -196,6 +196,7 @@ instance ToJSON DeletePrefixResponse where
 data UploadResponse = UploadResponse
   { uploadResponseOperationId :: OperationId
   , uploadResponseResult      :: MutationResult
+  , uploadResponseIdempotencyWindowSeconds :: Integer
   }
   deriving stock (Eq, Show)
 
@@ -203,11 +204,14 @@ instance ToJSON UploadResponse where
   toJSON response = object
     [ "operation_id" .= uploadResponseOperationId response
     , "result" .= mutationResultText (uploadResponseResult response)
+    , "idempotency_window_seconds"
+        .= uploadResponseIdempotencyWindowSeconds response
     ]
 
 data DeleteResponse = DeleteResponse
   { deleteResponseOperationId :: OperationId
   , deleteResponseResult      :: MutationResult
+  , deleteResponseIdempotencyWindowSeconds :: Integer
   }
   deriving stock (Eq, Show)
 
@@ -215,6 +219,8 @@ instance ToJSON DeleteResponse where
   toJSON response = object
     [ "operation_id" .= deleteResponseOperationId response
     , "result" .= mutationResultText (deleteResponseResult response)
+    , "idempotency_window_seconds"
+        .= deleteResponseIdempotencyWindowSeconds response
     ]
 
 data Throws error

src/Nuthatch/App.hs

@@ -362,6 +362,8 @@ handleUploadRequest env session root path operation declaredSize contentIdentity
   pure UploadResponse
     { uploadResponseOperationId = operation
     , uploadResponseResult = result
+    , uploadResponseIdempotencyWindowSeconds =
+        cfgIdempotencyWindowSec (envConfig env)
     }
 
 requireDownloadBandwidth :: Env -> SessionUser -> Integer -> Handler ()
@@ -430,6 +432,8 @@ handleDeleteRequest env session request = do
   pure DeleteResponse
     { deleteResponseOperationId = operation
     , deleteResponseResult = result
+    , deleteResponseIdempotencyWindowSeconds =
+        cfgIdempotencyWindowSec (envConfig env)
     }
 
 handleDeletePrefixRequest
@@ -537,6 +541,7 @@ runPut env user root rel op size sha body = do
   outcome <- withTransaction (envDb env) $ \conn ->
     admitMutation conn uid Put op pool key rel size (Just sha)
       (cfgMaxObjectBytes (envConfig env))
+      (cfgIdempotencyWindowSec (envConfig env))
   case outcome of
     AdmitConflict -> pure (Right MutationConflict)
     AdmitRejected reason _ -> pure (Left (PutRejected reason))
@@ -608,6 +613,7 @@ runDelete env user root rel op = do
   outcome <- withTransaction (envDb env) $ \conn ->
     admitMutation conn uid Delete op pool key rel 0 Nothing
       (cfgMaxObjectBytes (envConfig env))
+      (cfgIdempotencyWindowSec (envConfig env))
   case outcome of
     AdmitConflict -> pure (Right MutationConflict)
     AdmitRejected reason _ -> pure (Left reason)

src/Nuthatch/Config.hs

@@ -50,6 +50,7 @@ data Config = Config
   , cfgListCacheTtlSec     :: Integer
   , cfgSearchMaxKeys       :: Int
   , cfgRecoveryGraceSec    :: Integer
+  , cfgIdempotencyWindowSec :: Integer
   }
 
 loadConfig :: IO Config
@@ -112,6 +113,9 @@ loadConfig = do
   listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
   searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
   recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
+  idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
+  when (idempotencyWindow <= 0) $
+    fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
   pure Config
     { cfgListenHost = host
     , cfgListenPort = port
@@ -148,6 +152,7 @@ loadConfig = do
     , cfgListCacheTtlSec = listTtl
     , cfgSearchMaxKeys = searchMax
     , cfgRecoveryGraceSec = recoveryGrace
+    , cfgIdempotencyWindowSec = idempotencyWindow
     }
 
 luaExactIntegerMax :: Integer

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