ron-rdt 0.6 → 0.7
raw patch · 10 files changed
+622/−538 lines, 10 files
Files
- CHANGELOG.md +153/−0
- lib/RON/Data.hs +66/−11
- lib/RON/Data/Internal.hs +97/−32
- lib/RON/Data/LWW.hs +42/−46
- lib/RON/Data/ORSet.hs +139/−119
- lib/RON/Data/RGA.hs +106/−106
- lib/RON/Data/Time.hs +2/−0
- lib/RON/Data/VersionVector.hs +11/−8
- prelude/Prelude.hs +0/−189
- ron-rdt.cabal +6/−27
+ CHANGELOG.md view
@@ -0,0 +1,153 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0)+and this project adheres to+[Compatible Versioning](https://github.com/staltz/comver).++## [Unreleased]++## [0.7] - 2019-07-26+### Added+- `newObjectState`+- `ObjectState` "monad":+ - `ObjectStateT`, `MonadObjectState`+ - `evalObjectState`+ - `evalObjectState_`+ - `execObjectState`+ - `execObjectState_`+ - `newObjectState`+ - `newObjectStateWith`+ - `runObjectState`+ - `runObjectState_`+- `ORSet`:+ - Instances `Eq`, `Show` for `ORSet`.+ - `ORSetItem` type.+ - Methods `findAnyAlive`, `findAnyAlive'`, `zoom`.+- `ORSetMap` type.++### Changed+- `ReplicatedAsObject.newObject` now has more specific type,+ and implementation doesn't need to call `collectFrame`.+- Method `ReplicatedAsObject.newObject` is now a function `newObject` with the+ same type.+- Now `ObjectState` keeps a typed reference to an object with state frame+ attached,+ and `Object` is just a type UUID --+ a typed reference to an object in a state frame passed in+ `MonadObjectState` context.+ Object is now passed as an explicit argument.+- `ORSet` now can contain objects.+- `ORSet.addValue` now accepts objects.+- Renamed `LwwPerField` to `LwwRep`.+- Renamed `RgaRaw` to `RgaRep`.+- Renamed `ORSetRaw` to `ORSetRep`.++### Removed+- `ObjectORSet` merged into `ORSet`.+- `ORSet.addNewRef` merged into `addValue`.++## [0.6] - 2019-04-25+### Added+- `RON.Data.RGA`:+ - `getAliveIndices`+ - `insert`+ - `insertAfter`+ - `insertAtBegin`+ - `insertText`+ - `insertTextAfter`+ - `insertTextAtBegin`+ - `remove`++## [0.5] - 2019-02-04+### Added+- `RON.UUID.liftName` function to create name UUIDs in compile time.+- `RON.Util.ByteStringL` type.+- `RON.Error` module with unified pretty errors.+- Organize `Replicated`, `ReplicatedAsPayload`, and `ReplicatedAsObject` in+ class hierarchy.+- Add `ORSet.removeValue` and `removeRef` implementation.+- Op "patterns" and patterns.++### Removed+- Type alias `ObjectId` since objects are identified by UUID.++### Changed+- Extracted `ron-storage` package.+- Extracted `ron-schema` package.+- Extracted `ron-rdt` package.+- Switched from `Either String a` to `MonadError String m => m a` in failable+ procedures.+- `ORSet.addRef` now adds item's frame, too.+- `ORSet.addNewRef` now returns the reference to the freshly created object.+- Change `StateFrame` key to UUID since objects are identified by UUID.+- Renamed `RawOp` to `ClosedOp` according to the fresh spec.++### Fixed+- Error handling in Boole decoder.++## [0.4] - 2019-01-09+### Added+- Schema `enum` declaration.+- `docIdFromUuid`.+- `OnDocumentChanged` is called each time when any document is changed.++### Changed+- Made GHC 8.6 default.++### Removed+- Schema embedded DSL helpers: `atomInteger`, `atomString`, `boole`, `char`,+ `field`, `option`, `orSet`, `rgaString`, `structLww`, `versionVector`.++### Fixed+- `RGA.edit` bug with re-adding deleted items (#39).++## [0.3] - 2018-12-05+### Added+- Encode/decode EpochTime.+- EDN-based schema DSL.++### Removed+- `RON.Storage.createVersion` from public API.+- `NFData` instances.++## [0.2] - 2018-11-20+### Added+- Schema boole type.+- RON.Storage and submodules are moved from ff project.+- RON.Schema is now re-exported via RON.Schema.TH.++### Changed+- Renamed UUID field "schema" to "version", according to changes in the+ specification.+- RGA: sequential UUIDs on initialization.+- Optimized `Base64.isLetter`.+- Extend `UUID.mkName` to accept any monad.+- Renamed `MonadStorage` methods `list...` -> `get...`+- Renamed `RON.Storage.saveDocument` -> `createDocument`++### Removed+- `RON.Storage.uuidToFileName` as it has no sense as an abstraction+- `RON.Storage.IO.runStorageT` with `StorageT`++## [0.1] - 2018-11-08+### Added+- Package `ron`+ - RON-text format+ - RON-binary format+ - RON-RDT:+ - LWW+ - RGA+ - OR-Set+ - VersionVector+ - 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+[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+[0.3]: https://github.com/ff-notes/ff/compare/v0.2...v0.3+[0.2]: https://github.com/ff-notes/ff/compare/v0.1...v0.2+[0.1]: https://github.com/ff-notes/ff/tree/v0.1
lib/RON/Data.hs view
@@ -23,19 +23,33 @@ reduceObject, reduceStateFrame, reduceWireFrame,+ -- * 'ObjectState' monad+ ObjectStateT,+ MonadObjectState,+ evalObjectState,+ evalObjectState_,+ execObjectState,+ execObjectState_,+ newObjectState,+ newObjectStateWith,+ runObjectState,+ runObjectState_, ) where +import RON.Prelude+ import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict ((!?)) import qualified Data.Map.Strict as Map import RON.Data.Internal-import RON.Data.LWW (LwwPerField)-import RON.Data.ORSet (ORSetRaw)-import RON.Data.RGA (RgaRaw)+import RON.Data.LWW (LwwRep)+import RON.Data.ORSet (ORSetRep)+import RON.Data.RGA (RgaRep) import RON.Data.VersionVector (VersionVector) import RON.Error (MonadE, throwErrorString)-import RON.Types (ClosedOp (..), Object (..), Op (..),+import RON.Types (ClosedOp (..), Object (Object),+ ObjectState (ObjectState, frame, uuid), Op (..), StateChunk (..), StateFrame, UUID, WireChunk (Closed, Query, Value), WireFrame, WireReducedChunk (..))@@ -44,9 +58,9 @@ reducers :: Map UUID Reducer reducers = Map.fromList- [ mkReducer @LwwPerField- , mkReducer @RgaRaw- , mkReducer @ORSetRaw+ [ mkReducer @LwwRep+ , mkReducer @RgaRep+ , mkReducer @ORSetRep , mkReducer @VersionVector ] @@ -170,14 +184,15 @@ throwErrorString $ "Cannot reduce StateFrame of unknown type " ++ show stateType -unsafeReduceObject :: MonadE m => Object a -> StateFrame -> m (Object a)-unsafeReduceObject obj@Object{frame = s1} s2 = do+unsafeReduceObject+ :: MonadE m => ObjectState a -> StateFrame -> m (ObjectState a)+unsafeReduceObject obj@ObjectState{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 => Object a -> Object a -> m (Object a)-reduceObject o1@Object{id = id1} Object{id = id2, frame = frame2}+reduceObject :: MonadE m => ObjectState a -> ObjectState a -> m (ObjectState a)+reduceObject o1@ObjectState{uuid = id1} ObjectState{uuid = id2, frame = frame2} | id1 == id2 = unsafeReduceObject o1 frame2 | otherwise = throwErrorString $ "Object ids differ: " ++ show (id1, id2) @@ -187,3 +202,43 @@ mof1@(MaxOnFst (a1, _)) <> mof2@(MaxOnFst (a2, _)) | a1 < a2 = mof2 | otherwise = mof1++-- | Run ObjectState action+evalObjectState :: Monad m => ObjectState b -> ObjectStateT b m a -> m a+evalObjectState ObjectState{uuid, frame} action =+ evalStateT (runReaderT action $ Object uuid) frame++-- | Run ObjectState action, starting with an empty frame+evalObjectState_ :: Monad m => StateT StateFrame m a -> m a+evalObjectState_ action = evalStateT action mempty++-- | Run ObjectState action+execObjectState+ :: Monad m => ObjectState b -> ObjectStateT b m a -> m (ObjectState b)+execObjectState state@ObjectState{uuid, frame} action = do+ frame' <- execStateT (runReaderT action $ Object uuid) frame+ pure state{frame = frame'}++-- | Run ObjectState action, starting with an empty frame+execObjectState_ :: Monad m => StateT StateFrame m a -> m StateFrame+execObjectState_ action = execStateT action mempty++-- | Run ObjectState action+runObjectState+ :: Functor m+ => ObjectState b+ -> ObjectStateT b m a+ -> m (a, ObjectState b)+runObjectState state@ObjectState{uuid, frame} action =+ runStateT (runReaderT action $ Object uuid) frame+ <&> \(a, frame') -> (a, state{frame = frame'})++-- | Run ObjectState 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}
lib/RON/Data/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}@@ -19,24 +20,35 @@ ReplicatedAsPayload (..), Unapplied, WireReducer,- collectFrame,+ advanceToObject, eqPayload, eqRef,- fromRon, getObjectStateChunk, mkStateChunk,- newRon,+ modifyObjectStateChunk,+ modifyObjectStateChunk_,+ newObjectState,+ -- objectEncoding, payloadEncoding,+ --+ fromRon,+ newRon,+ --+ ObjectStateT,+ MonadObjectState, ) where +import RON.Prelude+ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import RON.Error (MonadE, errorContext, liftMaybe)-import RON.Event (ReplicaClock)+import RON.Event (ReplicaClock, advanceToUuid) import RON.Types (Atom (AInteger, AString, AUuid), Object (Object),- Op (Op, opId),+ ObjectState (ObjectState, frame, uuid),+ Op (Op, opId, payload, refId), StateChunk (StateChunk, stateBody, stateType, stateVersion), StateFrame, UUID (UUID), WireChunk) import RON.UUID (zero)@@ -128,37 +140,42 @@ data Encoding a = Encoding { encodingNewRon- :: forall m . ReplicaClock m => a -> WriterT StateFrame m [Atom]- , encodingFromRon :: forall m . MonadE m => [Atom] -> StateFrame -> m a+ :: forall m+ . (ReplicaClock m, MonadState StateFrame m) => a -> m [Atom]+ , encodingFromRon+ :: forall m . (MonadE m, MonadState StateFrame m) => [Atom] -> m a } -- | Encode typed data to a payload with possible addition objects-newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame m [Atom]+newRon+ :: (Replicated a, ReplicaClock m, MonadState StateFrame m) => a -> m [Atom] newRon = encodingNewRon encoding -- | Decode typed data from a payload. -- The implementation may use other objects in the frame to resolve references.-fromRon :: (MonadE m, Replicated a) => [Atom] -> StateFrame -> m a+-- TODO(2019-06-28, cblp) use 'ReaderT' for symmetry with 'newRon'+fromRon :: (MonadE m, Replicated a, MonadState StateFrame m) => [Atom] -> m a fromRon = encodingFromRon encoding -- | Standard implementation of 'Replicated' for 'ReplicatedAsObject' types. objectEncoding :: ReplicatedAsObject a => Encoding a objectEncoding = Encoding { encodingNewRon = \a -> do- Object oid frame <- lift $ newObject a- tell frame- pure [AUuid oid]- , encodingFromRon = objectFromRon getObject+ Object uuid <- newObject a+ pure [AUuid uuid]+ , encodingFromRon = objectFromRon $ runReaderT getObject } -- | Standard implementation of 'Replicated' for 'ReplicatedAsPayload' types. payloadEncoding :: ReplicatedAsPayload a => Encoding a payloadEncoding = Encoding { encodingNewRon = pure . toPayload- , encodingFromRon = \atoms _ -> fromPayload atoms+ , encodingFromRon = fromPayload } -- | Instances of this class are encoded as payload only.+--+-- Law: @'encoding' == 'payloadEncoding'@ class Replicated a => ReplicatedAsPayload a where -- | Encode data@@ -201,33 +218,61 @@ -- | Instances of this class are encoded as objects. -- An enclosing object's payload will be filled with this object's id.+--+-- Law: @'encoding' == 'objectEncoding'@ class Replicated a => ReplicatedAsObject a where -- | UUID of the type objectOpType :: UUID - -- | Encode data- newObject :: ReplicaClock m => a -> m (Object a)+ -- | Encode data. Write frame and return id.+ newObject :: (ReplicaClock m, MonadState StateFrame m) => a -> m (Object a) -- | Decode data- getObject :: MonadE m => Object a -> m a+ getObject :: (MonadE m, MonadObjectState a m) => m a -objectFromRon :: MonadE m => (Object a -> m a) -> [Atom] -> StateFrame -> m a-objectFromRon handler atoms frame = case atoms of- [AUuid oid] -> handler $ Object oid frame- _ -> throwError "Expected object UUID"+objectFromRon :: MonadE m => (Object a -> m a) -> [Atom] -> m a+objectFromRon handler atoms = case atoms of+ [AUuid uuid] -> handler $ Object uuid+ _ -> throwError "Expected object UUID" --- | Helper to build an object frame using arbitrarily nested serializers.-collectFrame :: Functor m => WriterT StateFrame m UUID -> m (Object a)-collectFrame = fmap (uncurry Object) . runWriterT+-- | Create new 'ObjectState' from a value+newObjectState+ :: (ReplicatedAsObject a, ReplicaClock m) => a -> m (ObjectState a)+newObjectState a = do+ (Object uuid, frame) <- runStateT (newObject a) mempty+ pure $ ObjectState{uuid, frame} -getObjectStateChunk :: MonadE m => Object a -> m StateChunk-getObjectStateChunk (Object oid frame) =- liftMaybe "no such object in chunk" $ Map.lookup oid frame+getObjectStateChunk :: (MonadE m, MonadObjectState a m) => m StateChunk+getObjectStateChunk = do+ Object uuid <- ask+ frame <- get+ liftMaybe "no such object in chunk" $ Map.lookup uuid frame +modifyObjectStateChunk+ :: (MonadObjectState a m, ReplicaClock m, MonadE m)+ => (StateChunk -> m (b, StateChunk)) -> m b+modifyObjectStateChunk f = do+ 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'+ pure a++modifyObjectStateChunk_+ :: (MonadObjectState a m, ReplicaClock m, MonadE m)+ => (StateChunk -> m StateChunk) -> m ()+modifyObjectStateChunk_ f = modifyObjectStateChunk $ \chunk -> do+ chunk' <- f chunk+ pure ((), chunk')+ eqRef :: Object a -> [Atom] -> Bool-eqRef (Object oid _) atoms = case atoms of- [AUuid ref] -> oid == ref+eqRef (Object uuid) atoms = case atoms of+ [AUuid ref] -> uuid == ref _ -> False eqPayload :: ReplicatedAsPayload a => a -> [Atom] -> Bool@@ -244,9 +289,9 @@ { encodingNewRon = \case Just a -> (Some :) <$> newRon a Nothing -> pure [None]- , encodingFromRon = \atoms frame ->+ , encodingFromRon = \atoms -> errorContext "Option" $ case atoms of- Some : atoms' -> Just <$> fromRon atoms' frame+ Some : atoms' -> Just <$> fromRon atoms' [None] -> pure Nothing _ -> throwError "Bad Option" }@@ -273,7 +318,27 @@ | b = [ATrue] | otherwise = [AFalse] - fromPayload = errorContext "Boole" . \case+ fromPayload = errorContext "Bool" . \case [ATrue] -> pure True [AFalse] -> pure False _ -> throwError "Expected single UUID `true` or `false`"++type ObjectStateT b m a = ReaderT (Object b) (StateT StateFrame m) a++type MonadObjectState b m = (MonadReader (Object b) m, MonadState StateFrame m)++advanceToObject :: (MonadE m, MonadObjectState a m, ReplicaClock m) => m ()+advanceToObject = do+ Object uuid <- ask+ StateChunk{stateBody} <- getObjectStateChunk+ advanceToUuid $+ maximumDef+ uuid+ [ max opId $ maximumDef refId $ mapMaybe atomAsUuid payload+ | Op{opId, refId, payload} <- stateBody+ ]+ where+ -- | TODO(2019-07-26, cblp) Use lens+ atomAsUuid = \case+ AUuid u -> Just u+ _ -> Nothing
lib/RON/Data/LWW.hs view
@@ -9,7 +9,7 @@ -- | LWW-per-field RDT module RON.Data.LWW- ( LwwPerField (..)+ ( LwwRep (..) , assignField , lwwType , newObject@@ -18,12 +18,14 @@ , zoomField ) where +import RON.Prelude+ import qualified Data.Map.Strict as Map -import RON.Data.Internal (Reducible, Replicated, collectFrame,- fromRon, getObjectStateChunk, mkStateChunk,- newRon, reducibleOpType, stateFromChunk,- stateToChunk)+import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,+ Replicated, fromRon, getObjectStateChunk,+ mkStateChunk, newRon, reducibleOpType,+ stateFromChunk, stateToChunk) import RON.Error (MonadE, errorContext) import RON.Event (ReplicaClock, advanceToUuid, getEventUuid) import RON.Types (Atom (AUuid), Object (..), Op (..), StateChunk (..),@@ -36,32 +38,34 @@ lww = maxOn opId -- | Untyped LWW. Implementation: a map from 'opRef' to the original op.-newtype LwwPerField = LwwPerField (Map UUID Op)+newtype LwwRep = LwwRep (Map UUID Op) deriving (Eq, Monoid, Show) -instance Semigroup LwwPerField where- LwwPerField fields1 <> LwwPerField fields2 =- LwwPerField $ Map.unionWith lww fields1 fields2+instance Semigroup LwwRep where+ LwwRep fields1 <> LwwRep fields2 =+ LwwRep $ Map.unionWith lww fields1 fields2 -instance Reducible LwwPerField where+instance Reducible LwwRep where reducibleOpType = lwwType stateFromChunk ops =- LwwPerField $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops]+ LwwRep $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops] - stateToChunk (LwwPerField fields) = mkStateChunk lwwType $ Map.elems fields+ stateToChunk (LwwRep fields) = mkStateChunk lwwType $ Map.elems fields -- | Name-UUID to use as LWW type marker. lwwType :: UUID lwwType = $(UUID.liftName "lww") -- | Create LWW object from a list of named fields.-newObject :: ReplicaClock m => [(UUID, Instance Replicated)] -> m (Object a)-newObject fields = collectFrame $ do+newObject+ :: (MonadState StateFrame m, ReplicaClock m)+ => [(UUID, Instance Replicated)] -> m UUID+newObject fields = do payloads <- for fields $ \(_, Instance value) -> newRon value- event <- lift getEventUuid- tell $- Map.singleton event $+ event <- getEventUuid+ modify' $+ (<>) $ Map.singleton event $ StateChunk { stateType = lwwType , stateVersion = event@@ -72,70 +76,62 @@ -- | Decode field value viewField- :: (Replicated a, MonadE m)+ :: (Replicated a, MonadE m, MonadState StateFrame m) => UUID -- ^ Field name -> StateChunk -- ^ LWW object chunk- -> StateFrame -> m a-viewField field StateChunk{..} frame =+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 frame+ fromRon payload -- | Decode field value readField- :: (MonadE m, MonadState (Object a) m, Replicated b)+ :: (MonadE m, MonadObjectState struct m, Replicated field) => UUID -- ^ Field name- -> m b+ -> m field readField field = do- obj@Object{..} <- get- stateChunk <- getObjectStateChunk obj- viewField field stateChunk frame+ stateChunk <- getObjectStateChunk+ viewField field stateChunk -- | Assign a value to a field assignField- :: forall a b m- . (Replicated b, ReplicaClock m, MonadE m, MonadState (Object a) m)- => UUID -- ^ Field name- -> b -- ^ Value (from untyped world)+ :: (Replicated field, ReplicaClock m, MonadE m, MonadObjectState struct m)+ => UUID -- ^ Field name+ -> field -- ^ Value -> m () assignField field value = do- obj@Object{id, frame} <- get- StateChunk{..} <- getObjectStateChunk obj+ StateChunk{stateBody, stateVersion} <- getObjectStateChunk advanceToUuid stateVersion let chunk = filter (\Op{refId} -> refId /= field) stateBody event <- getEventUuid- (p, frame') <- runWriterT $ newRon value+ p <- newRon value let newOp = Op event field p let chunk' = sortOn refId $ newOp : chunk let state' = StateChunk {stateVersion = event, stateBody = chunk', stateType = lwwType}- put obj{frame = Map.insert id state' frame <> frame'}+ Object uuid <- ask+ modify' $ Map.insert uuid state' --- | Anti-lens to an object inside a specified field+-- | Pseudo-lens to an object inside a specified field zoomField :: MonadE m- => UUID -- ^ Field name- -> StateT (Object inner) m a -- ^ Nested object modifier- -> StateT (Object outer) m a+ => UUID -- ^ Field name+ -> ObjectStateT field m a -- ^ Inner object modifier+ -> ObjectStateT struct m a zoomField field innerModifier = errorContext ("LWW.zoomField" <> show field) $ do- obj@Object{..} <- get- StateChunk{..} <- getObjectStateChunk obj+ StateChunk{stateBody} <- getObjectStateChunk let ops = filter (\Op{refId} -> refId == field) stateBody Op{payload} <- case ops of [] -> throwError "empty chunk" [op] -> pure op _ -> throwError "unreduced state"- innerObjectId <- errorContext "inner object" $ case payload of+ fieldObjectId <- errorContext "inner object" $ case payload of [AUuid oid] -> pure oid _ -> throwError "Expected object UUID"- let innerObject = Object innerObjectId frame- (a, Object{frame = frame'}) <-- lift $ runStateT innerModifier innerObject- put obj{frame = frame'}- pure a+ lift $ runReaderT innerModifier $ Object fieldObjectId
lib/RON/Data/ORSet.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}@@ -10,21 +9,34 @@ -- | Observed-Remove Set (OR-Set) module RON.Data.ORSet ( ORSet (..)- , ObjectORSet (..)- , ORSetRaw- , addNewRef+ , ORSetItem (..)+ , ORSetMap+ , ORSetRep , addRef , addValue+ , findAnyAlive+ , findAnyAlive' , removeRef , removeValue+ , zoom ) where +import RON.Prelude+ import qualified Data.Map.Strict as Map -import RON.Data.Internal-import RON.Error (MonadE)+import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,+ Replicated, ReplicatedAsObject,+ ReplicatedAsPayload, encoding, eqPayload,+ eqRef, fromRon, getObject,+ getObjectStateChunk, mkStateChunk,+ modifyObjectStateChunk_, newObject, newRon,+ objectEncoding, objectOpType,+ reducibleOpType, stateFromChunk,+ stateToChunk)+import RON.Error (MonadE, throwErrorText) import RON.Event (ReplicaClock, getEventUuid)-import RON.Types (Atom, Object (Object, frame, id),+import RON.Types (Atom (AUuid), Object (Object), Op (Op, opId, payload, refId), StateChunk (StateChunk, stateBody, stateType, stateVersion), UUID)@@ -34,7 +46,7 @@ -- | Untyped OR-Set. -- Implementation: -- a map from the last change (creation or deletion) to the original op.-newtype ORSetRaw = ORSetRaw (Map UUID Op)+newtype ORSetRep = ORSetRep (Map UUID Op) deriving (Eq, Show) opKey :: Op -> UUID@@ -45,151 +57,159 @@ observedRemove :: Op -> Op -> Op observedRemove = maxOn refId -instance Semigroup ORSetRaw where- ORSetRaw set1 <> ORSetRaw set2 =- ORSetRaw $ Map.unionWith observedRemove set1 set2+instance Semigroup ORSetRep where+ ORSetRep set1 <> ORSetRep set2 =+ ORSetRep $ Map.unionWith observedRemove set1 set2 -instance Monoid ORSetRaw where- mempty = ORSetRaw mempty+instance Monoid ORSetRep where+ mempty = ORSetRep mempty -instance Reducible ORSetRaw where+instance Reducible ORSetRep where reducibleOpType = setType stateFromChunk ops =- ORSetRaw $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops]+ ORSetRep $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops] - stateToChunk (ORSetRaw set) =+ stateToChunk (ORSetRep set) = mkStateChunk setType . sortOn opId $ Map.elems set -- | Name-UUID to use as OR-Set type marker. setType :: UUID setType = $(UUID.liftName "set") --- | Type-directing wrapper for typed OR-Set of atomic values+-- | Type-directing wrapper for typed OR-Set newtype ORSet a = ORSet [a]---- | Type-directing wrapper for typed OR-Set of objects-newtype ObjectORSet a = ObjectORSet [a]+ deriving (Eq, Show) -instance ReplicatedAsPayload a => Replicated (ORSet a) where+instance Replicated a => Replicated (ORSet a) where encoding = objectEncoding -instance ReplicatedAsPayload a => ReplicatedAsObject (ORSet a) where+instance Replicated a => ReplicatedAsObject (ORSet a) where objectOpType = setType- newObject = commonNewObject pure- getObject = commonGetObject pure -instance ReplicatedAsObject a => Replicated (ObjectORSet a) where- encoding = objectEncoding--instance ReplicatedAsObject a => ReplicatedAsObject (ObjectORSet a) where- objectOpType = setType- newObject = commonNewObject $ fmap (\Object{id} -> id) . newObject- getObject obj@Object{frame} =- commonGetObject (\itemId -> getObject (Object itemId frame)) obj--commonNewObject- :: ( Coercible (orset item) [item]- , ReplicaClock m- , ReplicatedAsPayload itemRep- )- => (item -> m itemRep) -> orset item -> m (Object (orset item))-commonNewObject newItem items = collectFrame $ do- ops <- for (coerce items) $ \item -> do- event <- lift getEventUuid- payload <- lift $ newItem item- pure . Op event Zero $ toPayload payload- oid <- lift getEventUuid- let stateVersion = maximumDef oid $ map opId ops- tell $- Map.singleton oid $- StateChunk{stateType = setType, stateVersion, stateBody = ops}- pure oid+ newObject (ORSet items) = do+ ops <- for items $ \item -> do+ event <- getEventUuid+ 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}+ pure $ Object oid -commonGetObject- :: forall item m orset itemRep- . (Coercible (orset item) [item], MonadE m, ReplicatedAsPayload itemRep)- => (itemRep -> m item) -> Object (orset item) -> m (orset item)-commonGetObject getItem obj@Object{..} = do- StateChunk{..} <- getObjectStateChunk obj- mItems <- for stateBody $ \Op{refId, payload} -> case refId of- Zero -> Just <$> (fromPayload payload >>= getItem)- _ -> pure Nothing- pure . coerce @[item] $ catMaybes mItems+ getObject = do+ StateChunk{stateBody} <- getObjectStateChunk+ mItems <- for stateBody $ \Op{refId, payload} -> case refId of+ Zero -> do+ item <- fromRon payload+ pure $ Just item+ _ -> pure Nothing+ pure . ORSet $ catMaybes mItems -- | XXX Internal. Common implementation of 'addValue' and 'addRef'.-commonAdd :: (ReplicatedAsPayload b, ReplicaClock m, MonadE m)- => b -> StateT (Object a) m ()-commonAdd item = do- obj@Object{id, frame} <- get- StateChunk{..} <- getObjectStateChunk obj- event <- getEventUuid- let payload = toPayload item- let newOp = Op event Zero payload- let chunk' = stateBody ++ [newOp]- let state' = StateChunk+commonAdd :: (MonadE m, MonadObjectState a m, ReplicaClock m) => [Atom] -> m ()+commonAdd payload =+ modifyObjectStateChunk_ $ \StateChunk{stateBody} -> do+ event <- getEventUuid+ let newOp = Op event Zero payload+ let chunk' = stateBody ++ [newOp]+ pure StateChunk {stateType = setType, stateVersion = event, stateBody = chunk'}- put obj{frame = Map.insert id state' frame} --- | Add atomic value to the OR-Set+-- | Encode a value and add a it to the OR-Set addValue- :: (ReplicatedAsPayload a, ReplicaClock m, MonadE m)- => a -> StateT (Object (ORSet a)) m ()-addValue = commonAdd+ :: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState (ORSet a) m)+ => a -> m ()+addValue item = do+ payload <- newRon item+ commonAdd payload --- | Add a reference to the object to the OR-Set addRef- :: (ReplicaClock m, MonadE m)- => Object a -> StateT (Object (ObjectORSet a)) m ()-addRef Object{id = itemId, frame = itemFrame} = do- modify' $ \Object{..} -> Object{frame = frame <> itemFrame, ..}- commonAdd itemId---- | Encode an object and add a reference to it to the OR-Set-addNewRef- :: forall a m- . (ReplicatedAsObject a, ReplicaClock m, MonadE m)- => a -> StateT (Object (ObjectORSet a)) m (Object a)-addNewRef item = do- itemObj@(Object _ itemFrame) <- lift $ newObject item- modify' $ \Object{..} -> Object{frame = frame <> itemFrame, ..}- addRef itemObj- pure itemObj+ :: (ReplicaClock m, MonadE m, MonadObjectState (ORSet a) m)+ => Object a -> m ()+addRef (Object itemUuid) = commonAdd [AUuid itemUuid] -- | XXX Internal. Common implementation of 'removeValue' and 'removeRef'. commonRemove- :: (MonadE m, ReplicaClock m)- => ([Atom] -> Bool) -> StateT (Object (orset a)) m ()-commonRemove isTarget = do- obj@Object{id, frame} <- get- StateChunk{..} <- getObjectStateChunk obj- let state0@(ORSetRaw opMap) = stateFromChunk stateBody- let targetEvents =- [ opId- | Op{opId, refId, payload} <- toList opMap- , refId == Zero -- is alive- , isTarget payload- ]- case targetEvents of- [] -> pure ()- _ -> do- tombstone <- getEventUuid- let patch =- [ Op{opId = tombstone, refId, payload = []}- | refId <- targetEvents- ]- let chunk' = state0 <> stateFromChunk patch- let state' = stateToChunk chunk'- put obj{frame = Map.insert id state' frame}+ :: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)+ => ([Atom] -> Bool) -> m ()+commonRemove isTarget =+ modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do+ let state0@(ORSetRep opMap) = stateFromChunk stateBody+ let targetEvents =+ [ opId+ | Op{opId, refId, payload} <- toList opMap+ , refId == Zero -- is alive+ , 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' -- | Remove an atomic value from the OR-Set removeValue- :: (ReplicatedAsPayload a, MonadE m, ReplicaClock m)- => a -> StateT (Object (ORSet a)) m ()+ :: ( ReplicatedAsPayload a+ , MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m+ )+ => a -> m () removeValue = commonRemove . eqPayload -- | Remove an object reference from the OR-Set removeRef- :: (MonadE m, ReplicaClock m)- => Object a -> StateT (Object (ObjectORSet a)) m ()+ :: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)+ => Object a -> m () removeRef = commonRemove . eqRef++-- | Reference to an item inside an 'ORSet'.+newtype ORSetItem a = ORSetItem UUID+ deriving (Show)++-- | Go from modification of the whole set to the modification of an item+-- object.+zoom+ :: 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+ itemValueRef <- case Map.lookup key opMap of+ Nothing ->+ -- TODO(2019-08-07, cblp) creat empty object?+ throwErrorText "no such key in ORSet"+ Just Op{payload} -> case payload of+ [AUuid itemValueRef] -> pure itemValueRef+ _ -> throwErrorText "item payload is not an object ref"+ lift $ runReaderT innerModifier $ Object itemValueRef++-- | Find any alive item. If no alive item found, return 'Nothing'.+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++-- | Find any alive item. If no alive item found, report an error.+findAnyAlive'+ :: (MonadE m, MonadObjectState (ORSet item) m) => m (ORSetItem item)+findAnyAlive' = do+ mx <- findAnyAlive+ case mx of+ Just x -> pure x+ Nothing -> throwErrorText "empty set"++type ORSetMap k v = ORSet (k, v)
lib/RON/Data/RGA.hs view
@@ -12,7 +12,7 @@ -- | Replicated Growable Array (RGA) module RON.Data.RGA ( RGA (..)- , RgaRaw+ , RgaRep , RgaString , edit , editText@@ -31,6 +31,8 @@ , rgaType ) where +import RON.Prelude+ import Data.Algorithm.Diff (Diff (Both, First, Second), getGroupedDiffBy) import qualified Data.HashMap.Strict as HashMap@@ -38,11 +40,21 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text -import RON.Data.Internal+import RON.Data.Internal (MonadObjectState,+ ReducedChunk (ReducedChunk), Reducible,+ Replicated, ReplicatedAsObject,+ ReplicatedAsPayload, Unapplied,+ applyPatches, encoding, fromRon, getObject,+ getObjectStateChunk,+ modifyObjectStateChunk_, newObject, newRon,+ objectEncoding, objectOpType, rcBody, rcRef,+ rcVersion, reduceUnappliedPatches,+ reducibleOpType, stateFromChunk,+ stateToChunk, toPayload) import RON.Error (MonadE, errorContext, throwErrorText)-import RON.Event (ReplicaClock, advanceToUuid, getEventUuid,- getEventUuids)-import RON.Types (Object (..), Op (..), StateChunk (..), UUID)+import RON.Event (ReplicaClock, getEventUuid, getEventUuids)+import RON.Types (Object (Object), Op (..), StateChunk (..),+ StateFrame, UUID) import RON.Util.Word (pattern B11, ls60) import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID@@ -99,7 +111,7 @@ HashMap.insert opId (item $ Just listHead) listItems -- | Untyped RGA-newtype RgaRaw = RgaRaw (Maybe VertexList)+newtype RgaRep = RgaRep (Maybe VertexList) deriving (Eq, Monoid, Semigroup, Show) data PatchSet = PatchSet@@ -152,18 +164,18 @@ Just patch -> mempty{psPatches = Map.singleton rcRef patch} Nothing -> mempty -instance Reducible RgaRaw where+instance Reducible RgaRep where reducibleOpType = rgaType - stateFromChunk = RgaRaw . vertexListFromOps+ stateFromChunk = RgaRep . vertexListFromOps - stateToChunk (RgaRaw rga) = StateChunk+ stateToChunk (RgaRep rga) = StateChunk {stateType = rgaType, stateVersion = chunkVersion stateBody, stateBody} where stateBody = maybe [] vertexListToOps rga applyPatches rga (patches, ops) =- bimap identity patchSetToChunks . reapplyPatchSetToState rga $+ bimap id patchSetToChunks . reapplyPatchSetToState rga $ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops reduceUnappliedPatches (patches, ops) =@@ -191,7 +203,7 @@ reapplyPatchSet ps = continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches] -reapplyPatchSetToState :: RgaRaw -> PatchSet -> (RgaRaw, PatchSet)+reapplyPatchSetToState :: RgaRep -> PatchSet -> (RgaRep, PatchSet) reapplyPatchSetToState rga ps = continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState] @@ -200,13 +212,13 @@ Nothing -> x Just x' -> continue x' fs -reapplyPatchesToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet)-reapplyPatchesToState (RgaRaw rstate, ps@PatchSet{..}) = case rstate of+reapplyPatchesToState :: (RgaRep, PatchSet) -> Maybe (RgaRep, PatchSet)+reapplyPatchesToState (RgaRep rstate, ps@PatchSet{..}) = case rstate of Just VertexList{listHead = targetHead, listItems = targetItems} -> asum [ do targetItems' <- applyPatch parent patch targetItems pure- ( RgaRaw . Just $ VertexList targetHead targetItems'+ ( RgaRep . Just $ VertexList targetHead targetItems' , ps{psPatches = Map.delete parent psPatches} ) | (parent, patch) <- Map.assocs psPatches@@ -215,7 +227,7 @@ -- rstate is empty => only virtual 0 node exists -- => we can apply only 0 patch patch <- psPatches !? Zero- pure (RgaRaw $ Just patch, ps{psPatches = Map.delete Zero psPatches})+ pure (RgaRep $ Just patch, ps{psPatches = Map.delete Zero psPatches}) reapplyPatchesToOtherPatches :: PatchSet -> Maybe PatchSet reapplyPatchesToOtherPatches ps@PatchSet{..} = asum@@ -248,14 +260,14 @@ let item' = item{itemNext = Just next'} pure $ HashMap.insert parent item' targetItems <> newItems -reapplyRemovalsToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet)-reapplyRemovalsToState (RgaRaw rstate, ps@PatchSet{..}) = do+reapplyRemovalsToState :: (RgaRep, PatchSet) -> Maybe (RgaRep, PatchSet)+reapplyRemovalsToState (RgaRep rstate, ps@PatchSet{..}) = do VertexList{listHead = targetHead, listItems = targetItems} <- rstate asum [ do targetItems' <- applyRemoval parent tombstone targetItems pure- ( RgaRaw . Just $ VertexList targetHead targetItems'+ ( RgaRep . Just $ VertexList targetHead targetItems' , ps{psRemovals = Map.delete parent psRemovals} ) | (parent, tombstone) <- Map.assocs psRemovals@@ -318,29 +330,29 @@ -- | Typed RGA newtype RGA a = RGA [a]- deriving (Eq)+ deriving (Eq, Show) instance Replicated a => Replicated (RGA a) where encoding = objectEncoding instance Replicated a => ReplicatedAsObject (RGA a) where objectOpType = rgaType - newObject (RGA items) = collectFrame $ do- vertexIds <- lift $ getEventUuids $ ls60 $ genericLength items+ newObject (RGA items) = do+ vertexIds <- getEventUuids $ ls60 $ genericLength items ops <- for (zip items vertexIds) $ \(item, vertexId) -> do payload <- newRon item pure $ Op vertexId Zero payload- oid <- lift getEventUuid+ oid <- getEventUuid let stateVersion = maximumDef oid $ map opId ops- tell $- Map.singleton oid $+ modify' $+ (<>) $ Map.singleton oid $ StateChunk{stateType = rgaType, stateVersion, stateBody = ops}- pure oid+ pure $ Object oid - getObject obj@Object{frame} = do- StateChunk{..} <- getObjectStateChunk obj- mItems <- for stateBody $ \Op{..} -> case refId of- Zero -> Just <$> fromRon payload frame+ getObject = do+ StateChunk{stateBody} <- getObjectStateChunk+ mItems <- for stateBody $ \Op{refId, payload} -> case refId of+ Zero -> Just <$> fromRon payload _ -> pure Nothing pure . RGA $ catMaybes mItems @@ -348,44 +360,40 @@ -- 'getGroupedDiffBy'. edit :: ( ReplicatedAsPayload a- , ReplicaClock m, MonadE m, MonadState (Object (RGA a)) m+ , ReplicaClock m, MonadE m, MonadObjectState (RGA a) m ) => [a] -> m ()-edit newItems = do- obj@Object{id, frame} <- get- StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj- advanceToUuid stateVersion-- 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 'Replicated'- let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems'- (stateBody', Last lastEvent) <- runWriterT . fmap fold . for diff $ \case- First removed -> for removed $ \case- op@Op{refId = Zero} -> do -- not deleted yet- -- TODO(2018-11-03, #15, cblp) get sequential ids- tombstone <- lift getEventUuid- tell . Last $ Just tombstone- pure op{refId = tombstone}- op -> -- deleted already- pure op- Both v _ -> pure v- Second added -> for added $ \op -> do- -- TODO(2018-11-03, #15, cblp) get sequential ids- opId <- lift getEventUuid- tell . Last $ Just opId- pure op{opId}-- case lastEvent of- Nothing -> pure ()- Just stateVersion' -> do- let state' = StateChunk+edit newItems =+ 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+ -- 'Replicated'+ let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems'+ (stateBody', Last lastEvent) <-+ runWriterT . fmap fold . for diff $ \case+ First removed -> for removed $ \case+ op@Op{refId = Zero} -> do -- not deleted yet+ -- TODO(2018-11-03, #15, cblp) get sequential ids+ tombstone <- getEventUuid+ tell . Last $ Just tombstone+ pure op{refId = tombstone}+ op -> -- deleted already+ pure op+ 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' }- put obj{frame = Map.insert id state' frame}- where eqAliveOnPayload Op{refId = Zero, payload = p1}@@ -395,7 +403,7 @@ -- | Speciaization of 'edit' for 'Text' editText- :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> m () editText = edit . Text.unpack @@ -404,16 +412,20 @@ type RgaString = RGA Char -- | Create an RGA from a list-newFromList :: (Replicated a, ReplicaClock m) => [a] -> m (Object (RGA a))+newFromList+ :: (Replicated a, MonadState StateFrame m, ReplicaClock m)+ => [a] -> m (Object (RGA a)) newFromList = newObject . RGA -- | Create an 'RgaString' from a text-newFromText :: ReplicaClock m => Text -> m (Object RgaString)+newFromText+ :: (MonadState StateFrame m, ReplicaClock m)+ => Text -> m (Object RgaString) newFromText = newFromList . Text.unpack -getAliveIndices :: MonadE m => Object (RGA a) -> m [UUID]-getAliveIndices obj = do- StateChunk{stateBody} <- getObjectStateChunk obj+getAliveIndices :: (MonadE m, MonadObjectState (RGA a) m) => m [UUID]+getAliveIndices = do+ StateChunk{stateBody} <- getObjectStateChunk let mItems = [ case refId of Zero -> Just opId@@ -423,39 +435,34 @@ pure $ catMaybes mItems -- | Read elements from RGA-getList :: (Replicated a, MonadE m) => Object (RGA a) -> m [a]-getList = fmap coerce . getObject+getList :: (Replicated a, MonadE m, MonadObjectState (RGA a) m) => m [a]+getList = coerce <$> getObject -- | Read characters from 'RgaString'-getText :: MonadE m => Object RgaString -> m Text-getText = fmap Text.pack . getList+getText :: (MonadE m, MonadObjectState RgaString m) => m Text+getText = Text.pack <$> getList -- | Insert a sequence of elements after the specified position. -- Position is identified by 'UUID'. 'Nothing' means the beginning. insert- :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) => [a] -> Maybe UUID -- ^ position -> m ()-insert [] _ = pure ()-insert items mPosition = do- obj@Object{id, frame} <- get- stateChunk@StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj- advanceToUuid stateVersion-- vertexIds <- getEventUuids $ ls60 $ genericLength items- (ops, newFrame) <- runWriterT $- for (zip items vertexIds) $ \(item, vertexId) -> do- payload <- newRon item- pure $ Op vertexId Zero payload+insert [] _ = pure ()+insert items mPosition =+ modifyObjectStateChunk_ $ \chunk@StateChunk{stateVersion, 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- let stateChunk' =- stateChunk{stateVersion = stateVersion', stateBody = stateBody'}- put obj{frame = Map.insert id stateChunk' frame <> newFrame}+ 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'} where findAndInsertAfter pos newOps = go where go = \case@@ -465,12 +472,12 @@ | otherwise -> (op :) <$> go ops insertAtBegin- :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) => [a] -> m () insertAtBegin items = insert items Nothing insertAfter- :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ :: (Replicated a, MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) => [a] -> UUID -- ^ position -> m ()@@ -479,19 +486,18 @@ -- | Insert a text after the specified position. -- Position is identified by 'UUID'. 'Nothing' means the beginning. insertText- :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> Maybe UUID -- ^ position -> m () insertText = insert . Text.unpack insertTextAtBegin- :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)- => Text -> m ()+ :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> m () insertTextAtBegin text = insertText text Nothing insertTextAfter- :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ :: (ReplicaClock m, MonadE m, MonadObjectState RgaString m) => Text -> UUID -- ^ position -> m ()@@ -499,22 +505,16 @@ -- | Record a removal of a specific item remove- :: (MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m)+ :: (MonadE m, MonadObjectState (RGA a) m, ReplicaClock m) => UUID -- ^ position -> m () remove position = errorContext "RGA.remove" $- errorContext ("position = " <> show position) $ do- obj@Object{id, frame} <- get- stateChunk@StateChunk{stateVersion, stateBody} <-- getObjectStateChunk obj- advanceToUuid stateVersion-+ errorContext ("position = " <> show position) $+ modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do event <- getEventUuid stateBody' <- findAndTombstone event stateBody- let stateChunk' =- stateChunk{stateVersion = event, stateBody = stateBody'}- put obj{frame = Map.insert id stateChunk' frame}+ pure chunk{stateVersion = event, stateBody = stateBody'} where findAndTombstone event = go where go = \case
lib/RON/Data/Time.hs view
@@ -6,6 +6,8 @@ -- | 'Day' instances module RON.Data.Time (Day) where +import RON.Prelude+ import Data.Time (Day, fromGregorian, toGregorian) import RON.Data (Replicated (..), ReplicatedAsPayload (..),
lib/RON/Data/VersionVector.hs view
@@ -8,12 +8,15 @@ ( VersionVector ) where +import RON.Prelude+ import Data.Hashable (hashWithSalt) import qualified Data.Map.Strict as Map import RON.Data.Internal import RON.Event (getEventUuid)-import RON.Types (Op (..), StateChunk (..), UUID (UUID))+import RON.Types (Object (Object), Op (..), StateChunk (..),+ UUID (UUID)) import qualified RON.UUID as UUID type Origin = Word64@@ -58,15 +61,15 @@ instance ReplicatedAsObject VersionVector where objectOpType = vvType - newObject (VersionVector vv) = collectFrame $ do- oid <- lift getEventUuid+ newObject (VersionVector vv) = do+ oid <- getEventUuid let ops = Map.elems vv let stateVersion = maximumDef oid $ map opId ops- tell $- Map.singleton oid $+ modify' $+ (<>) $ Map.singleton oid $ StateChunk{stateType = vvType, stateVersion, stateBody = ops}- pure oid+ pure $ Object oid - getObject obj = do- StateChunk{..} <- getObjectStateChunk obj+ getObject = do+ StateChunk{stateBody} <- getObjectStateChunk pure $ stateFromChunk stateBody
− prelude/Prelude.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}--module Prelude (- module X,- fmapL,- foldr1,- headMay,- identity,- lastDef,- maximumDef,- maxOn,- minOn,- note,- replicateM2,- replicateM3,- show,- whenJust,- (!!),- (?:),-) where---- base-import Control.Applicative as X (Alternative, Applicative, liftA2,- many, optional, pure, some, (*>),- (<*), (<*>), (<|>))-import Control.Exception as X (Exception, catch, evaluate, throwIO)-import Control.Monad as X (Monad, filterM, guard, unless, void, when,- (<=<), (=<<), (>=>), (>>=))-import Control.Monad.Fail as X (MonadFail, fail)-import Control.Monad.IO.Class as X (MonadIO, liftIO)-import Data.Bifunctor as X (bimap)-import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||))-import Data.Char as X (Char, chr, ord, toLower, toUpper)-import Data.Coerce as X (Coercible, coerce)-import Data.Data as X (Data)-import Data.Either as X (Either (Left, Right), either)-import Data.Eq as X (Eq, (/=), (==))-import Data.Foldable as X (Foldable, and, asum, fold, foldMap, foldl',- foldr, for_, length, minimumBy, null, or,- toList, traverse_)-import Data.Function as X (const, flip, on, ($), (.))-import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>))-import Data.Functor.Identity as X (Identity)-import Data.Int as X (Int, Int16, Int32, Int64, Int8)-import Data.IORef as X (IORef, atomicModifyIORef', newIORef,- readIORef, writeIORef)-import Data.List as X (drop, filter, genericLength, intercalate,- isPrefixOf, isSuffixOf, lookup, map, partition,- repeat, replicate, sortBy, sortOn, span,- splitAt, take, takeWhile, unlines, unwords,- zip, (++))-import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)-import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe,- listToMaybe, maybe, maybeToList)-import Data.Monoid as X (Last (Last), Monoid, mempty)-import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT),- compare, comparing, max, min, (<), (<=), (>),- (>=))-import Data.Ratio as X ((%))-import Data.Semigroup as X (Semigroup, sconcat, (<>))-import Data.String as X (String)-import Data.Traversable as X (for, sequence, sequenceA, traverse)-import Data.Tuple as X (fst, snd, uncurry)-import Data.Typeable as X (Typeable)-import Data.Word as X (Word, Word16, Word32, Word64, Word8)-import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound,- pred, succ, toEnum)-import GHC.Err as X (error, undefined)-import GHC.Exts as X (Double)-import GHC.Generics as X (Generic)-import GHC.Integer as X (Integer)-import GHC.Num as X (Num, negate, subtract, (*), (+), (-))-import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round,- (^), (^^))-import GHC.Stack as X (HasCallStack)-import System.IO as X (FilePath, IO)-import Text.Show as X (Show)--#ifdef VERSION_bytestring-import Data.ByteString as X (ByteString)-#endif--#ifdef VERSION_containers-import Data.Map.Strict as X (Map)-#endif--#ifdef VERSION_deepseq-import Control.DeepSeq as X (NFData, force)-#endif--#ifdef VERSION_filepath-import System.FilePath as X ((</>))-#endif--#ifdef VERSION_hashable-import Data.Hashable as X (Hashable, hash)-#endif--#ifdef VERSION_mtl-import Control.Monad.Except as X (ExceptT, MonadError, catchError,- liftEither, runExceptT, throwError)-import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader,- runReaderT)-import Control.Monad.State.Strict as X (MonadState, State, StateT,- evalState, evalStateT,- execStateT, get, gets,- modify', put, runState,- runStateT, state)-import Control.Monad.Trans as X (MonadTrans, lift)-import Control.Monad.Writer.Strict as X (MonadWriter, WriterT,- runWriterT, tell)-#endif--#ifdef VERSION_text-import Data.Text as X (Text)-#endif--#ifdef VERSION_time-import Data.Time as X (UTCTime)-#endif--#ifdef VERSION_unordered_containers-import Data.HashMap.Strict as X (HashMap)-#endif------------------------------------------------------------------------------------import qualified Data.Foldable-import Data.List (last, maximum)-import Data.String (IsString, fromString)-import qualified Text.Show--fmapL :: (a -> b) -> Either a c -> Either b c-fmapL f = either (Left . f) Right--foldr1 :: (a -> a -> a) -> NonEmpty a -> a-foldr1 = Data.Foldable.foldr1--headMay :: [a] -> Maybe a-headMay = \case- [] -> Nothing- a:_ -> Just a--identity :: a -> a-identity x = x--lastDef :: a -> [a] -> a-lastDef def = list' def last--list' :: b -> ([a] -> b) -> [a] -> b-list' onEmpty onNonEmpty = \case- [] -> onEmpty- xs -> onNonEmpty xs--maximumDef :: Ord a => a -> [a] -> a-maximumDef def = list' def maximum--maxOn :: Ord b => (a -> b) -> a -> a -> a-maxOn f x y = if f x < f y then y else x--minOn :: Ord b => (a -> b) -> a -> a -> a-minOn f x y = if f x < f y then x else y--note :: e -> Maybe a -> Either e a-note e = maybe (Left e) Right--replicateM2 :: Applicative m => m a -> m (a, a)-replicateM2 ma = (,) <$> ma <*> ma--replicateM3 :: Applicative m => m a -> m (a, a, a)-replicateM3 ma = (,,) <$> ma <*> ma <*> ma--show :: (Show a, IsString s) => a -> s-show = fromString . Text.Show.show--whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()-whenJust m f = maybe (pure ()) f m--(!!) :: [a] -> Int -> Maybe a-xs !! i- | i < 0 = Nothing- | otherwise = headMay $ drop i xs---- | An infix form of 'fromMaybe' with arguments flipped.-(?:) :: Maybe a -> a -> a-maybeA ?: b = fromMaybe b maybeA-{-# INLINABLE (?:) #-}-infixr 0 ?:
ron-rdt.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-rdt-version: 0.6+version: 0.7 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -15,38 +15,17 @@ description: Replicated Object Notation (RON), data types (RDT), and RON-Schema .- Typical usage:- .- > import RON.Data- > import RON.Schema.TH- > import RON.Storage.FS as Storage- >- > [mkReplicated|- > (struct_lww Note- > active Boole- > text RgaString)- > |]- >- > instance Collection Note where- > collectionName = "note"- >- > main :: IO ()- > main = do- > let dataDir = "./data/"- > h <- Storage.newHandle dataDir- > runStorage h $ do- > obj <- newObject- > Note{active = True, text = "Write a task manager"}- > createDocument obj+ Examples: https://github.com/ff-notes/ron/tree/master/examples build-type: Simple +extra-source-files:+ CHANGELOG.md+ common language build-depends: base >= 4.10 && < 4.13, integer-gmp- default-extensions: MonadFailDesugaring StrictData+ default-extensions: MonadFailDesugaring NoImplicitPrelude StrictData default-language: Haskell2010- hs-source-dirs: prelude- other-modules: Prelude library import: language