Type protocol persistence around model phases

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
-            , mrPriorSha256 = Just (ContentSha256 "prior")
+            { mrPriorObject =
+                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)
-  assert (not (sameFingerprint rec Delete key size sha))
-  assert (not (sameFingerprint rec Put otherRootKey size sha))
-  assert (not (sameFingerprint rec Put otherPathKey size sha))
-  assert (not (sameFingerprint rec Put key (size + 1) sha))
-  assert (not (sameFingerprint rec Put key size (Just (ContentSha256 "content-b"))))
+  let fingerprint = MutationFingerprint Put key size sha
+  assert (sameFingerprint rec fingerprint)
+  assert (not (sameFingerprint rec
+    (fingerprint { fingerprintKind = Delete })))
+  assert (not (sameFingerprint rec
+    (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
-        , mrPriorSha256 = priorSha
-        }
+        { mrPriorObject = PriorObject priorSize 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"
-  , mrKind = kind
-  , mrOperationId = OperationId "op"
+  { mrAdmissionIdentity =
+      AdmissionIdentity (UserId "u") kind (OperationId "op")
   , mrPoolId = PoolId "personal:u"
-  , mrObjectKey = key
   , mrRelativePath = RelativePath "file"
-  , mrDeclaredSize = size
-  , mrContentSha256 = sha
-  , mrPriorSize = 0
-  , mrPriorSha256 = Nothing
+  , mrFingerprint = MutationFingerprint kind key size sha
+  , mrPriorObject = PriorObject 0 Nothing
   , mrGrowth = size
-  , mrState = Applying
-  , mrExternal = ExtSettled
+  , mrPhase = PhaseApplying ExtSettled
   }