Type protocol persistence around model phases
This commit is contained in:
parent
37a7a55bfe
commit
a31b883516
6 changed files with 607 additions and 258 deletions
|
|
@ -57,9 +57,20 @@ runPut env user root rel op size sha dispatchPut = do
|
|||
available <-
|
||||
if existing then pure True else objectStoreAvailable (envS3 env)
|
||||
if available
|
||||
then Just <$> admitMutation conn uid Put op pool key rel size (Just sha)
|
||||
(cfgMaxObjectBytes (envConfig env))
|
||||
(cfgIdempotencyWindowSec (envConfig env))
|
||||
then Just <$> admitMutation
|
||||
conn
|
||||
AdmissionRequest
|
||||
{ admissionIdentity = AdmissionIdentity uid Put op
|
||||
, admissionPoolId = pool
|
||||
, admissionRelativePath = rel
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Put key size (Just sha)
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes (envConfig env)
|
||||
, admissionIdempotencyWindowSec =
|
||||
cfgIdempotencyWindowSec (envConfig env)
|
||||
}
|
||||
else pure Nothing
|
||||
case admitted of
|
||||
Nothing ->
|
||||
|
|
@ -103,9 +114,20 @@ runDelete env user root rel op = do
|
|||
available <-
|
||||
if existing then pure True else objectStoreAvailable (envS3 env)
|
||||
if available
|
||||
then Just <$> admitMutation conn uid Delete op pool key rel 0 Nothing
|
||||
(cfgMaxObjectBytes (envConfig env))
|
||||
(cfgIdempotencyWindowSec (envConfig env))
|
||||
then Just <$> admitMutation
|
||||
conn
|
||||
AdmissionRequest
|
||||
{ admissionIdentity = AdmissionIdentity uid Delete op
|
||||
, admissionPoolId = pool
|
||||
, admissionRelativePath = rel
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Delete key 0 Nothing
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes (envConfig env)
|
||||
, admissionIdempotencyWindowSec =
|
||||
cfgIdempotencyWindowSec (envConfig env)
|
||||
}
|
||||
else pure Nothing
|
||||
case admitted of
|
||||
Nothing -> pure (Left "object store unavailable")
|
||||
|
|
@ -143,8 +165,10 @@ dispatchAndFinalize env user root record timeoutFailure dispatch = do
|
|||
else markExternalPending
|
||||
conn
|
||||
record
|
||||
(requestTimeoutSec * 2)
|
||||
(cfgRecoveryGraceSec cfg)
|
||||
DispatchTiming
|
||||
{ dispatchSettlementBoundSec = requestTimeoutSec * 2
|
||||
, dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
|
||||
}
|
||||
if not prepared
|
||||
then pure (Right MutationPending)
|
||||
else do
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{ mrAdmissionIdentity :: AdmissionIdentity
|
||||
, mrPoolId :: PoolId
|
||||
, mrObjectKey :: ObjectKey
|
||||
, mrRelativePath :: RelativePath
|
||||
, mrDeclaredSize :: Integer
|
||||
, mrContentSha256 :: Maybe ContentSha256
|
||||
, mrPriorSize :: Integer
|
||||
, mrPriorSha256 :: Maybe ContentSha256
|
||||
, mrFingerprint :: MutationFingerprint
|
||||
, mrPriorObject :: PriorObject
|
||||
, mrGrowth :: Integer
|
||||
, mrState :: MutationState
|
||||
, mrExternal :: ExternalState
|
||||
, 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
|
||||
)
|
||||
|
||||
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
|
||||
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
|
||||
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
|
||||
}
|
||||
|
||||
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
|
||||
{ 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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ main = do
|
|||
migrate database "sql" config
|
||||
verifySchema database
|
||||
verifyAdmission database config
|
||||
verifyRowDecoder database
|
||||
store <- newS3 config
|
||||
verifyStorage config store
|
||||
putStrLn "Storage foundation integration gate passed"
|
||||
|
|
@ -160,7 +161,8 @@ verifyAdmission database config = do
|
|||
"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
|
||||
settled <- withTransaction database $ \connection -> do
|
||||
applying <- markApplying connection observationRecord
|
||||
pending <- markExternalPending connection observationRecord 600 90
|
||||
pending <- markExternalPending
|
||||
connection observationRecord (DispatchTiming 600 90)
|
||||
externalSettled <- markExternalSettled connection observationRecord
|
||||
pure (applying && pending && externalSettled)
|
||||
assert "observation fixture reached applying/settled" settled
|
||||
|
|
@ -193,7 +195,7 @@ verifyIdempotencyExpiry database = do
|
|||
let rec = preparedRecord [first]
|
||||
finalized <- withTransaction database $ \connection -> do
|
||||
applying <- markApplying connection rec
|
||||
pending <- markExternalPending connection rec 600 90
|
||||
pending <- markExternalPending connection rec (DispatchTiming 600 90)
|
||||
settled <- markExternalSettled connection rec
|
||||
succeeded <- finalizeSuccess connection rec 10 (Just fixedIdentity)
|
||||
pure (applying && pending && settled && succeeded)
|
||||
|
|
@ -230,6 +232,40 @@ verifyIdempotencyExpiry database = do
|
|||
assertEqual "aged active key remains locked" 1 (countRejected [blocked])
|
||||
assertAuthority database 1 10
|
||||
|
||||
verifyRowDecoder :: Db -> IO ()
|
||||
verifyRowDecoder database = do
|
||||
resetAuthority database 100
|
||||
outcome <- admit database "invalid-phase-operation" "invalid-phase-key" 10
|
||||
let record = preparedRecord [outcome]
|
||||
roundTripped <- withTransaction database $ \connection ->
|
||||
lookupMutation
|
||||
connection
|
||||
(mrUserId record)
|
||||
(mrKind record)
|
||||
(mrOperationId record)
|
||||
assertEqual "typed mutation row round-trip" (Just record) roundTripped
|
||||
_ <- Db.execute database
|
||||
"UPDATE mutations SET external_state = 'pending', \
|
||||
\dispatch_started_at = now(), request_deadline_at = now(), \
|
||||
\worker_lease_until = now() \
|
||||
\WHERE user_id = ? AND kind = ? AND operation_id = ?"
|
||||
( unUserId (mrUserId record)
|
||||
, kindLabel (mrKind record)
|
||||
, unOperationId (mrOperationId record)
|
||||
)
|
||||
invalidDecode <-
|
||||
( try $ withTransaction database $ \connection ->
|
||||
lookupMutation
|
||||
connection
|
||||
(mrUserId record)
|
||||
(mrKind record)
|
||||
(mrOperationId record)
|
||||
) :: IO (Either SomeException (Maybe MutationRecord))
|
||||
case invalidDecode of
|
||||
Left _ -> pure ()
|
||||
Right value ->
|
||||
fail ("invalid persisted mutation phase decoded as " <> show value)
|
||||
|
||||
verifyStorage :: Config -> S3 -> IO ()
|
||||
verifyStorage config store = do
|
||||
let fallbackKey = ObjectKey "shared/fallback.bin"
|
||||
|
|
@ -322,16 +358,21 @@ admitWithWindow database operation key size window =
|
|||
withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
(UserId "integration-user")
|
||||
Put
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity (UserId "integration-user") Put
|
||||
(OperationId operation)
|
||||
sharedPool
|
||||
(ObjectKey ("shared/" <> key))
|
||||
(RelativePath key)
|
||||
size
|
||||
(Just fixedIdentity)
|
||||
1000
|
||||
window
|
||||
, admissionPoolId = sharedPool
|
||||
, admissionRelativePath = RelativePath key
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint
|
||||
Put
|
||||
(ObjectKey ("shared/" <> key)) size (Just fixedIdentity)
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = 1000
|
||||
, admissionIdempotencyWindowSec = window
|
||||
}
|
||||
|
||||
resetAuthority :: Db -> Integer -> IO ()
|
||||
resetAuthority database limitBytes = do
|
||||
|
|
|
|||
|
|
@ -457,7 +457,7 @@ dispatch :: Db -> MutationRecord -> IO ()
|
|||
dispatch database record = do
|
||||
ok <- withTransaction database $ \connection -> do
|
||||
applying <- markApplying connection record
|
||||
pending <- markExternalPending connection record 10 5
|
||||
pending <- markExternalPending connection record (DispatchTiming 10 5)
|
||||
pure (applying && pending)
|
||||
assert "PrepareEffect/DispatchEffect" ok
|
||||
coveredAction "PrepareEffect"
|
||||
|
|
@ -498,48 +498,59 @@ admitPut cfg database operation path size identity =
|
|||
withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
protocolUser
|
||||
Put
|
||||
(OperationId operation)
|
||||
sharedPool
|
||||
(ObjectKey ("shared/" <> path))
|
||||
(RelativePath path)
|
||||
size
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity protocolUser Put (OperationId operation)
|
||||
, admissionPoolId = sharedPool
|
||||
, admissionRelativePath = RelativePath path
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Put (ObjectKey ("shared/" <> path)) size
|
||||
(Just identity)
|
||||
(cfgMaxObjectBytes cfg)
|
||||
(cfgIdempotencyWindowSec cfg)
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
|
||||
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
|
||||
}
|
||||
|
||||
admitDelete :: Config -> Db -> Text -> Text -> IO AdmitOutcome
|
||||
admitDelete cfg database operation path =
|
||||
withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
protocolUser
|
||||
Delete
|
||||
(OperationId operation)
|
||||
sharedPool
|
||||
(ObjectKey ("shared/" <> path))
|
||||
(RelativePath path)
|
||||
0
|
||||
Nothing
|
||||
(cfgMaxObjectBytes cfg)
|
||||
(cfgIdempotencyWindowSec cfg)
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity protocolUser Delete (OperationId operation)
|
||||
, admissionPoolId = sharedPool
|
||||
, admissionRelativePath = RelativePath path
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Delete (ObjectKey ("shared/" <> path)) 0 Nothing
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
|
||||
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
|
||||
}
|
||||
|
||||
admitPersonal :: Config -> Db -> UserId -> Text -> IO AdmitOutcome
|
||||
admitPersonal cfg database user operation =
|
||||
withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
user
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity user Put (OperationId operation)
|
||||
, admissionPoolId = personalPool user
|
||||
, admissionRelativePath = RelativePath "file.bin"
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint
|
||||
Put
|
||||
(OperationId operation)
|
||||
(personalPool user)
|
||||
(ObjectKey ("users/" <> unUserId user <> "/file.bin"))
|
||||
(RelativePath "file.bin")
|
||||
9
|
||||
(Just identityA)
|
||||
(cfgMaxObjectBytes cfg)
|
||||
(cfgIdempotencyWindowSec cfg)
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
|
||||
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
|
||||
}
|
||||
|
||||
seedObject :: Db -> S3 -> Text -> BL.ByteString -> IO ()
|
||||
seedObject database store path body = do
|
||||
|
|
|
|||
|
|
@ -112,16 +112,15 @@ preparePut database redis name size identity = do
|
|||
outcome <- withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
recoveryUser
|
||||
Put
|
||||
(phaseOperation name)
|
||||
sharedPool
|
||||
(phaseKey name)
|
||||
(RelativePath (name <> ".bin"))
|
||||
size
|
||||
(Just identity)
|
||||
(1024 * 1024 * 1024)
|
||||
3600
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity recoveryUser Put (phaseOperation name)
|
||||
, admissionPoolId = sharedPool
|
||||
, admissionRelativePath = RelativePath (name <> ".bin")
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Put (phaseKey name) size (Just identity)
|
||||
}
|
||||
(AdmissionLimits (1024 * 1024 * 1024) 3600)
|
||||
prepared outcome
|
||||
|
||||
prepareDelete :: Config -> Db -> Redis -> S3 -> IO MutationRecord
|
||||
|
|
@ -146,16 +145,18 @@ prepareDelete cfg database redis store = do
|
|||
outcome <- withTransaction database $ \connection ->
|
||||
admitMutation
|
||||
connection
|
||||
recoveryUser
|
||||
Delete
|
||||
(phaseOperation name)
|
||||
sharedPool
|
||||
key
|
||||
(RelativePath (name <> ".bin"))
|
||||
0
|
||||
Nothing
|
||||
(cfgMaxObjectBytes cfg)
|
||||
(cfgIdempotencyWindowSec cfg)
|
||||
AdmissionRequest
|
||||
{ admissionIdentity =
|
||||
AdmissionIdentity recoveryUser Delete (phaseOperation name)
|
||||
, admissionPoolId = sharedPool
|
||||
, admissionRelativePath = RelativePath (name <> ".bin")
|
||||
, admissionFingerprint =
|
||||
MutationFingerprint Delete key 0 Nothing
|
||||
}
|
||||
AdmissionLimits
|
||||
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
|
||||
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
|
||||
}
|
||||
prepared outcome
|
||||
|
||||
beginDispatch :: Config -> Db -> MutationRecord -> IO ()
|
||||
|
|
@ -165,8 +166,10 @@ beginDispatch cfg database rec = do
|
|||
pending <- markExternalPending
|
||||
connection
|
||||
rec
|
||||
(cfgObjectRequestTimeoutSec cfg * 2)
|
||||
(cfgRecoveryGraceSec cfg)
|
||||
DispatchTiming
|
||||
{ dispatchSettlementBoundSec = cfgObjectRequestTimeoutSec cfg * 2
|
||||
, dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
|
||||
}
|
||||
pure (applying && pending)
|
||||
unless started (fail "could not begin dispatch")
|
||||
|
||||
|
|
|
|||
91
test/Spec.hs
91
test/Spec.hs
|
|
@ -101,12 +101,21 @@ import Nuthatch.Paths
|
|||
, listCacheAncestorPrefixes
|
||||
)
|
||||
import Nuthatch.Protocol
|
||||
( ExistingDisposition (..)
|
||||
( AdmissionIdentity (..)
|
||||
, ExistingDisposition (..)
|
||||
, MutationFingerprint (..)
|
||||
, MutationPhase (..)
|
||||
, MutationRecord (..)
|
||||
, ObjectObservation (..)
|
||||
, PriorObject (..)
|
||||
, TerminalResult (..)
|
||||
, decodeMutationPhase
|
||||
, desiredMatches
|
||||
, encodeMutationPhase
|
||||
, existingDisposition
|
||||
, growthBytes
|
||||
, mrContentSha256
|
||||
, mrObjectKey
|
||||
, priorMatches
|
||||
, quotaAllows
|
||||
, recoveryEligible
|
||||
|
|
@ -307,20 +316,50 @@ identityTests = testGroup "identities"
|
|||
|
||||
protocolTests :: TestTree
|
||||
protocolTests = testGroup "mutation protocol decisions"
|
||||
[ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
|
||||
[ testCase "protocol phases round-trip through persisted state labels" $
|
||||
mapM_
|
||||
(\phase -> do
|
||||
let (state, external) = encodeMutationPhase phase
|
||||
decodeMutationPhase state external @?= Just phase)
|
||||
[ PhasePrepared
|
||||
, PhaseApplying ExtIdle
|
||||
, PhaseApplying ExtPending
|
||||
, PhaseApplying ExtSettled
|
||||
, PhaseTerminal TerminalSucceeded
|
||||
, PhaseTerminal TerminalFailed
|
||||
, PhaseTerminal TerminalRejected
|
||||
]
|
||||
, testCase "invalid persisted protocol phase combinations are rejected" $
|
||||
mapM_
|
||||
(\(state, external) ->
|
||||
decodeMutationPhase state external @?= Nothing)
|
||||
[ (Prepared, ExtPending)
|
||||
, (Prepared, ExtSettled)
|
||||
, (Succeeded, ExtPending)
|
||||
, (Succeeded, ExtSettled)
|
||||
, (Failed, ExtPending)
|
||||
, (Failed, ExtSettled)
|
||||
, (Rejected, ExtPending)
|
||||
, (Rejected, ExtSettled)
|
||||
]
|
||||
, testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
|
||||
, testCase "removed terminal identity starts a new mutation epoch" $ do
|
||||
let rec = sampleMutation
|
||||
Put
|
||||
(ObjectKey "users/u/file")
|
||||
4
|
||||
(Just (ContentSha256 "content"))
|
||||
case existingDisposition Nothing Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
|
||||
let fingerprint =
|
||||
MutationFingerprint Put (mrObjectKey rec) 4 (mrContentSha256 rec)
|
||||
case existingDisposition Nothing fingerprint of
|
||||
NewMutationEpoch -> pure ()
|
||||
other -> assertFailure ("expected new epoch, got " <> show other)
|
||||
case existingDisposition (Just rec) Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
|
||||
case existingDisposition (Just rec) fingerprint of
|
||||
ExistingReplay MutationPending _ -> pure ()
|
||||
other -> assertFailure ("expected replay, got " <> show other)
|
||||
case existingDisposition (Just rec) Put (mrObjectKey rec) 5 (mrContentSha256 rec) of
|
||||
case existingDisposition
|
||||
(Just rec)
|
||||
(fingerprint { fingerprintDeclaredSize = 5 }) of
|
||||
ExistingConflict -> pure ()
|
||||
other -> assertFailure ("expected conflict, got " <> show other)
|
||||
, testProperty "quota growth and admission preserve the limit" propQuotaInvariant
|
||||
|
|
@ -334,8 +373,8 @@ protocolTests = testGroup "mutation protocol decisions"
|
|||
, testCase "ambiguous same-size content matches no terminal state" $ do
|
||||
let rec = (sampleMutation Put (ObjectKey "shared/file") 10
|
||||
(Just (ContentSha256 "desired")))
|
||||
{ mrPriorSize = 10
|
||||
, mrPriorSha256 = Just (ContentSha256 "prior")
|
||||
{ mrPriorObject =
|
||||
PriorObject 10 (Just (ContentSha256 "prior"))
|
||||
}
|
||||
observation = ObjectPresent 10 (Just (ContentSha256 "other"))
|
||||
desiredMatches rec observation @?= False
|
||||
|
|
@ -1105,12 +1144,19 @@ propFingerprintDistinction = property $ do
|
|||
otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
|
||||
sha = Just (ContentSha256 "content-a")
|
||||
rec = sampleMutation Put key size sha
|
||||
assert (sameFingerprint rec Put key size sha)
|
||||
assert (not (sameFingerprint rec Delete key size sha))
|
||||
assert (not (sameFingerprint rec Put otherRootKey size sha))
|
||||
assert (not (sameFingerprint rec Put otherPathKey size sha))
|
||||
assert (not (sameFingerprint rec Put key (size + 1) sha))
|
||||
assert (not (sameFingerprint rec Put key size (Just (ContentSha256 "content-b"))))
|
||||
let fingerprint = MutationFingerprint Put key size sha
|
||||
assert (sameFingerprint rec fingerprint)
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintKind = Delete })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintObjectKey = otherRootKey })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintObjectKey = otherPathKey })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintDeclaredSize = size + 1 })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint
|
||||
{ fingerprintContentSha256 = Just (ContentSha256 "content-b") })))
|
||||
|
||||
propQuotaInvariant :: Property
|
||||
propQuotaInvariant = property $ do
|
||||
|
|
@ -1140,9 +1186,7 @@ propObservations = property $ do
|
|||
let desiredSha = Just (ContentSha256 "desired")
|
||||
priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
|
||||
rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
|
||||
{ mrPriorSize = priorSize
|
||||
, mrPriorSha256 = priorSha
|
||||
}
|
||||
{ mrPriorObject = PriorObject priorSize priorSha }
|
||||
desiredMatches rec observation === modelDesired kind desiredSize desiredSha observation
|
||||
priorMatches rec observation === modelPrior priorSize priorSha observation
|
||||
|
||||
|
|
@ -1257,17 +1301,12 @@ sampleMutation
|
|||
-> Maybe ContentSha256
|
||||
-> MutationRecord
|
||||
sampleMutation kind key size sha = MutationRecord
|
||||
{ mrUserId = UserId "u"
|
||||
, mrKind = kind
|
||||
, mrOperationId = OperationId "op"
|
||||
{ mrAdmissionIdentity =
|
||||
AdmissionIdentity (UserId "u") kind (OperationId "op")
|
||||
, mrPoolId = PoolId "personal:u"
|
||||
, mrObjectKey = key
|
||||
, mrRelativePath = RelativePath "file"
|
||||
, mrDeclaredSize = size
|
||||
, mrContentSha256 = sha
|
||||
, mrPriorSize = 0
|
||||
, mrPriorSha256 = Nothing
|
||||
, mrFingerprint = MutationFingerprint kind key size sha
|
||||
, mrPriorObject = PriorObject 0 Nothing
|
||||
, mrGrowth = size
|
||||
, mrState = Applying
|
||||
, mrExternal = ExtSettled
|
||||
, mrPhase = PhaseApplying ExtSettled
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue