Type protocol persistence around model phases
This commit is contained in:
parent
37a7a55bfe
commit
a31b883516
1 changed files with 607 additions and 258 deletions
|
|
@ -1,8 +1,32 @@
|
|||
-- | Short Postgres transactions for mutation authority; store I/O stays outside them.
|
||||
module Nuthatch.Protocol
|
||||
( AdmitOutcome (..)
|
||||
, AdmissionIdentity (..)
|
||||
, MutationFingerprint (..)
|
||||
, AdmissionRequest (..)
|
||||
, AdmissionLimits (..)
|
||||
, DispatchTiming (..)
|
||||
, PriorObject (..)
|
||||
, DesiredObject (..)
|
||||
, ExistingDisposition (..)
|
||||
, MutationRecord (..)
|
||||
, MutationPhase (..)
|
||||
, TerminalResult (..)
|
||||
, mutationState
|
||||
, externalState
|
||||
, encodeMutationPhase
|
||||
, decodeMutationPhase
|
||||
, mrState
|
||||
, mrExternal
|
||||
, mrUserId
|
||||
, mrKind
|
||||
, mrOperationId
|
||||
, mrObjectKey
|
||||
, mrDeclaredSize
|
||||
, mrContentSha256
|
||||
, mrPriorSize
|
||||
, mrPriorSha256
|
||||
, desiredObject
|
||||
, ObjectObservation (..)
|
||||
, admitMutation
|
||||
, markApplying
|
||||
|
|
@ -27,27 +51,74 @@ module Nuthatch.Protocol
|
|||
, finalizeFromObservation
|
||||
) where
|
||||
|
||||
import Data.Maybe (listToMaybe, mapMaybe)
|
||||
import Control.Exception (throwIO)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Database.PostgreSQL.Simple (Connection, Only (..), execute, query)
|
||||
import qualified Database.PostgreSQL.Simple.FromField as PG
|
||||
import qualified Database.PostgreSQL.Simple.FromRow as PGRow
|
||||
import qualified Database.PostgreSQL.Simple.ToField as PGToField
|
||||
import qualified Database.PostgreSQL.Simple.ToRow as PGToRow
|
||||
import Nuthatch.Types
|
||||
|
||||
data MutationRecord = MutationRecord
|
||||
{ mrUserId :: UserId
|
||||
, mrKind :: MutationKind
|
||||
, mrOperationId :: OperationId
|
||||
, mrPoolId :: PoolId
|
||||
, mrObjectKey :: ObjectKey
|
||||
, mrRelativePath :: RelativePath
|
||||
, mrDeclaredSize :: Integer
|
||||
, mrContentSha256 :: Maybe ContentSha256
|
||||
, mrPriorSize :: Integer
|
||||
, mrPriorSha256 :: Maybe ContentSha256
|
||||
, mrGrowth :: Integer
|
||||
, mrState :: MutationState
|
||||
, mrExternal :: ExternalState
|
||||
{ mrAdmissionIdentity :: AdmissionIdentity
|
||||
, mrPoolId :: PoolId
|
||||
, mrRelativePath :: RelativePath
|
||||
, mrFingerprint :: MutationFingerprint
|
||||
, mrPriorObject :: PriorObject
|
||||
, mrGrowth :: Integer
|
||||
, mrPhase :: MutationPhase
|
||||
}
|
||||
deriving stock (Show)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data MutationPhase
|
||||
= PhasePrepared
|
||||
| PhaseApplying ExternalState
|
||||
| PhaseTerminal TerminalResult
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data TerminalResult
|
||||
= TerminalSucceeded
|
||||
| TerminalFailed
|
||||
| TerminalRejected
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
mutationState :: MutationPhase -> MutationState
|
||||
mutationState = \case
|
||||
PhasePrepared -> Prepared
|
||||
PhaseApplying _ -> Applying
|
||||
PhaseTerminal TerminalSucceeded -> Succeeded
|
||||
PhaseTerminal TerminalFailed -> Failed
|
||||
PhaseTerminal TerminalRejected -> Rejected
|
||||
|
||||
externalState :: MutationPhase -> ExternalState
|
||||
externalState = \case
|
||||
PhaseApplying external -> external
|
||||
_ -> ExtIdle
|
||||
|
||||
encodeMutationPhase :: MutationPhase -> (MutationState, ExternalState)
|
||||
encodeMutationPhase phase = (mutationState phase, externalState phase)
|
||||
|
||||
decodeMutationPhase :: MutationState -> ExternalState -> Maybe MutationPhase
|
||||
decodeMutationPhase state external =
|
||||
case (state, external) of
|
||||
(Prepared, ExtIdle) -> Just PhasePrepared
|
||||
(Applying, value) -> Just (PhaseApplying value)
|
||||
(Succeeded, ExtIdle) ->
|
||||
Just (PhaseTerminal TerminalSucceeded)
|
||||
(Failed, ExtIdle) ->
|
||||
Just (PhaseTerminal TerminalFailed)
|
||||
(Rejected, ExtIdle) ->
|
||||
Just (PhaseTerminal TerminalRejected)
|
||||
_ -> Nothing
|
||||
|
||||
mrState :: MutationRecord -> MutationState
|
||||
mrState = mutationState . mrPhase
|
||||
|
||||
mrExternal :: MutationRecord -> ExternalState
|
||||
mrExternal = externalState . mrPhase
|
||||
|
||||
-- | Unavailable must not drive terminal finalize.
|
||||
data ObjectObservation
|
||||
|
|
@ -63,38 +134,214 @@ data AdmitOutcome
|
|||
| AdmitConflict
|
||||
deriving stock (Show)
|
||||
|
||||
data AdmissionIdentity = AdmissionIdentity
|
||||
{ admissionUserId :: UserId
|
||||
, admissionKind :: MutationKind
|
||||
, admissionOperationId :: OperationId
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data MutationFingerprint = MutationFingerprint
|
||||
{ fingerprintKind :: MutationKind
|
||||
, fingerprintObjectKey :: ObjectKey
|
||||
, fingerprintDeclaredSize :: Integer
|
||||
, fingerprintContentSha256 :: Maybe ContentSha256
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data AdmissionRequest = AdmissionRequest
|
||||
{ admissionIdentity :: AdmissionIdentity
|
||||
, admissionPoolId :: PoolId
|
||||
, admissionRelativePath :: RelativePath
|
||||
, admissionFingerprint :: MutationFingerprint
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data AdmissionLimits = AdmissionLimits
|
||||
{ admissionMaxObjectBytes :: Integer
|
||||
, admissionIdempotencyWindowSec :: Integer
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data DispatchTiming = DispatchTiming
|
||||
{ dispatchSettlementBoundSec :: Integer
|
||||
, dispatchWorkerGraceSec :: Integer
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data PriorObject = PriorObject
|
||||
{ priorObjectSize :: Integer
|
||||
, priorObjectSha256 :: Maybe ContentSha256
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data DesiredObject
|
||||
= DesiredPresent Integer (Maybe ContentSha256)
|
||||
| DesiredAbsent
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
mrUserId :: MutationRecord -> UserId
|
||||
mrUserId = admissionUserId . mrAdmissionIdentity
|
||||
|
||||
mrKind :: MutationRecord -> MutationKind
|
||||
mrKind = admissionKind . mrAdmissionIdentity
|
||||
|
||||
mrOperationId :: MutationRecord -> OperationId
|
||||
mrOperationId = admissionOperationId . mrAdmissionIdentity
|
||||
|
||||
mrObjectKey :: MutationRecord -> ObjectKey
|
||||
mrObjectKey = fingerprintObjectKey . mrFingerprint
|
||||
|
||||
mrDeclaredSize :: MutationRecord -> Integer
|
||||
mrDeclaredSize = fingerprintDeclaredSize . mrFingerprint
|
||||
|
||||
mrContentSha256 :: MutationRecord -> Maybe ContentSha256
|
||||
mrContentSha256 = fingerprintContentSha256 . mrFingerprint
|
||||
|
||||
mrPriorSize :: MutationRecord -> Integer
|
||||
mrPriorSize = priorObjectSize . mrPriorObject
|
||||
|
||||
mrPriorSha256 :: MutationRecord -> Maybe ContentSha256
|
||||
mrPriorSha256 = priorObjectSha256 . mrPriorObject
|
||||
|
||||
desiredObject :: MutationRecord -> DesiredObject
|
||||
desiredObject record =
|
||||
case mrKind record of
|
||||
Put -> DesiredPresent
|
||||
(mrDeclaredSize record)
|
||||
(mrContentSha256 record)
|
||||
Delete -> DesiredAbsent
|
||||
|
||||
data ExistingDisposition
|
||||
= NewMutationEpoch
|
||||
| ExistingReplay MutationResult MutationRecord
|
||||
| ExistingConflict
|
||||
deriving stock (Show)
|
||||
|
||||
type ResultRow =
|
||||
( Text, Text, Text, Text, Text, Text, Integer, Maybe Text
|
||||
, Integer, Maybe Text, Integer, Text, Text
|
||||
)
|
||||
data MutationRow = MutationRow
|
||||
{ rowUserId :: Text
|
||||
, rowKind :: DbMutationKind
|
||||
, rowOperationId :: Text
|
||||
, rowPoolId :: Text
|
||||
, rowObjectKey :: Text
|
||||
, rowRelativePath :: Text
|
||||
, rowDeclaredSize :: Integer
|
||||
, rowContentSha256 :: Maybe Text
|
||||
, rowPriorSize :: Integer
|
||||
, rowPriorSha256 :: Maybe Text
|
||||
, rowGrowth :: Integer
|
||||
, rowState :: DbMutationState
|
||||
, rowExternal :: DbExternalState
|
||||
}
|
||||
|
||||
rowToRecord :: ResultRow -> Maybe MutationRecord
|
||||
rowToRecord (user, kindT, op, pool, key, rel, size, csha, prior, psha, growth, stateT, extT) = do
|
||||
kind <- parseKind kindT
|
||||
state <- parseState stateT
|
||||
ext <- parseExternal extT
|
||||
data SettlementRow =
|
||||
SettlementRow DbMutationState DbExternalState Integer Integer
|
||||
|
||||
newtype DbMutationKind = DbMutationKind MutationKind
|
||||
|
||||
newtype DbMutationState = DbMutationState MutationState
|
||||
|
||||
newtype DbExternalState = DbExternalState ExternalState
|
||||
|
||||
newtype MutationInsertRow = MutationInsertRow MutationRecord
|
||||
|
||||
instance PG.FromField DbMutationKind where
|
||||
fromField field value = do
|
||||
label <- PG.fromField field value
|
||||
maybe
|
||||
(PG.returnError PG.ConversionFailed field "invalid mutation kind")
|
||||
(pure . DbMutationKind)
|
||||
(parseKind label)
|
||||
|
||||
instance PG.FromField DbMutationState where
|
||||
fromField field value = do
|
||||
label <- PG.fromField field value
|
||||
maybe
|
||||
(PG.returnError PG.ConversionFailed field "invalid mutation state")
|
||||
(pure . DbMutationState)
|
||||
(parseState label)
|
||||
|
||||
instance PG.FromField DbExternalState where
|
||||
fromField field value = do
|
||||
label <- PG.fromField field value
|
||||
maybe
|
||||
(PG.returnError PG.ConversionFailed field "invalid external state")
|
||||
(pure . DbExternalState)
|
||||
(parseExternal label)
|
||||
|
||||
instance PGRow.FromRow MutationRow where
|
||||
fromRow =
|
||||
MutationRow
|
||||
<$> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
|
||||
instance PGRow.FromRow SettlementRow where
|
||||
fromRow =
|
||||
SettlementRow
|
||||
<$> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
<*> PGRow.field
|
||||
|
||||
instance PGToRow.ToRow MutationInsertRow where
|
||||
toRow (MutationInsertRow record) =
|
||||
let (state, external) = encodeMutationPhase (mrPhase record)
|
||||
in
|
||||
[ PGToField.toField (unUserId (mrUserId record))
|
||||
, PGToField.toField (kindLabel (mrKind record))
|
||||
, PGToField.toField (unOperationId (mrOperationId record))
|
||||
, PGToField.toField (unPoolId (mrPoolId record))
|
||||
, PGToField.toField (unObjectKey (mrObjectKey record))
|
||||
, PGToField.toField (unRelativePath (mrRelativePath record))
|
||||
, PGToField.toField (mrDeclaredSize record)
|
||||
, PGToField.toField
|
||||
(unContentSha256 <$> mrContentSha256 record)
|
||||
, PGToField.toField (mrPriorSize record)
|
||||
, PGToField.toField
|
||||
(unContentSha256 <$> mrPriorSha256 record)
|
||||
, PGToField.toField (mrGrowth record)
|
||||
, PGToField.toField (stateLabel state)
|
||||
, PGToField.toField (externalLabel external)
|
||||
]
|
||||
|
||||
rowToRecord :: MutationRow -> Either Text MutationRecord
|
||||
rowToRecord MutationRow{..} = do
|
||||
let DbMutationKind kind = rowKind
|
||||
DbMutationState state = rowState
|
||||
DbExternalState ext = rowExternal
|
||||
phase <- maybe (Left "invalid mutation phase") Right (decodeMutationPhase state ext)
|
||||
pure MutationRecord
|
||||
{ mrUserId = UserId user
|
||||
, mrKind = kind
|
||||
, mrOperationId = OperationId op
|
||||
, mrPoolId = PoolId pool
|
||||
, mrObjectKey = ObjectKey key
|
||||
, mrRelativePath = RelativePath rel
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = ContentSha256 <$> csha
|
||||
, mrPriorSize = prior
|
||||
, mrPriorSha256 = ContentSha256 <$> psha
|
||||
, mrGrowth = growth
|
||||
, mrState = state
|
||||
, mrExternal = ext
|
||||
{ mrAdmissionIdentity =
|
||||
AdmissionIdentity (UserId rowUserId) kind (OperationId rowOperationId)
|
||||
, mrPoolId = PoolId rowPoolId
|
||||
, mrRelativePath = RelativePath rowRelativePath
|
||||
, mrFingerprint =
|
||||
MutationFingerprint
|
||||
kind
|
||||
(ObjectKey rowObjectKey)
|
||||
rowDeclaredSize
|
||||
(ContentSha256 <$> rowContentSha256)
|
||||
, mrPriorObject =
|
||||
PriorObject rowPriorSize (ContentSha256 <$> rowPriorSha256)
|
||||
, mrGrowth = rowGrowth
|
||||
, mrPhase = phase
|
||||
}
|
||||
|
||||
decodeRows :: [MutationRow] -> IO [MutationRecord]
|
||||
decodeRows rows =
|
||||
either (throwIO . userError . T.unpack) pure (traverse rowToRecord rows)
|
||||
|
||||
lookupMutation :: Connection -> UserId -> MutationKind -> OperationId -> IO (Maybe MutationRecord)
|
||||
lookupMutation conn uid kind op = do
|
||||
rows <- query conn
|
||||
|
|
@ -103,7 +350,7 @@ lookupMutation conn uid kind op = do
|
|||
\state, external_state FROM mutations \
|
||||
\WHERE user_id = ? AND kind = ? AND operation_id = ?"
|
||||
(unUserId uid, kindLabel kind, unOperationId op)
|
||||
pure (listToMaybe rows >>= rowToRecord)
|
||||
listToMaybe <$> decodeRows rows
|
||||
|
||||
mutationEpochExists
|
||||
:: Connection
|
||||
|
|
@ -137,25 +384,19 @@ lookupObjectMeta conn (ObjectKey key) = do
|
|||
[(sz, sha)] -> Just (sz, ContentSha256 sha)
|
||||
_ -> Nothing
|
||||
|
||||
sameFingerprint :: MutationRecord -> MutationKind -> ObjectKey -> Integer -> Maybe ContentSha256 -> Bool
|
||||
sameFingerprint rec kind key size msha =
|
||||
mrKind rec == kind
|
||||
&& mrObjectKey rec == key
|
||||
&& mrDeclaredSize rec == size
|
||||
&& mrContentSha256 rec == msha
|
||||
sameFingerprint :: MutationRecord -> MutationFingerprint -> Bool
|
||||
sameFingerprint rec fingerprint =
|
||||
mrFingerprint rec == fingerprint
|
||||
|
||||
existingDisposition
|
||||
:: Maybe MutationRecord
|
||||
-> MutationKind
|
||||
-> ObjectKey
|
||||
-> Integer
|
||||
-> Maybe ContentSha256
|
||||
-> MutationFingerprint
|
||||
-> ExistingDisposition
|
||||
existingDisposition existing kind key size msha =
|
||||
existingDisposition existing fingerprint =
|
||||
case existing of
|
||||
Nothing -> NewMutationEpoch
|
||||
Just rec
|
||||
| sameFingerprint rec kind key size msha ->
|
||||
| sameFingerprint rec fingerprint ->
|
||||
ExistingReplay (stateToResult (mrState rec)) rec
|
||||
| otherwise -> ExistingConflict
|
||||
|
||||
|
|
@ -180,18 +421,38 @@ recoveryEligible state elapsedSeconds graceSeconds =
|
|||
|
||||
admitMutation
|
||||
:: Connection
|
||||
-> UserId
|
||||
-> MutationKind
|
||||
-> OperationId
|
||||
-> PoolId
|
||||
-> ObjectKey
|
||||
-> RelativePath
|
||||
-> Integer
|
||||
-> Maybe ContentSha256
|
||||
-> Integer
|
||||
-> Integer
|
||||
-> AdmissionRequest
|
||||
-> AdmissionLimits
|
||||
-> IO AdmitOutcome
|
||||
admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindow = do
|
||||
admitMutation conn AdmissionRequest{..} limits =
|
||||
if fingerprintKind admissionFingerprint
|
||||
/= admissionKind admissionIdentity
|
||||
then pure AdmitConflict
|
||||
else admitConsistentMutation
|
||||
conn
|
||||
admissionIdentity
|
||||
admissionPoolId
|
||||
admissionRelativePath
|
||||
admissionFingerprint
|
||||
limits
|
||||
|
||||
admitConsistentMutation
|
||||
:: Connection
|
||||
-> AdmissionIdentity
|
||||
-> PoolId
|
||||
-> RelativePath
|
||||
-> MutationFingerprint
|
||||
-> AdmissionLimits
|
||||
-> IO AdmitOutcome
|
||||
admitConsistentMutation
|
||||
conn
|
||||
(AdmissionIdentity uid kind op)
|
||||
pool
|
||||
rel
|
||||
fingerprint@(MutationFingerprint _ key size msha)
|
||||
AdmissionLimits{..} = do
|
||||
let maxObject = admissionMaxObjectBytes
|
||||
idempotencyWindow = admissionIdempotencyWindowSec
|
||||
let identity =
|
||||
unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
|
||||
_ <- query conn
|
||||
|
|
@ -205,7 +466,7 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
|
|||
\AND updated_at < now() - (? * interval '1 second')"
|
||||
(unUserId uid, kindLabel kind, unOperationId op, idempotencyWindow)
|
||||
existing <- lookupMutation conn uid kind op
|
||||
case existingDisposition existing kind key size msha of
|
||||
case existingDisposition existing fingerprint of
|
||||
ExistingReplay result rec -> pure (AdmitReplay result rec)
|
||||
ExistingConflict -> pure AdmitConflict
|
||||
NewMutationEpoch -> do
|
||||
|
|
@ -216,21 +477,15 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
|
|||
Put -> size
|
||||
Delete -> 0
|
||||
growth = growthBytes priorSize desiredSize
|
||||
baseRec state =
|
||||
baseRec phase =
|
||||
MutationRecord
|
||||
{ mrUserId = uid
|
||||
, mrKind = kind
|
||||
, mrOperationId = op
|
||||
{ mrAdmissionIdentity = AdmissionIdentity uid kind op
|
||||
, mrPoolId = pool
|
||||
, mrObjectKey = key
|
||||
, mrRelativePath = rel
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = msha
|
||||
, mrPriorSize = priorSize
|
||||
, mrPriorSha256 = priorSha
|
||||
, mrFingerprint = fingerprint
|
||||
, mrPriorObject = PriorObject priorSize priorSha
|
||||
, mrGrowth = 0
|
||||
, mrState = state
|
||||
, mrExternal = ExtIdle
|
||||
, mrPhase = phase
|
||||
}
|
||||
|
||||
poolRows <- query conn
|
||||
|
|
@ -261,24 +516,22 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
|
|||
rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
|
||||
pure (AdmitRejected "quota exceeded" rec)
|
||||
else do
|
||||
let preparedRecord = MutationRecord
|
||||
{ mrAdmissionIdentity = AdmissionIdentity uid kind op
|
||||
, mrPoolId = pool
|
||||
, mrRelativePath = rel
|
||||
, mrFingerprint = fingerprint
|
||||
, mrPriorObject = PriorObject priorSize priorSha
|
||||
, mrGrowth = growth
|
||||
, mrPhase = PhasePrepared
|
||||
}
|
||||
n <- execute conn
|
||||
"INSERT INTO mutations \
|
||||
\(user_id, kind, operation_id, pool_id, object_key, relative_path, \
|
||||
\ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
|
||||
\ state, external_state) \
|
||||
\VALUES (?,?,?,?,?,?,?,?,?,?,?,'prepared','idle')"
|
||||
( unUserId uid
|
||||
, kindLabel kind
|
||||
, unOperationId op
|
||||
, unPoolId pool
|
||||
, unObjectKey key
|
||||
, unRelativePath rel
|
||||
, size
|
||||
, unContentSha256 <$> msha
|
||||
, priorSize
|
||||
, unContentSha256 <$> priorSha
|
||||
, growth
|
||||
)
|
||||
\VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
(MutationInsertRow preparedRecord)
|
||||
if n /= 1
|
||||
then pure AdmitConflict
|
||||
else do
|
||||
|
|
@ -294,26 +547,12 @@ admitMutation conn uid kind op pool key rel size msha maxObject idempotencyWindo
|
|||
\WHERE user_id = ? AND kind = ? AND operation_id = ?"
|
||||
(unUserId uid, kindLabel kind, unOperationId op)
|
||||
pure $ AdmitRejected "key locked by another mutation"
|
||||
(baseRec Rejected)
|
||||
(baseRec (PhaseTerminal TerminalRejected))
|
||||
else do
|
||||
_ <- execute conn
|
||||
"UPDATE pools SET reserved_bytes = reserved_bytes + ? WHERE pool_id = ?"
|
||||
(growth, unPoolId pool)
|
||||
pure $ AdmitPrepared MutationRecord
|
||||
{ mrUserId = uid
|
||||
, mrKind = kind
|
||||
, mrOperationId = op
|
||||
, mrPoolId = pool
|
||||
, mrObjectKey = key
|
||||
, mrRelativePath = rel
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = msha
|
||||
, mrPriorSize = priorSize
|
||||
, mrPriorSha256 = priorSha
|
||||
, mrGrowth = growth
|
||||
, mrState = Prepared
|
||||
, mrExternal = ExtIdle
|
||||
}
|
||||
pure (AdmitPrepared preparedRecord)
|
||||
|
||||
insertTerminalRejected
|
||||
:: Connection
|
||||
|
|
@ -329,39 +568,25 @@ insertTerminalRejected
|
|||
-> Maybe ContentSha256
|
||||
-> IO MutationRecord
|
||||
insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha = do
|
||||
let record = MutationRecord
|
||||
{ mrAdmissionIdentity = AdmissionIdentity uid kind op
|
||||
, mrPoolId = pool
|
||||
, mrRelativePath = rel
|
||||
, mrFingerprint =
|
||||
MutationFingerprint kind key size msha
|
||||
, mrPriorObject = PriorObject priorSize priorSha
|
||||
, mrGrowth = 0
|
||||
, mrPhase = PhaseTerminal TerminalRejected
|
||||
}
|
||||
_ <- execute conn
|
||||
"INSERT INTO mutations \
|
||||
\(user_id, kind, operation_id, pool_id, object_key, relative_path, \
|
||||
\ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
|
||||
\ state, external_state) \
|
||||
\VALUES (?,?,?,?,?,?,?,?,?,?,0,'rejected','idle') \
|
||||
\VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) \
|
||||
\ON CONFLICT DO NOTHING"
|
||||
( unUserId uid
|
||||
, kindLabel kind
|
||||
, unOperationId op
|
||||
, unPoolId pool
|
||||
, unObjectKey key
|
||||
, unRelativePath rel
|
||||
, size
|
||||
, unContentSha256 <$> msha
|
||||
, priorSize
|
||||
, unContentSha256 <$> priorSha
|
||||
)
|
||||
pure MutationRecord
|
||||
{ mrUserId = uid
|
||||
, mrKind = kind
|
||||
, mrOperationId = op
|
||||
, mrPoolId = pool
|
||||
, mrObjectKey = key
|
||||
, mrRelativePath = rel
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = msha
|
||||
, mrPriorSize = priorSize
|
||||
, mrPriorSha256 = priorSha
|
||||
, mrGrowth = 0
|
||||
, mrState = Rejected
|
||||
, mrExternal = ExtIdle
|
||||
}
|
||||
(MutationInsertRow record)
|
||||
pure record
|
||||
|
||||
stateToResult :: MutationState -> MutationResult
|
||||
stateToResult Prepared = MutationPending
|
||||
|
|
@ -381,10 +606,9 @@ markApplying conn rec = do
|
|||
markExternalPending
|
||||
:: Connection
|
||||
-> MutationRecord
|
||||
-> Integer
|
||||
-> Integer
|
||||
-> DispatchTiming
|
||||
-> IO Bool
|
||||
markExternalPending conn rec settlementBoundSec workerGraceSec = do
|
||||
markExternalPending conn rec DispatchTiming{..} = do
|
||||
n <- execute conn
|
||||
"UPDATE mutations SET external_state = 'pending', \
|
||||
\dispatch_started_at = now(), \
|
||||
|
|
@ -393,8 +617,8 @@ markExternalPending conn rec settlementBoundSec workerGraceSec = do
|
|||
\updated_at = now() \
|
||||
\WHERE user_id = ? AND kind = ? AND operation_id = ? \
|
||||
\AND state = 'applying' AND external_state = 'idle'"
|
||||
( settlementBoundSec
|
||||
, workerGraceSec
|
||||
( dispatchSettlementBoundSec
|
||||
, dispatchWorkerGraceSec
|
||||
, unUserId (mrUserId rec)
|
||||
, kindLabel (mrKind rec)
|
||||
, unOperationId (mrOperationId rec)
|
||||
|
|
@ -427,10 +651,15 @@ finalizeSuccess conn rec finalSize finalSha = do
|
|||
"SELECT state, external_state, growth_bytes, prior_size FROM mutations \
|
||||
\WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
|
||||
(unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
|
||||
:: IO [(Text, Text, Integer, Integer)]
|
||||
:: IO [SettlementRow]
|
||||
case rows of
|
||||
[(st, ext, growth, prior)]
|
||||
| st == "applying" && ext == "settled" -> do
|
||||
[SettlementRow
|
||||
(DbMutationState state)
|
||||
(DbExternalState external)
|
||||
growth
|
||||
prior]
|
||||
| decodeMutationPhase state external
|
||||
== Just (PhaseApplying ExtSettled) -> do
|
||||
let pool = mrPoolId rec
|
||||
_ <- execute conn
|
||||
"UPDATE pools SET used_bytes = used_bytes - ? + ?, \
|
||||
|
|
@ -470,13 +699,18 @@ finalizeSuccess conn rec finalSize finalSha = do
|
|||
finalizeFailure :: Connection -> MutationRecord -> IO Bool
|
||||
finalizeFailure conn rec = do
|
||||
rows <- query conn
|
||||
"SELECT state, external_state, growth_bytes FROM mutations \
|
||||
"SELECT state, external_state, growth_bytes, prior_size FROM mutations \
|
||||
\WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
|
||||
(unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
|
||||
:: IO [(Text, Text, Integer)]
|
||||
:: IO [SettlementRow]
|
||||
case rows of
|
||||
[(st, ext, growth)]
|
||||
| st == "applying" && ext == "settled" -> do
|
||||
[SettlementRow
|
||||
(DbMutationState state)
|
||||
(DbExternalState external)
|
||||
growth
|
||||
_]
|
||||
| decodeMutationPhase state external
|
||||
== Just (PhaseApplying ExtSettled) -> do
|
||||
_ <- execute conn
|
||||
"UPDATE pools SET reserved_bytes = reserved_bytes - ? WHERE pool_id = ?"
|
||||
(growth, unPoolId (mrPoolId rec))
|
||||
|
|
@ -515,38 +749,35 @@ claimActiveBatch conn limit graceSec = do
|
|||
\FOR UPDATE SKIP LOCKED \
|
||||
\LIMIT ?"
|
||||
(graceSec, graceSec, limit)
|
||||
pure (mapMaybe rowToRecord rows)
|
||||
decodeRows rows
|
||||
|
||||
desiredMatches :: MutationRecord -> ObjectObservation -> Bool
|
||||
desiredMatches rec = \case
|
||||
ObjectUnavailable _ -> False
|
||||
ObjectAbsent ->
|
||||
case mrKind rec of
|
||||
Delete -> True
|
||||
Put -> False
|
||||
ObjectPresent sz msha ->
|
||||
case mrKind rec of
|
||||
Delete -> False
|
||||
Put ->
|
||||
sz == mrDeclaredSize rec
|
||||
&& case (mrContentSha256 rec, msha) of
|
||||
(Just want, Just got) -> want == got
|
||||
(Just _, Nothing) -> False
|
||||
(Nothing, _) -> True
|
||||
desiredMatches rec observation =
|
||||
case (desiredObject rec, observation) of
|
||||
(_, ObjectUnavailable _) -> False
|
||||
(DesiredAbsent, ObjectAbsent) -> True
|
||||
(DesiredPresent size expectedSha, ObjectPresent observedSize observedSha) ->
|
||||
size == observedSize
|
||||
&& case (expectedSha, observedSha) of
|
||||
(Just want, Just got) -> want == got
|
||||
(Just _, Nothing) -> False
|
||||
(Nothing, _) -> True
|
||||
_ -> False
|
||||
|
||||
priorMatches :: MutationRecord -> ObjectObservation -> Bool
|
||||
priorMatches rec obs =
|
||||
let priorEmpty = mrPriorSize rec == 0 && mrPriorSha256 rec == Nothing
|
||||
let PriorObject priorSize priorSha = mrPriorObject rec
|
||||
priorEmpty = priorSize == 0 && priorSha == Nothing
|
||||
in case obs of
|
||||
ObjectUnavailable _ -> False
|
||||
ObjectAbsent -> priorEmpty
|
||||
ObjectPresent sz msha ->
|
||||
sz == mrPriorSize rec
|
||||
&& ( case (mrPriorSha256 rec, msha) of
|
||||
sz == priorSize
|
||||
&& ( case (priorSha, msha) of
|
||||
(Just want, Just got) -> want == got
|
||||
(Nothing, Nothing) -> True
|
||||
(Just _, Nothing) -> False
|
||||
(Nothing, Just _) -> mrPriorSize rec == sz
|
||||
(Nothing, Just _) -> priorSize == sz
|
||||
)
|
||||
|
||||
finalizeFromObservation
|
||||
|
|
|
|||
Loading…
Reference in a new issue