Expire terminal mutation identities by configured epoch

test/Integration.hs

@@ -246,6 +246,52 @@ verifyAdmission database config = do
     [("applying", "settled")]
     durableState
 
+  verifyIdempotencyExpiry database
+
+verifyIdempotencyExpiry :: Db -> IO ()
+verifyIdempotencyExpiry database = do
+  resetAuthority database 100
+  first <- admitWithWindow database "expiring-operation" "expiring-key" 10 1
+  let rec = preparedRecord [first]
+  finalized <- withTransaction database $ \connection -> do
+    applying <- markApplying connection rec
+    pending <- markExternalPending connection rec
+    settled <- markExternalSettled connection rec
+    succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
+    pure (applying && pending && settled && succeeded)
+  assert "terminal expiry fixture finalized" finalized
+  _ <- Db.execute database
+    "UPDATE mutations SET updated_at = now() - interval '5 seconds' \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+    ( "integration-user" :: Text
+    , "put" :: Text
+    , "expiring-operation" :: Text
+    )
+  outcomes <- mapConcurrently
+    (\size ->
+      admitWithWindow database "expiring-operation" "expiring-key" size 1)
+    [11, 12]
+  assertEqual "one first request after terminal expiry" 1 (countPrepared outcomes)
+  assertEqual "atomic conflicting reuse after terminal expiry" 1
+    (countConflict outcomes)
+  assertAuthority database 1 (mrGrowth (preparedRecord outcomes))
+
+  resetAuthority database 100
+  active <- admitWithWindow database "active-operation" "active-key" 10 1
+  _ <- Db.execute database
+    "UPDATE mutations SET updated_at = now() - interval '5 seconds' \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+    ( "integration-user" :: Text
+    , "put" :: Text
+    , "active-operation" :: Text
+    )
+  replay <- admitWithWindow database "active-operation" "active-key" 10 1
+  blocked <- admitWithWindow database "other-operation" "active-key" 10 1
+  assertEqual "aged active identity remains replayable" 1
+    (countReplay [active, replay])
+  assertEqual "aged active key remains locked" 1 (countRejected [blocked])
+  assertAuthority database 1 10
+
 verifyStorage :: Config -> S3 -> IO ()
 verifyStorage config store = do
   let fallbackKey = ObjectKey "shared/fallback.bin"
@@ -258,8 +304,8 @@ verifyStorage config store = do
       (toInteger (BL.length fallbackBody))
       Nothing
       fallbackBody
-  fallbackHead <- expectJust "observe object without identity metadata"
-    =<< headObject store fallbackKey
+  fallbackHead <- expectRight "observe object without identity metadata"
+    =<< observeObjectFully store fallbackKey
   assertEqual "streaming digest fallback size"
     (toInteger (BL.length fallbackBody))
     (oiSize fallbackHead)
@@ -329,6 +375,10 @@ collectPages store prefix marker accumulated = do
 
 admit :: Db -> Text -> Text -> Integer -> IO AdmitOutcome
 admit database operation key size =
+  admitWithWindow database operation key size 3600
+
+admitWithWindow :: Db -> Text -> Text -> Integer -> Integer -> IO AdmitOutcome
+admitWithWindow database operation key size window =
   withTransaction database $ \connection ->
     admitMutation
       connection
@@ -341,6 +391,7 @@ admit database operation key size =
       size
       (Just fixedIdentity)
       1000
+      window
 
 resetAuthority :: Db -> Integer -> IO ()
 resetAuthority database limitBytes = do

test/Spec.hs

@@ -79,15 +79,18 @@ import           Nuthatch.Paths
   , listCacheAncestorPrefixes
   )
 import           Nuthatch.Protocol
-  ( MutationRecord (..)
+  ( ExistingDisposition (..)
+  , MutationRecord (..)
   , ObjectObservation (..)
   , desiredMatches
+  , existingDisposition
   , growthBytes
   , priorMatches
   , quotaAllows
   , recoveryEligible
   , sameFingerprint
   , terminalExpiryEligible
+  , terminalExpired
   )
 import           Nuthatch.Types
 import           Nuthatch.Session (mintSession)
@@ -107,7 +110,7 @@ import           Servant.Types.SourceT
   , source
   )
 import           Test.Tasty (TestTree, defaultMain, testGroup)
-import           Test.Tasty.HUnit ((@?=), assertBool, testCase)
+import           Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)
 import           Test.Tasty.Hedgehog (testProperty)
 
 main :: IO ()
@@ -198,6 +201,21 @@ identityTests = testGroup "identities"
 protocolTests :: TestTree
 protocolTests = testGroup "mutation protocol decisions"
   [ 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
+        NewMutationEpoch -> pure ()
+        other -> assertFailure ("expected new epoch, got " <> show other)
+      case existingDisposition (Just rec) Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
+        ExistingReplay MutationPending _ -> pure ()
+        other -> assertFailure ("expected replay, got " <> show other)
+      case existingDisposition (Just rec) Put (mrObjectKey rec) 5 (mrContentSha256 rec) of
+        ExistingConflict -> pure ()
+        other -> assertFailure ("expected conflict, got " <> show other)
   , testProperty "quota growth and admission preserve the limit" propQuotaInvariant
   , testProperty "object observations match the independent classifier" propObservations
   , testCase "unavailable observations match no terminal state" $ do
@@ -216,6 +234,7 @@ protocolTests = testGroup "mutation protocol decisions"
       desiredMatches rec observation @?= False
       priorMatches rec observation @?= False
   , testProperty "only settled terminal records are expiry eligible" propExpiryEligibility
+  , testProperty "terminal identities expire only after the window" propTerminalExpiry
   , testProperty "only stale active records are recovery eligible" propRecoveryTiming
   ]
 
@@ -547,6 +566,9 @@ testStreamingEndpoints = do
     headers
     "body"
   simpleStatus upload @?= status200
+  assertBool "upload advertises the idempotency window"
+    ("\"idempotency_window_seconds\":3600"
+      `BS.isInfixOf` BL.toStrict (simpleBody upload))
   download <- apiRequest calls methodGet
     "/download?root=shared&path=docs%2Ffile.txt"
     []
@@ -579,6 +601,9 @@ testOperationRepresentations = do
   simpleStatus deletion @?= status200
   assertBool "delete response must carry a mutation result"
     ("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
+  assertBool "delete advertises the idempotency window"
+    ("\"idempotency_window_seconds\":3600"
+      `BS.isInfixOf` BL.toStrict (simpleBody deletion))
   malformed <- apiRequest calls methodPost
     "/delete"
     [("Content-Type", "application/json")]
@@ -674,10 +699,12 @@ typedTestServer calls =
   :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
         { uploadResponseOperationId = operation
         , uploadResponseResult = MutationSucceeded
+        , uploadResponseIdempotencyWindowSeconds = 3600
         })
   :<|> (\_ request -> counted DeleteResponse
         { deleteResponseOperationId = deleteOperationId request
         , deleteResponseResult = MutationSucceeded
+        , deleteResponseIdempotencyWindowSeconds = 3600
         })
   :<|> (\_ _ -> counted (DeletePrefixResponse 1))
   where
@@ -846,6 +873,7 @@ testConfig = Config
   , cfgListCacheTtlSec = 30
   , cfgSearchMaxKeys = 100
   , cfgRecoveryGraceSec = 30
+  , cfgIdempotencyWindowSec = 3600
   }
 
 newtype ValidPath = ValidPath { getValidPath :: Text }
@@ -981,6 +1009,18 @@ propExpiryEligibility = property $ do
   terminalExpiryEligible state external
     === (state `elem` [Succeeded, Failed, Rejected] && external == ExtIdle)
 
+propTerminalExpiry :: Property
+propTerminalExpiry = property $ do
+  state <- forAll genMutationState
+  external <- forAll genExternalState
+  elapsed <- forAll (Gen.integral (Range.linear 0 10000))
+  window <- forAll (Gen.integral (Range.linear 1 10000))
+  terminalExpired state external elapsed window
+    === ( state `elem` [Succeeded, Failed, Rejected]
+          && external == ExtIdle
+          && elapsed > window
+        )
+
 propRecoveryTiming :: Property
 propRecoveryTiming = property $ do
   state <- forAll genMutationState