Make object recovery settlement-safe

Dockerfile

@@ -19,10 +19,11 @@ COPY app ./app
 COPY src ./src
 COPY test ./test
 
-RUN cabal build exe:nuthatch exe:nuthatch-wp04-integration \
+RUN cabal build exe:nuthatch exe:nuthatch-wp04-integration exe:nuthatch-wp09-phase \
   && mkdir -p /out \
   && cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch \
-  && cp "$(cabal list-bin exe:nuthatch-wp04-integration)" /out/nuthatch-wp04-integration
+  && cp "$(cabal list-bin exe:nuthatch-wp04-integration)" /out/nuthatch-wp04-integration \
+  && cp "$(cabal list-bin exe:nuthatch-wp09-phase)" /out/nuthatch-wp09-phase
 
 FROM debian:bookworm-slim AS runtime-base
 
@@ -44,6 +45,8 @@ FROM runtime-base AS test-runtime
 
 COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
 COPY --from=build /out/nuthatch-wp04-integration /usr/local/bin/nuthatch-wp04-integration
+COPY --from=build /out/nuthatch-wp09-phase /usr/local/bin/nuthatch-wp09-phase
+CMD ["nuthatch"]
 
 FROM runtime-base AS runtime
 

Makefile

@@ -1,4 +1,4 @@
-.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-streaming check-idempotency app-up app-down check-frontend build-frontend
+.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-streaming check-idempotency check-recovery app-up app-down check-frontend build-frontend
 
 test:
 	cabal test --offline nuthatch-unit
@@ -27,6 +27,9 @@ check-streaming:
 check-idempotency:
 	./tests/kind/wp08-run.sh
 
+check-recovery:
+	./tests/kind/wp09-run.sh
+
 app-up:
 	NUTHATCH_APP_INTERACTIVE=1 ./tests/kind/wp05-run.sh
 

app/Main.hs

@@ -1,6 +1,6 @@
 module Main (main) where
 
-import           Control.Concurrent (forkIO, threadDelay)
+import           Control.Concurrent (threadDelay)
 import           Control.Exception (SomeException, try)
 import           Data.String (fromString)
 import           Database.PostgreSQL.Simple (Only (..))
@@ -14,6 +14,7 @@ import           Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
 import           Nuthatch
 import           Nuthatch.Db (migrate, query_, withDb)
 import           Nuthatch.Redis (withRedis)
+import           Nuthatch.Recovery (withLinkedWorker)
 import           Nuthatch.S3 (newS3)
 import           System.Directory (doesDirectoryExist)
 import           System.FilePath ((</>))
@@ -30,7 +31,7 @@ main = do
     withRedis cfg $ \redis -> do
       s3 <- newS3 cfg
       let env = newEnv cfg db redis s3
-      _ <- forkIO (runRecovery env)
+      withLinkedWorker (runRecovery env) $ do
         let settings =
               setPort (cfgListenPort cfg) $
                 setHost (readHost (cfgListenHost cfg)) defaultSettings

deploy/kubernetes/nuthatch.yaml.in

@@ -16,6 +16,7 @@ data:
   NUTHATCH_S3_BUCKET: "@@S3_BUCKET@@"
   NUTHATCH_S3_PATH_STYLE: "true"
   NUTHATCH_IDEMPOTENCY_WINDOW_SEC: "86400"
+  NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC: "300"
 ---
 apiVersion: v1
 kind: Secret

nuthatch.cabal

@@ -10,6 +10,7 @@ build-type:         Simple
 extra-source-files:
   sql/001_schema.sql
   sql/002_pool_limit_guard.sql
+  sql/003_recovery_settlement.sql
 
 common shared
   default-language:   Haskell2010
@@ -74,6 +75,7 @@ common shared
     , postgresql-migration  >= 0.2.1.8 && < 0.3
     , resource-pool         >= 0.4 && < 0.5
     , resourcet             >= 1.3 && < 1.4
+    , retry                 >= 0.9 && < 0.10
     , scientific            >= 0.3 && < 0.4
     , servant               >= 0.20 && < 0.21
     , servant-server        >= 0.20 && < 0.21
@@ -105,6 +107,7 @@ library
     Nuthatch.Paths
     Nuthatch.Protocol
     Nuthatch.Redis
+    Nuthatch.Recovery
     Nuthatch.S3
     Nuthatch.Session
     Nuthatch.Streaming
@@ -138,6 +141,20 @@ executable nuthatch-wp04-integration
     -rtsopts
     -with-rtsopts=-N
 
+executable nuthatch-wp09-phase
+  import:         shared
+  main-is:        RecoveryPhase.hs
+  hs-source-dirs: test
+  build-depends:
+    , nuthatch
+    , base
+    , bytestring
+    , text
+  ghc-options:
+    -threaded
+    -rtsopts
+    -with-rtsopts=-N
+
 test-suite nuthatch-unit
   import:         shared
   type:           exitcode-stdio-1.0

sql/003_recovery_settlement.sql

@@ -0,0 +1,33 @@
+ALTER TABLE mutations
+    ADD COLUMN IF NOT EXISTS dispatch_started_at TIMESTAMPTZ,
+    ADD COLUMN IF NOT EXISTS request_deadline_at TIMESTAMPTZ,
+    ADD COLUMN IF NOT EXISTS worker_lease_until TIMESTAMPTZ,
+    ADD COLUMN IF NOT EXISTS settled_at TIMESTAMPTZ;
+
+DO $$
+BEGIN
+    IF EXISTS (
+        SELECT 1
+        FROM mutations
+        WHERE external_state = 'pending'
+    ) THEN
+        RAISE EXCEPTION
+            'recovery settlement migration requires no pending mutations';
+    END IF;
+END
+$$;
+
+ALTER TABLE mutations
+    ADD CONSTRAINT mutations_dispatch_timing_check CHECK (
+        (external_state <> 'pending') OR
+        (dispatch_started_at IS NOT NULL AND
+         request_deadline_at IS NOT NULL AND
+         worker_lease_until IS NOT NULL)
+    ) NOT VALID;
+
+ALTER TABLE mutations
+    VALIDATE CONSTRAINT mutations_dispatch_timing_check;
+
+CREATE INDEX IF NOT EXISTS mutations_recovery_idx
+    ON mutations (worker_lease_until, request_deadline_at, updated_at)
+    WHERE state IN ('prepared', 'applying');

src/Nuthatch/App.hs

@@ -5,13 +5,21 @@ module Nuthatch.App
   , utf8Boundary
   , authenticationHandler
   , loginResponse
+  , dispatchAndFinalize
   , runRecovery
   ) where
 
 import           Control.Concurrent (threadDelay)
-import           Control.Exception (SomeException, throwIO, try)
+import           Control.Concurrent.Async (mapConcurrently_)
-import           Control.Monad (forever, void, when)
+import           Control.Exception
+  ( SomeException
+  , throwIO
+  , try
+  )
+import           Control.Monad (forever, when)
 import           Control.Monad.IO.Class (liftIO)
+import           Control.Retry
+  ( retrying )
 import qualified Data.Aeson as A
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
@@ -47,6 +55,9 @@ import           Nuthatch.Redis
   , throttleCheck
   , throttleTake
   )
+import           Nuthatch.Recovery
+  ( recoveryRetryPolicy
+  )
 import           Nuthatch.S3
   ( ListPage (..)
   , ObjectInfo (..)
@@ -74,6 +85,7 @@ import           Servant.Server.Experimental.Auth
   , mkAuthHandler
   )
 import           Servant.Types.SourceT (SourceT)
+import           System.Timeout (timeout)
 import           Web.Cookie
   ( defaultSetCookie
   , parseCookies
@@ -554,6 +566,7 @@ runPut env user root rel op size sha body = do
         root
         rec
         PutSettlementFailed
+        (PutDispatchFailed (PutObjectStoreError S3TransportError))
         (putObjectStream
           (envS3 env)
           key
@@ -626,6 +639,7 @@ runDelete env user root rel op = do
         root
         rec
         "mutation failed after store settlement"
+        "object request timed out"
         (deleteObject (envS3 env) key
           >>= pure . either (Left . renderS3Error) Right)
 
@@ -684,31 +698,46 @@ dispatchAndFinalize
   -> Root
   -> MutationRecord
   -> failure
+  -> failure
   -> IO (Either failure ())
   -> IO (Either failure MutationResult)
-dispatchAndFinalize env user root rec settlementFailure dispatch = do
+dispatchAndFinalize env user root rec settlementFailure timeoutFailure dispatch = do
+  let cfg = envConfig env
+      requestTimeoutSec = cfgObjectRequestTimeoutSec cfg
   prepared <- withTransaction (envDb env) $ \conn -> do
     moved <- markApplying conn rec
     if not moved
       then pure False
-      else markExternalPending conn rec
+      else markExternalPending
+        conn
+        rec
+        (requestTimeoutSec * 2)
+        (cfgRecoveryGraceSec cfg)
   if not prepared
     then pure (Right MutationPending)
     else do
-      dispatchResult <- dispatch
+      dispatchOutcome <- timeout
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
+        (fromInteger (requestTimeoutSec * 1000000))
-      finalized <- withTransaction (envDb env) $ \conn -> do
+        dispatch
-        settled <- markExternalSettled conn rec
+      case dispatchOutcome of
+        Nothing -> pure (Left timeoutFailure)
+        Just (Left dispatchFailure) -> pure (Left dispatchFailure)
+        Just (Right ()) -> do
+          settled <- withTransaction (envDb env) $ \conn ->
+            markExternalSettled conn rec
           if not settled
-          then pure Nothing
+            then pure (Right MutationPending)
-          else finalizeFromObservation conn rec observed
+            else do
+              observed <- observeObject (envS3 env) (mrObjectKey rec)
+              finalized <- withTransaction (envDb env) $ \conn ->
+                finalizeFromObservation conn rec observed
               case finalized of
                 Just MutationSucceeded -> do
                   cacheInvalidatePrefixes (envRedis env) (suUserId user) root
                     (listCacheAncestorPrefixes (mrRelativePath rec))
                   pure (Right MutationSucceeded)
                 Just MutationFailed ->
-          pure (Left (either id (const settlementFailure) dispatchResult))
+                  pure (Left settlementFailure)
                 Just other -> pure (Right other)
                 Nothing -> pure (Right MutationPending)
 
@@ -822,47 +851,76 @@ collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
 
 runRecovery :: Env -> IO ()
 runRecovery env = forever $ do
-  _ <- try (recoverOnce env) :: IO (Either SomeException ())
+  recoverOnce env
   threadDelay (5 * 1000000)
 
 recoverOnce :: Env -> IO ()
 recoverOnce env = do
   let grace = cfgRecoveryGraceSec (envConfig env)
   batch <- withTransaction (envDb env) $ \conn -> claimActiveBatch conn 20 grace
-  mapM_ (recoverOne env) batch
+  mapConcurrently_ (recoverOne env) batch
 
 recoverOne :: Env -> MutationRecord -> IO ()
 recoverOne env rec =
   case (mrState rec, mrExternal rec) of
     (Prepared, _) -> do
-      _ <- withTransaction (envDb env) $ \conn -> do
+      settled <- withTransaction (envDb env) $ \conn -> do
         moved <- markApplying conn rec
-        when moved $ void (markSettledFromIdle conn rec)
+        if moved then markSettledFromIdle conn rec else pure False
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      when settled (finalizeRecovered env rec)
-      _ <- withTransaction (envDb env) $ \conn ->
-        finalizeFromObservation conn rec observed
-      pure ()
     (Applying, ExtIdle) -> do
-      _ <- withTransaction (envDb env) $ \conn -> markSettledFromIdle conn rec
+      settled <- withTransaction (envDb env) $ \conn ->
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
+        markSettledFromIdle conn rec
-      _ <- withTransaction (envDb env) $ \conn ->
+      when settled (finalizeRecovered env rec)
-        finalizeFromObservation conn rec observed
-      pure ()
     (Applying, ExtPending) -> do
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      settled <- withTransaction (envDb env) $ \conn ->
-      _ <- withTransaction (envDb env) $ \conn -> do
+        markExternalSettled conn rec
-        settled <- markExternalSettled conn rec
+      when settled (finalizeRecovered env rec)
-        if settled
+    (Applying, ExtSettled) -> finalizeRecovered env rec
-          then finalizeFromObservation conn rec observed
-          else pure Nothing
-      pure ()
-    (Applying, ExtSettled) -> do
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
-      _ <- withTransaction (envDb env) $ \conn ->
-        finalizeFromObservation conn rec observed
-      pure ()
     _ -> pure ()
 
+finalizeRecovered :: Env -> MutationRecord -> IO ()
+finalizeRecovered env rec = do
+  observed <- observeObjectWithRetry env rec
+  result <- withTransaction (envDb env) $ \conn ->
+    finalizeFromObservation conn rec observed
+  when (result == Just MutationSucceeded) $
+    cacheInvalidatePrefixes
+      (envRedis env)
+      (mrUserId rec)
+      (recordRoot rec)
+      (listCacheAncestorPrefixes (mrRelativePath rec))
+
+observeObjectWithRetry :: Env -> MutationRecord -> IO ObjectObservation
+observeObjectWithRetry env rec = do
+  observed <- retrying
+    recoveryRetryPolicy
+    retryUnavailable
+    (\_ -> observeObject (envS3 env) (mrObjectKey rec))
+  case observed of
+    ObjectUnavailable reason -> do
+      audit "recovery_observation" "exhausted" (Just (unUserId (mrUserId rec)))
+        [ ("operation_id", A.toJSON (unOperationId (mrOperationId rec)))
+        , ("reason", A.toJSON reason)
+        ]
+      pure observed
+    _ -> pure observed
+  where
+    retryUnavailable _ observation =
+      case observation of
+        ObjectUnavailable reason -> do
+          audit "recovery_observation" "retry" (Just (unUserId (mrUserId rec)))
+            [ ("operation_id", A.toJSON (unOperationId (mrOperationId rec)))
+            , ("reason", A.toJSON reason)
+            ]
+          pure True
+        _ -> pure False
+
+recordRoot :: MutationRecord -> Root
+recordRoot rec
+  | mrPoolId rec == sharedPool = Shared
+  | otherwise = Personal
+
 
 lastSeg :: Text -> Text
 lastSeg t =

src/Nuthatch/Config.hs

@@ -51,6 +51,7 @@ data Config = Config
   , cfgSearchMaxKeys       :: Int
   , cfgRecoveryGraceSec    :: Integer
   , cfgIdempotencyWindowSec :: Integer
+  , cfgObjectRequestTimeoutSec :: Integer
   }
 
 loadConfig :: IO Config
@@ -114,8 +115,13 @@ loadConfig = do
   searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
   recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
   idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
+  objectRequestTimeout <- envInteger "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC" 300
+  when (recoveryGrace <= 0) $
+    fail "NUTHATCH_RECOVERY_GRACE_SEC must be positive"
   when (idempotencyWindow <= 0) $
     fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
+  when (objectRequestTimeout <= 0) $
+    fail "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC must be positive"
   pure Config
     { cfgListenHost = host
     , cfgListenPort = port
@@ -153,6 +159,7 @@ loadConfig = do
     , cfgSearchMaxKeys = searchMax
     , cfgRecoveryGraceSec = recoveryGrace
     , cfgIdempotencyWindowSec = idempotencyWindow
+    , cfgObjectRequestTimeoutSec = objectRequestTimeout
     }
 
 luaExactIntegerMax :: Integer

src/Nuthatch/Protocol.hs

@@ -354,19 +354,34 @@ markApplying conn rec = do
     (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
   pure (n == 1)
 
-markExternalPending :: Connection -> MutationRecord -> IO Bool
+markExternalPending
-markExternalPending conn rec = do
+  :: Connection
+  -> MutationRecord
+  -> Integer
+  -> Integer
+  -> IO Bool
+markExternalPending conn rec settlementBoundSec workerGraceSec = do
   n <- execute conn
-    "UPDATE mutations SET external_state = 'pending', updated_at = now() \
+    "UPDATE mutations SET external_state = 'pending', \
+    \dispatch_started_at = now(), \
+    \request_deadline_at = now() + (? * interval '1 second'), \
+    \worker_lease_until = now() + (? * interval '1 second'), \
+    \updated_at = now() \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? \
     \AND state = 'applying' AND external_state = 'idle'"
-    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+    ( settlementBoundSec
+    , workerGraceSec
+    , unUserId (mrUserId rec)
+    , kindLabel (mrKind rec)
+    , unOperationId (mrOperationId rec)
+    )
   pure (n == 1)
 
 markExternalSettled :: Connection -> MutationRecord -> IO Bool
 markExternalSettled conn rec = do
   n <- execute conn
-    "UPDATE mutations SET external_state = 'settled', updated_at = now() \
+    "UPDATE mutations SET external_state = 'settled', settled_at = now(), \
+    \updated_at = now() \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? \
     \AND state = 'applying' AND external_state = 'pending'"
     (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
@@ -375,7 +390,8 @@ markExternalSettled conn rec = do
 markSettledFromIdle :: Connection -> MutationRecord -> IO Bool
 markSettledFromIdle conn rec = do
   n <- execute conn
-    "UPDATE mutations SET external_state = 'settled', updated_at = now() \
+    "UPDATE mutations SET external_state = 'settled', settled_at = now(), \
+    \updated_at = now() \
     \WHERE user_id = ? AND kind = ? AND operation_id = ? \
     \AND state = 'applying' AND external_state = 'idle'"
     (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
@@ -462,11 +478,19 @@ claimActiveBatch conn limit graceSec = do
     \declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
     \state, external_state FROM mutations \
     \WHERE state IN ('prepared', 'applying') \
-    \AND updated_at < now() - (? * interval '1 second') \
+    \AND ( \
+    \  (external_state = 'idle' \
+    \    AND updated_at < now() - (? * interval '1 second')) \
+    \  OR (external_state = 'settled' \
+    \    AND updated_at < now() - (? * interval '1 second')) \
+    \  OR (external_state = 'pending' \
+    \    AND worker_lease_until < now() \
+    \    AND request_deadline_at < now()) \
+    \) \
     \ORDER BY updated_at ASC \
     \FOR UPDATE SKIP LOCKED \
     \LIMIT ?"
-    (graceSec, limit)
+    (graceSec, graceSec, limit)
   pure (mapMaybe rowToRecord rows)
 
 desiredMatches :: MutationRecord -> ObjectObservation -> Bool

src/Nuthatch/Recovery.hs

@@ -0,0 +1,52 @@
+module Nuthatch.Recovery
+  ( recoveryClaimEligible
+  , recoveryRetryPolicy
+  , trySynchronous
+  , withLinkedWorker
+  ) where
+
+import           Control.Concurrent.Async (link, withAsync)
+import           Control.Exception
+  ( SomeAsyncException
+  , SomeException
+  , fromException
+  , tryJust
+  )
+import           Control.Retry
+  ( RetryPolicyM
+  , exponentialBackoff
+  , limitRetries
+  )
+import           Nuthatch.Types
+
+recoveryClaimEligible
+  :: MutationState
+  -> ExternalState
+  -> Integer
+  -> Integer
+  -> Bool
+  -> Bool
+  -> Bool
+recoveryClaimEligible state external elapsed grace leaseExpired deadlineExpired =
+  state `elem` [Prepared, Applying]
+    && case external of
+         ExtIdle    -> elapsed > grace
+         ExtSettled -> elapsed > grace
+         ExtPending -> leaseExpired && deadlineExpired
+
+recoveryRetryPolicy :: RetryPolicyM IO
+recoveryRetryPolicy =
+  exponentialBackoff 100000 <> limitRetries 4
+
+trySynchronous :: IO a -> IO (Either SomeException a)
+trySynchronous =
+  tryJust $ \exception ->
+    case fromException exception :: Maybe SomeAsyncException of
+      Just _  -> Nothing
+      Nothing -> Just exception
+
+withLinkedWorker :: IO worker -> IO foreground -> IO foreground
+withLinkedWorker worker foreground =
+  withAsync worker $ \running -> do
+    link running
+    foreground

src/Nuthatch/Redis.hs

@@ -8,7 +8,7 @@ module Nuthatch.Redis
   , throttleTake
   ) where
 
-import           Control.Exception (SomeException, try)
+import           Control.Exception (SomeException)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS8
 import           Data.Text (Text)
@@ -27,6 +27,7 @@ import           Database.Redis
   )
 import qualified Database.Redis as R
 import           Nuthatch.Config (Config (..))
+import           Nuthatch.Recovery (trySynchronous)
 import           Nuthatch.Types
 
 type Redis = Connection
@@ -42,7 +43,7 @@ withRedis cfg action = do
 
 cacheGet :: Redis -> Text -> IO (Maybe ByteString)
 cacheGet conn key = do
-  result <- try (runRedis conn (get (TE.encodeUtf8 key)))
+  result <- trySynchronous (runRedis conn (get (TE.encodeUtf8 key)))
               :: IO (Either SomeException (Either Reply (Maybe ByteString)))
   pure $ case result of
     Left _                 -> Nothing
@@ -51,7 +52,7 @@ cacheGet conn key = do
 
 cacheSet :: Redis -> Text -> Integer -> ByteString -> IO ()
 cacheSet conn key ttl value = do
-  _ <- try (runRedis conn (setex (TE.encodeUtf8 key) ttl value))
+  _ <- trySynchronous (runRedis conn (setex (TE.encodeUtf8 key) ttl value))
         :: IO (Either SomeException (Either Reply R.Status))
   pure ()
 
@@ -65,7 +66,7 @@ cacheInvalidatePrefixes conn uid root prefixes = do
   case ks of
     [] -> pure ()
     _  -> do
-      _ <- try (runRedis conn (del ks))
+      _ <- trySynchronous (runRedis conn (del ks))
             :: IO (Either SomeException (Either Reply Integer))
       pure ()
 
@@ -114,7 +115,7 @@ throttleRequest conn cfg uid bytes consume = do
           , "redis.call('EXPIRE', key, ttl)"
           , "return 1"
           ]
-  result <- try (runRedis conn $
+  result <- trySynchronous (runRedis conn $
     R.eval script [key]
       [ BS8.pack (show rate)
       , BS8.pack (show burst)

src/Nuthatch/S3.hs

@@ -73,6 +73,7 @@ import           Servant.Types.SourceT
   ( SourceT (..)
   , StepT (..)
   )
+import           System.Timeout (timeout)
 import           Text.Read (readMaybe)
 
 data S3 = S3
@@ -80,6 +81,7 @@ data S3 = S3
   , s3Service       :: S3.S3Configuration Aws.NormalQuery
   , s3Manager       :: HTTP.Manager
   , s3Bucket        :: Text
+  , s3RequestTimeoutMicros :: Int
   }
 
 data S3Error
@@ -118,6 +120,8 @@ newS3 cfg = do
   let defaultPort = case protocol of
         AwsCore.HTTP  -> 80
         AwsCore.HTTPS -> 443
+      requestTimeoutMicros =
+        fromInteger (cfgObjectRequestTimeoutSec cfg * 1000000)
       signedHost =
         if endpointPort == defaultPort
           then endpointHost
@@ -125,7 +129,7 @@ newS3 cfg = do
       managerSettings =
         tlsManagerSettings
           { HTTP.managerResponseTimeout =
-              HTTP.responseTimeoutMicro (30 * 1000000)
+              HTTP.responseTimeoutMicro requestTimeoutMicros
           -- The SDK signs the authority verbatim; http-client resolves only its host.
           , HTTP.managerModifyRequest = \request ->
               let requestHost = HTTP.host request
@@ -163,6 +167,7 @@ newS3 cfg = do
     , s3Service = service
     , s3Manager = manager
     , s3Bucket = cfgS3Bucket cfg
+    , s3RequestTimeoutMicros = requestTimeoutMicros
     }
 
 putObjectStream
@@ -234,7 +239,8 @@ uploadMultipart
 uploadMultipart store key size identity pieceSize inspect body uploadId = do
   nextPartRef <- newIORef (1 :: Integer)
   etagsRef <- newIORef []
-  let abort = void (try (runMemory store $
+  let abort = void $ timeout (s3RequestTimeoutMicros store) $
+        void (trySynchronous (runMemory store $
           S3.postAbortMultipartUpload (s3Bucket store) key uploadId)
           :: IO (Either SomeException S3.AbortMultipartUploadResponse))
       upload = do
@@ -287,7 +293,7 @@ putObject store (ObjectKey key) size sha body
                     [("nuthatch-sha256", unContentSha256 identity)])
                   sha
               }
-      result <- try (runMemory store request)
+      result <- trySynchronous (runMemory store request)
         :: IO (Either SomeException S3.PutObjectResponse)
       pure (either (Left . classifyException) (const (Right ())) result)
 
@@ -353,7 +359,7 @@ getObjectSource store (ObjectKey key) pieceSize inspect =
 
 headObject :: S3 -> ObjectKey -> IO (Either S3Error (Maybe ObjectInfo))
 headObject store (ObjectKey key) = do
-  result <- try (runMemory store (S3.headObject (s3Bucket store) key))
+  result <- trySynchronous (runMemory store (S3.headObject (s3Bucket store) key))
     :: IO (Either SomeException S3.HeadObjectMemoryResponse)
   case result of
     Left err -> pure (Left (classifyException err))
@@ -364,7 +370,7 @@ headObject store (ObjectKey key) = do
 
 getObjectHeaders :: S3 -> Text -> IO (Either S3Error ObjectInfo)
 getObjectHeaders store key = do
-  result <- try (runResourceT $ do
+  result <- trySynchronous (runResourceT $ do
     response <- AwsRun.pureAws
       (s3Configuration store)
       (s3Service store)
@@ -392,7 +398,7 @@ observeObjectFully store (ObjectKey key) = observeObjectStream store key
 
 deleteObject :: S3 -> ObjectKey -> IO (Either S3Error ())
 deleteObject store (ObjectKey key) = do
-  result <- try (runMemory store (S3.DeleteObject key (s3Bucket store)))
+  result <- trySynchronous (runMemory store (S3.DeleteObject key (s3Bucket store)))
     :: IO (Either SomeException S3.DeleteObjectResponse)
   pure $ case result of
     Left err ->
@@ -416,7 +422,7 @@ listObjects store prefix delimiter continuation maxKeys = do
           , S3.gbMarker = continuation
           , S3.gbMaxKeys = Just maxKeys
           }
-  result <- try (runMemory store request)
+  result <- trySynchronous (runMemory store request)
     :: IO (Either SomeException S3.GetBucketResponse)
   pure $ case result of
     Left err -> Left (classifyException err)
@@ -465,7 +471,7 @@ getObjectMemory
   -> Text
   -> IO (Either S3Error (S3.ObjectMetadata, BL.ByteString))
 getObjectMemory store key = do
-  result <- try (runMemory store (S3.getObject (s3Bucket store) key))
+  result <- trySynchronous (runMemory store (S3.getObject (s3Bucket store) key))
     :: IO (Either SomeException S3.GetObjectMemoryResponse)
   pure $ case result of
     Left err -> Left (classifyException err)
@@ -474,7 +480,7 @@ getObjectMemory store key = do
 
 observeObjectStream :: S3 -> Text -> IO (Either S3Error ObjectInfo)
 observeObjectStream store key = do
-  result <- try (runResourceT getInfo)
+  result <- trySynchronous (runResourceT getInfo)
     :: IO (Either SomeException ObjectInfo)
   pure (either (Left . classifyException) Right result)
   where

test/Integration.hs

@@ -66,7 +66,10 @@ verifySchema database = do
     "SELECT filename FROM schema_migrations ORDER BY filename"
     :: IO [Only Text]
   assertEqual "migration history"
-    ["001_schema.sql", "002_pool_limit_guard.sql"]
+    [ "001_schema.sql"
+    , "002_pool_limit_guard.sql"
+    , "003_recovery_settlement.sql"
+    ]
     (map fromOnly migrations)
 
 schemaCatalog :: Db -> IO [Text]
@@ -222,7 +225,7 @@ verifyAdmission database config = do
             "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
   settled <- withTransaction database $ \connection -> do
     applying <- markApplying connection observationRecord
-    pending <- markExternalPending connection observationRecord
+    pending <- markExternalPending connection observationRecord 600 90
     externalSettled <- markExternalSettled connection observationRecord
     pure (applying && pending && externalSettled)
   assert "observation fixture reached applying/settled" settled
@@ -255,7 +258,7 @@ verifyIdempotencyExpiry database = do
   let rec = preparedRecord [first]
   finalized <- withTransaction database $ \connection -> do
     applying <- markApplying connection rec
-    pending <- markExternalPending connection rec
+    pending <- markExternalPending connection rec 600 90
     settled <- markExternalSettled connection rec
     succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
     pure (applying && pending && settled && succeeded)

test/RecoveryPhase.hs

@@ -0,0 +1,239 @@
+module Main (main) where
+
+import           Control.Concurrent (threadDelay)
+import           Control.Monad (unless)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Nuthatch.App (dispatchAndFinalize, newEnv)
+import           Nuthatch.Config
+import           Nuthatch.Db
+import qualified Nuthatch.Db as Db
+import           Nuthatch.Protocol
+import           Nuthatch.Redis
+import           Nuthatch.S3
+import           Nuthatch.Types
+import           Servant.Types.SourceT
+import           System.Environment (getEnv)
+import           System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  cfg <- loadConfig
+  phase <- getEnv "NUTHATCH_RECOVERY_PHASE"
+  withDb cfg $ \database -> do
+    migrate database "sql" cfg
+    withRedis cfg $ \redis -> do
+      store <- newS3 cfg
+      runPhase cfg database redis store phase
+
+runPhase :: Config -> Db -> Redis -> S3 -> String -> IO ()
+runPhase cfg database redis store phase =
+  case phase of
+    "before-dispatch" ->
+      preparePut database redis "before-dispatch" 13 phaseIdentity >>= checkpoint
+    "during-put" -> do
+      rec <- preparePut database redis "during-put" slowSize slowIdentity
+      beginDispatch cfg database rec
+      result <- putObjectStream
+        store
+        (mrObjectKey rec)
+        slowSize
+        (Just slowIdentity)
+        65536
+        (const (pure ()))
+        (slowZeroSource slowSize)
+      fail ("during-put completed before process loss: " <> show result)
+    "live-timeout" -> do
+      rec <- preparePut database redis "live-timeout" slowSize slowIdentity
+      result <- dispatchAndFinalize
+        (newEnv cfg database redis store)
+        recoverySession
+        Shared
+        rec
+        "settlement failed"
+        "request timed out"
+        (putObjectStream
+          store
+          (mrObjectKey rec)
+          slowSize
+          (Just slowIdentity)
+          65536
+          (const (pure ()))
+          (slowZeroSource slowSize)
+          >>= pure . either (Left . T.pack . show) Right)
+      case result of
+        Left "request timed out" -> checkpoint rec
+        other -> fail ("live timeout returned unexpected result: " <> show other)
+    "after-dispatch" -> do
+      rec <- preparePut database redis "after-dispatch" 13 phaseIdentity
+      beginDispatch cfg database rec
+      expectRight =<< putObject
+        store
+        (mrObjectKey rec)
+        13
+        (Just phaseIdentity)
+        "recovered-put"
+      checkpoint rec
+    "after-settlement" -> do
+      rec <- preparePut database redis "after-settlement" 13 phaseIdentity
+      beginDispatch cfg database rec
+      expectRight =<< putObject
+        store
+        (mrObjectKey rec)
+        13
+        (Just phaseIdentity)
+        "recovered-put"
+      settled <- withTransaction database $ \connection ->
+        markExternalSettled connection rec
+      unless settled (fail "could not record settlement")
+      checkpoint rec
+    "delete-settled" -> do
+      rec <- prepareDelete cfg database redis store
+      beginDispatch cfg database rec
+      expectRight =<< deleteObject store (mrObjectKey rec)
+      settled <- withTransaction database $ \connection ->
+        markExternalSettled connection rec
+      unless settled (fail "could not record delete settlement")
+      checkpoint rec
+    _ -> fail ("unknown recovery phase: " <> phase)
+
+preparePut
+  :: Db
+  -> Redis
+  -> Text
+  -> Integer
+  -> ContentSha256
+  -> IO MutationRecord
+preparePut database redis name size identity = do
+  cacheRecoveryListing redis
+  outcome <- withTransaction database $ \connection ->
+    admitMutation
+      connection
+      recoveryUser
+      Put
+      (phaseOperation name)
+      sharedPool
+      (phaseKey name)
+      (RelativePath (name <> ".bin"))
+      size
+      (Just identity)
+      (1024 * 1024 * 1024)
+      3600
+  prepared outcome
+
+prepareDelete :: Config -> Db -> Redis -> S3 -> IO MutationRecord
+prepareDelete cfg database redis store = do
+  let name = "delete-settled"
+      key = phaseKey name
+      body = "delete-me"
+      size = toInteger (BL.length body)
+  cacheRecoveryListing redis
+  expectRight =<< putObject store key size (Just deleteIdentity) body
+  _ <- Db.execute database
+    "UPDATE pools SET used_bytes = ? WHERE pool_id = ?"
+    (size, unPoolId sharedPool)
+  _ <- Db.execute database
+    "INSERT INTO objects_meta \
+    \(object_key, pool_id, size_bytes, content_sha256) VALUES (?,?,?,?)"
+    ( unObjectKey key
+    , unPoolId sharedPool
+    , size
+    , unContentSha256 deleteIdentity
+    )
+  outcome <- withTransaction database $ \connection ->
+    admitMutation
+      connection
+      recoveryUser
+      Delete
+      (phaseOperation name)
+      sharedPool
+      key
+      (RelativePath (name <> ".bin"))
+      0
+      Nothing
+      (cfgMaxObjectBytes cfg)
+      (cfgIdempotencyWindowSec cfg)
+  prepared outcome
+
+beginDispatch :: Config -> Db -> MutationRecord -> IO ()
+beginDispatch cfg database rec = do
+  started <- withTransaction database $ \connection -> do
+    applying <- markApplying connection rec
+    pending <- markExternalPending
+      connection
+      rec
+      (cfgObjectRequestTimeoutSec cfg * 2)
+      (cfgRecoveryGraceSec cfg)
+    pure (applying && pending)
+  unless started (fail "could not begin dispatch")
+
+cacheRecoveryListing :: Redis -> IO ()
+cacheRecoveryListing redis =
+  cacheSet redis "nuthatch:list:recovery-user:shared::" 600 "stale"
+
+prepared :: AdmitOutcome -> IO MutationRecord
+prepared outcome =
+  case outcome of
+    AdmitPrepared rec -> pure rec
+    other -> fail ("phase admission failed: " <> show other)
+
+checkpoint :: MutationRecord -> IO a
+checkpoint rec = do
+  putStrLn
+    ("recovery checkpoint "
+      <> T.unpack (unOperationId (mrOperationId rec)))
+  spin
+
+spin :: IO a
+spin = threadDelay 1000000 >> spin
+
+slowZeroSource :: Integer -> SourceT IO BS.ByteString
+slowZeroSource total =
+  SourceT $ \consume -> consume (go total)
+  where
+    go remaining
+      | remaining <= 0 = Stop
+      | otherwise = Effect $ do
+          threadDelay 200000
+          let size = fromInteger (min remaining 65536)
+          pure (Yield (BS.replicate size 0) (go (remaining - toInteger size)))
+
+expectRight :: Either S3Error a -> IO a
+expectRight result =
+  case result of
+    Right value -> pure value
+    Left err -> fail ("object operation failed: " <> show err)
+
+phaseOperation :: Text -> OperationId
+phaseOperation name = OperationId ("recovery-" <> name)
+
+phaseKey :: Text -> ObjectKey
+phaseKey name = ObjectKey ("shared/recovery-" <> name <> ".bin")
+
+recoveryUser :: UserId
+recoveryUser = UserId "recovery-user"
+
+recoverySession :: SessionUser
+recoverySession =
+  SessionUser "wp09" "recovery" recoveryUser (Just "Recovery")
+
+slowSize :: Integer
+slowSize = 20 * 1024 * 1024
+
+phaseIdentity :: ContentSha256
+phaseIdentity =
+  ContentSha256
+    "1cfe64e6951d3efd9cfe80b53c65cb55d0e87e2a3c72474e6afd8a89fb0e2f69"
+
+deleteIdentity :: ContentSha256
+deleteIdentity =
+  ContentSha256
+    "af77c0879d9cc69681600bb17fa8fedccfe7ae605b65974fee792581ed63a84c"
+
+slowIdentity :: ContentSha256
+slowIdentity =
+  ContentSha256
+    "cd52d81e25f372e6fa4db2c0dfceb59862c1969cab17096da352b34950c973cc"

test/Spec.hs

@@ -1,7 +1,20 @@
 module Main (main) where
 
-import           Control.Exception (try)
+import           Control.Concurrent (threadDelay)
+import           Control.Concurrent.MVar
+  ( newEmptyMVar
+  , putMVar
+  , takeMVar
+  )
+import           Control.Exception
+  ( AsyncException (ThreadKilled)
+  , SomeException
+  , finally
+  , throwIO
+  , try
+  )
 import           Control.Monad.IO.Class (liftIO)
+import           Control.Retry (simulatePolicy)
 import           Control.Lens ((&), (?~))
 import           Crypto.JOSE (runJOSE)
 import           Crypto.JOSE.Compact (encodeCompact)
@@ -92,6 +105,12 @@ import           Nuthatch.Protocol
   , terminalExpiryEligible
   , terminalExpired
   )
+import           Nuthatch.Recovery
+  ( recoveryClaimEligible
+  , recoveryRetryPolicy
+  , trySynchronous
+  , withLinkedWorker
+  )
 import           Nuthatch.Types
 import           Nuthatch.Session (mintSession)
 import           Nuthatch.Streaming
@@ -109,6 +128,7 @@ import           Servant.Types.SourceT
   , fromStepT
   , source
   )
+import qualified System.Timeout as Timeout
 import           Test.Tasty (TestTree, defaultMain, testGroup)
 import           Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)
 import           Test.Tasty.Hedgehog (testProperty)
@@ -121,6 +141,7 @@ tests = testGroup "nuthatch-unit"
   [ pathTests
   , identityTests
   , protocolTests
+  , recoveryTests
   , streamingTests
   , oidcTests
   , apiTests
@@ -238,6 +259,42 @@ protocolTests = testGroup "mutation protocol decisions"
   , testProperty "only stale active records are recovery eligible" propRecoveryTiming
   ]
 
+recoveryTests :: TestTree
+recoveryTests = testGroup "recovery"
+  [ testProperty "worker lease and settlement independently gate recovery"
+      propRecoveryClaim
+  , testCase "asynchronous cancellation is not converted to failure" $ do
+      result <- try (trySynchronous (throwIO ThreadKilled))
+        :: IO (Either AsyncException (Either SomeException ()))
+      case result of
+        Left ThreadKilled -> pure ()
+        other -> assertFailure ("asynchronous exception was swallowed: " <> show other)
+  , testCase "linked worker failure interrupts the foreground" $ do
+      result <- Timeout.timeout 1000000 $
+        try (withLinkedWorker
+          (threadDelay 10000 >> fail "worker failed")
+          (threadDelay 5000000))
+          :: IO (Maybe (Either SomeException ()))
+      case result of
+        Just (Left _) -> pure ()
+        other -> assertFailure ("linked worker did not fail promptly: " <> show other)
+  , testCase "structured worker scope cancels and joins the worker" $ do
+      started <- newEmptyMVar
+      stopped <- newEmptyMVar
+      withLinkedWorker
+        (putMVar started () >>
+          (threadDelay 5000000 `finally` putMVar stopped ()))
+        (takeMVar started)
+      takeMVar stopped
+  , testCase "recovery retry policy has bounded exponential decisions" $ do
+      schedule <- simulatePolicy 8 recoveryRetryPolicy
+      let decisions = map snd schedule
+          retries = length [() | Just _ <- decisions]
+      assertBool "retry policy must retry" (retries > 0)
+      assertBool "retry policy must be bounded" (retries <= 5)
+      assertBool "retry policy must exhaust" (Nothing `elem` decisions)
+  ]
+
 oidcTests :: TestTree
 oidcTests = testGroup "OIDC validation"
   [ testCase "accepts an exact RS256 ID token" testValidIdToken
@@ -874,6 +931,7 @@ testConfig = Config
   , cfgSearchMaxKeys = 100
   , cfgRecoveryGraceSec = 30
   , cfgIdempotencyWindowSec = 3600
+  , cfgObjectRequestTimeoutSec = 300
   }
 
 newtype ValidPath = ValidPath { getValidPath :: Text }
@@ -1029,6 +1087,28 @@ propRecoveryTiming = property $ do
   recoveryEligible state elapsed grace
     === (state `elem` [Prepared, Applying] && elapsed > grace)
 
+propRecoveryClaim :: Property
+propRecoveryClaim = property $ do
+  state <- forAll genMutationState
+  external <- forAll genExternalState
+  elapsed <- forAll (Gen.integral (Range.linear 0 10000))
+  grace <- forAll (Gen.integral (Range.linear 0 10000))
+  leaseExpired <- forAll Gen.bool
+  deadlineExpired <- forAll Gen.bool
+  recoveryClaimEligible
+    state
+    external
+    elapsed
+    grace
+    leaseExpired
+    deadlineExpired
+    === ( state `elem` [Prepared, Applying]
+          && case external of
+               ExtIdle -> elapsed > grace
+               ExtSettled -> elapsed > grace
+               ExtPending -> leaseExpired && deadlineExpired
+        )
+
 genObservation :: Gen ObjectObservation
 genObservation = Gen.choice
   [ pure ObjectAbsent

tests/kind/wp09-phase.yaml.in

@@ -0,0 +1,34 @@
+apiVersion: batch/v1
+kind: Job
+metadata:
+  name: @@JOB_NAME@@
+  namespace: nuthatch-testbed
+spec:
+  activeDeadlineSeconds: 300
+  backoffLimit: 0
+  template:
+    spec:
+      automountServiceAccountToken: false
+      enableServiceLinks: false
+      restartPolicy: Never
+      containers:
+        - name: phase
+          image: @@TEST_IMAGE@@
+          imagePullPolicy: Never
+          command: [nuthatch-wp09-phase]
+          envFrom:
+            - configMapRef: {name: @@PROFILE_NAME@@}
+          env:
+            - {name: NUTHATCH_RECOVERY_PHASE, value: "@@PHASE@@"}
+            - {name: NUTHATCH_RECOVERY_GRACE_SEC, value: "1"}
+            - {name: NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC, value: "2"}
+            - {name: NUTHATCH_JWT_SECRET, value: synthetic-wp09-session-jwt-secret}
+            - {name: NUTHATCH_PUBLIC_BASE_URL, value: "https://wp09.invalid"}
+            - {name: NUTHATCH_OIDC_ISSUER, value: "https://issuer.invalid"}
+            - {name: NUTHATCH_OIDC_CLIENT_ID, value: wp09}
+            - {name: NUTHATCH_OIDC_ADDITIONAL_AUDIENCES, value: ""}
+            - {name: NUTHATCH_OIDC_CLIENT_SECRET, value: synthetic-wp09-oidc-client-secret}
+            - {name: NUTHATCH_OIDC_REDIRECT_URI, value: "https://wp09.invalid/oidc/callback"}
+          resources:
+            requests: {cpu: 100m, memory: 64Mi}
+            limits: {cpu: "2", memory: 256Mi}

tests/kind/wp09-run.sh

@@ -0,0 +1,402 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+ROOT="$(cd "$(dirname "$0")/../.." && pwd)"
+source "$ROOT/tests/kind/lib.sh"
+
+USER_KUBECONFIG_BEFORE="$(user_kubeconfig_digest)"
+SUCCEEDED=false
+OWNS_FIXTURE=false
+APP_IMAGE=nuthatch-wp09:local
+
+cleanup() {
+  local status=$?
+  trap - EXIT INT TERM
+  if [[ "${NUTHATCH_TESTBED_RETAIN:-0}" = 1 ]] && [[ "$SUCCEEDED" != true ]]; then
+    printf 'retained kubeconfig: %s\n' "$KUBECONFIG_PATH"
+    printf 'retained context: %s\n' "$CONTEXT"
+    exit "$status"
+  fi
+  if [[ "$OWNS_FIXTURE" = true ]]; then
+    destroy_fixture || status=1
+  fi
+  if [[ "$(user_kubeconfig_digest)" != "$USER_KUBECONFIG_BEFORE" ]]; then
+    printf 'user kubeconfig changed unexpectedly\n' >&2
+    status=1
+  fi
+  exit "$status"
+}
+
+trap cleanup EXIT
+trap 'exit 130' INT
+trap 'exit 143' TERM
+
+pg_value() {
+  local database="$1"
+  local query="$2"
+  kube --namespace "$FIXTURE_NAMESPACE" exec deployment/postgres -- \
+    env PGPASSWORD=synthetic-postgres psql \
+      --username nuthatch \
+      --dbname "$database" \
+      --tuples-only \
+      --no-align \
+      --set ON_ERROR_STOP=1 \
+      --command "$query" |
+    tr -d '[:space:]'
+}
+
+wait_for_value() {
+  local database="$1"
+  local query="$2"
+  local expected="$3"
+  local description="$4"
+  for _ in $(seq 1 120); do
+    if [[ "$(pg_value "$database" "$query" 2>/dev/null || true)" = "$expected" ]]; then
+      return
+    fi
+    sleep 0.25
+  done
+  printf 'timed out waiting for %s\n' "$description" >&2
+  return 1
+}
+
+render_application() {
+  local lane="$1"
+  local profile_file="$2"
+  local pg_conn
+  local redis_url
+  local s3_endpoint
+  local s3_region
+  local s3_bucket
+  local s3_access_key
+  local s3_secret_key
+  pg_conn="$(sed -n 's/^NUTHATCH_PG_CONN=//p' "$profile_file")"
+  redis_url="$(sed -n 's/^NUTHATCH_REDIS_URL=//p' "$profile_file")"
+  s3_endpoint="$(sed -n 's/^NUTHATCH_S3_ENDPOINT=//p' "$profile_file")"
+  s3_region="$(sed -n 's/^NUTHATCH_S3_REGION=//p' "$profile_file")"
+  s3_bucket="$(sed -n 's/^NUTHATCH_S3_BUCKET=//p' "$profile_file")"
+  s3_access_key="$(sed -n 's/^NUTHATCH_S3_ACCESS_KEY=//p' "$profile_file")"
+  s3_secret_key="$(sed -n 's/^NUTHATCH_S3_SECRET_KEY=//p' "$profile_file")"
+  sed \
+    -e "s|@@LANE@@|$lane|g" \
+    -e "s|@@APP_IMAGE@@|$APP_IMAGE|g" \
+    -e "s|@@PG_CONN@@|$pg_conn|g" \
+    -e "s|@@REDIS_URL@@|$redis_url|g" \
+    -e "s|@@OIDC_ISSUER@@|https://issuer.invalid|g" \
+    -e "s|@@OIDC_CLIENT_ID@@|wp09|g" \
+    -e "s|@@OIDC_ADDITIONAL_AUDIENCES@@||g" \
+    -e "s|@@OIDC_CLIENT_SECRET@@|synthetic-wp09-oidc-client-secret|g" \
+    -e "s|@@S3_ENDPOINT@@|$s3_endpoint|g" \
+    -e "s|@@S3_REGION@@|$s3_region|g" \
+    -e "s|@@S3_BUCKET@@|$s3_bucket|g" \
+    -e "s|@@S3_ACCESS_KEY@@|$s3_access_key|g" \
+    -e "s|@@S3_SECRET_KEY@@|$s3_secret_key|g" \
+    "$ROOT/deploy/kubernetes/nuthatch.yaml.in" >"$RUNTIME/wp09-app-$lane.yaml"
+  sed -i \
+    's/NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC: "300"/NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC: "2"/' \
+    "$RUNTIME/wp09-app-$lane.yaml"
+  sed -i \
+    '/NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC/a\  NUTHATCH_RECOVERY_GRACE_SEC: "1"' \
+    "$RUNTIME/wp09-app-$lane.yaml"
+  sed -i 's/nameservers: \[10.96.0.53\]/nameservers: [10.96.0.10]/' \
+    "$RUNTIME/wp09-app-$lane.yaml"
+  sed -i 's/  replicas: 1/  replicas: 2/' "$RUNTIME/wp09-app-$lane.yaml"
+}
+
+deploy_recovery() {
+  local lane="$1"
+  local profile="$2"
+  render_application "$lane" "$RUNTIME/$profile.env"
+  kube apply --filename "$RUNTIME/wp09-app-$lane.yaml" >/dev/null
+  kube --namespace "$FIXTURE_NAMESPACE" rollout status \
+    "deployment/nuthatch-$lane" --timeout=180s
+}
+
+cleanup_recovery() {
+  local lane="$1"
+  kube --namespace "$FIXTURE_NAMESPACE" delete \
+    "deployment/nuthatch-$lane" \
+    "service/nuthatch-$lane" \
+    "configmap/nuthatch-$lane" \
+    "secret/nuthatch-$lane" \
+    --ignore-not-found >/dev/null
+  kube --namespace "$FIXTURE_NAMESPACE" wait \
+    --for=delete pod \
+    --selector="app=nuthatch-$lane" \
+    --timeout=60s >/dev/null
+  rm -f "$RUNTIME/wp09-app-$lane.yaml"
+}
+
+start_phase() {
+  local lane="$1"
+  local profile="$2"
+  local phase="$3"
+  local job="wp09-$phase-$lane"
+  render_lane_job \
+    "$job" \
+    "$TESTBED/wp09-phase.yaml.in" \
+    "$APP_IMAGE" \
+    "$profile"
+  sed -i "s|@@PHASE@@|$phase|g" "$RUNTIME/$job.yaml"
+  kube apply --filename "$RUNTIME/$job.yaml" >/dev/null
+}
+
+kill_phase() {
+  local lane="$1"
+  local phase="$2"
+  local job="wp09-$phase-$lane"
+  kube --namespace "$FIXTURE_NAMESPACE" delete pod \
+    --selector="job-name=$job" \
+    --grace-period=0 \
+    --force >/dev/null
+  kube --namespace "$FIXTURE_NAMESPACE" delete "job/$job" \
+    --ignore-not-found >/dev/null
+}
+
+wait_for_phase_checkpoint() {
+  local lane="$1"
+  local phase="$2"
+  local operation="recovery-$phase"
+  local job="wp09-$phase-$lane"
+  for _ in $(seq 1 120); do
+    if kube --namespace "$FIXTURE_NAMESPACE" logs "job/$job" 2>/dev/null |
+        grep -F "recovery checkpoint $operation" >/dev/null; then
+      return
+    fi
+    sleep 0.25
+  done
+  printf 'timed out waiting for %s checkpoint\n' "$phase" >&2
+  return 1
+}
+
+assert_terminal_authority() {
+  local database="$1"
+  local operation="$2"
+  local result="$3"
+  wait_for_value \
+    "$database" \
+    "SELECT state FROM mutations WHERE operation_id = '$operation'" \
+    "$result" \
+    "$operation terminal result"
+  test "$(
+    pg_value "$database" \
+      "SELECT count(*) FROM key_locks WHERE operation_id = '$operation'"
+  )" = 0
+  test "$(
+    pg_value "$database" \
+      "SELECT reserved_bytes FROM pools WHERE pool_id = 'shared'"
+  )" = 0
+}
+
+set_service_available() {
+  local service="$1"
+  local available="$2"
+  local selector="$service"
+  if [[ "$available" = false ]]; then
+    selector=wp09-unavailable
+  fi
+  kube --namespace "$FIXTURE_NAMESPACE" patch service "$service" \
+    --type merge \
+    --patch "{\"spec\":{\"selector\":{\"app\":\"$selector\"}}}" >/dev/null
+}
+
+terminate_database_connections() {
+  local database="$1"
+  kube --namespace "$FIXTURE_NAMESPACE" exec deployment/postgres -- \
+    env PGPASSWORD=synthetic-postgres psql \
+      --username nuthatch \
+      --dbname postgres \
+      --set ON_ERROR_STOP=1 \
+      --command \
+        "SELECT pg_terminate_backend(pid) FROM pg_stat_activity WHERE datname = '$database' AND pid <> pg_backend_pid()" \
+      >/dev/null
+}
+
+assert_object_absent() {
+  local target="$1"
+  local bucket="$2"
+  local key="$3"
+  local endpoint
+  endpoint="$(target_loopback_endpoint "$target")"
+  if kube --namespace "$FIXTURE_NAMESPACE" exec "deployment/$target" \
+    --container s3-readiness -- \
+    aws --endpoint-url "$endpoint" s3api head-object \
+      --bucket "$bucket" \
+      --key "$key" >/dev/null 2>&1; then
+    return 1
+  fi
+}
+
+assert_object_present() {
+  local target="$1"
+  local bucket="$2"
+  local key="$3"
+  local endpoint
+  endpoint="$(target_loopback_endpoint "$target")"
+  kube --namespace "$FIXTURE_NAMESPACE" exec "deployment/$target" \
+    --container s3-readiness -- \
+    aws --endpoint-url "$endpoint" s3api head-object \
+      --bucket "$bucket" \
+      --key "$key" >/dev/null
+}
+
+assert_cache_invalidated() {
+  local lane="$1"
+  local value
+  value="$(
+    kube --namespace "$FIXTURE_NAMESPACE" exec deployment/redis -- \
+      redis-cli --raw -n "$((10#$lane))" \
+      GET nuthatch:list:recovery-user:shared:: |
+      tr -d '[:space:]'
+  )"
+  test -z "$value"
+}
+
+run_phase_recovery() {
+  local lane="$1"
+  local profile="$2"
+  local database="$3"
+  local target="$4"
+  local phase="$5"
+  local durable_state="$6"
+  local terminal_state="$7"
+  local operation="recovery-$phase"
+  start_phase "$lane" "$profile" "$phase"
+  wait_for_value \
+    "$database" \
+    "SELECT state || ':' || external_state FROM mutations WHERE operation_id = '$operation'" \
+    "$durable_state" \
+    "$phase durable checkpoint"
+  if [[ "$phase" = during-put ]]; then
+    sleep 1
+  fi
+  kill_phase "$lane" "$phase"
+  deploy_recovery "$lane" "$profile"
+  assert_terminal_authority "$database" "$operation" "$terminal_state"
+  cleanup_recovery "$lane"
+  if [[ "$terminal_state" = succeeded ]]; then
+    assert_cache_invalidated "$lane"
+  fi
+}
+
+acquire_fixture_lock
+OWNS_FIXTURE=true
+setup_fixture durable coordination target
+source "$RUNTIME/fixture.env"
+"$NUTHATCH_REAL_NERDCTL" --namespace "$NERDCTL_NAMESPACE" build \
+  --file "$ROOT/Dockerfile" \
+  --target test-runtime \
+  --tag "$APP_IMAGE" \
+  "$ROOT"
+load_local_image "$APP_IMAGE" "$NERDCTL_NAMESPACE"
+
+while IFS=$'\t' read -r lane coordination oidc target; do
+  if [[ -n "${NUTHATCH_WP09_TARGET:-}" ]] &&
+      [[ "$target" != "$NUTHATCH_WP09_TARGET" ]]; then
+    continue
+  fi
+  profile="$(write_lane_profile "$lane" redis - "$target")"
+  database="nuthatch_lane_$lane"
+  bucket="nuthatch-lane-$lane"
+  printf 'Running WP09 lane %s: target=%s\n' "$lane" "$target"
+
+  run_phase_recovery \
+    "$lane" "$profile" "$database" "$target" \
+    before-dispatch prepared:idle failed
+  run_phase_recovery \
+    "$lane" "$profile" "$database" "$target" \
+    during-put applying:pending failed
+  sleep 5
+  assert_object_absent "$target" "$bucket" \
+    shared/recovery-during-put.bin
+
+  start_phase "$lane" "$profile" live-timeout
+  wait_for_phase_checkpoint "$lane" live-timeout
+  test "$(
+    pg_value "$database" \
+      "SELECT count(*) FROM key_locks WHERE operation_id = 'recovery-live-timeout'"
+  )" = 1
+  test "$(
+    pg_value "$database" \
+      "SELECT reserved_bytes FROM pools WHERE pool_id = 'shared'"
+  )" = "$((20 * 1024 * 1024))"
+  kill_phase "$lane" live-timeout
+  deploy_recovery "$lane" "$profile"
+  assert_terminal_authority "$database" recovery-live-timeout failed
+  cleanup_recovery "$lane"
+  sleep 5
+  assert_object_absent "$target" "$bucket" \
+    shared/recovery-live-timeout.bin
+
+  start_phase "$lane" "$profile" after-dispatch
+  wait_for_value \
+    "$database" \
+    "SELECT state || ':' || external_state FROM mutations WHERE operation_id = 'recovery-after-dispatch'" \
+    applying:pending \
+    "after-dispatch checkpoint"
+  kill_phase "$lane" after-dispatch
+  pg_value \
+    "$database" \
+    "UPDATE mutations SET request_deadline_at = now() + interval '60 seconds', worker_lease_until = now() + interval '60 seconds' WHERE operation_id = 'recovery-after-dispatch'; SELECT 1" \
+    >/dev/null
+  deploy_recovery "$lane" "$profile"
+  set_service_available postgres false
+  terminate_database_connections "$database"
+  sleep 6
+  test "$(
+    kube --namespace "$FIXTURE_NAMESPACE" get pods \
+      --selector="app=nuthatch-$lane" \
+      --output json |
+      jq '[.items[].status.containerStatuses[].restartCount] | add'
+  )" -gt 0
+  set_service_available postgres true
+  wait_for_value "$database" "SELECT 1" 1 "PostgreSQL recovery"
+  pg_value \
+    "$database" \
+    "UPDATE mutations SET request_deadline_at = now() - interval '1 second', worker_lease_until = now() - interval '1 second' WHERE operation_id = 'recovery-after-dispatch'; SELECT 1" \
+    >/dev/null
+  assert_terminal_authority "$database" recovery-after-dispatch succeeded
+  cleanup_recovery "$lane"
+  assert_cache_invalidated "$lane"
+  assert_object_present "$target" "$bucket" \
+    shared/recovery-after-dispatch.bin
+
+  start_phase "$lane" "$profile" after-settlement
+  wait_for_value \
+    "$database" \
+    "SELECT state || ':' || external_state FROM mutations WHERE operation_id = 'recovery-after-settlement'" \
+    applying:settled \
+    "after-settlement checkpoint"
+  kill_phase "$lane" after-settlement
+  set_service_available "$target" false
+  deploy_recovery "$lane" "$profile"
+  sleep 3
+  kube --namespace "$FIXTURE_NAMESPACE" logs \
+    --selector="app=nuthatch-$lane" \
+    --prefix=true |
+    grep -F '"result":"exhausted"'
+  set_service_available "$target" true
+  assert_terminal_authority "$database" recovery-after-settlement succeeded
+  cleanup_recovery "$lane"
+  assert_cache_invalidated "$lane"
+
+  run_phase_recovery \
+    "$lane" "$profile" "$database" "$target" \
+    delete-settled applying:settled succeeded
+  assert_object_absent "$target" "$bucket" \
+    shared/recovery-delete-settled.bin
+
+  cleanup_lane_state "$lane" redis - "$target"
+  for phase in \
+    before-dispatch \
+    during-put \
+    live-timeout \
+    after-dispatch \
+    after-settlement \
+    delete-settled; do
+    cleanup_lane_resources "wp09-$phase-$lane" "$profile"
+  done
+done < <(expand_fixture_matrix target)
+
+SUCCEEDED=true
+printf 'Nuthatch WP-09 recovery gate passed\n'