ron-rdt 0.7 → 0.8
raw patch · 8 files changed
+640/−374 lines, 8 files
Files
- CHANGELOG.md +42/−2
- lib/RON/Data.hs +48/−62
- lib/RON/Data/Internal.hs +151/−89
- lib/RON/Data/LWW.hs +73/−63
- lib/RON/Data/ORSet.hs +247/−76
- lib/RON/Data/RGA.hs +52/−66
- lib/RON/Data/VersionVector.hs +26/−15
- ron-rdt.cabal +1/−1
CHANGELOG.md view
@@ -7,6 +7,45 @@ ## [Unreleased] +## [0.8] - 2019-08-10+### Added+- Function `reduceState`+- Function `reduceObjectStates`+- Checking type field and correcting object reduce+- Function `stateFromWireChunk`+- Function `stateToWireChunk`++### Changed+- `Reducible` depends on `BoundedSemilattice`.+- `ReplicatedAsObject` depends on `ReplicatedBoundedSemilattice`.+- `ReplicatedAsObject`:+ - Removed method `objectOpType`+ - Added associated type alias `Rep` --+ untyped RON-RDT representation of a typed RDT.+ - Behavior: referencing `Rep` type instead of duplicating type UUID+- `Option` encoding: for availability, anything except `some` means None.+ None is encoded as empty payload.+- Renamed `ORSet.zoom` -> `zoomItem`.+- Renamed `LWW.newObject` -> `newStruct`.+- Event simulation: decreased max event leap from 2³² to 2¹⁶+- Text serialization: changed chunk sort order from (type, id) to just id+- ORSet: keep payload on removal+- LWW+ - fields are always optional+ - `viewField` returns `Maybe`+ - `readField` returns `Maybe`+ - `assignField` takes `Maybe`++### Fixed+- Causality: an object happens-before its ops (in ORSet, RGA, LWW)+- Tombstone creation in ORSet++### Removed+- Function `mkStateChunk`.+- RON type `Option` (instances for Haskell type `Maybe`)+- Class `ReplicatedBoundedSemilattice`+- Function `objectRconcat` (`rconcat` took its place)+ ## [0.7] - 2019-07-26 ### Added - `newObjectState`@@ -143,8 +182,9 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/v0.7...HEAD-[0.7]: https://github.com/ff-notes/ron/compare/v0.6...v0.7+[Unreleased]: https://github.com/ff-notes/ron/compare/ron-rdt-0.8...HEAD+[0.8]: https://github.com/ff-notes/ron/compare/ron-rdt-0.7...ron-rdt-0.8+[0.7]: https://github.com/ff-notes/ron/compare/ron-rdt-0.6...ron-rdt-0.7 [0.6]: https://github.com/ff-notes/ff/compare/v0.5...ron-rdt-0.6 [0.5]: https://github.com/ff-notes/ff/compare/v0.4...v0.5 [0.4]: https://github.com/ff-notes/ff/compare/v0.3...v0.4
lib/RON/Data.hs view
@@ -16,22 +16,24 @@ ReplicatedAsPayload (..), fromRon, getObjectStateChunk,- mkStateChunk, newRon, objectEncoding, payloadEncoding,+ rconcat, reduceObject, reduceStateFrame, reduceWireFrame,- -- * 'ObjectState' monad+ stateFromWireChunk,+ stateToWireChunk,+ -- * Object-state monad ObjectStateT, MonadObjectState, evalObjectState, evalObjectState_, execObjectState, execObjectState_,- newObjectState,- newObjectStateWith,+ newObjectFrame,+ newObjectFrameWith, runObjectState, runObjectState_, ) where@@ -49,12 +51,12 @@ import RON.Data.VersionVector (VersionVector) import RON.Error (MonadE, throwErrorString) import RON.Types (ClosedOp (..), Object (Object),- ObjectState (ObjectState, frame, uuid), Op (..),+ ObjectFrame (ObjectFrame, frame, uuid), Op (..), StateChunk (..), StateFrame, UUID, WireChunk (Closed, Query, Value), WireFrame,- WireReducedChunk (..))+ WireReducedChunk (..),+ WireStateChunk (WireStateChunk, stateBody, stateType)) import RON.UUID (pattern Zero)-import qualified RON.UUID as UUID reducers :: Map UUID Reducer reducers = Map.fromList@@ -93,8 +95,17 @@ mkReducer :: forall a . Reducible a => (UUID, Reducer) mkReducer = ( reducibleOpType @a- , Reducer{wireReducer = mkWireReducer @a, stateReducer = reduceState @a}+ , Reducer+ {wireReducer = mkWireReducer @a, stateReducer = unsafeReduceState @a} )+ where+ -- | Reduce states using type @rep@ without checking 'stateType'+ unsafeReduceState+ :: forall rep+ . Reducible rep => WireStateChunk -> WireStateChunk -> WireStateChunk+ unsafeReduceState+ WireStateChunk{stateBody = c1} WireStateChunk{stateBody = c2} =+ wireStateChunk @rep $ reduceState (StateChunk c1) (StateChunk c2) mkWireReducer :: forall a . Reducible a => WireReducer mkWireReducer obj chunks = chunks' <> leftovers where@@ -109,22 +120,8 @@ nState = sconcat $ fmap snd nStates (reducedState, unapplied') = applyPatches nState (patches, closedOps)- StateChunk- { stateVersion = reducedStateVersion- , stateBody = reducedStateBody- } =- stateToChunk @a reducedState- MaxOnFst (seenStateVersion, seenState) =- sconcat $ fmap MaxOnFst nStates- stateVersion = if- | reducedStateVersion > seenStateVersion -> reducedStateVersion- | reducedState == seenState -> seenStateVersion- | otherwise -> UUID.succValue seenStateVersion- rc = ReducedChunk- { rcVersion = stateVersion- , rcRef = Zero- , rcBody = reducedStateBody- }+ reducedStateBody = stateToChunk @a reducedState+ rc = ReducedChunk{rcRef = Zero, rcBody = reducedStateBody} in (Just $ Value $ wrapRChunk rc, reduceUnappliedPatches @a unapplied') typ = reducibleOpType @a@@ -141,9 +138,7 @@ case ref of Zero -> -- state pure- ( [ ( opId $ op wrcHeader- , stateFromChunk wrcBody- ) ]+ ( [(opId $ op wrcHeader, stateFromChunk wrcBody)] , [] , [] , []@@ -151,31 +146,22 @@ _ -> -- patch pure ( []- , [ ReducedChunk- { rcVersion = opId $ op wrcHeader- , rcRef = ref- , rcBody = wrcBody- }- ]+ , [ReducedChunk{rcRef = ref, rcBody = wrcBody}] , [] , [] ) _ -> Nothing guardSameObject ClosedOp{reducerId, objectId} = guard $ reducerId == typ && objectId == obj- wrapRChunk ReducedChunk{..} = WireReducedChunk- { wrcHeader = wrapOp Op{opId = rcVersion, refId = rcRef, payload = []}+ wrapRChunk ReducedChunk{rcRef, rcBody} = WireReducedChunk+ { wrcHeader = wrapOp Op{opId = Zero, refId = rcRef, payload = []} , wrcBody = rcBody } -reduceState :: forall a . Reducible a => StateChunk -> StateChunk -> StateChunk-reduceState s1 s2 =- stateToChunk @a $ ((<>) `on` (stateFromChunk . stateBody)) s1 s2- reduceStateFrame :: MonadE m => StateFrame -> StateFrame -> m StateFrame reduceStateFrame s1 s2 = (`execStateT` s1) . (`Map.traverseWithKey` s2) $ \oid chunk -> let- StateChunk{stateType} = chunk+ WireStateChunk{stateType} = chunk in case reducers !? stateType of Just Reducer{stateReducer} ->@@ -185,14 +171,14 @@ "Cannot reduce StateFrame of unknown type " ++ show stateType unsafeReduceObject- :: MonadE m => ObjectState a -> StateFrame -> m (ObjectState a)-unsafeReduceObject obj@ObjectState{frame = s1} s2 = do+ :: MonadE m => ObjectFrame a -> StateFrame -> m (ObjectFrame a)+unsafeReduceObject obj@ObjectFrame{frame = s1} s2 = do frame' <- reduceStateFrame s1 s2 pure obj{frame = frame'} -- | Reduce object with frame from another version of the same object.-reduceObject :: MonadE m => ObjectState a -> ObjectState a -> m (ObjectState a)-reduceObject o1@ObjectState{uuid = id1} ObjectState{uuid = id2, frame = frame2}+reduceObject :: MonadE m => ObjectFrame a -> ObjectFrame a -> m (ObjectFrame a)+reduceObject o1@ObjectFrame{uuid = id1} ObjectFrame{uuid = id2, frame = frame2} | id1 == id2 = unsafeReduceObject o1 frame2 | otherwise = throwErrorString $ "Object ids differ: " ++ show (id1, id2) @@ -203,42 +189,42 @@ | a1 < a2 = mof2 | otherwise = mof1 --- | Run ObjectState action-evalObjectState :: Monad m => ObjectState b -> ObjectStateT b m a -> m a-evalObjectState ObjectState{uuid, frame} action =+-- | Run ObjectFrame action+evalObjectState :: Monad m => ObjectFrame b -> ObjectStateT b m a -> m a+evalObjectState ObjectFrame{uuid, frame} action = evalStateT (runReaderT action $ Object uuid) frame --- | Run ObjectState action, starting with an empty frame+-- | Run ObjectFrame action, starting with an empty frame evalObjectState_ :: Monad m => StateT StateFrame m a -> m a evalObjectState_ action = evalStateT action mempty --- | Run ObjectState action+-- | Run ObjectFrame action execObjectState- :: Monad m => ObjectState b -> ObjectStateT b m a -> m (ObjectState b)-execObjectState state@ObjectState{uuid, frame} action = do+ :: Monad m => ObjectFrame b -> ObjectStateT b m a -> m (ObjectFrame b)+execObjectState state@ObjectFrame{uuid, frame} action = do frame' <- execStateT (runReaderT action $ Object uuid) frame pure state{frame = frame'} --- | Run ObjectState action, starting with an empty frame+-- | Run ObjectFrame action, starting with an empty frame execObjectState_ :: Monad m => StateT StateFrame m a -> m StateFrame execObjectState_ action = execStateT action mempty --- | Run ObjectState action+-- | Run ObjectFrame action runObjectState :: Functor m- => ObjectState b+ => ObjectFrame b -> ObjectStateT b m a- -> m (a, ObjectState b)-runObjectState state@ObjectState{uuid, frame} action =+ -> m (a, ObjectFrame b)+runObjectState state@ObjectFrame{uuid, frame} action = runStateT (runReaderT action $ Object uuid) frame <&> \(a, frame') -> (a, state{frame = frame'}) --- | Run ObjectState action, starting with an empty frame+-- | Run ObjectFrame action, starting with an empty frame runObjectState_ :: StateT StateFrame m a -> m (a, StateFrame) runObjectState_ action = runStateT action mempty --- | Create new 'ObjectState' with an action-newObjectStateWith- :: Functor m => StateT StateFrame m (Object a) -> m (ObjectState a)-newObjectStateWith action =- runObjectState_ action <&> \(Object uuid, frame) -> ObjectState{uuid, frame}+-- | Create new 'ObjectFrame' with an action+newObjectFrameWith+ :: Functor m => StateT StateFrame m (Object a) -> m (ObjectFrame a)+newObjectFrameWith action =+ runObjectState_ action <&> \(Object uuid, frame) -> ObjectFrame{uuid, frame}
lib/RON/Data/Internal.hs view
@@ -6,12 +6,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module RON.Data.Internal (+ Encoding (..), ReducedChunk (..), Reducer (..), Reducible (..),@@ -23,13 +24,22 @@ advanceToObject, eqPayload, eqRef,+ getObjectState, getObjectStateChunk,- mkStateChunk, modifyObjectStateChunk, modifyObjectStateChunk_,- newObjectState,+ newObjectFrame,+ reduceState,+ reduceObjectStates,+ stateFromWireChunk,+ stateToWireChunk,+ tryFromRon,+ tryOptionFromRon,+ wireStateChunk,+ pattern Some, -- objectEncoding,+ rconcat, payloadEncoding, -- fromRon,@@ -41,43 +51,45 @@ import RON.Prelude +import Data.List (minimum) import qualified Data.Map.Strict as Map import qualified Data.Text as Text -import RON.Error (MonadE, errorContext, liftMaybe)+import RON.Error (Error (Error), MonadE, correct, errorContext,+ liftMaybe) import RON.Event (ReplicaClock, advanceToUuid)+import RON.Semilattice (BoundedSemilattice) import RON.Types (Atom (AInteger, AString, AUuid), Object (Object),- ObjectState (ObjectState, frame, uuid),- Op (Op, opId, payload, refId),- StateChunk (StateChunk, stateBody, stateType, stateVersion),- StateFrame, UUID (UUID), WireChunk)-import RON.UUID (zero)+ ObjectFrame (ObjectFrame, frame, uuid),+ Op (Op, opId, payload, refId), Payload,+ StateChunk (StateChunk), StateFrame, UUID (UUID),+ WireChunk,+ WireStateChunk (WireStateChunk, stateBody, stateType)) -- | Reduce all chunks of specific type and object in the frame type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk] data Reducer = Reducer { wireReducer :: WireReducer- , stateReducer :: StateChunk -> StateChunk -> StateChunk+ , stateReducer :: WireStateChunk -> WireStateChunk -> WireStateChunk } -- | Unapplied patches and raw ops type Unapplied = ([ReducedChunk], [Op]) --- TODO(2018-08-24, cblp, #26) Semilattice a? -- | Untyped-reducible types. -- Untyped means if this type is a container then the types of data contained in -- it is not considered.-class (Eq a, Monoid a) => Reducible a where+class (Eq a, BoundedSemilattice a) => Reducible a where -- | UUID of the type reducibleOpType :: UUID - -- | Load a state from a state chunk+ -- | Load a state from a state chunk. stateFromChunk :: [Op] -> a -- | Store a state to a state chunk- stateToChunk :: a -> StateChunk+ stateToChunk :: a -> [Op] -- | Merge a state with patches and raw ops applyPatches :: a -> Unapplied -> (a, Unapplied)@@ -97,20 +109,26 @@ , [] ) +stateToWireChunk :: forall rep . Reducible rep => rep -> WireStateChunk+stateToWireChunk rep = wireStateChunk @rep $ StateChunk $ stateToChunk @rep rep++stateFromWireChunk+ :: forall a m . (MonadE m, Reducible a) => WireStateChunk -> m a+stateFromWireChunk WireStateChunk{stateType, stateBody} = do+ unless (stateType == reducibleOpType @a) $+ throwError $+ Error "bad type"+ [ Error ("expected " <> show (reducibleOpType @a)) []+ , Error ("got " <> show stateType) []+ ]+ pure $ stateFromChunk stateBody+ data ReducedChunk = ReducedChunk- { rcVersion :: UUID- , rcRef :: UUID+ { rcRef :: UUID , rcBody :: [Op] } deriving (Show) -mkChunkVersion :: [Op] -> UUID-mkChunkVersion = maximumDef zero . map opId--mkStateChunk :: UUID -> [Op] -> StateChunk-mkStateChunk stateType ops =- StateChunk{stateType, stateVersion = mkChunkVersion ops, stateBody = ops}- data Patch a = Patch{patchRef :: UUID, patchValue :: a} instance Semigroup a => Semigroup (Patch a) where@@ -123,14 +141,14 @@ } patchFromChunk :: Reducible a => ReducedChunk -> Patch a-patchFromChunk ReducedChunk{..} =+patchFromChunk ReducedChunk{rcRef, rcBody} = Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody} patchToChunk :: Reducible a => Patch a -> ReducedChunk patchToChunk Patch{patchRef, patchValue} =- ReducedChunk{rcRef = patchRef, rcVersion = stateVersion, rcBody = stateBody}+ ReducedChunk{rcRef = patchRef, rcBody = stateBody} where- StateChunk{stateVersion, stateBody} = stateToChunk patchValue+ WireStateChunk{stateBody} = stateToWireChunk patchValue -- | Base class for typed encoding class Replicated a where@@ -141,20 +159,19 @@ data Encoding a = Encoding { encodingNewRon :: forall m- . (ReplicaClock m, MonadState StateFrame m) => a -> m [Atom]+ . (ReplicaClock m, MonadState StateFrame m) => a -> m Payload , encodingFromRon- :: forall m . (MonadE m, MonadState StateFrame m) => [Atom] -> m a+ :: forall m . (MonadE m, MonadState StateFrame m) => Payload -> m a } -- | Encode typed data to a payload with possible addition objects newRon- :: (Replicated a, ReplicaClock m, MonadState StateFrame m) => a -> m [Atom]+ :: (Replicated a, ReplicaClock m, MonadState StateFrame m) => a -> m Payload newRon = encodingNewRon encoding -- | Decode typed data from a payload. -- The implementation may use other objects in the frame to resolve references.--- TODO(2019-06-28, cblp) use 'ReaderT' for symmetry with 'newRon'-fromRon :: (MonadE m, Replicated a, MonadState StateFrame m) => [Atom] -> m a+fromRon :: (MonadE m, Replicated a, MonadState StateFrame m) => Payload -> m a fromRon = encodingFromRon encoding -- | Standard implementation of 'Replicated' for 'ReplicatedAsObject' types.@@ -179,10 +196,10 @@ class Replicated a => ReplicatedAsPayload a where -- | Encode data- toPayload :: a -> [Atom]+ toPayload :: a -> Payload -- | Decode data- fromPayload :: MonadE m => [Atom] -> m a+ fromPayload :: MonadE m => Payload -> m a instance Replicated Int64 where encoding = payloadEncoding @@ -190,7 +207,7 @@ toPayload int = [AInteger int] fromPayload atoms = errorContext "Integer" $ case atoms of [AInteger int] -> pure int- _ -> throwError "Expected Integer syntax"+ _ -> throwError "Expected Integer" instance Replicated UUID where encoding = payloadEncoding @@ -198,7 +215,7 @@ toPayload u = [AUuid u] fromPayload atoms = errorContext "UUID" $ case atoms of [AUuid u] -> pure u- _ -> throwError "Expected UUID syntax"+ _ -> throwError "Expected UUID" instance Replicated Text where encoding = payloadEncoding @@ -206,7 +223,7 @@ toPayload t = [AString t] fromPayload atoms = errorContext "String" $ case atoms of [AString t] -> pure t- _ -> throwError "Expected string syntax"+ _ -> throwError "Expected String" instance Replicated Char where encoding = payloadEncoding @@ -220,10 +237,10 @@ -- An enclosing object's payload will be filled with this object's id. -- -- Law: @'encoding' == 'objectEncoding'@-class Replicated a => ReplicatedAsObject a where+class (Reducible (Rep a), Replicated a) => ReplicatedAsObject a where - -- | UUID of the type- objectOpType :: UUID+ -- | Untyped RON-RDT representation+ type Rep a -- | Encode data. Write frame and return id. newObject :: (ReplicaClock m, MonadState StateFrame m) => a -> m (Object a)@@ -231,80 +248,65 @@ -- | Decode data getObject :: (MonadE m, MonadObjectState a m) => m a -objectFromRon :: MonadE m => (Object a -> m a) -> [Atom] -> m a+ -- | Counterpart of 'mempty', but without an explicit 'Semigroup'+ -- rempty :: a++objectFromRon :: MonadE m => (Object a -> m a) -> Payload -> m a objectFromRon handler atoms = case atoms of [AUuid uuid] -> handler $ Object uuid _ -> throwError "Expected object UUID" --- | Create new 'ObjectState' from a value-newObjectState- :: (ReplicatedAsObject a, ReplicaClock m) => a -> m (ObjectState a)-newObjectState a = do+-- | Create new 'ObjectFrame' from a value+newObjectFrame+ :: (ReplicatedAsObject a, ReplicaClock m) => a -> m (ObjectFrame a)+newObjectFrame a = do (Object uuid, frame) <- runStateT (newObject a) mempty- pure $ ObjectState{uuid, frame}+ pure $ ObjectFrame{uuid, frame} -getObjectStateChunk :: (MonadE m, MonadObjectState a m) => m StateChunk+getObjectStateChunk+ :: forall a m . (MonadE m, MonadObjectState a m) => m (StateChunk (Rep a)) getObjectStateChunk = do Object uuid <- ask frame <- get- liftMaybe "no such object in chunk" $ Map.lookup uuid frame+ WireStateChunk{stateType, stateBody} <-+ liftMaybe "no such object in chunk" $ Map.lookup uuid frame+ unless (stateType == reducibleOpType @(Rep a)) $+ throwError $+ Error "bad type"+ [ Error ("expected " <> show (reducibleOpType @(Rep a))) []+ , Error ("got " <> show stateType) []+ ]+ pure $ StateChunk stateBody modifyObjectStateChunk- :: (MonadObjectState a m, ReplicaClock m, MonadE m)- => (StateChunk -> m (b, StateChunk)) -> m b+ :: forall a b m+ . (MonadObjectState a m, ReplicaClock m, MonadE m)+ => (StateChunk (Rep a) -> m (b, StateChunk (Rep a))) -> m b modifyObjectStateChunk f = do+ advanceToObject Object uuid <- ask- chunk@StateChunk{stateVersion} <- getObjectStateChunk- advanceToUuid stateVersion- -- event <- getEventUuid- -- let state' = StateChunk- -- {stateType = _, stateVersion = event, stateBody = chunk'}- (a, chunk') <- f chunk- modify' $ Map.insert uuid chunk'+ chunk <- getObjectStateChunk+ (a, StateChunk chunk') <- f chunk+ modify' $+ Map.insert uuid $+ WireStateChunk{stateType = reducibleOpType @(Rep a), stateBody = chunk'} pure a modifyObjectStateChunk_ :: (MonadObjectState a m, ReplicaClock m, MonadE m)- => (StateChunk -> m StateChunk) -> m ()+ => (StateChunk (Rep a) -> m (StateChunk (Rep a))) -> m () modifyObjectStateChunk_ f = modifyObjectStateChunk $ \chunk -> do chunk' <- f chunk pure ((), chunk') -eqRef :: Object a -> [Atom] -> Bool+eqRef :: Object a -> Payload -> Bool eqRef (Object uuid) atoms = case atoms of [AUuid ref] -> uuid == ref _ -> False -eqPayload :: ReplicatedAsPayload a => a -> [Atom] -> Bool+eqPayload :: ReplicatedAsPayload a => a -> Payload -> Bool eqPayload a atoms = toPayload a == atoms -pattern None :: Atom-pattern None = AUuid (UUID 0xcb3ca9000000000 0) -- none--pattern Some :: Atom-pattern Some = AUuid (UUID 0xdf3c69000000000 0) -- some--instance Replicated a => Replicated (Maybe a) where- encoding = Encoding- { encodingNewRon = \case- Just a -> (Some :) <$> newRon a- Nothing -> pure [None]- , encodingFromRon = \atoms ->- errorContext "Option" $ case atoms of- Some : atoms' -> Just <$> fromRon atoms'- [None] -> pure Nothing- _ -> throwError "Bad Option"- }--instance ReplicatedAsPayload a => ReplicatedAsPayload (Maybe a) where- toPayload = \case- Just a -> Some : toPayload a- Nothing -> [None]- fromPayload = errorContext "Option" . \case- Some : atoms -> Just <$> fromPayload atoms- [None] -> pure Nothing- _ -> throwError "Bad Option"- pattern ATrue :: Atom pattern ATrue = AUuid (UUID 0xe36e69000000000 0) -- true @@ -325,20 +327,80 @@ type ObjectStateT b m a = ReaderT (Object b) (StateT StateFrame m) a -type MonadObjectState b m = (MonadReader (Object b) m, MonadState StateFrame m)+type MonadObjectState a m =+ (MonadReader (Object a) m, MonadState StateFrame m, Reducible (Rep a)) advanceToObject :: (MonadE m, MonadObjectState a m, ReplicaClock m) => m () advanceToObject = do Object uuid <- ask- StateChunk{stateBody} <- getObjectStateChunk+ StateChunk chunk <- getObjectStateChunk advanceToUuid $ maximumDef uuid [ max opId $ maximumDef refId $ mapMaybe atomAsUuid payload- | Op{opId, refId, payload} <- stateBody+ | Op{opId, refId, payload} <- chunk ] where -- | TODO(2019-07-26, cblp) Use lens atomAsUuid = \case AUuid u -> Just u _ -> Nothing++reduceState+ :: forall rep+ . Reducible rep => StateChunk rep -> StateChunk rep -> StateChunk rep+reduceState (StateChunk s1) (StateChunk s2) =+ StateChunk $ stateToChunk @rep $ stateFromChunk s1 <> stateFromChunk s2++reduceObjectStates+ :: forall a m+ . (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)+ => NonEmpty (Object a) -> m (Object a)+reduceObjectStates (obj :| objs) = do+ c :| cs <- for (obj :| objs) $ runReaderT getObjectStateChunk+ let chunk = foldl' (reduceState @(Rep a)) c cs+ oid = minimum [i | Object i <- obj:objs]+ modify' $ Map.insert oid $ wireStateChunk chunk+ pure $ Object oid++rconcat+ :: forall a m+ . (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)+ => NonEmpty UUID -> m a+rconcat uuids =+ errorContext "rconcat" $ do+ Object ref <- reduceObjectStates @a $ Object <$> uuids+ fromRon [AUuid ref]++tryFromRon+ :: (MonadE m, MonadState StateFrame m, Replicated a)+ => Payload -> m (Maybe a)+tryFromRon = correct Nothing . fmap Just . fromRon++tryOptionFromRon+ :: (MonadE m, MonadState StateFrame m, Replicated a)+ => Payload -> m (Maybe a)+tryOptionFromRon payload = case payload of+ Some : payload' ->+ correct Nothing $+ (Just <$> fromRon payload)+ `catchError` \e1 ->+ (Just <$> fromRon payload')+ `catchError` \e2 ->+ throwError $ Error "tryOptionFromRon" [e1, e2]+ _ -> tryFromRon payload++-- | TODO(2019-08-06, cblp) Remove a year after release+-- (the release is planned on 2019-08; removal is planned on 2020-08)+pattern Some :: Atom+pattern Some = AUuid (UUID 0xdf3c69000000000 0)+{-# DEPRECATED Some "Will be removed soon" #-}++getObjectState :: (MonadE m, MonadObjectState a m) => m (Rep a)+getObjectState = do+ StateChunk chunk <- getObjectStateChunk+ pure $ stateFromChunk chunk++wireStateChunk :: forall rep . Reducible rep => StateChunk rep -> WireStateChunk+wireStateChunk (StateChunk stateBody) =+ WireStateChunk{stateType = reducibleOpType @rep, stateBody}
lib/RON/Data/LWW.hs view
@@ -1,35 +1,43 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -- | LWW-per-field RDT-module RON.Data.LWW- ( LwwRep (..)- , assignField- , lwwType- , newObject- , readField- , viewField- , zoomField- ) where+module RON.Data.LWW (+ LwwRep (..),+ assignField,+ lwwType,+ newStruct,+ readField,+ viewField,+ zoomField,+) where import RON.Prelude import qualified Data.Map.Strict as Map import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,- Replicated, fromRon, getObjectStateChunk,- mkStateChunk, newRon, reducibleOpType,- stateFromChunk, stateToChunk)+ Rep, Replicated, ReplicatedAsObject,+ getObjectStateChunk,+ modifyObjectStateChunk_, newRon,+ reducibleOpType, stateFromChunk,+ stateToChunk, tryOptionFromRon) import RON.Error (MonadE, errorContext)-import RON.Event (ReplicaClock, advanceToUuid, getEventUuid)-import RON.Types (Atom (AUuid), Object (..), Op (..), StateChunk (..),- StateFrame, UUID)+import RON.Event (ReplicaClock, getEventUuid)+import RON.Semilattice (Semilattice)+import RON.Types (Atom (AUuid), Object (Object),+ Op (Op, opId, payload, refId),+ StateChunk (StateChunk), StateFrame, UUID,+ WireStateChunk (WireStateChunk, stateBody, stateType)) import RON.Util (Instance (Instance)) import qualified RON.UUID as UUID @@ -45,89 +53,91 @@ LwwRep fields1 <> LwwRep fields2 = LwwRep $ Map.unionWith lww fields1 fields2 +-- | Laws:+-- 1. Idempotent because 'Map.unionWith' is idempotent.+-- 2. Commutative because 'lww' is commutative.+instance Semilattice LwwRep+ instance Reducible LwwRep where reducibleOpType = lwwType stateFromChunk ops = LwwRep $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops] - stateToChunk (LwwRep fields) = mkStateChunk lwwType $ Map.elems fields+ stateToChunk (LwwRep fields) = Map.elems fields +wireStateChunk :: [Op] -> WireStateChunk+wireStateChunk stateBody = WireStateChunk{stateType = lwwType, stateBody}+ -- | Name-UUID to use as LWW type marker. lwwType :: UUID lwwType = $(UUID.liftName "lww") --- | Create LWW object from a list of named fields.-newObject+-- | Create an LWW object from a list of named fields.+newStruct :: (MonadState StateFrame m, ReplicaClock m)- => [(UUID, Instance Replicated)] -> m UUID-newObject fields = do- payloads <- for fields $ \(_, Instance value) -> newRon value+ => [(UUID, Maybe (Instance Replicated))] -> m UUID+newStruct fields = do event <- getEventUuid- modify' $- (<>) $ Map.singleton event $- StateChunk- { stateType = lwwType- , stateVersion = event- , stateBody =- [Op event name p | ((name, _), p) <- zip fields payloads]- }+ stateBody <-+ for fields $ \(name, mvalue) -> do+ payload <- case mvalue of+ Just (Instance value) -> newRon value+ Nothing -> pure []+ pure $ Op event name payload+ modify' $ Map.insert event $ wireStateChunk stateBody pure event -- | Decode field value viewField :: (Replicated a, MonadE m, MonadState StateFrame m)- => UUID -- ^ Field name- -> StateChunk -- ^ LWW object chunk- -> m a-viewField field StateChunk{..} =- errorContext ("LWW.viewField " <> show field) $ do- let ops = filter (\Op{refId} -> refId == field) stateBody- Op{payload} <- case ops of- [] -> throwError "no field in lww chunk"- [op] -> pure op- _ -> throwError "unreduced state"- fromRon payload+ => UUID -- ^ Field name+ -> StateChunk LwwRep -- ^ LWW object chunk+ -> m (Maybe a)+viewField field (StateChunk ops) =+ errorContext "LWW.viewField" $+ maybe (pure Nothing) (tryOptionFromRon . payload) $+ maximumMayOn opId $+ filter (\Op{refId} -> refId == field) ops --- | Decode field value+-- | Read field value readField- :: (MonadE m, MonadObjectState struct m, Replicated field)- => UUID -- ^ Field name- -> m field+ :: ( MonadE m+ , MonadObjectState struct m+ , Rep struct ~ LwwRep+ , Replicated field+ )+ => UUID -- ^ Field name+ -> m (Maybe field) readField field = do stateChunk <- getObjectStateChunk viewField field stateChunk -- | Assign a value to a field assignField- :: (Replicated field, ReplicaClock m, MonadE m, MonadObjectState struct m)- => UUID -- ^ Field name- -> field -- ^ Value+ :: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState struct m)+ => UUID -- ^ Field name+ -> Maybe a -- ^ Value -> m ()-assignField field value = do- StateChunk{stateBody, stateVersion} <- getObjectStateChunk- advanceToUuid stateVersion- let chunk = filter (\Op{refId} -> refId /= field) stateBody- event <- getEventUuid- p <- newRon value- let newOp = Op event field p- let chunk' = sortOn refId $ newOp : chunk- let state' = StateChunk- {stateVersion = event, stateBody = chunk', stateType = lwwType}- Object uuid <- ask- modify' $ Map.insert uuid state'+assignField field mvalue =+ modifyObjectStateChunk_ $ \(StateChunk ops) -> do+ let chunk = filter (\Op{refId} -> refId /= field) ops+ event <- getEventUuid+ p <- maybe (pure []) newRon mvalue+ let newOp = Op event field p+ pure $ StateChunk $ sortOn refId $ newOp : chunk -- | Pseudo-lens to an object inside a specified field zoomField- :: MonadE m+ :: (MonadE m, ReplicatedAsObject struct) => UUID -- ^ Field name -> ObjectStateT field m a -- ^ Inner object modifier -> ObjectStateT struct m a zoomField field innerModifier = errorContext ("LWW.zoomField" <> show field) $ do- StateChunk{stateBody} <- getObjectStateChunk- let ops = filter (\Op{refId} -> refId == field) stateBody- Op{payload} <- case ops of+ StateChunk ops <- getObjectStateChunk+ let fieldOps = filter (\Op{refId} -> refId == field) ops+ Op{payload} <- case fieldOps of [] -> throwError "empty chunk" [op] -> pure op _ -> throwError "unreduced state"
lib/RON/Data/ORSet.hs view
@@ -1,91 +1,119 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -- | Observed-Remove Set (OR-Set)-module RON.Data.ORSet- ( ORSet (..)- , ORSetItem (..)- , ORSetMap- , ORSetRep- , addRef- , addValue- , findAnyAlive- , findAnyAlive'- , removeRef- , removeValue- , zoom- ) where+module RON.Data.ORSet (+ ORSet (..),+ ORSetItem (..),+ ORSetMap,+ ORSetRep,+ addRef,+ addValue,+ findAnyAlive,+ findAnyAlive',+ removeRef,+ removeValue,+ zoomItem,+ -- * struct_set+ assignField,+ newStruct,+ viewField,+ viewFieldLWW,+ viewFieldMax,+ viewFieldMin,+ viewFieldSet,+ zoomFieldObject,+) where import RON.Prelude import qualified Data.Map.Strict as Map import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,- Replicated, ReplicatedAsObject,- ReplicatedAsPayload, encoding, eqPayload,- eqRef, fromRon, getObject,- getObjectStateChunk, mkStateChunk,+ Rep, Replicated (encoding),+ ReplicatedAsObject, ReplicatedAsPayload,+ eqPayload, eqRef, fromPayload, fromRon,+ getObject, getObjectState,+ getObjectStateChunk, modifyObjectStateChunk_, newObject, newRon,- objectEncoding, objectOpType,+ objectEncoding, rconcat, reduceObjectStates, reducibleOpType, stateFromChunk, stateToChunk)-import RON.Error (MonadE, throwErrorText)+import RON.Error (MonadE, errorContext, throwErrorText) import RON.Event (ReplicaClock, getEventUuid)+import RON.Semilattice (Semilattice) import RON.Types (Atom (AUuid), Object (Object),- Op (Op, opId, payload, refId),- StateChunk (StateChunk, stateBody, stateType, stateVersion),- UUID)+ Op (Op, opId, payload, refId), Payload,+ StateChunk (StateChunk), StateFrame, UUID,+ WireStateChunk (WireStateChunk, stateBody, stateType))+import RON.Util (Instance (Instance)) import RON.UUID (pattern Zero) import qualified RON.UUID as UUID -- | Untyped OR-Set.--- Implementation:--- a map from the last change (creation or deletion) to the original op.+-- Implementation: a map from the itemKey to the original op.+-- Each time a value is added, a new item=op is created.+-- Deletion of a value replaces all its known items with tombstone ops. newtype ORSetRep = ORSetRep (Map UUID Op) deriving (Eq, Show) -opKey :: Op -> UUID-opKey Op{opId, refId} = case refId of+itemKey :: Op -> UUID+itemKey Op{opId, refId} = case refId of Zero -> opId -- alive _ -> refId -- tombstone -observedRemove :: Op -> Op -> Op-observedRemove = maxOn refId+preferTombstone :: Op -> Op -> Op+preferTombstone = maxOn refId instance Semigroup ORSetRep where ORSetRep set1 <> ORSetRep set2 =- ORSetRep $ Map.unionWith observedRemove set1 set2+ ORSetRep $ Map.unionWith preferTombstone set1 set2 instance Monoid ORSetRep where mempty = ORSetRep mempty +-- | Laws:+-- 1. Idempotent because 'Map.unionWith' is idempotent.+-- 2. Commutative because 'preferTombstone' is commutative.+instance Semilattice ORSetRep+ instance Reducible ORSetRep where reducibleOpType = setType - stateFromChunk ops =- ORSetRep $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops]+ stateFromChunk ops = ORSetRep $+ Map.fromListWith preferTombstone [(itemKey op, op) | op <- ops] - stateToChunk (ORSetRep set) =- mkStateChunk setType . sortOn opId $ Map.elems set+ stateToChunk (ORSetRep set) = sortOn opId $ Map.elems set +wireStateChunk :: [Op] -> WireStateChunk+wireStateChunk stateBody = WireStateChunk{stateType = setType, stateBody}+ -- | Name-UUID to use as OR-Set type marker. setType :: UUID setType = $(UUID.liftName "set") --- | Type-directing wrapper for typed OR-Set+-- | Type-directing wrapper for typed OR-Set.+-- 'Eq' instance is purely technical, it doesn't use 'Ord', nor 'Hashable',+-- so its result may be confusing. newtype ORSet a = ORSet [a] deriving (Eq, Show)+{- TODO(2019-07-24, cblp, #102) data family ORSet c a where+ newtype instance ORSet Ord a = ORSetOrd (Set a)+ newtype instance ORSet Hashable a = ORSetHash (HashSet a)+-} instance Replicated a => Replicated (ORSet a) where encoding = objectEncoding instance Replicated a => ReplicatedAsObject (ORSet a) where- objectOpType = setType+ type Rep (ORSet a) = ORSetRep newObject (ORSet items) = do ops <- for items $ \item -> do@@ -93,30 +121,26 @@ payload <- newRon item pure $ Op event Zero payload oid <- getEventUuid- let stateVersion = maximumDef oid $ map opId ops- modify' $- (<>) $ Map.singleton oid $- StateChunk{stateType = setType, stateVersion, stateBody = ops}+ modify' $ Map.insert oid $ wireStateChunk ops pure $ Object oid getObject = do- StateChunk{stateBody} <- getObjectStateChunk- mItems <- for stateBody $ \Op{refId, payload} -> case refId of+ StateChunk ops <- getObjectStateChunk+ mItems <- for ops $ \Op{refId, payload} -> case refId of Zero -> do item <- fromRon payload pure $ Just item _ -> pure Nothing pure . ORSet $ catMaybes mItems + -- rempty = ORSet []+ -- | XXX Internal. Common implementation of 'addValue' and 'addRef'.-commonAdd :: (MonadE m, MonadObjectState a m, ReplicaClock m) => [Atom] -> m ()+commonAdd :: (MonadE m, MonadObjectState a m, ReplicaClock m) => Payload -> m () commonAdd payload =- modifyObjectStateChunk_ $ \StateChunk{stateBody} -> do+ modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do event <- getEventUuid- let newOp = Op event Zero payload- let chunk' = stateBody ++ [newOp]- pure StateChunk- {stateType = setType, stateVersion = event, stateBody = chunk'}+ pure $ StateChunk $ stateBody ++ [Op event Zero payload] -- | Encode a value and add a it to the OR-Set addValue@@ -134,26 +158,26 @@ -- | XXX Internal. Common implementation of 'removeValue' and 'removeRef'. commonRemove :: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)- => ([Atom] -> Bool) -> m ()+ => (Payload -> Bool) -> m () commonRemove isTarget =- modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do- let state0@(ORSetRep opMap) = stateFromChunk stateBody+ modifyObjectStateChunk_ $ \(StateChunk chunk) -> do+ let state0@(ORSetRep opMap) = stateFromChunk chunk let targetEvents =- [ opId- | Op{opId, refId, payload} <- toList opMap- , refId == Zero -- is alive+ [ op+ | op@Op{refId = Zero, payload} <- toList opMap , isTarget payload ]- case targetEvents of- [] -> pure chunk- _ -> do- tombstone <- getEventUuid- let patch =- [ Op{opId = tombstone, refId, payload = []}- | refId <- targetEvents- ]- let state' = state0 <> stateFromChunk patch- pure $ stateToChunk state'+ StateChunk <$>+ case targetEvents of+ [] -> pure chunk+ _ -> do+ tombstone <- getEventUuid+ let patch =+ [ op{opId = tombstone, refId = observed}+ | op@Op{opId = observed} <- targetEvents+ ]+ let state' = state0 <> stateFromChunk patch+ pure $ stateToChunk state' -- | Remove an atomic value from the OR-Set removeValue@@ -175,15 +199,14 @@ -- | Go from modification of the whole set to the modification of an item -- object.-zoom+zoomItem :: MonadE m => ORSetItem item -> ObjectStateT item m a -> ObjectStateT (ORSet item) m a-zoom (ORSetItem key) innerModifier = do- StateChunk{stateBody} <- getObjectStateChunk- let ORSetRep opMap = stateFromChunk stateBody+zoomItem (ORSetItem key) innerModifier = do+ ORSetRep opMap <- getObjectState itemValueRef <- case Map.lookup key opMap of Nothing ->- -- TODO(2019-08-07, cblp) creat empty object?+ -- TODO(2019-07-08, cblp) create empty object? throwErrorText "no such key in ORSet" Just Op{payload} -> case payload of [AUuid itemValueRef] -> pure itemValueRef@@ -194,14 +217,11 @@ findAnyAlive :: (MonadE m, MonadObjectState (ORSet item) m) => m (Maybe (ORSetItem item)) findAnyAlive = do- StateChunk{stateBody} <- getObjectStateChunk- pure $ let- ORSetRep opMap = stateFromChunk stateBody- aliveItems = [op | op@Op{refId = UUID.Zero} <- toList opMap]- in- case listToMaybe aliveItems of- Nothing -> Nothing- Just Op{opId} -> Just $ ORSetItem opId+ ORSetRep opMap <- getObjectState+ let aliveItems = [op | op@Op{refId = Zero} <- toList opMap]+ pure $ case listToMaybe aliveItems of+ Nothing -> Nothing+ Just Op{opId} -> Just $ ORSetItem opId -- | Find any alive item. If no alive item found, report an error. findAnyAlive'@@ -213,3 +233,154 @@ Nothing -> throwErrorText "empty set" type ORSetMap k v = ORSet (k, v)++-- | Assign a value to a field+assignField+ :: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState struct m)+ => UUID -- ^ Field name+ -> Maybe a -- ^ Value+ -> m ()+assignField field mvalue =+ modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do+ event <- getEventUuid+ valuePayload <- maybe (pure []) newRon mvalue+ let addOp = Op+ { opId = event+ , refId = Zero+ , payload = AUuid field : valuePayload+ }+ let (observedOps, stateBody1) = partition (isAliveField field) stateBody+ removeOps <- for observedOps $ \op@Op{opId = observedEvent} -> do+ tombstone <- getEventUuid -- TODO(2019-07-10, cblp) sequential+ pure op{opId = tombstone, refId = observedEvent}+ let stateBody2 = sortOn opId $ addOp : removeOps ++ stateBody1+ pure $ StateChunk stateBody2++isAliveField :: UUID -> Op -> Bool+isAliveField field = \case+ Op{refId = Zero, payload = AUuid field' : _} -> field == field'+ _ -> False++filterAliveFieldPayloads+ :: UUID -- ^ field+ -> [Op] -- ^ state body+ -> [Payload] -- ^ value payloads+filterAliveFieldPayloads field ops =+ [ valuePayload+ | Op{refId = Zero, payload = AUuid field' : valuePayload} <- ops+ , field' == field+ ]++filterAliveFieldIdsAndPayloads+ :: UUID -- ^ field+ -> [Op] -- ^ state body+ -> [(UUID, Payload)] -- ^ op ids and value payloads+filterAliveFieldIdsAndPayloads field ops =+ [ (opId, valuePayload)+ | Op{opId, refId = Zero, payload = AUuid field' : valuePayload} <- ops+ , field' == field+ ]++-- | Decode field value, merge all versions, return 'Nothing' if no versions+viewField+ :: (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)+ => UUID -- ^ Field name+ -> StateChunk ORSetRep -- ^ ORSet object chunk+ -> m (Maybe a)+viewField field (StateChunk stateBody) =+ errorContext "ORSet.viewField" $ do+ let payloads = filterAliveFieldPayloads field stateBody+ refs = [ref | AUuid ref : _ <- payloads]+ case refs of+ [] -> pure Nothing+ p:ps -> fmap Just . rconcat $ p :| ps++-- | Decode field value, keep last version only+viewFieldLWW+ :: (MonadE m, MonadState StateFrame m, Replicated a)+ => UUID -- ^ Field name+ -> StateChunk ORSetRep -- ^ ORSet object chunk+ -> m (Maybe a)+viewFieldLWW field (StateChunk stateBody) =+ errorContext "ORSet.viewFieldLWW" $ do+ let mPayload =+ fmap snd . maximumMayOn fst $+ filterAliveFieldIdsAndPayloads field stateBody+ case mPayload of+ Nothing -> pure Nothing+ Just [] -> pure Nothing+ Just payload -> Just <$> fromRon payload++-- | Decode field value, keep max value only, only for Integer and Float+viewFieldMax+ :: (MonadE m, Ord a, ReplicatedAsPayload a)+ => UUID -- ^ Field name+ -> StateChunk ORSetRep -- ^ ORSet object chunk+ -> m (Maybe a)+viewFieldMax field (StateChunk stateBody) =+ errorContext "ORSet.viewFieldMax" $+ fmap maximumMay $+ traverse fromPayload $+ filterAliveFieldPayloads field stateBody++-- | Decode field value, keep min value only, only for Integer and Float+viewFieldMin+ :: (MonadE m, Ord a, ReplicatedAsPayload a)+ => UUID -- ^ Field name+ -> StateChunk ORSetRep -- ^ ORSet object chunk+ -> m (Maybe a)+viewFieldMin field (StateChunk stateBody) =+ errorContext "ORSet.viewFieldMin" $+ fmap minimumMay $+ traverse fromPayload $+ filterAliveFieldPayloads field stateBody++-- | Decode field value, keep all versions+viewFieldSet+ :: (MonadE m, MonadState StateFrame m, Replicated a)+ => UUID -- ^ Field name+ -> StateChunk ORSetRep -- ^ ORSet object chunk+ -> m [a]+viewFieldSet field (StateChunk stateBody) =+ errorContext "ORSet.viewFieldSet" $+ traverse fromRon $+ filterAliveFieldPayloads field stateBody++-- | Pseudo-lens to an object inside a specified field+zoomFieldObject+ :: forall a field m struct+ . ( MonadE m+ , ReplicaClock m+ , ReplicatedAsObject field+ , ReplicatedAsObject struct+ )+ => UUID -- ^ Field name+ -> ObjectStateT field m a -- ^ Inner object modifier+ -> ObjectStateT struct m a+zoomFieldObject field innerModifier =+ errorContext ("ORSet.zoomFieldObject" <> show field) $ do+ (StateChunk stateBody) <- getObjectStateChunk+ let objectIds =+ [ objectId+ | AUuid objectId : _ <- filterAliveFieldPayloads field stateBody+ ]+ object <- case objectIds of+ [] -> Object <$> getEventUuid -- create empty object+ oid:oids -> reduceObjectStates @field $ fmap Object $ oid :| oids+ lift $ runReaderT innerModifier object++-- | Create an ORSet object from a list of named fields.+newStruct+ :: (MonadState StateFrame m, ReplicaClock m)+ => [(UUID, Maybe (Instance Replicated))] -> m UUID+newStruct fields = do+ objectId <- getEventUuid+ stateBody <-+ for fields $ \(name, mvalue) -> do+ opId <- getEventUuid -- TODO(2019-07-12, cblp, #15) sequential uuids+ valuePayload <- case mvalue of+ Just (Instance value) -> newRon value+ Nothing -> pure []+ pure Op{opId, refId = Zero, payload = AUuid name : valuePayload}+ modify' $ Map.insert objectId $ wireStateChunk stateBody+ pure objectId
lib/RON/Data/RGA.hs view
@@ -8,28 +8,29 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -- | Replicated Growable Array (RGA)-module RON.Data.RGA- ( RGA (..)- , RgaRep- , RgaString- , edit- , editText- , getAliveIndices- , getList- , getText- , insert- , insertAfter- , insertAtBegin- , insertText- , insertTextAfter- , insertTextAtBegin- , newFromList- , newFromText- , remove- , rgaType- ) where+module RON.Data.RGA (+ RGA (..),+ RgaRep,+ RgaString,+ edit,+ editText,+ getAliveIndices,+ getList,+ getText,+ insert,+ insertAfter,+ insertAtBegin,+ insertText,+ insertTextAfter,+ insertTextAtBegin,+ newFromList,+ newFromText,+ remove,+ rgaType,+) where import RON.Prelude @@ -41,20 +42,21 @@ import qualified Data.Text as Text import RON.Data.Internal (MonadObjectState,- ReducedChunk (ReducedChunk), Reducible,- Replicated, ReplicatedAsObject,- ReplicatedAsPayload, Unapplied,- applyPatches, encoding, fromRon, getObject,+ ReducedChunk (ReducedChunk, rcBody, rcRef),+ Reducible, Rep, Replicated (encoding),+ ReplicatedAsObject, ReplicatedAsPayload,+ Unapplied, applyPatches, fromRon, getObject, getObjectStateChunk, modifyObjectStateChunk_, newObject, newRon,- objectEncoding, objectOpType, rcBody, rcRef,- rcVersion, reduceUnappliedPatches,+ objectEncoding, reduceUnappliedPatches, reducibleOpType, stateFromChunk, stateToChunk, toPayload) import RON.Error (MonadE, errorContext, throwErrorText) import RON.Event (ReplicaClock, getEventUuid, getEventUuids)-import RON.Types (Object (Object), Op (..), StateChunk (..),- StateFrame, UUID)+import RON.Semilattice (Semilattice)+import RON.Types (Object (Object), Op (Op, opId, payload, refId),+ StateChunk (StateChunk), StateFrame, UUID,+ WireStateChunk (WireStateChunk, stateBody, stateType)) import RON.Util.Word (pattern B11, ls60) import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID@@ -112,7 +114,7 @@ -- | Untyped RGA newtype RgaRep = RgaRep (Maybe VertexList)- deriving (Eq, Monoid, Semigroup, Show)+ deriving (Eq, Monoid, Semigroup, Semilattice, Show) data PatchSet = PatchSet { psPatches :: Map UUID VertexList@@ -169,10 +171,7 @@ stateFromChunk = RgaRep . vertexListFromOps - stateToChunk (RgaRep rga) = StateChunk- {stateType = rgaType, stateVersion = chunkVersion stateBody, stateBody}- where- stateBody = maybe [] vertexListToOps rga+ stateToChunk (RgaRep rga) = maybe [] vertexListToOps rga applyPatches rga (patches, ops) = bimap id patchSetToChunks . reapplyPatchSetToState rga $@@ -183,8 +182,8 @@ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops patchSetToChunks :: PatchSet -> Unapplied-patchSetToChunks PatchSet{..} =- ( [ ReducedChunk{rcVersion = chunkVersion rcBody, ..}+patchSetToChunks PatchSet{psPatches, psRemovals} =+ ( [ ReducedChunk{..} | (rcRef, vertices) <- Map.assocs psPatches , let rcBody = vertexListToOps vertices ]@@ -193,12 +192,6 @@ ] ) -chunkVersion :: [Op] -> UUID-chunkVersion ops = maximumDef Zero- [ max vertexId tombstone- | Op{opId = vertexId, refId = tombstone} <- ops- ]- reapplyPatchSet :: PatchSet -> PatchSet reapplyPatchSet ps = continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches]@@ -335,22 +328,19 @@ instance Replicated a => Replicated (RGA a) where encoding = objectEncoding instance Replicated a => ReplicatedAsObject (RGA a) where- objectOpType = rgaType+ type Rep (RGA a) = RgaRep newObject (RGA items) = do+ oid <- getEventUuid vertexIds <- getEventUuids $ ls60 $ genericLength items ops <- for (zip items vertexIds) $ \(item, vertexId) -> do payload <- newRon item pure $ Op vertexId Zero payload- oid <- getEventUuid- let stateVersion = maximumDef oid $ map opId ops- modify' $- (<>) $ Map.singleton oid $- StateChunk{stateType = rgaType, stateVersion, stateBody = ops}+ modify' $ Map.insert oid $ wireStateChunk ops pure $ Object oid getObject = do- StateChunk{stateBody} <- getObjectStateChunk+ StateChunk stateBody <- getObjectStateChunk mItems <- for stateBody $ \Op{refId, payload} -> case refId of Zero -> Just <$> fromRon payload _ -> pure Nothing@@ -364,7 +354,7 @@ ) => [a] -> m () edit newItems =- modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do+ modifyObjectStateChunk_ $ \chunk@(StateChunk stateBody) -> do let newItems' = [Op Zero Zero $ toPayload item | item <- newItems] -- TODO(2019-04-17, #59, cblp) replace 'toPayload' with 'newRon' and -- relax constraint on 'a' from 'ReplicatedAsPayload' to@@ -380,20 +370,15 @@ pure op{refId = tombstone} op -> -- deleted already pure op- Both v _ -> pure v- Second added -> for added $ \op -> do+ Both v _ -> pure v+ Second added -> for added $ \op -> do -- TODO(2018-11-03, #15, cblp) get sequential ids opId <- getEventUuid tell . Last $ Just opId pure op{opId}- case lastEvent of- Nothing -> pure chunk- Just stateVersion' ->- pure StateChunk- { stateType = rgaType- , stateVersion = stateVersion'- , stateBody = stateBody'- }+ pure $ case lastEvent of+ Nothing -> chunk+ Just _ -> StateChunk stateBody' where eqAliveOnPayload Op{refId = Zero, payload = p1}@@ -425,7 +410,7 @@ getAliveIndices :: (MonadE m, MonadObjectState (RGA a) m) => m [UUID] getAliveIndices = do- StateChunk{stateBody} <- getObjectStateChunk+ StateChunk stateBody <- getObjectStateChunk let mItems = [ case refId of Zero -> Just opId@@ -451,18 +436,16 @@ -> m () insert [] _ = pure () insert items mPosition =- modifyObjectStateChunk_ $ \chunk@StateChunk{stateVersion, stateBody} -> do+ modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do vertexIds <- getEventUuids $ ls60 $ genericLength items ops <- for (zip items vertexIds) $ \(item, vertexId) -> do payload <- newRon item pure $ Op vertexId Zero payload-- let stateVersion' = maximumDef stateVersion $ map opId ops stateBody' <- case mPosition of Nothing -> pure $ ops <> stateBody Just position -> findAndInsertAfter position ops stateBody- pure chunk{stateVersion = stateVersion', stateBody = stateBody'}+ pure $ StateChunk stateBody' where findAndInsertAfter pos newOps = go where go = \case@@ -511,10 +494,10 @@ remove position = errorContext "RGA.remove" $ errorContext ("position = " <> show position) $- modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do+ modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do event <- getEventUuid stateBody' <- findAndTombstone event stateBody- pure chunk{stateVersion = event, stateBody = stateBody'}+ pure $ StateChunk stateBody' where findAndTombstone event = go where go = \case@@ -522,3 +505,6 @@ op@Op{opId} : ops | opId == position -> pure $ op{refId = event} : ops | otherwise -> (op :) <$> go ops++wireStateChunk :: [Op] -> WireStateChunk+wireStateChunk stateBody = WireStateChunk{stateType = rgaType, stateBody}
lib/RON/Data/VersionVector.hs view
@@ -2,21 +2,27 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -- | Version Vector-module RON.Data.VersionVector- ( VersionVector- ) where+module RON.Data.VersionVector (+ VersionVector,+) where import RON.Prelude import Data.Hashable (hashWithSalt) import qualified Data.Map.Strict as Map -import RON.Data.Internal+import RON.Data.Internal (Reducible, Rep, Replicated (encoding),+ ReplicatedAsObject, getObject,+ getObjectState, newObject, objectEncoding,+ reducibleOpType, stateFromChunk,+ stateToChunk) import RON.Event (getEventUuid)-import RON.Types (Object (Object), Op (..), StateChunk (..),- UUID (UUID))+import RON.Semilattice (Semilattice)+import RON.Types (Object (Object), Op (Op, opId), UUID (UUID), WireStateChunk (WireStateChunk, stateBody, stateType)) import qualified RON.UUID as UUID type Origin = Word64@@ -43,14 +49,22 @@ instance Monoid VersionVector where mempty = VersionVector mempty +-- | Laws:+-- 1. Idempotent because 'Map.unionWith' is idempotent.+-- 2. Commutative because 'latter' is commutative.+instance Semilattice VersionVector+ instance Reducible VersionVector where reducibleOpType = vvType stateFromChunk ops = VersionVector $ Map.fromListWith latter [(opOrigin op, op) | op <- ops] - stateToChunk (VersionVector vv) = mkStateChunk vvType $ Map.elems vv+ stateToChunk (VersionVector vv) = Map.elems vv +wireStateChunk :: [Op] -> WireStateChunk+wireStateChunk stateBody = WireStateChunk{stateType = vvType, stateBody}+ -- | Name-UUID to use as Version Vector type marker. vvType :: UUID vvType = $(UUID.liftName "vv")@@ -59,17 +73,14 @@ encoding = objectEncoding instance ReplicatedAsObject VersionVector where- objectOpType = vvType+ type Rep VersionVector = VersionVector newObject (VersionVector vv) = do oid <- getEventUuid let ops = Map.elems vv- let stateVersion = maximumDef oid $ map opId ops- modify' $- (<>) $ Map.singleton oid $- StateChunk{stateType = vvType, stateVersion, stateBody = ops}+ modify' $ Map.insert oid $ wireStateChunk ops pure $ Object oid - getObject = do- StateChunk{stateBody} <- getObjectStateChunk- pure $ stateFromChunk stateBody+ getObject = getObjectState++ -- rempty = mempty
ron-rdt.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-rdt-version: 0.7+version: 0.8 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database