Type protocol persistence around model phases

test/Integration.hs

@@ -38,6 +38,7 @@ main = do
     migrate database "sql" config
     verifySchema database
     verifyAdmission database config
+    verifyRowDecoder database
   store <- newS3 config
   verifyStorage config store
   putStrLn "Storage foundation integration gate passed"
@@ -160,7 +161,8 @@ verifyAdmission database config = do
             "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
   settled <- withTransaction database $ \connection -> do
     applying <- markApplying connection observationRecord
-    pending <- markExternalPending connection observationRecord 600 90
+    pending <- markExternalPending
+      connection observationRecord (DispatchTiming 600 90)
     externalSettled <- markExternalSettled connection observationRecord
     pure (applying && pending && externalSettled)
   assert "observation fixture reached applying/settled" settled
@@ -193,7 +195,7 @@ verifyIdempotencyExpiry database = do
   let rec = preparedRecord [first]
   finalized <- withTransaction database $ \connection -> do
     applying <- markApplying connection rec
-    pending <- markExternalPending connection rec 600 90
+    pending <- markExternalPending connection rec (DispatchTiming 600 90)
     settled <- markExternalSettled connection rec
     succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
     pure (applying && pending && settled && succeeded)
@@ -230,6 +232,40 @@ verifyIdempotencyExpiry database = do
   assertEqual "aged active key remains locked" 1 (countRejected [blocked])
   assertAuthority database 1 10
 
+verifyRowDecoder :: Db -> IO ()
+verifyRowDecoder database = do
+  resetAuthority database 100
+  outcome <- admit database "invalid-phase-operation" "invalid-phase-key" 10
+  let record = preparedRecord [outcome]
+  roundTripped <- withTransaction database $ \connection ->
+    lookupMutation
+      connection
+      (mrUserId record)
+      (mrKind record)
+      (mrOperationId record)
+  assertEqual "typed mutation row round-trip" (Just record) roundTripped
+  _ <- Db.execute database
+    "UPDATE mutations SET external_state = 'pending', \
+    \dispatch_started_at = now(), request_deadline_at = now(), \
+    \worker_lease_until = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+    ( unUserId (mrUserId record)
+    , kindLabel (mrKind record)
+    , unOperationId (mrOperationId record)
+    )
+  invalidDecode <-
+    ( try $ withTransaction database $ \connection ->
+        lookupMutation
+          connection
+          (mrUserId record)
+          (mrKind record)
+          (mrOperationId record)
+    ) :: IO (Either SomeException (Maybe MutationRecord))
+  case invalidDecode of
+    Left _ -> pure ()
+    Right value ->
+      fail ("invalid persisted mutation phase decoded as " <> show value)
+
 verifyStorage :: Config -> S3 -> IO ()
 verifyStorage config store = do
   let fallbackKey = ObjectKey "shared/fallback.bin"
@@ -322,16 +358,21 @@ admitWithWindow database operation key size window =
   withTransaction database $ \connection ->
     admitMutation
       connection
-      (UserId "integration-user")
-      Put
-      (OperationId operation)
-      sharedPool
-      (ObjectKey ("shared/" <> key))
-      (RelativePath key)
-      size
-      (Just fixedIdentity)
-      1000
-      window
+      AdmissionRequest
+        { admissionIdentity =
+            AdmissionIdentity (UserId "integration-user") Put
+              (OperationId operation)
+        , admissionPoolId = sharedPool
+        , admissionRelativePath = RelativePath key
+        , admissionFingerprint =
+            MutationFingerprint
+              Put
+              (ObjectKey ("shared/" <> key)) size (Just fixedIdentity)
+        }
+      AdmissionLimits
+        { admissionMaxObjectBytes = 1000
+        , admissionIdempotencyWindowSec = window
+        }
 
 resetAuthority :: Db -> Integer -> IO ()
 resetAuthority database limitBytes = do