crdt 7.0 → 8.0

raw patch · 11 files changed

+119/−133 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• crdt.cabal +2/−2
• lib/CRDT/Cm/RGA.hs +4/−19
• lib/CRDT/LamportClock.hs +8/−0
• lib/CRDT/LamportClock/Simulation.hs +32/−57
• test/Cm/ORSet.hs +7/−4
• test/Cv/ORSet.hs +6/−5
• test/Cv/RGA.hs +2/−2
• test/LWW.hs +2/−2
• test/Laws.hs +28/−18
• test/LwwElementSet.hs +4/−4
• test/RGA.hs +24/−20

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 03da394dee75b1bb3cc8d9b26448adbfe3b32c0f4f91c1f62c6672bb5ab17d04+-- hash: f6c5e8a56fae4a26b32be8d375082402b27412d45fd5f75b9d227c7f77374a7c  name:           crdt-version:        7.0+version:        8.0 synopsis:       Conflict-free replicated data types description:    Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs. category:       Distributed Systems

@@ -49,14 +49,6 @@             _           -> False         Nothing -> False --- before :: Vertex -> Vertex -> Bool--- before u v = b---     pre lookup(u) ∧ lookup(v)---     ∃w_1, ..., w_m ∈ verticesAdded:---         w_1 = u---         ∧ w_m = v---         ∧ ∀j: (w_j, w_{j+1}) ∈ edges- data RgaIntent a     = AddAfter (Maybe VertexId) a       -- ^ 'Nothing' means the beginning@@ -75,10 +67,7 @@     precedes _ _ = False  emptyPayload :: RgaPayload a-emptyPayload = RgaPayload-    { vertices = Vector.empty-    , vertexIxs = Map.empty-    }+emptyPayload = RgaPayload{vertices = Vector.empty, vertexIxs = Map.empty}  instance Ord a => CmRDT (RGA a) where     type Intent  (RGA a) = RgaIntent  a@@ -95,9 +84,8 @@         RgaPayload{vertexIxs} = payload         ok = Just $ do             case Map.lookupMax vertexIxs of-                Just (LamportTime maxKnownTime _, _) ->-                    advance maxKnownTime-                Nothing -> pure ()+                Just (LamportTime maxKnownTime _, _) -> advance maxKnownTime+                Nothing                              -> pure ()             newId <- getTime             pure $ OpAddAfter mOldId atom newId @@ -106,10 +94,7 @@         | otherwise        = Nothing      apply (OpAddAfter mOldId newAtom newId) payload =-        RgaPayload-            { vertices  = vertices'-            , vertexIxs = vertexIxs'-            }+        RgaPayload{vertices = vertices', vertexIxs = vertexIxs'}       where         RgaPayload{vertices, vertexIxs} = payload         n = length vertices

@@ -21,6 +21,7 @@                                          readTVar, writeTVar) import           Control.Monad.IO.Class (MonadIO, liftIO) import           Control.Monad.Reader (ReaderT, ask, runReaderT)+import           Control.Monad.State.Strict (StateT) import           Control.Monad.Trans (lift) import           Data.Binary (decode) import qualified Data.ByteString.Lazy as BSL@@ -97,6 +98,13 @@ instance Process m => Process (ReaderT r m) where     getPid = lift getPid +instance Process m => Process (StateT s m) where+    getPid = lift getPid+ instance Clock m => Clock (ReaderT r m) where+    advance = lift . advance+    getTime = lift getTime++instance Clock m => Clock (StateT s m) where     advance = lift . advance     getTime = lift getTime

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -20,9 +21,8 @@                                        throwError) import           Control.Monad.Fail (MonadFail, fail) import           Control.Monad.Reader (ReaderT, ask, runReaderT)-import           Control.Monad.RWS.Strict (RWST, evalRWS, evalRWST)-import           Control.Monad.State.Strict (MonadState, get, gets, modify, put,-                                             state)+import           Control.Monad.State.Strict (StateT, evalState, evalStateT,+                                             modify, state) import           Control.Monad.Trans (MonadTrans, lift) import           Data.Functor.Identity (Identity) import           Data.Map.Strict (Map)@@ -33,36 +33,31 @@  -- | Lamport clock simulation. Key is 'Pid'. -- Non-present value is equivalent to (0, initial).-newtype LamportClockSimT s m a =-    LamportClockSim (ExceptT String (RWST s () (Map Pid (ProcessState s)) m) a)+newtype LamportClockSimT m a =+    LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) a)     deriving (Applicative, Functor, Monad, MonadError String) -instance MonadTrans (LamportClockSimT s) where+instance MonadTrans LamportClockSimT where     lift = LamportClockSim . lift . lift -instance Monad m => MonadFail (LamportClockSimT s m) where+instance Monad m => MonadFail (LamportClockSimT m) where     fail = throwError -type LamportClockSim s = LamportClockSimT s Identity--data ProcessState s = ProcessState-    { time :: LocalTime-    , var  :: s-    }+type LamportClockSim = LamportClockSimT Identity  -- | ProcessSim inside Lamport clock simulation.-newtype ProcessSimT s m a = ProcessSim (ReaderT Pid (LamportClockSimT s m) a)+newtype ProcessSimT m a = ProcessSim (ReaderT Pid (LamportClockSimT m) a)     deriving (Applicative, Functor, Monad, MonadFail) -type ProcessSim s = ProcessSimT s Identity+type ProcessSim = ProcessSimT Identity -instance MonadTrans (ProcessSimT s) where+instance MonadTrans ProcessSimT where     lift = ProcessSim . lift . lift -instance Monad m => Process (ProcessSimT s m) where+instance Monad m => Process (ProcessSimT m) where     getPid = ProcessSim ask -instance Monad m => Clock (ProcessSimT s m) where+instance Monad m => Clock (ProcessSimT m) where     getTime = ProcessSim $ do         pid <- ask         time <- lift $ preIncrementTime pid@@ -70,50 +65,30 @@      advance time = ProcessSim $ do         pid <- ask-        lift . LamportClockSim $ do-            initial <- ask-            modify $ Map.alter (Just . advancePS initial) pid-      where-        advancePS initial Nothing = ProcessState{time, var = initial}-        advancePS _       (Just ProcessState{time = current, var}) =-            ProcessState{time = max time current, var}--instance Monad m => MonadState s (ProcessSimT s m) where-    get = ProcessSim $ do-        pid <- ask-        lift . LamportClockSim $ do-            initial <- ask-            gets $ maybe initial var . Map.lookup pid-    put var = ProcessSim $ do-        pid <- ask-        lift . LamportClockSim . modify $ Map.alter (Just . putPS) pid+        lift . LamportClockSim . modify $ Map.alter (Just . advancePS) pid       where-        putPS Nothing                   = ProcessState{time = 0, var}-        putPS (Just ProcessState{time}) = ProcessState{time,     var}+        advancePS = \case+            Nothing      -> time+            Just current -> max time current -runLamportClockSim :: s -> LamportClockSim s a -> Either String a-runLamportClockSim initial (LamportClockSim action) =-    fst $ evalRWS (runExceptT action) initial mempty+runLamportClockSim :: LamportClockSim a -> Either String a+runLamportClockSim (LamportClockSim action) =+    evalState (runExceptT action) mempty -runLamportClockSimT-    :: Monad m => s -> LamportClockSimT s m a -> m (Either String a)-runLamportClockSimT initial (LamportClockSim action) =-    fst <$> evalRWST (runExceptT action) initial mempty+runLamportClockSimT :: Monad m => LamportClockSimT m a -> m (Either String a)+runLamportClockSimT (LamportClockSim action) =+    evalStateT (runExceptT action) mempty -runProcessSim :: Pid -> ProcessSim s a -> LamportClockSim s a+runProcessSim :: Pid -> ProcessSim a -> LamportClockSim a runProcessSim pid (ProcessSim action) = runReaderT action pid -runProcessSimT :: Pid -> ProcessSimT s m a -> LamportClockSimT s m a+runProcessSimT :: Pid -> ProcessSimT m a -> LamportClockSimT m a runProcessSimT pid (ProcessSim action) = runReaderT action pid -preIncrementTime :: Monad m => Pid -> LamportClockSimT s m LocalTime-preIncrementTime pid = LamportClockSim $ do-    initial <- ask-    state $ \pss -> let-        ps@ProcessState{time} =-            case Map.lookup pid pss of-                Nothing -> ProcessState{time = 1, var = initial}-                Just ProcessState{time = current, var} ->-                    ProcessState{time = succ current, var}-        in-        (time, Map.insert pid ps pss)+preIncrementTime :: Monad m => Pid -> LamportClockSimT m LocalTime+preIncrementTime pid = LamportClockSim $ state $ \pss -> let+    time = case Map.lookup pid pss of+        Nothing      -> 1+        Just current -> succ current+    in+    (time, Map.insert pid time pss)

@@ -7,6 +7,7 @@  module Cm.ORSet where +import           Control.Monad.State.Strict (evalStateT) import qualified Data.MultiMap as MultiMap import           Test.QuickCheck (counterexample, (.&&.), (===), (==>)) @@ -22,10 +23,11 @@ prop_Cm = cmrdtLaw @(ORSet Char)  -- | Example from fig. 14 from "A comprehensive study of CRDTs"-prop_fig14 α β a = expectRight . runLamportClockSim (initial @(ORSet Char)) $ do-    op1 <- runProcessSim β $ makeAndApplyOp (Add (a :: Char))-    op2 <- runProcessSim α $ makeAndApplyOp (Add a)-    op3 <- runProcessSim α $ makeAndApplyOp (Remove a)+prop_fig14 α β a = expectRight . runLamportClockSim $ do+    op1 <- runProcessSim β . eval . makeAndApplyOp $ Add (a :: Char)+    (op2, op3) <- runProcessSim α . eval $+        (,) <$> makeAndApplyOp (Add a)+            <*> makeAndApplyOp (Remove a)     pure $         α < β ==>         check "2"   [op2]           [a :- [Tag α 0]]          .&&.@@ -39,6 +41,7 @@         counterexample ("ops = " ++ opsLabel) $         counterexample ("ops = " ++ show ops) $         query' ops === result+    eval = (`evalStateT` initial @(ORSet Char))  query' :: (Ord a, Foldable f) => f (ORSet a) -> [(a, [Tag])] query' = MultiMap.assocs . elements . query

@@ -18,11 +18,12 @@  test_Cv = cvrdtLaws @(ORSet Int) -prop_add pid (x :: Char) s = expectRight . runLamportClockSim undefined $-    runProcessSim pid $ not . lookup x . remove x <$> add x s+prop_add pid (x :: Char) s =+    expectRight . runLamportClockSim . runProcessSim pid $+        not . lookup x . remove x <$> add x s  -- | Difference from 'LwwElementSet' -- -- other replica can not accidentally delete x-prop_add_merge (x :: Char) pid s1 s0 = expectRight $-    runLamportClockSim undefined $-        runProcessSim pid $ lookup x . (<> s1) <$> add x s0+prop_add_merge (x :: Char) pid s1 s0 =+    expectRight . runLamportClockSim . runProcessSim pid $+        lookup x . (<> s1) <$> add x s0

@@ -15,12 +15,12 @@ import           Util (expectRight)  prop_fromString_toString s pid = expectRight $ do-    s' <- runLamportClockSim undefined $ runProcessSim pid $ fromString s+    s' <- runLamportClockSim . runProcessSim pid $ fromString s     pure $ toString s' === s  test_Cv = cvrdtLaws @RgaString -prop_edit v1 s2 pid = expectRight . runLamportClockSim undefined $ do+prop_edit v1 s2 pid = expectRight . runLamportClockSim $ do     v2 <- runProcessSim pid $ edit s2 v1     pure $ toString v2 === s2 

@@ -26,13 +26,13 @@ test_Cv = cvrdtLaws @(LWW Char)  prop_assign pid1 pid2 (formerValue :: Char) latterValue =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         state1 <- runProcessSim pid1 $ initialize formerValue         state2 <- runProcessSim pid2 $ assign latterValue state1         pure $ query state2 === latterValue  prop_merge_with_former pid1 pid2 (formerValue :: Char) latterValue =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         state1 <- runProcessSim pid1 $ initialize formerValue         state2 <- runProcessSim pid2 $ assign latterValue state1         pure $ query (state1 <> state2) === latterValue

@@ -14,7 +14,8 @@     , opCommutativity     ) where -import           Control.Monad.State.Strict (MonadState, get, modify)+import           Control.Monad.State.Strict (MonadState, StateT, evalStateT,+                                             execStateT, get, modify) import           Control.Monad.Trans (lift) import           Data.Functor.Identity (runIdentity) import           Data.Maybe (isJust)@@ -59,31 +60,31 @@ -- | CmRDT law: concurrent ops commute cmrdtLaw     :: forall op.-    ( CmRDT op, Show op-    , Arbitrary (Intent  op), Show (Intent  op)-    , Arbitrary (Payload op), Show (Payload op)+    ( CmRDT op+    , Show op+    , Arbitrary (Intent  op)+    , Show (Intent  op)+    , Show (Payload op)     )     => Property cmrdtLaw = property concurrentOpsCommute   where-    concurrentOpsCommute payload pid1 pid2 pid3 =+    concurrentOpsCommute pid1 pid2 pid3 =         pid1 < pid2 && pid2 < pid3 ==>-        forAll genOps $ \case+        forAll genFixture $ \case             Right ((in1, op1), (in2, op2), state3) ->                 concurrent op1 op2 ==>                 opCommutativity (in1, op1) (in2, op2) state3             Left _ -> discard       where-        genOps = fmap runIdentity $ runGenT $ runLamportClockSimT payload $ (,,)-            <$> runProcessSimT pid1 (do-                    _ <- genAndApplyOps @op-                    genAndApplyOp @op)-            <*> runProcessSimT pid2 (do-                    _ <- genAndApplyOps @op-                    genAndApplyOp @op)-            <*> runProcessSimT pid3 (do-                    _ <- genAndApplyOps @op-                    get)+        genFixture = fmap runIdentity . runGenT . runLamportClockSimT $ (,,)+            <$> runProcessSimT pid1 genStateAndTakeLastOp+            <*> runProcessSimT pid2 genStateAndTakeLastOp+            <*> runProcessSimT pid3 genState+        genState = (`execStateT` initial @op) $ genAndApplyOps @op+        genStateAndTakeLastOp = (`evalStateT` initial @op) $ do+            _ <- genAndApplyOps @op+            genAndApplyOp @op  opCommutativity     :: forall op.@@ -102,7 +103,7 @@         .&&.         (apply op1 . apply op2) state === (apply op2 . apply op1) state   where-    makeOp' = makeOp @op @(ProcessSim (Payload op))+    makeOp' = makeOp @op @ProcessSim  genAndApplyOp     :: ( CmRDT op, Arbitrary (Intent op)@@ -128,7 +129,16 @@     => m [(Intent op, op)] genAndApplyOps = GenT.listOf genAndApplyOp -instance MonadGen m => MonadGen (ProcessSimT s m) where+instance MonadGen m => MonadGen (ProcessSimT m) where+    liftGen = lift . liftGen+    variant = undefined+    sized f = do+        size <- liftGen getSize+        f size+    resize = undefined+    choose = liftGen . choose++instance MonadGen m => MonadGen (StateT s m) where     liftGen = lift . liftGen     variant = undefined     sized f = do

@@ -25,19 +25,19 @@ test_Cv = cvrdtLaws @(LwwElementSet Char)  prop_add (s :: LwwElementSet Char) x pid1 =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         s1 <- runProcessSim pid1 $ add x s         pure $ lookup x s1  prop_remove (s :: LwwElementSet Char) x pid1 pid2 =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         s1 <- runProcessSim pid1 $ add x s         s2 <- runProcessSim pid2 $ remove x s1         pure . not $ lookup x s2  -- | Difference from 'TwoPSet' -- no removal bias prop_no_removal_bias (s :: LwwElementSet Char) x pid1 pid2 pid3 =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         s1 <- runProcessSim pid1 $ add x s         s2 <- runProcessSim pid2 $ remove x s1         s3 <- runProcessSim pid3 $ add x s2@@ -45,7 +45,7 @@  -- | Difference from 'ORSet' -- other replica can accidentally delete x prop_they_accidentally_delete_our_value (s :: LwwElementSet Char) x pid1 pid2 =-    expectRight . runLamportClockSim undefined $ do+    expectRight . runLamportClockSim $ do         s1 <- runProcessSim pid1 $ add x s         s2 <- runProcessSim pid2 $ remove x =<< add x s         pure . not . lookup x $ s1 <> s2

@@ -6,7 +6,7 @@  module RGA where -import           Control.Monad.State.Strict (get)+import           Control.Monad.State.Strict (execStateT, runStateT) import           Data.Maybe (isJust) import qualified Data.Vector as Vector import           Test.QuickCheck (conjoin, counterexample, (===))@@ -25,7 +25,7 @@ prop_makeOp =     isJust         (makeOp @(RGA Char) (AddAfter Nothing 'a') (initial @(RGA Char))-        :: Maybe (ProcessSim () (RGA Char)))+        :: Maybe (ProcessSim (RGA Char)))  prop_makeAndApplyOp = conjoin     [ counterexample "result3"  $ result3  === Right (op3, payload3)@@ -46,18 +46,19 @@     payload2 = load $ Vector.fromList [time2 :- Just '2', time3 :- Just '3']     payload12 = load $ Vector.fromList         [time2 :- Just '2', time1 :- Just '1', time3 :- Just '3']-    result3 = runLamportClockSim (initial @(RGA Char)) $-        runProcessSim (Pid 3) $ do+    result3 =+        runLamportClockSim .+        runProcessSim (Pid 3) .+        (`runStateT` initial @(RGA Char)) $ do             advance 2-            (,) <$> makeAndApplyOp @(RGA Char) (AddAfter Nothing '3')-                <*> get-    result2 = runLamportClockSim payload3 $ runProcessSim (Pid 2) $ do-        advance 1-        (,) <$> makeAndApplyOp @(RGA Char) (AddAfter Nothing '2')-            <*> get-    result1 = runLamportClockSim payload3 $ runProcessSim (Pid 1) $-        (,) <$> makeAndApplyOp @(RGA Char) (AddAfter Nothing '1')-            <*> get+            makeAndApplyOp @(RGA Char) (AddAfter Nothing '3')+    result2 =+        runLamportClockSim . runProcessSim (Pid 2) . (`runStateT` payload3) $ do+            advance 1+            makeAndApplyOp @(RGA Char) (AddAfter Nothing '2')+    result1 =+        runLamportClockSim . runProcessSim (Pid 1) . (`runStateT` payload3) $+            makeAndApplyOp @(RGA Char) (AddAfter Nothing '1')     result12 = apply op2 payload1     result21 = apply op1 payload2 @@ -66,16 +67,19 @@     Right (load $ Vector.fromList         [LamportTime t pid :- Just c | t <- [1..] | c <- s])   where-    result = runLamportClockSim (initial @(RGA Char)) $-        runProcessSim pid $ do-            _ <- fromString s-            get+    result =+        runLamportClockSim .+        runProcessSim pid .+        (`execStateT` initial @(RGA Char)) $+        fromString s  prop_fromString_toString s pid =     expectRightK result $ \s' -> toString s' === s   where-    result = runLamportClockSim (initial @(RGA Char)) $ runProcessSim pid $ do-        _ <- fromString s-        get+    result =+        runLamportClockSim .+        runProcessSim pid .+        (`execStateT` initial @(RGA Char)) $+        fromString s  prop_Cm = cmrdtLaw @(RGA Char)