ron-rdt (empty) → 0.5
raw patch · 10 files changed
+1577/−0 lines, 10 filesdep +Diffdep +basedep +containers
Dependencies added: Diff, base, containers, hashable, integer-gmp, mtl, ron, text, time, transformers, unordered-containers
Files
- LICENSE +29/−0
- lib/RON/Data.hs +189/−0
- lib/RON/Data/Internal.hs +279/−0
- lib/RON/Data/LWW.hs +141/−0
- lib/RON/Data/ORSet.hs +195/−0
- lib/RON/Data/RGA.hs +408/−0
- lib/RON/Data/Time.hs +26/−0
- lib/RON/Data/VersionVector.hs +72/−0
- prelude/Prelude.hs +164/−0
- ron-rdt.cabal +74/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, Yuriy Syrovetskiy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ lib/RON/Data.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Typed and untyped RON tools+module RON.Data (+ Reducible (..),+ Replicated (..),+ ReplicatedAsObject (..),+ ReplicatedAsPayload (..),+ fromRon,+ getObjectStateChunk,+ mkStateChunk,+ newRon,+ objectEncoding,+ payloadEncoding,+ reduceObject,+ reduceStateFrame,+ reduceWireFrame,+) where++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.VersionVector (VersionVector)+import RON.Error (MonadE, throwErrorString)+import RON.Types (ClosedOp (..), Object (..), Op (..),+ StateChunk (..), StateFrame, UUID,+ WireChunk (Closed, Query, Value), WireFrame,+ WireReducedChunk (..))+import RON.UUID (pattern Zero)+import qualified RON.UUID as UUID++reducers :: Map UUID Reducer+reducers = Map.fromList+ [ mkReducer @LwwPerField+ , mkReducer @RgaRaw+ , mkReducer @ORSetRaw+ , mkReducer @VersionVector+ ]++reduceWireFrame :: WireFrame -> WireFrame+reduceWireFrame chunks = values' ++ queries where+ chunkTypeAndObject = opTypeAndObject . \case+ Closed op -> op+ Value WireReducedChunk{wrcHeader = op} -> op+ Query WireReducedChunk{wrcHeader = op} -> op+ opTypeAndObject ClosedOp{..} = (reducerId, objectId)+ (queries, values) = partition isQuery chunks+ values' =+ fold $+ Map.mapWithKey reduceWireFrameByType $+ NonEmpty.fromList <$>+ Map.fromListWith (++)+ [(chunkTypeAndObject value, [value]) | value <- values]++reduceWireFrameByType :: (UUID, UUID) -> NonEmpty WireChunk -> [WireChunk]+reduceWireFrameByType (typ, obj) = case reducers !? typ of+ Nothing ->+ toList -- TODO(2018-11-08, cblp, #27) use default reducer+ Just Reducer{wireReducer} -> wireReducer obj++isQuery :: WireChunk -> Bool+isQuery = \case+ Query _ -> True+ _ -> False++mkReducer :: forall a . Reducible a => (UUID, Reducer)+mkReducer =+ ( reducibleOpType @a+ , Reducer{wireReducer = mkWireReducer @a, stateReducer = reduceState @a}+ )++mkWireReducer :: forall a . Reducible a => WireReducer+mkWireReducer obj chunks = chunks' <> leftovers where+ chunks'+ = maybeToList stateChunk'+ ++ map (Value . wrapRChunk) unappliedPatches+ ++ map (Closed . wrapOp) unappliedOps+ mStates = nonEmpty states+ (stateChunk', (unappliedPatches, unappliedOps)) = case mStates of+ Nothing -> (Nothing, reduceUnappliedPatches @a (patches, closedOps))+ Just nStates -> let+ 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+ }+ in+ (Just $ Value $ wrapRChunk rc, reduceUnappliedPatches @a unapplied')+ typ = reducibleOpType @a+ wrapOp = ClosedOp typ obj+ (states, patches, closedOps, leftovers) = foldMap load chunks+ load chunk = fromMaybe ([], [], [], [chunk]) $ load' chunk+ load' chunk = case chunk of+ Closed closedOp@ClosedOp{op} -> do+ guardSameObject closedOp+ pure ([], [], [op], [])+ Value WireReducedChunk{wrcHeader, wrcBody} -> do+ guardSameObject wrcHeader+ let ref = refId $ op wrcHeader+ case ref of+ Zero -> -- state+ pure+ ( [ ( opId $ op wrcHeader+ , stateFromChunk wrcBody+ ) ]+ , []+ , []+ , []+ )+ _ -> -- patch+ pure+ ( []+ , [ ReducedChunk+ { rcVersion = opId $ op wrcHeader+ , 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 = []}+ , 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+ in+ case reducers !? stateType of+ Just Reducer{stateReducer} ->+ modify' $ Map.insertWith stateReducer oid chunk+ Nothing ->+ 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+ 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}+ | id1 == id2 = unsafeReduceObject o1 frame2+ | otherwise = throwErrorString $ "Object ids differ: " ++ show (id1, id2)++newtype MaxOnFst a b = MaxOnFst (a, b)++instance Ord a => Semigroup (MaxOnFst a b) where+ mof1@(MaxOnFst (a1, _)) <> mof2@(MaxOnFst (a2, _))+ | a1 < a2 = mof2+ | otherwise = mof1
+ lib/RON/Data/Internal.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module RON.Data.Internal (+ ReducedChunk (..),+ Reducer (..),+ Reducible (..),+ Replicated (..),+ ReplicatedAsObject (..),+ ReplicatedAsPayload (..),+ Unapplied,+ WireReducer,+ collectFrame,+ eqPayload,+ eqRef,+ fromRon,+ getObjectStateChunk,+ mkStateChunk,+ newRon,+ objectEncoding,+ payloadEncoding,+) where++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.Types (Atom (AInteger, AString, AUuid), Object (Object),+ Op (Op, opId),+ StateChunk (StateChunk, stateBody, stateType, stateVersion),+ StateFrame, UUID (UUID), WireChunk)+import RON.UUID (zero)++-- | 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+ }++-- | 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++ -- | UUID of the type+ reducibleOpType :: UUID++ -- | Load a state from a state chunk+ stateFromChunk :: [Op] -> a++ -- | Store a state to a state chunk+ stateToChunk :: a -> StateChunk++ -- | Merge a state with patches and raw ops+ applyPatches :: a -> Unapplied -> (a, Unapplied)+ applyPatches a (patches, ops) =+ ( a <> foldMap (patchValue . patchFromChunk) patches+ <> foldMap (patchValue . patchFromRawOp) ops+ , mempty+ )++ -- | Merge patches and raw ops into bigger patches or throw obsolete ops+ reduceUnappliedPatches :: Unapplied -> Unapplied+ reduceUnappliedPatches (patches, ops) =+ ( maybeToList .+ fmap (patchToChunk @a . sconcat) .+ nonEmpty $+ map patchFromChunk patches <> map patchFromRawOp ops+ , []+ )++data ReducedChunk = ReducedChunk+ { rcVersion :: 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+ Patch ref1 a1 <> Patch ref2 a2 = Patch (min ref1 ref2) (a1 <> a2)++patchFromRawOp :: Reducible a => Op -> Patch a+patchFromRawOp op@Op{opId} = Patch+ { patchRef = opId+ , patchValue = stateFromChunk [op]+ }++patchFromChunk :: Reducible a => ReducedChunk -> Patch a+patchFromChunk ReducedChunk{..} =+ Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody}++patchToChunk :: Reducible a => Patch a -> ReducedChunk+patchToChunk Patch{patchRef, patchValue} =+ ReducedChunk{rcRef = patchRef, rcVersion = stateVersion, rcBody = stateBody}+ where+ StateChunk{stateVersion, stateBody} = stateToChunk patchValue++-- | Base class for typed encoding+class Replicated a where+ -- | Instances SHOULD implement 'encoding' either as 'objectEncoding' or as+ -- 'payloadEncoding'+ encoding :: Encoding a++data Encoding a = Encoding+ { encodingNewRon+ :: forall m . ReplicaClock m => a -> WriterT StateFrame m [Atom]+ , encodingFromRon :: forall m . MonadE m => [Atom] -> StateFrame -> m a+ }++-- | Encode typed data to a payload with possible addition objects+newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame 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+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+ }++-- | Standard implementation of 'Replicated' for 'ReplicatedAsPayload' types.+payloadEncoding :: ReplicatedAsPayload a => Encoding a+payloadEncoding = Encoding+ { encodingNewRon = pure . toPayload+ , encodingFromRon = \atoms _ -> fromPayload atoms+ }++-- | Instances of this class are encoded as payload only.+class Replicated a => ReplicatedAsPayload a where++ -- | Encode data+ toPayload :: a -> [Atom]++ -- | Decode data+ fromPayload :: MonadE m => [Atom] -> m a++instance Replicated Int64 where encoding = payloadEncoding++instance ReplicatedAsPayload Int64 where+ toPayload int = [AInteger int]+ fromPayload atoms = errorContext "Integer" $ case atoms of+ [AInteger int] -> pure int+ _ -> throwError "Expected Integer syntax"++instance Replicated UUID where encoding = payloadEncoding++instance ReplicatedAsPayload UUID where+ toPayload u = [AUuid u]+ fromPayload atoms = errorContext "UUID" $ case atoms of+ [AUuid u] -> pure u+ _ -> throwError "Expected UUID syntax"++instance Replicated Text where encoding = payloadEncoding++instance ReplicatedAsPayload Text where+ toPayload t = [AString t]+ fromPayload atoms = errorContext "String" $ case atoms of+ [AString t] -> pure t+ _ -> throwError "Expected string syntax"++instance Replicated Char where encoding = payloadEncoding++instance ReplicatedAsPayload Char where+ toPayload c = [AString $ Text.singleton c]+ fromPayload atoms = errorContext "Char" $ case atoms of+ [AString (Text.uncons -> Just (c, ""))] -> pure c+ _ -> throwError "Expected one-character string"++-- | Instances of this class are encoded as objects.+-- An enclosing object's payload will be filled with this object's id.+class Replicated a => ReplicatedAsObject a where++ -- | UUID of the type+ objectOpType :: UUID++ -- | Encode data+ newObject :: ReplicaClock m => a -> m (Object a)++ -- | Decode data+ getObject :: MonadE m => Object a -> 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"++-- | 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++getObjectStateChunk :: MonadE m => Object a -> m StateChunk+getObjectStateChunk (Object oid frame) =+ liftMaybe "no such object in chunk" $ Map.lookup oid frame++eqRef :: Object a -> [Atom] -> Bool+eqRef (Object oid _) atoms = case atoms of+ [AUuid ref] -> oid == ref+ _ -> False++eqPayload :: ReplicatedAsPayload a => a -> [Atom] -> 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 frame ->+ errorContext "Option" $ case atoms of+ Some : atoms' -> Just <$> fromRon atoms' frame+ [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++pattern AFalse :: Atom+pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0) -- false++instance Replicated Bool where encoding = payloadEncoding++instance ReplicatedAsPayload Bool where+ toPayload b+ | b = [ATrue]+ | otherwise = [AFalse]++ fromPayload = errorContext "Boole" . \case+ [ATrue] -> pure True+ [AFalse] -> pure False+ _ -> throwError "Expected single UUID `true` or `false`"
+ lib/RON/Data/LWW.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++-- | LWW-per-field RDT+module RON.Data.LWW+ ( LwwPerField (..)+ , assignField+ , lwwType+ , newObject+ , readField+ , viewField+ , zoomField+ ) where++import qualified Data.Map.Strict as Map++import RON.Data.Internal (Reducible, Replicated, collectFrame,+ 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 (..),+ StateFrame, UUID)+import RON.Util (Instance (Instance))+import qualified RON.UUID as UUID++-- | Last-Write-Wins: select an op with latter event+lww :: Op -> Op -> Op+lww = maxOn opId++-- | Untyped LWW. Implementation: a map from 'opRef' to the original op.+newtype LwwPerField = LwwPerField (Map UUID Op)+ deriving (Eq, Monoid, Show)++instance Semigroup LwwPerField where+ LwwPerField fields1 <> LwwPerField fields2 =+ LwwPerField $ Map.unionWith lww fields1 fields2++instance Reducible LwwPerField where+ reducibleOpType = lwwType++ stateFromChunk ops =+ LwwPerField $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops]++ stateToChunk (LwwPerField 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+ payloads <- for fields $ \(_, Instance value) -> newRon value+ event <- lift getEventUuid+ tell $+ Map.singleton event $+ StateChunk+ { stateType = lwwType+ , stateVersion = event+ , stateBody =+ [Op event name p | ((name, _), p) <- zip fields payloads]+ }+ pure event++-- | Decode field value+viewField+ :: (Replicated a, MonadE m)+ => UUID -- ^ Field name+ -> StateChunk -- ^ LWW object chunk+ -> StateFrame+ -> m a+viewField field StateChunk{..} frame =+ 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++-- | Decode field value+readField+ :: (MonadE m, MonadState (Object a) m, Replicated b)+ => UUID -- ^ Field name+ -> m b+readField field = do+ obj@Object{..} <- get+ stateChunk <- getObjectStateChunk obj+ viewField field stateChunk frame++-- | 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)+ -> m ()+assignField field value = do+ obj@Object{id, frame} <- get+ StateChunk{..} <- getObjectStateChunk obj+ advanceToUuid stateVersion+ let chunk = filter (\Op{refId} -> refId /= field) stateBody+ event <- getEventUuid+ (p, frame') <- runWriterT $ 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'}++-- | Anti-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+zoomField field innerModifier =+ errorContext ("LWW.zoomField" <> show field) $ do+ obj@Object{..} <- get+ StateChunk{..} <- getObjectStateChunk obj+ 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+ [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
+ lib/RON/Data/ORSet.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++-- | Observed-Remove Set (OR-Set)+module RON.Data.ORSet+ ( ORSet (..)+ , ObjectORSet (..)+ , ORSetRaw+ , addNewRef+ , addRef+ , addValue+ , removeRef+ , removeValue+ ) where++import qualified Data.Map.Strict as Map++import RON.Data.Internal+import RON.Error (MonadE)+import RON.Event (ReplicaClock, getEventUuid)+import RON.Types (Atom, Object (Object, frame, id),+ Op (Op, opId, payload, refId),+ StateChunk (StateChunk, stateBody, stateType, stateVersion),+ UUID)+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.+newtype ORSetRaw = ORSetRaw (Map UUID Op)+ deriving (Eq, Show)++opKey :: Op -> UUID+opKey Op{opId, refId} = case refId of+ Zero -> opId -- alive+ _ -> refId -- tombstone++observedRemove :: Op -> Op -> Op+observedRemove = maxOn refId++instance Semigroup ORSetRaw where+ ORSetRaw set1 <> ORSetRaw set2 =+ ORSetRaw $ Map.unionWith observedRemove set1 set2++instance Monoid ORSetRaw where+ mempty = ORSetRaw mempty++instance Reducible ORSetRaw where+ reducibleOpType = setType++ stateFromChunk ops =+ ORSetRaw $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops]++ stateToChunk (ORSetRaw 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+newtype ORSet a = ORSet [a]++-- | Type-directing wrapper for typed OR-Set of objects+newtype ObjectORSet a = ObjectORSet [a]++instance ReplicatedAsPayload a => Replicated (ORSet a) where+ encoding = objectEncoding++instance ReplicatedAsPayload 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++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++-- | 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+ {stateType = setType, stateVersion = event, stateBody = chunk'}+ put obj{frame = Map.insert id state' frame}++-- | Add atomic value to the OR-Set+addValue+ :: (ReplicatedAsPayload a, ReplicaClock m, MonadE m)+ => a -> StateT (Object (ORSet a)) m ()+addValue = commonAdd++-- | 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++-- | 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}++-- | Remove an atomic value from the OR-Set+removeValue+ :: (ReplicatedAsPayload a, MonadE m, ReplicaClock m)+ => a -> StateT (Object (ORSet 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 ()+removeRef = commonRemove . eqRef
+ lib/RON/Data/RGA.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++-- | Replicated Growable Array (RGA)+module RON.Data.RGA+ ( RGA (..)+ , RgaRaw+ , RgaString+ , edit+ , editText+ , getList+ , getText+ , newFromList+ , newFromText+ , rgaType+ ) where++import Data.Algorithm.Diff (Diff (Both, First, Second),+ getGroupedDiffBy)+import qualified Data.HashMap.Strict as HashMap+import Data.Map.Strict ((!?))+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text++import RON.Data.Internal+import RON.Error (MonadE)+import RON.Event (ReplicaClock, advanceToUuid, getEventUuid,+ getEventUuids)+import RON.Types (Object (..), Op (..), StateChunk (..), UUID)+import RON.Util.Word (pattern B11, ls60)+import RON.UUID (pattern Zero, uuidVersion)+import qualified RON.UUID as UUID++-- | opId = vertex id+-- refId:+-- 0 = value is alive,+-- _ = tombstone event, value is backup for undo+-- payload: the value+type Vertex = Op++data VertexListItem = VertexListItem+ { itemValue :: Vertex+ , itemNext :: Maybe UUID+ }+ deriving (Eq, Show)++data VertexList = VertexList+ { listHead :: UUID+ , listItems :: HashMap UUID VertexListItem+ }+ deriving (Eq, Show)++instance Semigroup VertexList where+ (<>) = merge++vertexListToOps :: VertexList -> [Vertex]+vertexListToOps v@VertexList{..} = go listHead listItems+ where+ go root items = let+ VertexListItem{..} =+ HashMap.lookupDefault+ (error $ unlines+ $ ["Cannot find vertex id", show root, "in array"]+ ++ map show (HashMap.toList items)+ ++ ["Original array is", show v])+ root+ items+ rest = case itemNext of+ Just next -> go next (HashMap.delete root items)+ Nothing -> []+ in itemValue : rest++vertexListFromOps :: [Vertex] -> Maybe VertexList+vertexListFromOps = foldr go mempty where+ go v@Op{opId} vlist = Just $ VertexList{listHead = opId, listItems = vlist'}+ where+ item itemNext = VertexListItem{itemValue = v, itemNext}+ vlist' = case vlist of+ Nothing -> HashMap.singleton opId (item Nothing)+ Just VertexList{listHead, listItems} ->+ HashMap.insert opId (item $ Just listHead) listItems++-- | Untyped RGA+newtype RgaRaw = RgaRaw (Maybe VertexList)+ deriving (Eq, Monoid, Semigroup, Show)++data PatchSet = PatchSet+ { psPatches :: Map UUID VertexList+ -- ^ the key is the parent event, the value is a non-empty VertexList+ , psRemovals :: Map UUID UUID+ -- ^ the key is the target event, the value is the tombstone event+ }+ deriving (Eq, Show)++instance Semigroup PatchSet where+ rga1 <> rga2 = reapplyPatchSet $ preMerge rga1 rga2++preMerge :: PatchSet -> PatchSet -> PatchSet+preMerge (PatchSet p1 r1) (PatchSet p2 r2) = PatchSet+ {psPatches = Map.unionWith (<>) p1 p2, psRemovals = Map.unionWith max r1 r2}++instance Monoid PatchSet where+ mempty = PatchSet{psPatches = mempty, psRemovals = mempty}++patchSetFromRawOp :: Op -> PatchSet+patchSetFromRawOp op@Op{opId, refId, payload} = case payload of+ [] -> -- remove op+ mempty{psRemovals = Map.singleton refId opId}+ _:_ -> -- append op+ mempty+ { psPatches =+ Map.singleton+ refId+ VertexList+ { listHead = opId+ , listItems =+ HashMap.singleton+ opId+ VertexListItem+ { itemValue = op{refId = Zero}+ , itemNext = Nothing+ }+ }+ }++patchSetFromChunk :: ReducedChunk -> PatchSet+patchSetFromChunk ReducedChunk{rcRef, rcBody} =+ case uuidVersion $ UUID.split rcRef of+ B11 ->+ -- derived event -- rm-patch compatibility+ foldMap patchSetFromRawOp rcBody+ _ -> -- patch+ case vertexListFromOps rcBody of+ Just patch -> mempty{psPatches = Map.singleton rcRef patch}+ Nothing -> mempty++instance Reducible RgaRaw where+ reducibleOpType = rgaType++ stateFromChunk = RgaRaw . vertexListFromOps++ stateToChunk (RgaRaw rga) = StateChunk+ {stateType = rgaType, stateVersion = chunkVersion stateBody, stateBody}+ where+ stateBody = maybe [] vertexListToOps rga++ applyPatches rga (patches, ops) =+ bimap identity patchSetToChunks . reapplyPatchSetToState rga $+ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops++ reduceUnappliedPatches (patches, ops) =+ patchSetToChunks . reapplyPatchSet $+ foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops++patchSetToChunks :: PatchSet -> Unapplied+patchSetToChunks PatchSet{..} =+ ( [ ReducedChunk{rcVersion = chunkVersion rcBody, ..}+ | (rcRef, vertices) <- Map.assocs psPatches+ , let rcBody = vertexListToOps vertices+ ]+ , [ Op{opId = tombstone, refId, payload = []}+ | (refId, tombstone) <- Map.assocs psRemovals+ ]+ )++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]++reapplyPatchSetToState :: RgaRaw -> PatchSet -> (RgaRaw, PatchSet)+reapplyPatchSetToState rga ps =+ continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState]++continue :: x -> [x -> Maybe x] -> x+continue x fs = case asum $ map ($ x) fs of+ Nothing -> x+ Just x' -> continue x' fs++reapplyPatchesToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet)+reapplyPatchesToState (RgaRaw 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'+ , ps{psPatches = Map.delete parent psPatches}+ )+ | (parent, patch) <- Map.assocs psPatches+ ]+ Nothing -> do+ -- 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})++reapplyPatchesToOtherPatches :: PatchSet -> Maybe PatchSet+reapplyPatchesToOtherPatches ps@PatchSet{..} = asum+ [ do+ targetItems' <- applyPatch parent patch targetItems+ pure ps+ { psPatches =+ Map.insert targetParent (VertexList targetHead targetItems') $+ Map.delete parent psPatches+ }+ | (parent, patch) <- Map.assocs psPatches+ , (targetParent, targetPatch) <- Map.assocs psPatches+ , parent /= targetParent+ , let VertexList targetHead targetItems = targetPatch+ ]++applyPatch+ :: UUID+ -> VertexList+ -> HashMap UUID VertexListItem+ -> Maybe (HashMap UUID VertexListItem)+applyPatch parent patch targetItems = case parent of+ Zero ->+ error "chunk with zero ref mustn't be considered a state, not a patch"+ _ -> do+ item@VertexListItem{itemNext} <- HashMap.lookup parent targetItems+ let VertexList next' newItems = case itemNext of+ Nothing -> patch+ Just next -> VertexList next targetItems <> patch+ 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+ VertexList{listHead = targetHead, listItems = targetItems} <- rstate+ asum+ [ do+ targetItems' <- applyRemoval parent tombstone targetItems+ pure+ ( RgaRaw . Just $ VertexList targetHead targetItems'+ , ps{psRemovals = Map.delete parent psRemovals}+ )+ | (parent, tombstone) <- Map.assocs psRemovals+ ]++reapplyRemovalsToPatches :: PatchSet -> Maybe PatchSet+reapplyRemovalsToPatches PatchSet{..} = asum+ [ do+ targetItems' <- applyRemoval parent tombstone targetItems+ pure PatchSet+ { psRemovals = Map.delete parent psRemovals+ , psPatches =+ Map.insert+ targetParent (VertexList targetHead targetItems') psPatches+ }+ | (parent, tombstone) <- Map.assocs psRemovals+ , (targetParent, targetPatch) <- Map.assocs psPatches+ , let VertexList targetHead targetItems = targetPatch+ ]++applyRemoval+ :: UUID+ -> UUID+ -> HashMap UUID VertexListItem+ -> Maybe (HashMap UUID VertexListItem)+applyRemoval parent tombstone targetItems = do+ item@VertexListItem{itemValue = v@Op{refId}} <-+ HashMap.lookup parent targetItems+ let item' = item{itemValue = v{refId = max refId tombstone}}+ pure $ HashMap.insert parent item' targetItems++merge :: VertexList -> VertexList -> VertexList+merge v1 v2+ = fromMaybe (error "merge of non-empty lists cannot be empty")+ $ vertexListFromOps+ $ (merge' `on` vertexListToOps) v1 v2++merge' :: [Vertex] -> [Vertex] -> [Vertex]+merge' [] vs2 = vs2+merge' vs1 [] = vs1+merge' w1@(v1 : vs1) w2@(v2 : vs2) =+ case compare e1 e2 of+ LT -> v2 : merge' w1 vs2+ GT -> v1 : merge' vs1 w2+ EQ -> mergeVertices : merge' vs1 vs2+ where+ Op{opId = e1, refId = tombstone1, payload = p1} = v1+ Op{opId = e2, refId = tombstone2, payload = p2} = v2++ -- priority of deletion+ mergeVertices = Op+ { opId = e1+ , refId = max tombstone1 tombstone2+ , payload = maxOn length p1 p2+ }++-- | Name-UUID to use as RGA type marker.+rgaType :: UUID+rgaType = $(UUID.liftName "rga")++-- | Typed RGA+newtype RGA a = RGA [a]+ deriving (Eq)++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+ ops <- for (zip items vertexIds) $ \(item, vertexId) -> do+ payload <- newRon item+ pure $ Op vertexId Zero payload+ oid <- lift getEventUuid+ let stateVersion = maximumDef oid $ map opId ops+ tell $+ Map.singleton oid $+ StateChunk{stateType = rgaType, stateVersion, stateBody = ops}+ pure oid++ getObject obj@Object{frame} = do+ StateChunk{..} <- getObjectStateChunk obj+ mItems <- for stateBody $ \Op{..} -> case refId of+ Zero -> Just <$> fromRon payload frame+ _ -> pure Nothing+ pure . RGA $ catMaybes mItems++-- | Replace content of the RGA throug introducing changes detected by+-- 'getGroupedDiffBy'.+edit+ :: ( ReplicatedAsPayload a+ , ReplicaClock m, MonadE m, MonadState (Object (RGA a)) m+ )+ => [a] -> m ()+edit newItems = do+ obj@Object{id, frame} <- get+ StateChunk{..} <- getObjectStateChunk obj+ advanceToUuid stateVersion++ let newItems' = [Op Zero Zero $ toPayload item | item <- newItems]+ 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+ { stateType = rgaType+ , stateVersion = stateVersion'+ , stateBody = stateBody'+ }+ put obj{frame = Map.insert id state' frame}++ where+ eqAliveOnPayload+ Op{refId = Zero, payload = p1}+ Op{refId = Zero, payload = p2}+ = p1 == p2+ eqAliveOnPayload _ _ = False++-- | Speciaization of 'edit' for 'Text'+editText+ :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m)+ => Text -> m ()+editText = edit . Text.unpack++-- | Speciaization of 'RGA' to 'Char'.+-- This is the recommended way to store a string.+type RgaString = RGA Char++-- | Create an RGA from a list+newFromList :: (Replicated a, ReplicaClock m) => [a] -> m (Object (RGA a))+newFromList = newObject . RGA++-- | Create an 'RgaString' from a text+newFromText :: ReplicaClock m => Text -> m (Object RgaString)+newFromText = newFromList . Text.unpack++-- | Read elements from RGA+getList :: forall a m . (Replicated a, MonadE m) => Object (RGA a) -> m [a]+getList = fmap coerce . getObject++-- | Read characters from 'RgaString'+getText :: MonadE m => Object RgaString -> m Text+getText = fmap Text.pack . getList
+ lib/RON/Data/Time.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS -Wno-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | 'Day' instances+module RON.Data.Time (Day) where++import Data.Time (Day, fromGregorian, toGregorian)++import RON.Data (Replicated (..), ReplicatedAsPayload (..),+ payloadEncoding)+import RON.Types (Atom (..))++instance Replicated Day where encoding = payloadEncoding++instance ReplicatedAsPayload Day where+ toPayload+ = (\(y, m, d) ->+ map AInteger [fromIntegral y, fromIntegral m, fromIntegral d])+ . toGregorian++ fromPayload = \case+ [AInteger y, AInteger m, AInteger d] -> pure $+ fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)+ _ -> throwError "bad Day"
+ lib/RON/Data/VersionVector.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Version Vector+module RON.Data.VersionVector+ ( VersionVector+ ) where++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 qualified RON.UUID as UUID++type Origin = Word64++opTime :: Op -> Word64+opTime Op{opId = UUID time _} = time++opOrigin :: Op -> Word64+opOrigin Op{opId = UUID _ origin} = origin++latter :: Op -> Op -> Op+latter = maxOn opTime++-- | Version Vector type. May be used both in typed and untyped contexts.+newtype VersionVector = VersionVector (Map Origin Op)+ deriving (Eq, Show)++instance Hashable VersionVector where+ hashWithSalt s (VersionVector vv) = hashWithSalt s $ Map.assocs vv++instance Semigroup VersionVector where+ (<>) = coerce $ Map.unionWith latter++instance Monoid VersionVector where+ mempty = VersionVector mempty++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++-- | Name-UUID to use as Version Vector type marker.+vvType :: UUID+vvType = $(UUID.liftName "vv")++instance Replicated VersionVector where+ encoding = objectEncoding++instance ReplicatedAsObject VersionVector where+ objectOpType = vvType++ newObject (VersionVector vv) = collectFrame $ do+ oid <- lift getEventUuid+ let ops = Map.elems vv+ let stateVersion = maximumDef oid $ map opId ops+ tell $+ Map.singleton oid $+ StateChunk{stateType = vvType, stateVersion, stateBody = ops}+ pure oid++ getObject obj = do+ StateChunk{..} <- getObjectStateChunk obj+ pure $ stateFromChunk stateBody
+ prelude/Prelude.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Prelude (+ module X,+ fmapL,+ foldr1,+ identity,+ lastDef,+ maximumDef,+ maxOn,+ minOn,+ 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 (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++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++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++-- | An infix form of 'fromMaybe' with arguments flipped.+(?:) :: Maybe a -> a -> a+maybeA ?: b = fromMaybe b maybeA+{-# INLINABLE (?:) #-}+infixr 0 ?:
+ ron-rdt.cabal view
@@ -0,0 +1,74 @@+cabal-version: 2.2++name: ron-rdt+version: 0.5++bug-reports: https://github.com/ff-notes/ron/issues+category: Distributed Systems, Protocol, Database+copyright: 2018-2019 Yuriy Syrovetskiy+homepage: https://github.com/ff-notes/ron+license: BSD-3-Clause+license-file: LICENSE+maintainer: Yuriy Syrovetskiy <haskell@cblp.su>+synopsis: Replicated Data Types (RON-RDT)++description:+ Replicated Object Notation (RON), data types (RDT), and RON-Schema+ .+ Typical usage:+ .+ > import RON.Data+ > import RON.Schema.TH+ > import RON.Storage.IO 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++build-type: Simple++common language+ build-depends: base >= 4.10 && < 4.13, integer-gmp+ default-extensions: MonadFailDesugaring StrictData+ default-language: Haskell2010+ hs-source-dirs: prelude+ other-modules: Prelude++library+ import: language+ build-depends:+ -- global+ containers,+ Diff,+ hashable,+ mtl,+ text,+ time,+ transformers,+ unordered-containers,+ -- project+ ron+ exposed-modules:+ RON.Data+ RON.Data.LWW+ RON.Data.ORSet+ RON.Data.RGA+ RON.Data.Time+ RON.Data.VersionVector+ other-modules:+ RON.Data.Internal+ hs-source-dirs: lib