Make object recovery settlement-safe
This commit is contained in:
parent
cc23211e63
commit
cd83841520
1 changed files with 1054 additions and 90 deletions
|
|
@ -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 =
|
||||
|
|
|
|||
Loading…
Reference in a new issue