Make object recovery settlement-safe

2026-07-18 22:49:19 +09:00 · 2026-07-18 22:49:19 +09:00 · cd83841520
commit cd83841520
parent cc23211e63
6 changed files with 1054 additions and 90 deletions
--- a/src/Nuthatch/App.hs
+++ b/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.Monad (forever, void, when)
+import           Control.Concurrent.Async (mapConcurrently_)
+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,33 +698,48 @@ 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
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
-      finalized <- withTransaction (envDb env) $ \conn -> do
-        settled <- markExternalSettled conn rec
-        if not settled
-          then pure Nothing
-          else 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))
-        Just other -> pure (Right other)
-        Nothing -> pure (Right MutationPending)
+      dispatchOutcome <- timeout
+        (fromInteger (requestTimeoutSec * 1000000))
+        dispatch
+      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 (Right MutationPending)
+            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 settlementFailure)
+                Just other -> pure (Right other)
+                Nothing -> pure (Right MutationPending)

 observeObject :: S3 -> ObjectKey -> IO ObjectObservation
 observeObject s3 key = do
@ -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)
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
-      _ <- withTransaction (envDb env) $ \conn ->
-        finalizeFromObservation conn rec observed
-      pure ()
+        if moved then markSettledFromIdle conn rec else pure False
+      when settled (finalizeRecovered env rec)
    (Applying, ExtIdle) -> do
-      _ <- withTransaction (envDb env) $ \conn -> markSettledFromIdle conn rec
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
-      _ <- withTransaction (envDb env) $ \conn ->
-        finalizeFromObservation conn rec observed
-      pure ()
+      settled <- withTransaction (envDb env) $ \conn ->
+        markSettledFromIdle conn rec
+      when settled (finalizeRecovered env rec)
    (Applying, ExtPending) -> do
-      observed <- observeObject (envS3 env) (mrObjectKey rec)
-      _ <- withTransaction (envDb env) $ \conn -> do
-        settled <- markExternalSettled conn rec
-        if settled
-          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 ()
+      settled <- withTransaction (envDb env) $ \conn ->
+        markExternalSettled conn rec
+      when settled (finalizeRecovered env rec)
+    (Applying, ExtSettled) -> finalizeRecovered env rec
    _ -> 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 =
--- a/src/Nuthatch/Config.hs
+++ b/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
--- a/src/Nuthatch/Protocol.hs
+++ b/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 conn rec = do
+markExternalPending
+  :: 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
--- a/src/Nuthatch/Recovery.hs
+++ b/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
--- a/src/Nuthatch/Redis.hs
+++ b/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)
--- a/src/Nuthatch/S3.hs
+++ b/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,9 +239,10 @@ uploadMultipart
 uploadMultipart store key size identity pieceSize inspect body uploadId = do
  nextPartRef <- newIORef (1 :: Integer)
  etagsRef <- newIORef []
-  let abort = void (try (runMemory store $
-        S3.postAbortMultipartUpload (s3Bucket store) key uploadId)
-        :: IO (Either SomeException S3.AbortMultipartUploadResponse))
+  let abort = void $ timeout (s3RequestTimeoutMicros store) $
+        void (trySynchronous (runMemory store $
+          S3.postAbortMultipartUpload (s3Bucket store) key uploadId)
+          :: IO (Either SomeException S3.AbortMultipartUploadResponse))
      upload = do
        consumeUploadParts
          size identity pieceSize multipartPartBytes inspect body $ \part -> 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