Expire terminal mutation identities by configured epoch

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