├── crdt ├── LICENSE ├── lib │ ├── CRDT │ │ ├── Cv │ │ │ ├── Max.hs │ │ │ ├── GSet.hs │ │ │ ├── GCounter.hs │ │ │ ├── TwoPSet.hs │ │ │ ├── ORSet.hs │ │ │ ├── LwwElementSet.hs │ │ │ ├── PNCounter.hs │ │ │ └── RGA.hs │ │ ├── Cv.hs │ │ ├── Cm │ │ │ ├── GSet.hs │ │ │ ├── Counter.hs │ │ │ ├── TwoPSet.hs │ │ │ ├── ORSet.hs │ │ │ └── RGA.hs │ │ ├── LWW.hs │ │ ├── LamportClock.hs │ │ ├── Cm.hs │ │ └── LamportClock │ │ │ └── Simulation.hs │ ├── Compat.hs │ ├── Data │ │ ├── Empty.hs │ │ ├── Semilattice.hs │ │ └── MultiMap.hs │ └── MacAddress.hs └── crdt.cabal ├── .gitignore ├── brittany.yaml ├── crdt-test ├── test │ ├── Main.hs │ ├── Counter.hs │ ├── GSet.hs │ ├── Max.hs │ ├── GCounter.hs │ ├── Cm │ │ ├── TwoPSet.hs │ │ ├── ORSet.hs │ │ └── RGA.hs │ ├── Util.hs │ ├── PNCounter.hs │ ├── Cv │ │ ├── TwoPSet.hs │ │ ├── ORSet.hs │ │ └── RGA.hs │ ├── LWW.hs │ └── LwwElementSet.hs ├── lib │ └── CRDT │ │ ├── Arbitrary │ │ ├── Common.hs │ │ └── Cm.hs │ │ ├── Arbitrary.hs │ │ └── Laws.hs └── crdt-test.cabal ├── HLint.hs ├── stack.yaml ├── .stylish-haskell.yaml ├── stack.yaml.lock ├── README.md ├── .travis.yml ├── test └── script ├── LICENSE └── CHANGELOG.md /crdt/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | dist/ 4 | -------------------------------------------------------------------------------- /brittany.yaml: -------------------------------------------------------------------------------- 1 | conf_layout: 2 | lconfig_indentAmount: 4 3 | -------------------------------------------------------------------------------- /crdt-test/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} 2 | -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | import "hint" HLint.Dollar 4 | import "hint" HLint.HLint 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.0 2 | 3 | packages: 4 | - crdt 5 | - crdt-test 6 | 7 | extra-deps: 8 | - QuickCheck-GenT-0.2.2 9 | -------------------------------------------------------------------------------- /crdt-test/test/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Counter where 6 | 7 | import CRDT.Cm.Counter (Counter) 8 | import CRDT.Laws (cmrdtLaw) 9 | 10 | prop_Cm = cmrdtLaw @(Counter Int) 11 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/Max.hs: -------------------------------------------------------------------------------- 1 | module CRDT.Cv.Max 2 | ( Max (..) 3 | , initial 4 | , query 5 | ) where 6 | 7 | import Data.Semigroup (Max (..)) 8 | 9 | -- | Construct new value 10 | initial :: a -> Max a 11 | initial = Max 12 | 13 | query :: Max a -> a 14 | query = getMax 15 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: global 4 | pad_module_names: false 5 | - language_pragmas: 6 | align: false 7 | - trailing_whitespace: {} 8 | language_extensions: 9 | - DataKinds 10 | - ExplicitForAll 11 | - ExplicitNamespaces 12 | - MultiParamTypeClasses 13 | -------------------------------------------------------------------------------- /crdt/lib/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Compat where 4 | 5 | import Prelude hiding (fail) 6 | 7 | import Control.Monad.Fail (MonadFail, fail) 8 | import Control.Monad.Reader (ReaderT, lift) 9 | 10 | instance MonadFail m => MonadFail (ReaderT r m) where 11 | fail = lift . fail 12 | -------------------------------------------------------------------------------- /crdt-test/test/GSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module GSet where 7 | 8 | import qualified CRDT.Cm.GSet as Cm 9 | import qualified CRDT.Cv.GSet as Cv 10 | import CRDT.Laws (cmrdtLaw, cvrdtLaws) 11 | 12 | prop_Cm = cmrdtLaw @(Cm.GSet Char) 13 | 14 | test_Cv = cvrdtLaws @(Cv.GSet Char) 15 | 16 | prop_add (x :: Char) = Cv.lookup x . Cv.add x 17 | -------------------------------------------------------------------------------- /crdt-test/test/Max.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Max where 7 | 8 | import Test.QuickCheck ((===)) 9 | 10 | import CRDT.Cv.Max (Max, initial, query) 11 | import CRDT.Laws (cvrdtLaws) 12 | import Data.Semilattice (merge) 13 | 14 | test_Cv = cvrdtLaws @(Max Char) 15 | 16 | prop_merge (x :: Char) y = query (initial x `merge` initial y) === max x y 17 | -------------------------------------------------------------------------------- /crdt-test/test/GCounter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module GCounter where 7 | 8 | import Test.QuickCheck ((===)) 9 | 10 | import CRDT.Cv.GCounter (GCounter (..), increment, query) 11 | import CRDT.Laws (cvrdtLaws) 12 | 13 | test_Cv = cvrdtLaws @(GCounter Int) 14 | 15 | prop_increment (counter :: GCounter Int) pid = 16 | query (increment pid counter) === succ (query counter) 17 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | 3 | module CRDT.Cv 4 | ( CvRDT 5 | ) where 6 | 7 | import Data.Semilattice (Semilattice) 8 | 9 | {- | 10 | State-based, or convergent (Cv) replicated data type. 11 | 12 | Update is any function modifying @state@. 13 | 14 | Query function is not needed. State itself is exposed. 15 | In other words, @query = 'id'@. 16 | Some types may offer more convenient query functions. 17 | 18 | Actually, a CvRDT is nothing more a 'Semilattice'. 19 | -} 20 | type CvRDT = Semilattice 21 | -------------------------------------------------------------------------------- /crdt-test/test/Cm/TwoPSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Cm.TwoPSet where 6 | 7 | import Test.QuickCheck (Small) 8 | 9 | import CRDT.Cm.TwoPSet (TwoPSet (Remove)) 10 | import CRDT.Laws (cmrdtLaw, opCommutativity) 11 | 12 | prop_Cm = cmrdtLaw @(TwoPSet Char) 13 | 14 | prop_remove_commutes_with_itself e = opCommutativity intentOp intentOp 15 | where 16 | intent = Remove (e :: Small Int) 17 | op = intent 18 | intentOp = (intent, op) 19 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm/GSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module CRDT.Cm.GSet 4 | ( GSet (..) 5 | ) where 6 | 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | 10 | import CRDT.Cm (CausalOrd (..), CmRDT (..)) 11 | 12 | newtype GSet a = Add a 13 | deriving (Eq, Show) 14 | 15 | instance Ord a => CmRDT (GSet a) where 16 | type Payload (GSet a) = Set a 17 | 18 | initial = Set.empty 19 | 20 | apply (Add a) = Set.insert a 21 | 22 | instance CausalOrd (GSet a) where 23 | precedes _ _ = False 24 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/GSet.hs: -------------------------------------------------------------------------------- 1 | module CRDT.Cv.GSet 2 | ( GSet 3 | , add 4 | , initial 5 | , lookup 6 | ) where 7 | 8 | import Prelude hiding (lookup) 9 | 10 | import Data.Set (Set) 11 | import qualified Data.Set as Set 12 | 13 | -- | Grow-only set 14 | type GSet = Set 15 | 16 | -- | update 17 | add :: Ord a => a -> GSet a -> GSet a 18 | add = Set.insert 19 | 20 | -- | initialization 21 | initial :: GSet a 22 | initial = Set.empty 23 | 24 | -- | lookup query 25 | lookup :: Ord a => a -> GSet a -> Bool 26 | lookup = Set.member 27 | -------------------------------------------------------------------------------- /crdt-test/test/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module Util where 4 | 5 | import Test.QuickCheck (Property, Testable, counterexample, property) 6 | 7 | expectRight :: Testable a => Either String a -> Property 8 | expectRight e = expectRightK e id 9 | 10 | expectRightK :: Testable b => Either String a -> (a -> b) -> Property 11 | expectRightK e f = case e of 12 | Left l -> counterexample l $ property False 13 | Right a -> property $ f a 14 | 15 | pattern (:-) :: a -> b -> (a, b) 16 | pattern a :- b = (a, b) 17 | infix 0 :- 18 | 19 | ok :: Property 20 | ok = property True 21 | 22 | fail :: String -> Property 23 | fail s = counterexample s $ property False 24 | -------------------------------------------------------------------------------- /crdt-test/test/PNCounter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module PNCounter where 7 | 8 | import Test.QuickCheck ((===)) 9 | 10 | import CRDT.Cv.PNCounter (PNCounter (..), decrement, increment, query) 11 | import CRDT.Laws (cvrdtLaws) 12 | 13 | import GCounter () 14 | 15 | test_Cv = cvrdtLaws @(PNCounter Int) 16 | 17 | prop_increment (counter :: PNCounter Int) pid = 18 | query (increment pid counter) === succ (query counter) 19 | 20 | prop_decrement (counter :: PNCounter Int) pid = 21 | query (decrement pid counter) === pred (query counter) 22 | -------------------------------------------------------------------------------- /crdt-test/lib/CRDT/Arbitrary/Common.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | 6 | module CRDT.Arbitrary.Common () where 7 | 8 | import Test.QuickCheck (Arbitrary (arbitrary)) 9 | import Test.QuickCheck.Instances () 10 | 11 | import CRDT.LamportClock (LamportTime (LamportTime), Pid (Pid)) 12 | import Data.MultiMap (MultiMap (MultiMap)) 13 | 14 | deriving instance 15 | (Arbitrary k, Ord k, Arbitrary v, Ord v) => Arbitrary (MultiMap k v) 16 | 17 | instance Arbitrary LamportTime where 18 | arbitrary = LamportTime <$> arbitrary <*> arbitrary 19 | 20 | deriving instance Arbitrary Pid 21 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module CRDT.Cm.Counter 7 | ( Counter (..) 8 | ) where 9 | 10 | import CRDT.Cm (CausalOrd (..), CmRDT (..)) 11 | 12 | data Counter a = Increment | Decrement 13 | deriving (Bounded, Enum, Eq, Show) 14 | 15 | instance (Num a, Eq a) => CmRDT (Counter a) where 16 | type Payload (Counter a) = a 17 | 18 | initial = 0 19 | 20 | apply = \case 21 | Increment -> (+ 1) 22 | Decrement -> subtract 1 23 | 24 | -- | Empty order, allowing arbitrary reordering 25 | instance CausalOrd (Counter a) where 26 | precedes _ _ = False 27 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: QuickCheck-GenT-0.2.2@sha256:a07dbc72e88bb27fcd0946cc51f5204d616114decfb3a67957bf4b56c7fea1fb,1435 9 | pantry-tree: 10 | size: 293 11 | sha256: fd2bc1a0b05e40e35ad34a94759f499eff5da5b3a73c0a991483b0e4d3c7ede5 12 | original: 13 | hackage: QuickCheck-GenT-0.2.2 14 | snapshots: 15 | - completed: 16 | size: 563100 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/0.yaml 18 | sha256: e93a85871577ea3423d5f3454b2b6bd37c2c2123c79faf511dfb64f5b49a9f8b 19 | original: lts-17.0 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CRDT [![Hackage version](https://img.shields.io/hackage/v/crdt.svg?label=Hackage)](https://hackage.haskell.org/package/crdt) [![Linux Build Status](https://img.shields.io/travis/cblp/crdt.svg?label=Linux%20build)](https://travis-ci.org/cblp/crdt) 2 | 3 | Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs. 4 | 5 | ## DEPRECATION NOTICE 6 | 7 | This package is for reference purposes only. If you plan on using CRDTs in a 8 | real-world application, take a look at the 9 | [ron](https://github.com/ff-notes/ron) package. 10 | -------------------------------------------------------------------------------- /crdt-test/test/Cv/TwoPSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Cv.TwoPSet where 7 | 8 | import Test.QuickCheck ((==>)) 9 | 10 | import CRDT.Cv.TwoPSet (TwoPSet (..), add, isKnown, member, remove) 11 | import CRDT.Laws (cvrdtLaws) 12 | 13 | -- | Difference from LwwElementSet and ORSet -- removal bias 14 | prop_removal_bias (s :: TwoPSet Char) x = 15 | not . member x . add x . remove x $ add x s 16 | 17 | prop_add (s :: TwoPSet Char) x = not (isKnown x s) ==> member x (add x s) 18 | 19 | prop_remove (s :: TwoPSet Char) x = not . member x $ remove x s 20 | 21 | prop_add_then_remove (s :: TwoPSet Char) x = 22 | not . member x . remove x $ add x s 23 | 24 | test_Cv = cvrdtLaws @(TwoPSet Char) 25 | -------------------------------------------------------------------------------- /crdt/lib/Data/Empty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Data.Empty where 5 | 6 | -- | A type that may be empty. 7 | -- If your type does not have a special empty value, just wrap it into 'Maybe', 8 | -- it is free. 9 | -- 10 | -- Based on Control.Lens.Empty.AsEmpty. 11 | class AsEmpty a where 12 | empty :: a 13 | 14 | isEmpty :: a -> Bool 15 | default isEmpty :: Eq a => a -> Bool 16 | isEmpty a = empty == a 17 | 18 | isNotEmpty :: a -> Bool 19 | default isNotEmpty :: Eq a => a -> Bool 20 | isNotEmpty a = empty /= a 21 | 22 | instance AsEmpty (Maybe a) where 23 | empty = Nothing 24 | 25 | isEmpty = \case 26 | Nothing -> True 27 | _ -> False 28 | 29 | isNotEmpty = \case 30 | Nothing -> False 31 | _ -> True 32 | 33 | instance AsEmpty Char where 34 | empty = '\NUL' 35 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | os: linux 2 | 3 | # Do not choose a language; we provide our own build tools. 4 | language: generic 5 | 6 | # Caching so the next build will be fast too. 7 | cache: 8 | directories: 9 | - $HOME/.stack 10 | 11 | # Ensure necessary system libraries are present 12 | addons: 13 | apt: 14 | packages: 15 | - libgmp-dev 16 | 17 | before_install: 18 | - mkdir -p ~/.local/bin 19 | - export PATH=$HOME/.local/bin:$PATH 20 | - export STACK="stack --no-terminal --install-ghc" 21 | 22 | install: 23 | # Download and unpack the stack executable 24 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 25 | | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 26 | 27 | jobs: 28 | include: 29 | - {name: build and test everything, script: test/script} 30 | - {name: haddock, script: $STACK haddock} 31 | - {name: hlint, script: $STACK build hlint --exec 'hlint .'} 32 | -------------------------------------------------------------------------------- /crdt/lib/Data/Semilattice.hs: -------------------------------------------------------------------------------- 1 | module Data.Semilattice 2 | ( Semilattice 3 | , merge 4 | ) where 5 | 6 | import Data.Semigroup (Max) 7 | import Data.Set (Set) 8 | 9 | {- | 10 | A semilattice. 11 | 12 | It may be a join-semilattice, or meet-semilattice, it doesn't matter. 13 | 14 | If it matters for you, use package @lattices@. 15 | 16 | In addition to 'Semigroup', Semilattice defines these laws: 17 | 18 | [commutativity] 19 | 20 | @x '<>' y == y '<>' x@ 21 | 22 | [idempotency] 23 | 24 | @x '<>' x == x@ 25 | -} 26 | class Semigroup a => Semilattice a 27 | 28 | -- | Just ('Semigroup.<>'), specialized to 'Semilattice'. 29 | merge :: Semilattice a => a -> a -> a 30 | merge = (<>) 31 | infixr 6 `merge` 32 | {-# INLINE merge #-} 33 | 34 | -- instances for external types 35 | 36 | instance Ord a => Semilattice (Max a) 37 | 38 | instance Ord a => Semilattice (Set a) 39 | 40 | instance Semilattice a => Semilattice (Maybe a) 41 | -------------------------------------------------------------------------------- /crdt-test/test/Cv/ORSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Cv.ORSet where 7 | 8 | import Prelude hiding (lookup) 9 | 10 | import CRDT.Cv.ORSet (ORSet, add, lookup, remove) 11 | import CRDT.LamportClock.Simulation (runLamportClockSim, 12 | runProcessSim) 13 | import CRDT.Laws (cvrdtLaws) 14 | 15 | import Util (expectRight) 16 | 17 | test_Cv = cvrdtLaws @(ORSet Int) 18 | 19 | prop_add pid (x :: Char) s = 20 | expectRight . runLamportClockSim . runProcessSim pid $ 21 | not . lookup x . remove x <$> add x s 22 | 23 | -- | Difference from 'LwwElementSet' -- 24 | -- other replica can not accidentally delete x 25 | prop_add_merge (x :: Char) pid s1 s0 = 26 | expectRight . runLamportClockSim . runProcessSim pid $ 27 | lookup x . (<> s1) <$> add x s0 28 | -------------------------------------------------------------------------------- /test/script: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | import os 4 | import subprocess 5 | 6 | GHC_WARNINGS = [ 7 | '-Wall', 8 | '-fwarn-incomplete-record-updates', 9 | '-fwarn-incomplete-uni-patterns', 10 | ] 11 | 12 | def etlas(*args): 13 | subprocess.check_call(['etlas'] + list(args)) 14 | 15 | if os.environ.get('ETA', ''): 16 | os.chdir('crdt/') 17 | GHC_OPTIONS = GHC_WARNINGS + ['-Werror'] 18 | subprocess.check_call('yes | etlas update', shell=True) 19 | etlas('select', 'latest') 20 | etlas('install', '--dependencies-only') 21 | etlas('build', *['--ghc-options=' + option for option in GHC_OPTIONS]) 22 | else: 23 | GHC = os.environ.get('STACK_YAML', 'ghc-8.2') 24 | if GHC >= 'ghc-8': 25 | GHC_WARNINGS += ['-Wcompat', '-Wredundant-constraints'] 26 | GHC_OPTIONS = GHC_WARNINGS + ['-Werror'] 27 | stack = os.environ.get('STACK', 'stack') 28 | subprocess.check_call( 29 | stack.split() 30 | + ['test', '--haddock', '--no-haddock-deps'] 31 | + ['--ghc-options=' + option for option in GHC_OPTIONS] 32 | ) 33 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/GCounter.hs: -------------------------------------------------------------------------------- 1 | module CRDT.Cv.GCounter 2 | ( GCounter (..) 3 | , initial 4 | , query 5 | -- * Operation 6 | , increment 7 | ) where 8 | 9 | import Data.IntMap.Strict (IntMap) 10 | import qualified Data.IntMap.Strict as IntMap 11 | import Data.Semilattice (Semilattice) 12 | 13 | -- | Grow-only counter. 14 | newtype GCounter a = GCounter (IntMap a) 15 | deriving (Eq, Show) 16 | 17 | instance Ord a => Semigroup (GCounter a) where 18 | GCounter x <> GCounter y = GCounter $ IntMap.unionWith max x y 19 | 20 | -- | See 'CvRDT' 21 | instance Ord a => Semilattice (GCounter a) 22 | 23 | -- | Increment counter 24 | increment 25 | :: Num a 26 | => Word -- ^ replica id 27 | -> GCounter a 28 | -> GCounter a 29 | increment replicaId (GCounter imap) = GCounter (IntMap.insertWith (+) i 1 imap) 30 | where 31 | i = fromIntegral replicaId 32 | 33 | -- | Initial state 34 | initial :: GCounter a 35 | initial = GCounter IntMap.empty 36 | 37 | -- | Get value from the state 38 | query :: Num a => GCounter a -> a 39 | query (GCounter v) = sum v 40 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm/TwoPSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- | TODO(cblp, 2017-09-29) USet? 5 | module CRDT.Cm.TwoPSet 6 | ( TwoPSet (..) 7 | ) where 8 | 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as Map 11 | 12 | import CRDT.Cm (CausalOrd (..), CmRDT (..)) 13 | 14 | data TwoPSet a = Add a | Remove a 15 | deriving (Eq, Show) 16 | 17 | instance Ord a => CmRDT (TwoPSet a) where 18 | type Payload (TwoPSet a) = Map a Bool 19 | 20 | initial = Map.empty 21 | 22 | makeOp op payload = case op of 23 | Add _ -> Just $ pure op 24 | Remove a 25 | | isKnown a -> Just $ pure op 26 | | otherwise -> Nothing 27 | where 28 | isKnown a = Map.member a payload 29 | 30 | apply = \case 31 | Add a -> Map.insertWith (&&) a True 32 | Remove a -> Map.insert a False 33 | 34 | instance Eq a => CausalOrd (TwoPSet a) where 35 | Add b `precedes` Remove a = a == b -- `Remove e` can occur only after `Add e` 36 | _ `precedes` _ = False -- Any other are not ordered 37 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/TwoPSet.hs: -------------------------------------------------------------------------------- 1 | module CRDT.Cv.TwoPSet 2 | ( TwoPSet (..) 3 | , add 4 | , initial 5 | , member 6 | , remove 7 | , singleton 8 | , isKnown 9 | ) where 10 | 11 | import Data.Map.Strict (Map) 12 | import qualified Data.Map.Strict as Map 13 | 14 | import Data.Semilattice (Semilattice) 15 | 16 | newtype TwoPSet a = TwoPSet (Map a Bool) 17 | deriving (Eq, Show) 18 | 19 | instance Ord a => Semigroup (TwoPSet a) where 20 | TwoPSet m1 <> TwoPSet m2 = TwoPSet (Map.unionWith (&&) m1 m2) 21 | 22 | instance Ord a => Semilattice (TwoPSet a) 23 | 24 | add :: Ord a => a -> TwoPSet a -> TwoPSet a 25 | add e (TwoPSet m) = TwoPSet (Map.insertWith (&&) e True m) 26 | 27 | initial :: TwoPSet a 28 | initial = TwoPSet Map.empty 29 | 30 | member :: Ord a => a -> TwoPSet a -> Bool 31 | member e (TwoPSet m) = Just True == Map.lookup e m 32 | 33 | remove :: Ord a => a -> TwoPSet a -> TwoPSet a 34 | remove e (TwoPSet m) = TwoPSet $ Map.adjust (const False) e m 35 | 36 | singleton :: Ord a => a -> TwoPSet a 37 | singleton a = add a initial 38 | 39 | -- | XXX Internal 40 | isKnown :: Ord a => a -> TwoPSet a -> Bool 41 | isKnown e (TwoPSet m) = Map.member e m 42 | -------------------------------------------------------------------------------- /crdt-test/test/LWW.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module LWW 7 | ( prop_Cm 8 | , prop_assign 9 | , prop_merge_with_former 10 | , test_Cv 11 | ) where 12 | 13 | import Test.QuickCheck ((===)) 14 | 15 | import CRDT.LamportClock.Simulation (runLamportClockSim, 16 | runProcessSim) 17 | import CRDT.Laws (cmrdtLaw, cvrdtLaws) 18 | import CRDT.LWW (LWW, assign, initialize, query) 19 | 20 | import Util (expectRight) 21 | 22 | prop_Cm = cmrdtLaw @(LWW Char) 23 | 24 | test_Cv = cvrdtLaws @(LWW Char) 25 | 26 | prop_assign pid1 pid2 (formerValue :: Char) latterValue = 27 | expectRight . runLamportClockSim $ do 28 | state1 <- runProcessSim pid1 $ initialize formerValue 29 | state2 <- runProcessSim pid2 $ assign latterValue state1 30 | pure $ query state2 === latterValue 31 | 32 | prop_merge_with_former pid1 pid2 (formerValue :: Char) latterValue = 33 | expectRight . runLamportClockSim $ do 34 | state1 <- runProcessSim pid1 $ initialize formerValue 35 | state2 <- runProcessSim pid2 $ assign latterValue state1 36 | pure $ query (state1 <> state2) === latterValue 37 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/ORSet.hs: -------------------------------------------------------------------------------- 1 | module CRDT.Cv.ORSet 2 | ( ORSet (..) 3 | , add 4 | , initial 5 | , remove 6 | , lookup 7 | ) where 8 | 9 | import Prelude hiding (lookup) 10 | 11 | import Data.Map.Strict (Map) 12 | import qualified Data.Map.Strict as Map 13 | import Data.Maybe (fromMaybe) 14 | import Numeric.Natural (Natural) 15 | 16 | import CRDT.LamportClock (Pid, Process, getPid) 17 | import Data.Semilattice (Semilattice) 18 | 19 | type Tag = (Pid, Natural) 20 | 21 | newtype ORSet a = ORSet (Map a (Map Tag Bool)) 22 | deriving (Eq, Show) 23 | 24 | unpack :: ORSet a -> Map a (Map Tag Bool) 25 | unpack (ORSet s) = s 26 | 27 | instance Ord a => Semigroup (ORSet a) where 28 | ORSet s1 <> ORSet s2 = ORSet $ Map.unionWith (Map.unionWith (&&)) s1 s2 29 | 30 | instance Ord a => Semilattice (ORSet a) 31 | 32 | initial :: ORSet a 33 | initial = ORSet Map.empty 34 | 35 | add :: (Ord a, Process m) => a -> ORSet a -> m (ORSet a) 36 | add a (ORSet s) = do 37 | pid <- getPid 38 | pure $ ORSet $ Map.alter (add1 pid) a s 39 | where 40 | add1 pid = Just . add2 pid . fromMaybe Map.empty 41 | add2 pid tags = Map.insert (pid, fromIntegral $ length tags) True tags 42 | 43 | remove :: Ord a => a -> ORSet a -> ORSet a 44 | remove a (ORSet s) = ORSet $ Map.adjust (Map.map $ const False) a s 45 | 46 | lookup :: Ord a => a -> ORSet a -> Bool 47 | lookup e = or . fromMaybe Map.empty . Map.lookup e . unpack 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Yuriy Syrovetskiy 2 | 3 | Redistribution and use in source and binary forms, with or without modification, 4 | are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, 7 | this list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software without 15 | specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/LwwElementSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module CRDT.Cv.LwwElementSet 4 | ( LwwElementSet (..) 5 | , add 6 | , initial 7 | , lookup 8 | , remove 9 | ) where 10 | 11 | import Prelude hiding (lookup) 12 | 13 | import Data.Foldable (for_) 14 | import Data.Map.Strict (Map) 15 | import qualified Data.Map.Strict as Map 16 | 17 | import CRDT.LamportClock (Clock) 18 | import CRDT.LWW (LWW, advanceFromLWW) 19 | import qualified CRDT.LWW as LWW 20 | import Data.Semilattice (Semilattice) 21 | 22 | newtype LwwElementSet a = LES (Map a (LWW Bool)) 23 | deriving (Eq, Show) 24 | 25 | instance Ord a => Semigroup (LwwElementSet a) where 26 | LES m1 <> LES m2 = LES (Map.unionWith (<>) m1 m2) 27 | 28 | instance Ord a => Semilattice (LwwElementSet a) 29 | 30 | initial :: LwwElementSet a 31 | initial = LES Map.empty 32 | 33 | add :: (Ord a, Clock m) => a -> LwwElementSet a -> m (LwwElementSet a) 34 | add value old@(LES m) = do 35 | advanceFromLES old 36 | tag <- LWW.initialize True 37 | pure . LES $ Map.insert value tag m 38 | 39 | remove :: (Ord a, Clock m) => a -> LwwElementSet a -> m (LwwElementSet a) 40 | remove value old@(LES m) = do 41 | advanceFromLES old 42 | tag <- LWW.initialize False 43 | pure . LES $ Map.insert value tag m 44 | 45 | lookup :: Ord a => a -> LwwElementSet a -> Bool 46 | lookup value (LES m) = maybe False LWW.query $ Map.lookup value m 47 | 48 | advanceFromLES :: Clock m => LwwElementSet a -> m () 49 | advanceFromLES (LES m) = for_ m advanceFromLWW 50 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/PNCounter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module CRDT.Cv.PNCounter 4 | ( PNCounter (..) 5 | , initial 6 | , query 7 | -- * Operations 8 | , decrement 9 | , increment 10 | ) where 11 | 12 | import Data.Semilattice (Semilattice) 13 | 14 | import CRDT.Cv.GCounter (GCounter) 15 | import qualified CRDT.Cv.GCounter as GCounter 16 | 17 | {- | 18 | Positive-negative counter. Allows incrementing and decrementing. 19 | Nice example of combining of existing CvRDT ('GCounter' in this case) 20 | to create another CvRDT. 21 | -} 22 | data PNCounter a = PNCounter 23 | { positive :: !(GCounter a) 24 | , negative :: !(GCounter a) 25 | } 26 | deriving (Eq, Show) 27 | 28 | instance Ord a => Semigroup (PNCounter a) where 29 | PNCounter p1 n1 <> PNCounter p2 n2 = PNCounter (p1 <> p2) (n1 <> n2) 30 | 31 | -- | See 'CvRDT' 32 | instance Ord a => Semilattice (PNCounter a) 33 | 34 | -- | Get value from the state 35 | query :: Num a => PNCounter a -> a 36 | query PNCounter{positive, negative} = 37 | GCounter.query positive - GCounter.query negative 38 | 39 | -- | Decrement counter 40 | decrement 41 | :: Num a 42 | => Word -- ^ replica id 43 | -> PNCounter a 44 | -> PNCounter a 45 | decrement i pnc@PNCounter{negative} = 46 | pnc{negative = GCounter.increment i negative} 47 | 48 | -- | Increment counter 49 | increment 50 | :: Num a 51 | => Word -- ^ replica id 52 | -> PNCounter a 53 | -> PNCounter a 54 | increment i pnc@PNCounter{positive} = 55 | pnc{positive = GCounter.increment i positive} 56 | 57 | -- | Initial state 58 | initial :: PNCounter a 59 | initial = PNCounter{positive = GCounter.initial, negative = GCounter.initial} 60 | -------------------------------------------------------------------------------- /crdt-test/crdt-test.cabal: -------------------------------------------------------------------------------- 1 | name: crdt-test 2 | version: 0 3 | build-type: Simple 4 | cabal-version: >= 1.10 5 | 6 | flag Cm 7 | description: Include commutative types 8 | default: True 9 | 10 | library 11 | hs-source-dirs: lib 12 | build-depends: base 13 | , crdt 14 | , mtl 15 | , QuickCheck 16 | , QuickCheck-GenT 17 | , quickcheck-instances 18 | , tasty 19 | , tasty-quickcheck 20 | exposed-modules: CRDT.Arbitrary 21 | CRDT.Arbitrary.Common 22 | CRDT.Laws 23 | if flag(Cm) 24 | cpp-options: -DENABLE_CM=1 25 | exposed-modules: CRDT.Arbitrary.Cm 26 | default-language: Haskell2010 27 | 28 | test-suite test 29 | type: exitcode-stdio-1.0 30 | main-is: Main.hs 31 | hs-source-dirs: test 32 | build-depends: base 33 | , containers 34 | , crdt 35 | , crdt-test 36 | , mtl 37 | , QuickCheck 38 | , quickcheck-instances 39 | , tasty 40 | , tasty-discover >=4.1 41 | , tasty-quickcheck 42 | other-modules: Cm.ORSet 43 | Cm.RGA 44 | Cm.TwoPSet 45 | Counter 46 | Cv.ORSet 47 | Cv.RGA 48 | Cv.TwoPSet 49 | GCounter 50 | GSet 51 | LWW 52 | LwwElementSet 53 | Max 54 | PNCounter 55 | Util 56 | if impl(ghc < 8) 57 | buildable: False 58 | default-language: Haskell2010 59 | -------------------------------------------------------------------------------- /crdt/lib/Data/MultiMap.hs: -------------------------------------------------------------------------------- 1 | module Data.MultiMap 2 | ( MultiMap (..) 3 | , assocs 4 | , delete 5 | , deleteMany 6 | , empty 7 | , insert 8 | , keysSet 9 | , lookup 10 | , singleton 11 | ) where 12 | 13 | import Prelude hiding (lookup) 14 | 15 | import Data.Map.Strict (Map) 16 | import qualified Data.Map.Strict as Map 17 | import Data.Maybe (fromMaybe) 18 | import Data.Set (Set) 19 | import qualified Data.Set as Set 20 | 21 | newtype MultiMap k v = MultiMap (Map k (Set v)) 22 | deriving (Eq, Show) 23 | 24 | assocs :: MultiMap k v -> [(k, [v])] 25 | assocs (MultiMap m) = Map.assocs $ Set.toList <$> m 26 | 27 | delete :: (Ord k, Ord v) => k -> v -> MultiMap k v -> MultiMap k v 28 | delete k v (MultiMap m) = MultiMap $ Map.update delete' k m 29 | where 30 | delete' s = let s' = Set.delete v s in if null s' then Nothing else Just s' 31 | 32 | deleteMany :: 33 | (Ord k, Ord v) => k -> Set v -> MultiMap k v -> MultiMap k v 34 | deleteMany k vs (MultiMap m) = MultiMap $ Map.update deleteMany' k m 35 | where 36 | deleteMany' s = 37 | let s' = Set.difference s vs in if null s' then Nothing else Just s' 38 | 39 | empty :: MultiMap k v 40 | empty = MultiMap Map.empty 41 | 42 | insert :: (Ord k, Ord v) => k -> v -> MultiMap k v -> MultiMap k v 43 | insert k v (MultiMap m) = 44 | MultiMap $ Map.insertWith (<>) k (Set.singleton v) m 45 | 46 | keysSet :: MultiMap k v -> Set k 47 | keysSet (MultiMap m) = Map.keysSet m 48 | 49 | -- | If no key in the map then the result is empty. 50 | lookup :: Ord k => k -> MultiMap k v -> Set v 51 | lookup k (MultiMap m) = fromMaybe Set.empty $ Map.lookup k m 52 | 53 | singleton :: k -> v -> MultiMap k v 54 | singleton k v = MultiMap $ Map.singleton k $ Set.singleton v 55 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm/ORSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module CRDT.Cm.ORSet 5 | ( ORSet (..) 6 | , Intent (..) 7 | , Payload (..) 8 | , Tag (..) 9 | , query 10 | ) where 11 | 12 | import Data.MultiMap (MultiMap) 13 | import qualified Data.MultiMap as MultiMap 14 | import Data.Set (Set) 15 | import Numeric.Natural (Natural) 16 | 17 | import CRDT.Cm (CausalOrd, CmRDT) 18 | import qualified CRDT.Cm as Cm 19 | import CRDT.LamportClock (Pid (Pid), getPid) 20 | 21 | data ORSet a = OpAdd a Tag | OpRemove a (Set Tag) 22 | deriving Show 23 | 24 | data Intent a = Add a | Remove a 25 | deriving Show 26 | 27 | data Payload a = Payload 28 | { elements :: MultiMap a Tag 29 | , version :: Version 30 | } 31 | deriving (Eq, Show) 32 | 33 | data Tag = Tag Pid Version 34 | deriving (Eq, Ord) 35 | 36 | type Version = Natural 37 | 38 | instance Show Tag where 39 | show (Tag (Pid pid) version) = show pid ++ '-' : show version 40 | 41 | instance CausalOrd (ORSet a) where 42 | precedes _ _ = False 43 | 44 | instance Ord a => CmRDT (ORSet a) where 45 | type Intent (ORSet a) = Intent a 46 | type Payload (ORSet a) = Payload a 47 | 48 | initial = Payload{elements = MultiMap.empty, version = 0} 49 | 50 | makeOp (Add a) Payload{version} = Just $ do 51 | pid <- getPid 52 | pure $ OpAdd a $ Tag pid version 53 | makeOp (Remove a) Payload{elements} = 54 | Just . pure . OpRemove a $ MultiMap.lookup a elements 55 | 56 | apply op Payload{elements, version} = Payload 57 | { version = version + 1 58 | , elements = case op of 59 | OpAdd a tag -> MultiMap.insert a tag elements 60 | OpRemove a tags -> MultiMap.deleteMany a tags elements 61 | } 62 | 63 | query :: (Ord a, Foldable f) => f (ORSet a) -> Set a 64 | query = MultiMap.keysSet . elements . Cm.query 65 | -------------------------------------------------------------------------------- /crdt/lib/MacAddress.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module MacAddress where 4 | 5 | import Data.Binary (decode) 6 | import qualified Data.ByteString.Lazy as BSL 7 | import Safe (headDef) 8 | 9 | #ifdef ETA_VERSION 10 | 11 | import Java 12 | 13 | import Data.Maybe (catMaybes) 14 | import Data.Traversable (for) 15 | import Data.Word (Word64, Word8) 16 | 17 | #else /* !defined ETA_VERSION */ 18 | 19 | import Data.Word (Word64) 20 | import Network.Info (MAC (MAC), getNetworkInterfaces, mac) 21 | 22 | #endif /* ETA_VERSION */ 23 | 24 | getMacAddress :: IO Word64 25 | 26 | #ifdef ETA_VERSION 27 | 28 | getMacAddress = java $ do 29 | interfaces <- fromJava <$> getNetworkInterfaces 30 | macs <- for interfaces (<.> getHardwareAddress) 31 | let macBytes = 32 | headDef (error "Can't get any non-zero MAC address of this machine") 33 | $ catMaybes macs 34 | let mac = foldBytes $ fromJava macBytes 35 | pure mac 36 | 37 | data NetworkInterface = NetworkInterface @java.net.NetworkInterface 38 | deriving Class 39 | 40 | foreign import java unsafe 41 | "@static java.net.NetworkInterface.getNetworkInterfaces" 42 | getNetworkInterfaces :: Java a (Enumeration NetworkInterface) 43 | 44 | foreign import java unsafe 45 | getHardwareAddress :: Java NetworkInterface (Maybe JByteArray) 46 | 47 | foldBytes :: [Word8] -> Word64 48 | foldBytes bytes = decode . BSL.pack $ replicate (8 - length bytes) 0 ++ bytes 49 | 50 | #else /* !defined ETA_VERSION */ 51 | 52 | getMacAddress = decodeMac <$> getMac 53 | 54 | getMac :: IO MAC 55 | getMac = 56 | headDef (error "Can't get any non-zero MAC address of this machine") 57 | . filter (/= minBound) 58 | . map mac 59 | <$> getNetworkInterfaces 60 | 61 | decodeMac :: MAC -> Word64 62 | decodeMac (MAC b5 b4 b3 b2 b1 b0) = 63 | decode $ BSL.pack [0, 0, b5, b4, b3, b2, b1, b0] 64 | 65 | #endif /* ETA_VERSION */ 66 | -------------------------------------------------------------------------------- /crdt-test/test/Cm/ORSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Cm.ORSet where 9 | 10 | import Control.Monad.State.Strict (evalStateT) 11 | import qualified Data.MultiMap as MultiMap 12 | import Test.QuickCheck (counterexample, (.&&.), (===), (==>)) 13 | 14 | import CRDT.Cm (initial, makeAndApplyOp, query) 15 | import CRDT.Cm.ORSet (Intent (Add, Remove), ORSet, Tag (Tag), 16 | elements) 17 | import CRDT.LamportClock.Simulation (runLamportClockSim, 18 | runProcessSim) 19 | import CRDT.Laws (cmrdtLaw) 20 | 21 | import Util (pattern (:-), expectRight) 22 | 23 | prop_Cm = cmrdtLaw @(ORSet Char) 24 | 25 | -- | Example from fig. 14 from "A comprehensive study of CRDTs" 26 | prop_fig14 α β a = expectRight . runLamportClockSim $ do 27 | op1 <- runProcessSim β . eval . makeAndApplyOp $ Add (a :: Char) 28 | (op2, op3) <- runProcessSim α . eval $ 29 | (,) <$> makeAndApplyOp (Add a) 30 | <*> makeAndApplyOp (Remove a) 31 | pure $ 32 | α < β ==> 33 | check "2" [op2] [a :- [Tag α 0]] .&&. 34 | check "23" [op2, op3] [] .&&. 35 | check "231" [op2, op3, op1] [a :- [Tag β 0]] .&&. 36 | check "1" [op1] [a :- [Tag β 0]] .&&. 37 | check "12" [op1, op2] [a :- [Tag α 0, Tag β 0]] .&&. 38 | check "123" [op1, op2, op3] [a :- [Tag β 0]] 39 | where 40 | check opsLabel ops result = 41 | counterexample ("ops = " ++ opsLabel) $ 42 | counterexample ("ops = " ++ show ops) $ 43 | query' ops === result 44 | eval = (`evalStateT` initial @(ORSet Char)) 45 | 46 | query' :: (Ord a, Foldable f) => f (ORSet a) -> [(a, [Tag])] 47 | query' = MultiMap.assocs . elements . query 48 | -------------------------------------------------------------------------------- /crdt-test/test/LwwElementSet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module LwwElementSet 7 | ( prop_add 8 | , prop_no_removal_bias 9 | , prop_remove 10 | , prop_they_accidentally_delete_our_value 11 | , test_Cv 12 | ) where 13 | 14 | import Prelude hiding (lookup) 15 | 16 | import CRDT.Cv.LwwElementSet (LwwElementSet, add, lookup, remove) 17 | import CRDT.LamportClock (LamportTime (LamportTime), advance, getTime) 18 | import CRDT.LamportClock.Simulation (runLamportClockSim, 19 | runProcessSim) 20 | import CRDT.Laws (cvrdtLaws) 21 | 22 | import Util (expectRight) 23 | 24 | test_Cv = cvrdtLaws @(LwwElementSet Char) 25 | 26 | prop_add (s :: LwwElementSet Char) x pid1 = 27 | expectRight . runLamportClockSim $ do 28 | s1 <- runProcessSim pid1 $ add x s 29 | pure $ lookup x s1 30 | 31 | prop_remove (s :: LwwElementSet Char) x pid1 pid2 = 32 | expectRight . runLamportClockSim $ do 33 | s1 <- runProcessSim pid1 $ add x s 34 | s2 <- runProcessSim pid2 $ remove x s1 35 | pure . not $ lookup x s2 36 | 37 | -- | Difference from 'TwoPSet' -- no removal bias 38 | prop_no_removal_bias (s :: LwwElementSet Char) x pid1 pid2 pid3 = 39 | expectRight . runLamportClockSim $ do 40 | s1 <- runProcessSim pid1 $ add x s 41 | s2 <- runProcessSim pid2 $ remove x s1 42 | s3 <- runProcessSim pid3 $ add x s2 43 | pure $ lookup x s3 44 | 45 | -- | Difference from 'ORSet' -- other replica can accidentally delete x 46 | prop_they_accidentally_delete_our_value (s :: LwwElementSet Char) x pid1 pid2 = 47 | expectRight . runLamportClockSim $ do 48 | (s1, LamportTime t0 _) <- 49 | runProcessSim pid1 $ (,) <$> add x s <*> getTime 50 | s2 <- runProcessSim pid2 $ do 51 | advance t0 52 | s' <- add x s 53 | remove x s' 54 | pure . not . lookup x $ s1 <> s2 55 | -------------------------------------------------------------------------------- /crdt-test/lib/CRDT/Arbitrary/Cm.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | 6 | module CRDT.Arbitrary.Cm () where 7 | 8 | import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum, 9 | elements, frequency, oneof) 10 | 11 | import CRDT.Cm.Counter (Counter (..)) 12 | import CRDT.Cm.GSet (GSet (..)) 13 | import qualified CRDT.Cm.ORSet as CmORSet 14 | import qualified CRDT.Cm.RGA as CmRGA 15 | import qualified CRDT.Cm.TwoPSet as CmTwoPSet 16 | 17 | import CRDT.Arbitrary.Common () 18 | 19 | instance Arbitrary (Counter a) where 20 | arbitrary = arbitraryBoundedEnum 21 | 22 | deriving instance Arbitrary a => Arbitrary (GSet a) 23 | 24 | instance Arbitrary a => Arbitrary (CmORSet.Intent a) where 25 | arbitrary = elements [CmORSet.Add, CmORSet.Remove] <*> arbitrary 26 | 27 | instance Arbitrary a => Arbitrary (CmORSet.ORSet a) where 28 | arbitrary = oneof 29 | [ CmORSet.OpAdd <$> arbitrary <*> arbitrary 30 | , CmORSet.OpRemove <$> arbitrary <*> arbitrary 31 | ] 32 | 33 | instance (Arbitrary a, Ord a) => Arbitrary (CmORSet.Payload a) where 34 | arbitrary = CmORSet.Payload <$> arbitrary <*> arbitrary 35 | 36 | instance Arbitrary CmORSet.Tag where 37 | arbitrary = CmORSet.Tag <$> arbitrary <*> arbitrary 38 | 39 | instance Arbitrary a => Arbitrary (CmRGA.RGA a) where 40 | arbitrary = oneof 41 | [ CmRGA.OpAddAfter <$> arbitrary <*> arbitrary <*> arbitrary 42 | , CmRGA.OpRemove <$> arbitrary 43 | ] 44 | 45 | instance Arbitrary a => Arbitrary (CmRGA.RgaIntent a) where 46 | arbitrary = frequency 47 | [ (10, CmRGA.AddAfter <$> arbitrary <*> arbitrary) 48 | , ( 1, CmRGA.Remove <$> arbitrary) 49 | ] 50 | 51 | instance (Arbitrary a, Ord a) => Arbitrary (CmRGA.RgaPayload a) where 52 | arbitrary = CmRGA.load <$> arbitrary 53 | 54 | instance Arbitrary a => Arbitrary (CmTwoPSet.TwoPSet a) where 55 | arbitrary = elements [CmTwoPSet.Add, CmTwoPSet.Remove] <*> arbitrary 56 | -------------------------------------------------------------------------------- /crdt-test/test/Cv/RGA.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Cv.RGA where 6 | 7 | import Prelude hiding (fail) 8 | 9 | import Test.QuickCheck (conjoin, (.&&.), (.||.), (===)) 10 | 11 | import CRDT.Arbitrary (NoNul (..)) 12 | import CRDT.Cv.RGA (RgaString, edit, fromString, pack, toString, 13 | unpack) 14 | import CRDT.LamportClock (LamportTime (LamportTime)) 15 | import CRDT.LamportClock.Simulation (runLamportClockSim, 16 | runProcessSim) 17 | import CRDT.Laws (cvrdtLaws) 18 | 19 | import Util (expectRight, fail) 20 | 21 | prop_fromString_toString (NoNul s) pid = expectRight $ do 22 | v <- runLamportClockSim . runProcessSim pid $ fromString s 23 | pure $ toString v === s 24 | 25 | test_Cv = cvrdtLaws @RgaString 26 | 27 | prop_edit v1 (NoNul s2) pid = expectRight . runLamportClockSim $ do 28 | v2 <- runProcessSim pid $ edit s2 v1 29 | pure $ toString v2 === s2 30 | 31 | prop_pack_unpack rga = unpack (pack rga) == (rga :: RgaString) 32 | 33 | prop_fromString_pack s pid = expectRight $ do 34 | v <- runLamportClockSim . runProcessSim pid $ fromString s 35 | pure $ case pack v of 36 | [(LamportTime _ pid', atoms)] -> atoms === s .&&. pid' === pid 37 | [] -> s === "" 38 | p -> fail $ "cannot pack " ++ show p 39 | 40 | prop_edit_pack s1 s2 pid1 pid2 = expectRight . runLamportClockSim $ do 41 | v1 <- runProcessSim pid1 $ fromString s1 42 | v2 <- runProcessSim pid2 $ edit (s1 ++ s2) v1 43 | pure $ case pack v2 of 44 | [(LamportTime _ pid1', atoms1), (LamportTime _ pid2', atoms2)] -> 45 | conjoin 46 | [atoms1 === s1, pid1' === pid1, atoms2 === s2, pid2' === pid2] 47 | [(LamportTime _ pid', atoms)] -> 48 | (atoms === s1 .&&. pid' === pid1 .&&. s2 === "") 49 | .||. (atoms === s2 .&&. pid' === pid2 .&&. s1 === "") 50 | [] -> s1 === "" .&&. s2 === "" 51 | p -> fail $ "cannot pack " ++ show p 52 | -------------------------------------------------------------------------------- /crdt-test/lib/CRDT/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | 8 | module CRDT.Arbitrary 9 | ( NoNul (..) 10 | ) where 11 | 12 | import Data.Ord (Down (..)) 13 | import Test.QuickCheck (Arbitrary (arbitrary)) 14 | import Test.QuickCheck.Gen (Gen (MkGen)) 15 | import Test.QuickCheck.Instances () 16 | import Test.QuickCheck.Random (mkQCGen) 17 | 18 | import CRDT.Cv.GCounter (GCounter (..)) 19 | import CRDT.Cv.LwwElementSet (LwwElementSet (..)) 20 | import qualified CRDT.Cv.ORSet as CvORSet 21 | import CRDT.Cv.PNCounter (PNCounter (..)) 22 | import qualified CRDT.Cv.RGA as CvRGA 23 | import qualified CRDT.Cv.TwoPSet as CvTwoPSet 24 | import CRDT.LamportClock (LamportTime (..), Pid (..)) 25 | import CRDT.LWW (LWW (..)) 26 | 27 | #if ENABLE_CM 28 | import CRDT.Arbitrary.Cm () 29 | #endif /* ENABLE_CM */ 30 | 31 | deriving instance Arbitrary a => Arbitrary (Down a) 32 | 33 | instance Arbitrary a => Arbitrary (LWW a) where 34 | arbitrary = do 35 | time <- arbitrary 36 | value <- seeded (hash time) arbitrary 37 | pure LWW{value, time} 38 | where 39 | hash (LamportTime t (Pid p)) = fromIntegral t * 997 + fromIntegral p 40 | 41 | deriving instance Arbitrary a => Arbitrary (GCounter a) 42 | 43 | deriving instance (Arbitrary a, Ord a) => Arbitrary (CvORSet.ORSet a) 44 | 45 | deriving instance (Arbitrary a, Ord a) => Arbitrary (LwwElementSet a) 46 | 47 | instance Arbitrary a => Arbitrary (PNCounter a) where 48 | arbitrary = PNCounter <$> arbitrary <*> arbitrary 49 | 50 | deriving instance Arbitrary a => Arbitrary (CvRGA.RGA a) 51 | 52 | deriving instance (Ord a, Arbitrary a) => Arbitrary (CvTwoPSet.TwoPSet a) 53 | 54 | -- | Generate deterministically 55 | seeded :: Int -> Gen a -> Gen a 56 | seeded s (MkGen g) = MkGen $ \_ n -> g (mkQCGen s) n 57 | 58 | newtype NoNul = NoNul String 59 | deriving Show 60 | 61 | instance Arbitrary NoNul where 62 | arbitrary = NoNul . filter ('\NUL' /=) <$> arbitrary 63 | -------------------------------------------------------------------------------- /crdt/crdt.cabal: -------------------------------------------------------------------------------- 1 | name: crdt 2 | version: 10.7 3 | -- ^ ComVer 4 | category: Distributed Systems 5 | copyright: 6 | 2017 Yuriy Syrovetskiy, Nikolay Loginov; 7 | 2018-2020 Yuriy Syrovetskiy 8 | maintainer: Yuriy Syrovetskiy 9 | license: BSD3 10 | license-file: LICENSE 11 | synopsis: Conflict-free replicated data types 12 | description: 13 | Definitions of CmRDT and CvRDT. Implementations for some classic CRDTs. 14 | . 15 | This package is just for experiments, so it supports only one GHC version. 16 | For real CRDT applications, use `ron` package. 17 | homepage: https://github.com/cblp/crdt#readme 18 | bug-reports: https://github.com/cblp/crdt/issues 19 | cabal-version: >= 1.10 20 | build-type: Simple 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/cblp/crdt.git 25 | 26 | library 27 | hs-source-dirs: lib 28 | build-depends: base >= 4.8 && < 4.15 29 | , binary 30 | , bytestring 31 | , containers >= 0.5.9 32 | -- since lookupMax is used 33 | , Diff >= 0.4 34 | , hashable 35 | , mtl 36 | , network-info 37 | , safe 38 | , stm 39 | , time 40 | , vector 41 | exposed-modules: CRDT.Cv 42 | CRDT.Cv.GCounter 43 | CRDT.Cv.GSet 44 | CRDT.Cv.LwwElementSet 45 | CRDT.Cv.Max 46 | CRDT.Cv.ORSet 47 | CRDT.Cv.PNCounter 48 | CRDT.Cv.RGA 49 | CRDT.Cv.TwoPSet 50 | CRDT.LamportClock 51 | CRDT.LamportClock.Simulation 52 | CRDT.LWW 53 | Data.Empty 54 | Data.MultiMap 55 | Data.Semilattice 56 | if impl(ghc >= 8) 57 | exposed-modules: CRDT.Cm 58 | CRDT.Cm.Counter 59 | CRDT.Cm.GSet 60 | CRDT.Cm.ORSet 61 | CRDT.Cm.RGA 62 | CRDT.Cm.TwoPSet 63 | other-modules: MacAddress 64 | default-language: Haskell2010 65 | 66 | if impl(ghc >= 8) 67 | default-extensions: StrictData 68 | else 69 | build-depends: fail 70 | , semigroups 71 | , transformers 72 | other-modules: Compat 73 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/LWW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | #if __GLASGOW_HASKELL__ >= 800 5 | {-# LANGUAGE LambdaCase #-} 6 | #endif /* __GLASGOW_HASKELL__ >= 800 */ 7 | 8 | module CRDT.LWW 9 | ( LWW (..) 10 | -- * CvRDT 11 | , initialize 12 | , assign 13 | , query 14 | -- * Implementation detail 15 | , advanceFromLWW 16 | ) where 17 | 18 | import Data.Semilattice (Semilattice) 19 | 20 | #if __GLASGOW_HASKELL__ >= 800 21 | import CRDT.Cm (CausalOrd (..), CmRDT (..)) 22 | #endif /* __GLASGOW_HASKELL__ >= 800 */ 23 | 24 | import CRDT.LamportClock (Clock, LamportTime (LamportTime), advance, 25 | getTime) 26 | 27 | -- | Last write wins. Assuming timestamp is unique. 28 | -- This type is both 'CmRDT' and 'CvRDT'. 29 | -- 30 | -- Timestamps are assumed unique, totally ordered, 31 | -- and consistent with causal order; 32 | -- i.e., if assignment 1 happened-before assignment 2, 33 | -- the former’s timestamp is less than the latter’s. 34 | data LWW a = LWW 35 | { value :: !a 36 | , time :: !LamportTime 37 | } 38 | deriving (Eq, Show) 39 | 40 | -------------------------------------------------------------------------------- 41 | -- CvRDT ----------------------------------------------------------------------- 42 | 43 | -- | Merge by choosing more recent timestamp. 44 | instance Eq a => Semigroup (LWW a) where 45 | x@(LWW xv xt) <> y@(LWW yv yt) 46 | | xt < yt = y 47 | | yt < xt = x 48 | | xv == yv = x 49 | | otherwise = error "LWW assumes timestamps to be unique" 50 | 51 | -- | See 'CvRDT' 52 | instance Eq a => Semilattice (LWW a) 53 | 54 | -- | Initialize state 55 | initialize :: Clock m => a -> m (LWW a) 56 | initialize val = LWW val <$> getTime 57 | 58 | -- | Change state as CvRDT operation. 59 | -- Current value is ignored, because new timestamp is always greater. 60 | assign :: Clock m => a -> LWW a -> m (LWW a) 61 | assign val old = do 62 | advanceFromLWW old 63 | initialize val 64 | 65 | -- | Query state 66 | query :: LWW a -> a 67 | query = value 68 | 69 | -------------------------------------------------------------------------------- 70 | -- CmRDT ----------------------------------------------------------------------- 71 | 72 | #if __GLASGOW_HASKELL__ >= 800 73 | 74 | instance CausalOrd (LWW a) where 75 | precedes _ _ = False 76 | 77 | instance Eq a => CmRDT (LWW a) where 78 | type Intent (LWW a) = a 79 | type Payload (LWW a) = Maybe (LWW a) 80 | 81 | initial = Nothing 82 | 83 | makeOp val = Just . \case 84 | Just payload -> assign val payload 85 | Nothing -> initialize val 86 | 87 | apply op = Just . \case 88 | Just payload -> op <> payload 89 | Nothing -> op 90 | 91 | #endif /* __GLASGOW_HASKELL__ >= 800 */ 92 | 93 | advanceFromLWW :: Clock m => LWW a -> m () 94 | advanceFromLWW LWW{time = LamportTime t _} = advance t 95 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/LamportClock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module CRDT.LamportClock 4 | ( Pid (..) 5 | -- * Lamport timestamp (for a single process) 6 | , Clock (..) 7 | , LamportTime (..) 8 | , getTime 9 | , LocalTime 10 | , Process (..) 11 | -- * Real Lamport clock 12 | , LamportClock 13 | , runLamportClock 14 | -- * Helpers 15 | , getRealLocalTime 16 | , getMacAddress 17 | ) where 18 | 19 | import Control.Monad.IO.Class (MonadIO, liftIO) 20 | import Control.Monad.Reader (ReaderT (..)) 21 | import Control.Monad.State.Strict (StateT) 22 | import Control.Monad.Trans (lift) 23 | import Data.IORef (IORef, atomicModifyIORef') 24 | import Data.Time.Clock.POSIX (getPOSIXTime) 25 | import Data.Word (Word64) 26 | import Numeric.Natural (Natural) 27 | 28 | import MacAddress (getMacAddress) 29 | 30 | -- | Unix time in 10^{-7} seconds (100 ns), as in RFC 4122 and Swarm RON. 31 | type LocalTime = Natural 32 | 33 | data LamportTime = LamportTime LocalTime Pid 34 | deriving (Eq, Ord) 35 | 36 | instance Show LamportTime where 37 | show (LamportTime time (Pid pid)) = show time ++ '.' : show pid 38 | 39 | -- | Unique process identifier 40 | newtype Pid = Pid Word64 41 | deriving (Eq, Ord, Show) 42 | 43 | class Monad m => Process m where 44 | getPid :: m Pid 45 | 46 | getRealLocalTime :: IO LocalTime 47 | getRealLocalTime = round . (* 10000000) <$> getPOSIXTime 48 | 49 | class Process m => Clock m where 50 | -- | Get sequential timestamps. 51 | -- 52 | -- Laws: 53 | -- 1. t1 <- getTimes n 54 | -- t2 <- getTime 55 | -- t2 >= t1 + n 56 | -- 57 | -- 2. getTimes 0 == getTimes 1 58 | getTimes 59 | :: Natural -- ^ number of needed timestamps 60 | -> m LamportTime 61 | -- ^ Starting value of the range. 62 | -- So return value @t@ means range @[t .. t + n - 1]@. 63 | 64 | advance :: LocalTime -> m () 65 | 66 | getTime :: Clock m => m LamportTime 67 | getTime = getTimes 1 68 | 69 | newtype LamportClock a = LamportClock (ReaderT (IORef LocalTime) IO a) 70 | deriving (Applicative, Functor, Monad, MonadIO) 71 | 72 | runLamportClock :: IORef LocalTime -> LamportClock a -> IO a 73 | runLamportClock var (LamportClock action) = runReaderT action var 74 | 75 | instance Process LamportClock where 76 | getPid = Pid <$> liftIO getMacAddress 77 | 78 | instance Clock LamportClock where 79 | advance time = LamportClock $ ReaderT $ \timeVar -> 80 | atomicModifyIORef' timeVar $ \t0 -> (max time t0, ()) 81 | 82 | getTimes n' = LamportTime <$> getTimes' <*> getPid 83 | where 84 | n = max n' 1 85 | getTimes' = LamportClock $ ReaderT $ \timeVar -> do 86 | realTime <- getRealLocalTime 87 | atomicModifyIORef' timeVar $ \timeCur -> 88 | let timeRangeStart = max realTime (timeCur + 1) 89 | in (timeRangeStart + n - 1, timeRangeStart) 90 | 91 | instance Process m => Process (ReaderT r m) where 92 | getPid = lift getPid 93 | 94 | instance Process m => Process (StateT s m) where 95 | getPid = lift getPid 96 | 97 | instance Clock m => Clock (ReaderT r m) where 98 | advance = lift . advance 99 | getTimes = lift . getTimes 100 | 101 | instance Clock m => Clock (StateT s m) where 102 | advance = lift . advance 103 | getTimes = lift . getTimes 104 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module CRDT.Cm 9 | ( CausalOrd (..) 10 | , CmRDT (..) 11 | , concurrent 12 | , query 13 | , makeAndApplyOp 14 | , makeAndApplyOps 15 | ) where 16 | 17 | import Control.Monad.State.Strict (MonadState, get, modify) 18 | 19 | import CRDT.LamportClock (Clock) 20 | 21 | -- | Partial order for causal semantics. 22 | -- Values of some type may be ordered and causally-ordered different ways. 23 | class CausalOrd a where 24 | -- | @x `precedes` y@ means that 25 | -- @x@ must go before @y@ and @y@ can not go before @x@. 26 | precedes :: a -> a -> Bool 27 | 28 | comparable :: CausalOrd a => a -> a -> Bool 29 | comparable a b = a `precedes` b || b `precedes` a 30 | 31 | -- | Not comparable, i. e. ¬(a ≤ b) ∧ ¬(b ≤ a). 32 | concurrent :: CausalOrd a => a -> a -> Bool 33 | concurrent a b = not $ comparable a b 34 | 35 | {- | 36 | Operation-based, or commutative (Cm) replicated data type. 37 | 38 | == Implementation 39 | 40 | In Haskell, a CmRDT implementation consists of 3 types — 41 | a __payload__, an __operation__ (@op@) and an __intent__. 42 | 43 | [Payload] 44 | Internal state of a replica. 45 | [Intent] 46 | User's request to update. 47 | [Operation (Op)] 48 | Operation to be applied to other replicas. 49 | 50 | For many types /operation/ and /intent/ may be the same. 51 | But for 'CRDT.Cm.LWW.LWW', for instance, this rule doesn't hold: 52 | user can request only value, and type attaches a timestamp to it. 53 | 54 | == Additional constraint — commutativity law 55 | 56 | Concurrent updates are observed equally. 57 | 58 | @ 59 | ∀ op1 op2 . 60 | 'concurrent' op1 op2 ==> 'apply' op1 . 'apply' op2 == 'apply' op2 . 'apply' op1 61 | @ 62 | 63 | Idempotency doesn't need to hold. 64 | -} 65 | 66 | class (CausalOrd op, Eq (Payload op)) => CmRDT op where 67 | type Intent op 68 | type Intent op = op -- common case 69 | 70 | type Payload op 71 | 72 | initial :: Payload op 73 | 74 | -- | Generate an update to the local and remote replicas. 75 | -- 76 | -- Returns 'Nothing' if the intended operation is not applicable. 77 | makeOp :: Clock m => Intent op -> Payload op -> Maybe (m op) 78 | 79 | default makeOp 80 | :: (Intent op ~ op, Applicative m) 81 | => Intent op -> Payload op -> Maybe (m op) 82 | makeOp i _ = Just $ pure i 83 | 84 | -- | Apply an update to the payload (downstream). 85 | -- An invalid update must be ignored. 86 | -- 87 | -- TODO(Syrovetsky, 2017-12-05) There is no downstream precondition yet. 88 | -- We must make a test for it first. 89 | apply :: op -> Payload op -> Payload op 90 | 91 | query :: forall op f . (CmRDT op, Foldable f) => f op -> Payload op 92 | query = foldl (flip apply) (initial @op) 93 | 94 | -- | Make op and apply it to the payload -- a common routine at the source node. 95 | makeAndApplyOp 96 | :: (CmRDT op, Clock m, MonadFail m, MonadState (Payload op) m) 97 | => Intent op 98 | -> m op 99 | makeAndApplyOp intent = do 100 | payload <- get 101 | case makeOp intent payload of 102 | Nothing -> fail "precodition failed" 103 | Just opAction -> do 104 | op <- opAction 105 | modify $ apply op 106 | pure op 107 | 108 | makeAndApplyOps 109 | :: ( CmRDT op 110 | , Clock m 111 | , MonadFail m 112 | , MonadState (Payload op) m 113 | , Traversable f 114 | ) 115 | => f (Intent op) 116 | -> m (f op) 117 | makeAndApplyOps = traverse makeAndApplyOp 118 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cv/RGA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ParallelListComp #-} 3 | 4 | module CRDT.Cv.RGA 5 | ( RGA (..) 6 | , fromList 7 | , toList 8 | , edit 9 | , RgaString 10 | , fromString 11 | , toString 12 | -- * Packed representation 13 | , RgaPacked 14 | , pack 15 | , unpack 16 | ) where 17 | 18 | import Data.Algorithm.Diff (PolyDiff (Both, First, Second), 19 | getGroupedDiffBy) 20 | import Data.Empty (AsEmpty (..)) 21 | import Data.Function (on) 22 | import Data.Semilattice (Semilattice) 23 | import Data.Traversable (for) 24 | 25 | import CRDT.LamportClock (Clock, LamportTime (LamportTime), getTimes) 26 | 27 | type VertexId = LamportTime 28 | 29 | -- | TODO(cblp, 2018-02-06) Vector.Unboxed 30 | newtype RGA a = RGA [(VertexId, a)] 31 | deriving (Eq, Show) 32 | 33 | type RgaString = RGA Char 34 | 35 | merge :: (Eq a, AsEmpty a) => RGA a -> RGA a -> RGA a 36 | merge (RGA vertices1) (RGA vertices2) = RGA 37 | $ mergeVertexLists vertices1 vertices2 38 | where 39 | mergeVertexLists [] vs2 = vs2 40 | mergeVertexLists vs1 [] = vs1 41 | mergeVertexLists (v1@(id1, a1):vs1) (v2@(id2, a2):vs2) = 42 | case compare id1 id2 of 43 | LT -> v2 : mergeVertexLists (v1 : vs1) vs2 44 | GT -> v1 : mergeVertexLists vs1 (v2 : vs2) 45 | EQ -> (id1, mergeAtoms a1 a2) : mergeVertexLists vs1 vs2 46 | 47 | -- priority of deletion 48 | mergeAtoms a1 a2 | isEmpty a1 || isEmpty a2 = empty 49 | | a1 == a2 = a1 50 | | otherwise = empty -- error: contradiction 51 | 52 | instance (Eq a, AsEmpty a) => Semigroup (RGA a) where 53 | (<>) = merge 54 | 55 | instance (Eq a, AsEmpty a) => Semilattice (RGA a) 56 | 57 | -- Why not? 58 | instance (Eq a, AsEmpty a) => Monoid (RGA a) where 59 | mempty = RGA [] 60 | mappend = (<>) 61 | 62 | toList :: AsEmpty a => RGA a -> [a] 63 | toList (RGA rga) = [ a | (_, a) <- rga, isNotEmpty a ] 64 | 65 | toString :: RgaString -> String 66 | toString = toList 67 | 68 | fromList :: Clock m => [a] -> m (RGA a) 69 | fromList = fmap RGA . fromList' 70 | 71 | fromList' :: Clock m => [a] -> m [(VertexId, a)] 72 | fromList' xs = do 73 | LamportTime time0 pid <- getTimes . fromIntegral $ length xs 74 | pure [ (LamportTime time pid, x) | time <- [time0..] | x <- xs ] 75 | 76 | fromString :: Clock m => String -> m RgaString 77 | fromString = fromList 78 | 79 | -- | Replace content with specified, 80 | -- applying changed found by the diff algorithm 81 | edit :: (Eq a, AsEmpty a, Clock m) => [a] -> RGA a -> m (RGA a) 82 | edit newList (RGA oldRga) = fmap (RGA . concat) . for diff $ \case 83 | First removed -> pure [ (vid, empty) | (vid, _) <- removed ] 84 | Both v _ -> pure v 85 | Second added -> fromList' $ map snd added 86 | where 87 | newList' = [ (undefined, a) | a <- newList ] 88 | diff = getGroupedDiffBy ((==) `on` snd) oldRga newList' 89 | 90 | -- | Compact version of 'RGA'. 91 | -- For each 'VertexId', the corresponding sequence of vetices has the same 'Pid' 92 | -- and sequentially growing 'LocalTime', starting with the specified one. 93 | type RgaPacked a = [(VertexId, [a])] 94 | 95 | pack :: RGA a -> RgaPacked a 96 | pack (RGA [] ) = [] 97 | pack (RGA ((first, atom):vs)) = go first [atom] 1 vs 98 | where 99 | -- TODO(cblp, 2018-02-08) buf :: DList 100 | go vid buf _ [] = [(vid, buf)] 101 | go vid buf dt ((wid, a):ws) 102 | | wid == next dt vid = go vid (buf ++ [a]) (succ dt) ws 103 | | otherwise = (vid, buf) : go wid [a] 1 ws 104 | next dt (LamportTime t p) = LamportTime (t + dt) p 105 | 106 | unpack :: RgaPacked a -> RGA a 107 | unpack packed = RGA $ do 108 | (LamportTime time pid, atoms) <- packed 109 | [ (LamportTime (time + i) pid, atom) | i <- [0..] | atom <- atoms ] 110 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/LamportClock/Simulation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | module CRDT.LamportClock.Simulation 8 | ( 9 | -- * Lamport clock simulation 10 | LamportClockSim 11 | , LamportClockSimT (..) 12 | , ObservedTime (..) 13 | , ProcessSim 14 | , ProcessSimT (..) 15 | , evalProcessSim 16 | , runLamportClockSim 17 | , runLamportClockSimT 18 | , runProcessSim 19 | , runProcessSimT 20 | ) where 21 | 22 | import Control.Monad.Except (ExceptT, MonadError, runExceptT, 23 | throwError) 24 | import Control.Monad.IO.Class (MonadIO, liftIO) 25 | import Control.Monad.Reader (ask) 26 | import Control.Monad.RWS.Strict (RWST, evalRWST, tell) 27 | import Control.Monad.State.Strict (StateT, evalState, evalStateT, 28 | modify, state) 29 | import Control.Monad.Trans (MonadTrans, lift) 30 | import Data.Bifunctor (second) 31 | import Data.Foldable (toList) 32 | import Data.Functor.Identity (Identity) 33 | import Data.Hashable (hash) 34 | import Data.Map.Strict (Map) 35 | import qualified Data.Map.Strict as Map 36 | import Data.Maybe (fromMaybe) 37 | import Data.Sequence (Seq) 38 | import qualified Data.Sequence as Seq 39 | import Numeric.Natural (Natural) 40 | 41 | import CRDT.LamportClock (Clock, LamportTime (LamportTime), LocalTime, 42 | Pid (Pid), Process, advance, getPid, 43 | getTimes) 44 | 45 | #if __GLASGOW_HASKELL__ < 800 46 | import Compat () 47 | #endif /* __GLASGOW_HASKELL__ < 800 */ 48 | 49 | -- | Lamport clock simulation. Key is 'Pid'. 50 | -- Non-present value is equivalent to (0, initial). 51 | newtype LamportClockSimT m a = 52 | LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) a) 53 | deriving (Applicative, Functor, Monad, MonadError String) 54 | 55 | instance MonadTrans LamportClockSimT where 56 | lift = LamportClockSim . lift . lift 57 | 58 | instance Monad m => MonadFail (LamportClockSimT m) where 59 | fail = throwError 60 | 61 | instance MonadIO m => MonadIO (LamportClockSimT m) where 62 | liftIO io = LamportClockSim $ liftIO io 63 | 64 | type LamportClockSim = LamportClockSimT Identity 65 | 66 | data ObservedTime = ObservedTime{stamp :: LocalTime, count :: Natural} 67 | 68 | -- | ProcessSim inside Lamport clock simulation. 69 | newtype ProcessSimT m a = 70 | ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a) 71 | deriving (Applicative, Functor, Monad, MonadFail) 72 | 73 | type ProcessSim = ProcessSimT Identity 74 | 75 | instance MonadTrans ProcessSimT where 76 | lift = ProcessSim . lift . lift 77 | 78 | instance Monad m => Process (ProcessSimT m) where 79 | getPid = ProcessSim ask 80 | 81 | instance Monad m => Clock (ProcessSimT m) where 82 | getTimes n' = ProcessSim $ do 83 | pid <- ask 84 | time <- lift $ preIncreaseTime n pid 85 | tell $ Seq.singleton ObservedTime{stamp = time, count = n} 86 | pure $ LamportTime time pid 87 | where 88 | n = max n' 1 89 | 90 | advance time = ProcessSim $ do 91 | pid <- ask 92 | lift . LamportClockSim . modify $ Map.alter (Just . advancePS) pid 93 | where 94 | advancePS = \case 95 | Nothing -> time 96 | Just current -> max time current 97 | 98 | instance MonadIO m => MonadIO (ProcessSimT m) where 99 | liftIO io = ProcessSim $ liftIO io 100 | 101 | runLamportClockSim :: LamportClockSim a -> Either String a 102 | runLamportClockSim (LamportClockSim action) = 103 | evalState (runExceptT action) mempty 104 | 105 | runLamportClockSimT :: Monad m => LamportClockSimT m a -> m (Either String a) 106 | runLamportClockSimT (LamportClockSim action) = 107 | evalStateT (runExceptT action) mempty 108 | 109 | runProcessSim :: Pid -> ProcessSim a -> LamportClockSim a 110 | runProcessSim = runProcessSimT 111 | 112 | runProcessSimT :: Monad m => Pid -> ProcessSimT m a -> LamportClockSimT m a 113 | runProcessSimT pid (ProcessSim action) = fst <$> evalRWST action pid () 114 | 115 | evalProcessSim :: Pid -> ProcessSim a -> LamportClockSim (a, [ObservedTime]) 116 | evalProcessSim pid (ProcessSim action) = 117 | second toList <$> evalRWST action pid () 118 | 119 | -- | Increase time by pid and return new value 120 | preIncreaseTime :: Monad m => Natural -> Pid -> LamportClockSimT m LocalTime 121 | preIncreaseTime n pid = LamportClockSim $ state $ \pss -> 122 | let time0 = fromMaybe 0 $ Map.lookup pid pss 123 | Pid p = pid 124 | d = fromIntegral . abs $ hash (time0, n, p) 125 | time = time0 + max 1 d 126 | in (time, Map.insert pid time pss) 127 | -------------------------------------------------------------------------------- /crdt-test/lib/CRDT/Laws.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | module CRDT.Laws 10 | ( cmrdtLaw 11 | , cvrdtLaws 12 | , opCommutativity 13 | ) where 14 | 15 | import Control.Monad.State.Strict (MonadState, StateT, evalStateT, 16 | execStateT, get, modify) 17 | import Control.Monad.Trans (lift) 18 | import Data.Functor.Identity (runIdentity) 19 | import Data.Maybe (isJust) 20 | import QuickCheck.GenT (MonadGen, liftGen, runGenT) 21 | import qualified QuickCheck.GenT as GenT 22 | import Test.QuickCheck (Arbitrary (..), Property, choose, 23 | counterexample, discard, forAll, getSize, 24 | property, (.&&.), (===), (==>)) 25 | import Test.Tasty (TestTree) 26 | import Test.Tasty.QuickCheck (testProperty) 27 | 28 | import CRDT.Cm (CmRDT (..), concurrent) 29 | import CRDT.Cv (CvRDT) 30 | import CRDT.LamportClock (Clock) 31 | import CRDT.LamportClock.Simulation (ProcessSim, ProcessSimT, 32 | runLamportClockSimT, 33 | runProcessSimT) 34 | import Data.Semilattice (Semilattice, merge) 35 | 36 | import CRDT.Arbitrary () 37 | 38 | semigroupLaw :: forall a . (Arbitrary a, Semigroup a, Eq a, Show a) => TestTree 39 | semigroupLaw = testProperty "associativity" associativity 40 | where associativity x y (z :: a) = (x <> y) <> z === x <> (y <> z) 41 | 42 | semilatticeLaws 43 | :: forall a . (Arbitrary a, Semilattice a, Eq a, Show a) => [TestTree] 44 | semilatticeLaws = 45 | [ semigroupLaw @a 46 | , testProperty "commutativity" commutativity 47 | , testProperty "idempotency" idempotency 48 | ] 49 | where 50 | idempotency (x :: a) = x `merge` x === x 51 | commutativity x (y :: a) = x `merge` y === y `merge` x 52 | 53 | cvrdtLaws :: forall a . (Arbitrary a, CvRDT a, Eq a, Show a) => [TestTree] 54 | cvrdtLaws = semilatticeLaws @a 55 | 56 | -- | CmRDT law: concurrent ops commute 57 | cmrdtLaw 58 | :: forall op 59 | . ( Arbitrary (Intent op) 60 | , CmRDT op 61 | , Show (Intent op) 62 | , Show (Payload op) 63 | , Show op 64 | ) 65 | => Property 66 | cmrdtLaw = property concurrentOpsCommute 67 | where 68 | concurrentOpsCommute pid1 pid2 pid3 = 69 | pid1 < pid2 && pid2 < pid3 ==> forAll genFixture $ \case 70 | Right ((in1, op1), (in2, op2), state3) -> 71 | concurrent op1 op2 72 | ==> opCommutativity (in1, op1) (in2, op2) state3 73 | Left _ -> discard 74 | where 75 | genFixture = 76 | fmap runIdentity 77 | . runGenT 78 | . runLamportClockSimT 79 | $ (,,) 80 | <$> runProcessSimT pid1 genStateAndTakeLastOp 81 | <*> runProcessSimT pid2 genStateAndTakeLastOp 82 | <*> runProcessSimT pid3 genState 83 | genState = (`execStateT` initial @op) $ genAndApplyOps @op 84 | genStateAndTakeLastOp = (`evalStateT` initial @op) $ do 85 | _ <- genAndApplyOps @op 86 | genAndApplyOp @op 87 | 88 | opCommutativity 89 | :: forall op 90 | . (CmRDT op, Show op, Show (Intent op), Show (Payload op)) 91 | => (Intent op, op) -- ^ the op must be made from the intent 92 | -> (Intent op, op) -- ^ the op must be made from the intent 93 | -> Payload op -- ^ any reachable state 94 | -> Property 95 | opCommutativity (in1, op1) (in2, op2) state = 96 | isJust (makeOp' in1 state) 97 | ==> isJust (makeOp' in2 state) 98 | ==> counterexample 99 | ( show in2 100 | ++ " must be valid after " 101 | ++ show op1 102 | ++ " applied to " 103 | ++ show state 104 | ) 105 | (isJust $ makeOp' in2 $ apply op1 state) 106 | .&&. (apply op1 . apply op2) state 107 | === (apply op2 . apply op1) state 108 | where makeOp' = makeOp @op @ProcessSim 109 | 110 | genAndApplyOp 111 | :: ( Arbitrary (Intent op) 112 | , Clock m 113 | , CmRDT op 114 | , MonadGen m 115 | , MonadState (Payload op) m 116 | ) 117 | => m (Intent op, op) 118 | genAndApplyOp = do 119 | payload <- get 120 | intent <- liftGen arbitrary 121 | case makeOp intent payload of 122 | Nothing -> genAndApplyOp 123 | Just opAction -> do 124 | op <- opAction 125 | modify $ apply op 126 | pure (intent, op) 127 | 128 | genAndApplyOps 129 | :: ( Arbitrary (Intent op) 130 | , Clock m 131 | , CmRDT op 132 | , MonadGen m 133 | , MonadState (Payload op) m 134 | ) 135 | => m [(Intent op, op)] 136 | genAndApplyOps = GenT.listOf genAndApplyOp 137 | 138 | instance MonadGen m => MonadGen (ProcessSimT m) where 139 | liftGen = lift . liftGen 140 | variant = undefined 141 | sized f = do 142 | size <- liftGen getSize 143 | f size 144 | resize = undefined 145 | choose = liftGen . choose 146 | 147 | instance MonadGen m => MonadGen (StateT s m) where 148 | liftGen = lift . liftGen 149 | variant = undefined 150 | sized f = do 151 | size <- liftGen getSize 152 | f size 153 | resize = undefined 154 | choose = liftGen . choose 155 | -------------------------------------------------------------------------------- /crdt/lib/CRDT/Cm/RGA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE ParallelListComp #-} 4 | {-# LANGUAGE StrictData #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | -- | Replicated Growable Array (RGA) 8 | module CRDT.Cm.RGA 9 | ( RGA (..) 10 | , RgaIntent (..) 11 | , RgaPayload (..) 12 | , fromString 13 | , load 14 | , toString 15 | , toVector 16 | ) where 17 | 18 | import Prelude hiding (lookup) 19 | 20 | import Control.Monad.State.Strict (MonadState) 21 | import Data.Empty (AsEmpty (..)) 22 | import Data.Map.Strict (Map) 23 | import qualified Data.Map.Strict as Map 24 | import Data.Vector (Vector, (//)) 25 | import qualified Data.Vector as Vector 26 | 27 | import CRDT.Cm (CausalOrd, CmRDT, Intent, Payload, apply, initial, 28 | makeAndApplyOp, makeOp, precedes) 29 | import CRDT.LamportClock (Clock, LamportTime (LamportTime), advance, 30 | getTime) 31 | 32 | -- | Using 'LamportTime' as an identifier for vertices 33 | type VertexId = LamportTime 34 | 35 | data RgaPayload a = RgaPayload 36 | { vertices :: Vector (VertexId, a) -- TODO(cblp, 2018-02-06) Unbox 37 | , vertexIxs :: Map VertexId Int 38 | -- ^ indices in `vertices` vector 39 | } 40 | deriving (Eq, Show) 41 | 42 | -- | Is added and is not removed. 43 | lookup :: AsEmpty a => VertexId -> RgaPayload a -> Bool 44 | lookup v RgaPayload { vertices, vertexIxs } = case Map.lookup v vertexIxs of 45 | Just ix -> let (_, a) = vertices Vector.! ix in isNotEmpty a 46 | Nothing -> False 47 | 48 | data RgaIntent a 49 | = AddAfter (Maybe VertexId) a 50 | -- ^ 'Nothing' means the beginning 51 | | Remove VertexId 52 | deriving (Show) 53 | 54 | data RGA a 55 | = OpAddAfter (Maybe VertexId) a VertexId 56 | -- ^ - id of previous vertex, 'Nothing' means the beginning 57 | -- - atom 58 | -- - id of this vertex 59 | | OpRemove VertexId 60 | deriving (Eq, Show) 61 | 62 | instance CausalOrd (RGA a) where 63 | precedes _ _ = False 64 | 65 | emptyPayload :: RgaPayload a 66 | emptyPayload = RgaPayload {vertices = Vector.empty, vertexIxs = Map.empty} 67 | 68 | instance (AsEmpty a, Ord a) => CmRDT (RGA a) where 69 | type Intent (RGA a) = RgaIntent a 70 | type Payload (RGA a) = RgaPayload a 71 | 72 | initial = emptyPayload 73 | 74 | makeOp (AddAfter mOldId atom) payload = case mOldId of 75 | Nothing -> ok 76 | Just oldId 77 | | lookup oldId payload -> ok 78 | | otherwise -> Nothing 79 | where 80 | RgaPayload{vertexIxs} = payload 81 | ok = Just $ do 82 | case Map.lookupMax vertexIxs of 83 | Just (LamportTime maxKnownTime _, _) -> advance maxKnownTime 84 | Nothing -> pure () 85 | OpAddAfter mOldId atom <$> getTime 86 | 87 | makeOp (Remove w) payload 88 | | lookup w payload = Just . pure $ OpRemove w 89 | | otherwise = Nothing 90 | 91 | apply (OpAddAfter mOldId newAtom newId) payload = 92 | RgaPayload{vertices = vertices', vertexIxs = vertexIxs'} 93 | where 94 | RgaPayload{vertices, vertexIxs} = payload 95 | n = length vertices 96 | 97 | (vertices', newIx) 98 | | null vertices = case mOldId of 99 | Nothing -> (Vector.singleton (newId, newAtom), 0) 100 | Just oldId -> error $ show oldId <> " not delivered" 101 | | otherwise = (insert ix, ix) 102 | where 103 | ix = findWhereToInsert $ case mOldId of 104 | Nothing -> 0 105 | Just oldId -> vertexIxs Map.! oldId + 1 106 | 107 | vertexIxs' = Map.insert newId newIx $ Map.map shift vertexIxs 108 | 109 | shift ix 110 | | ix >= newIx = ix + 1 111 | | otherwise = ix 112 | 113 | -- Find an edge (l, r) within which to splice new 114 | findWhereToInsert ix = 115 | case vertices Vector.!? ix of 116 | Just (t', _) | newId < t' -> -- Right position, wrong order 117 | findWhereToInsert $ succ ix 118 | _ -> ix 119 | 120 | insert ix 121 | | ix < n = left <> Vector.singleton (newId, newAtom) <> right 122 | | otherwise = Vector.snoc vertices (newId, newAtom) 123 | where 124 | (left, right) = Vector.splitAt ix vertices 125 | 126 | apply (OpRemove vid) payload@RgaPayload{vertices, vertexIxs} = 127 | -- pre addAfter(_, w) delivered -- 2P-Set precondition 128 | payload{vertices = vertices // [(ix, (vid, empty))]} 129 | where 130 | ix = vertexIxs Map.! vid 131 | 132 | fromList 133 | :: (AsEmpty a, Ord a, Clock m, MonadFail m, MonadState (RgaPayload a) m) 134 | => [a] 135 | -> m [RGA a] 136 | fromList = go Nothing 137 | where 138 | go _ [] = pure [] 139 | go prevId (x:xs) = do 140 | op@(OpAddAfter _ _ newId) <- makeAndApplyOp (AddAfter prevId x) 141 | (op :) <$> go (Just newId) xs 142 | 143 | toList :: RgaPayload a -> [a] 144 | toList RgaPayload { vertices } = map snd $ Vector.toList vertices 145 | 146 | toVector :: RgaPayload a -> Vector a 147 | toVector RgaPayload { vertices } = Vector.map snd vertices 148 | 149 | fromString 150 | :: (Clock m, MonadFail m, MonadState (RgaPayload Char) m) 151 | => String 152 | -> m [RGA Char] 153 | fromString = fromList 154 | 155 | toString :: RgaPayload Char -> String 156 | toString = toList 157 | 158 | load :: Vector (VertexId, a) -> RgaPayload a 159 | load vertices = RgaPayload 160 | { vertices 161 | , vertexIxs = Map.fromList 162 | [ (vid, ix) | ix <- [0..] | (vid, _) <- Vector.toList vertices ] 163 | } 164 | -------------------------------------------------------------------------------- /crdt-test/test/Cm/RGA.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | {-# LANGUAGE ParallelListComp #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Cm.RGA where 8 | 9 | import Prelude hiding (fail) 10 | 11 | import Control.Monad.State.Strict (execStateT, runStateT) 12 | import Data.Foldable (toList) 13 | import qualified Data.Map.Strict as Map 14 | import Data.Maybe (isJust) 15 | import Test.QuickCheck (Property, conjoin, counterexample, (.&&.), 16 | (===)) 17 | 18 | import CRDT.Arbitrary (NoNul (..)) 19 | import CRDT.Cm (apply, initial, makeAndApplyOp, makeOp) 20 | import CRDT.Cm.RGA (RGA (OpAddAfter, OpRemove), RgaIntent (AddAfter), 21 | RgaPayload (RgaPayload), fromString, load, 22 | toString) 23 | import CRDT.LamportClock (LamportTime (LamportTime), Pid (Pid), 24 | advance) 25 | import CRDT.LamportClock.Simulation (ProcessSim, runLamportClockSim, 26 | runProcessSim) 27 | import CRDT.Laws (cmrdtLaw) 28 | import GHC.Exts (fromList) 29 | 30 | import Util (pattern (:-), expectRightK, fail, ok) 31 | 32 | prop_makeOp = isJust $ makeOp @(RGA Char) @ProcessSim 33 | (AddAfter Nothing 'a') 34 | (initial @(RGA Char)) 35 | 36 | prop_makeAndApplyOp = conjoin 37 | [ counterexample "result3" $ expectRightK result3 $ \(op, payload) -> 38 | counterexample ("op = " ++ show op) (opsEqWoTime op op3) 39 | .&&. counterexample "payload" (payloadsEqWoTime payload payload3) 40 | , counterexample "result2" $ expectRightK result2 $ \(op, payload) -> 41 | counterexample ("op = " ++ show op) (opsEqWoTime op op2) 42 | .&&. counterexample "payload" (payloadsEqWoTime payload payload2) 43 | , counterexample "result1" $ expectRightK result1 $ \(op, payload) -> 44 | counterexample ("op = " ++ show op) (opsEqWoTime op op1) 45 | .&&. counterexample "payload" (payloadsEqWoTime payload payload1) 46 | , counterexample "result12" $ result12 === payload12 47 | , counterexample "results=" $ result21 === result12 48 | ] 49 | where 50 | time1 = LamportTime 4 $ Pid 1 -- TODO(cblp, 2018-02-11) arbitrary pids 51 | time2 = LamportTime 4 $ Pid 2 52 | time3 = LamportTime 3 $ Pid 3 53 | op1 = OpAddAfter Nothing '1' time1 54 | op2 = OpAddAfter Nothing '2' time2 55 | op3 = OpAddAfter Nothing '3' time3 56 | payload3 = load $ fromList [time3 :- '3'] 57 | payload1 = load $ fromList [time1 :- '1', time3 :- '3'] 58 | payload2 = load $ fromList [time2 :- '2', time3 :- '3'] 59 | payload12 = load $ fromList [time2 :- '2', time1 :- '1', time3 :- '3'] 60 | result3 = 61 | runLamportClockSim 62 | . runProcessSim (Pid 3) 63 | . (`runStateT` initial @(RGA Char)) 64 | $ do 65 | advance 2 66 | makeAndApplyOp @(RGA Char) (AddAfter Nothing '3') 67 | result2 = 68 | runLamportClockSim . runProcessSim (Pid 2) . (`runStateT` payload3) $ do 69 | advance 1 70 | makeAndApplyOp @(RGA Char) (AddAfter Nothing '2') 71 | result1 = 72 | runLamportClockSim 73 | . runProcessSim (Pid 1) 74 | . (`runStateT` payload3) 75 | $ makeAndApplyOp @(RGA Char) (AddAfter Nothing '1') 76 | result12 = apply op2 payload1 77 | result21 = apply op1 payload2 78 | 79 | prop_fromString (NoNul s) pid = 80 | expectRightK result $ payloadsEqWoTime $ load $ fromList 81 | [ LamportTime t pid :- c | t <- [1..] | c <- s ] 82 | where 83 | result = 84 | runLamportClockSim 85 | . runProcessSim pid 86 | . (`execStateT` initial @(RGA Char)) 87 | $ fromString s 88 | 89 | prop_fromString_toString (NoNul s) pid = expectRightK result 90 | $ \s' -> toString s' === s 91 | where 92 | result = 93 | runLamportClockSim 94 | . runProcessSim pid 95 | . (`execStateT` initial @(RGA Char)) 96 | $ fromString s 97 | 98 | prop_Cm = cmrdtLaw @(RGA Char) 99 | 100 | -- | Ops equal without local times 101 | opsEqWoTime (OpAddAfter parent1 atom1 id1) (OpAddAfter parent2 atom2 id2) = 102 | conjoin 103 | [ counterexample "parent" $ pidsMaybeEq parent1 parent2 104 | , counterexample "atom" $ atom1 === atom2 105 | , counterexample "id" $ pidsEqWoTime id1 id2 106 | ] 107 | opsEqWoTime (OpRemove parent1) (OpRemove parent2) = 108 | counterexample "parent" $ pidsEqWoTime parent1 parent2 109 | opsEqWoTime x y = fail $ show x ++ " /= " ++ show y 110 | 111 | pidsEqWoTime (LamportTime _ pid1) (LamportTime _ pid2) = pid1 === pid2 112 | 113 | pidsMaybeEq Nothing Nothing = ok 114 | pidsMaybeEq (Just x) (Just y) = pidsEqWoTime x y 115 | pidsMaybeEq x y = fail $ show x ++ " /= " ++ show y 116 | 117 | payloadsEqWoTime :: (Eq a, Show a) => RgaPayload a -> RgaPayload a -> Property 118 | payloadsEqWoTime (RgaPayload vertices1 vertexIxs1) (RgaPayload vertices2 vertexIxs2) 119 | = conjoin 120 | [ counterexample "vertices" $ conjoin 121 | [ counterexample ("[" ++ show i ++ "]") 122 | $ counterexample "id" (pidsEqWoTime id1 id2) 123 | .&&. counterexample "atom" (a1 === a2) 124 | | i <- [0 :: Int ..] | (id1, a1) <- toList vertices1 | (id2, a2) <- toList vertices2 125 | ] 126 | , counterexample "vertexIxs" $ conjoin 127 | [ counterexample "id" (pidsEqWoTime id1 id2) 128 | .&&. counterexample "ix" (ix1 === ix2) 129 | | (id1, ix1) <- Map.assocs vertexIxs1 | (id2, ix2) <- Map.assocs vertexIxs2 130 | ] 131 | ] 132 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to [Compatible Versioning](https://gitlab.com/staltz/comver). 6 | 7 | ## [Unreleased] 8 | 9 | [Unreleased]: https://github.com/cblp/crdt/compare/v10.7...master 10 | 11 | ## [10.7] - 2021-01-30 12 | ### Added 13 | - Support for GHC 8.10/base-4.14 14 | 15 | [10.7]: https://github.com/cblp/crdt/compare/v10.6...v10.7 16 | 17 | ## [10.6] - 2020-12-26 18 | ### Changed 19 | - Updated Diff dependency. 20 | - Simplified LwwElementSet implementation. 21 | We know for sure the new item is happened-after all existing items, 22 | so we can use unconditional insert. 23 | 24 | ### Removed 25 | - Dropped support of GHC < 8.8, since this package is for experiments only. 26 | 27 | [10.6]: https://github.com/cblp/crdt/compare/v10.5...v10.6 28 | 29 | ## [10.5] - 2019-09-22 30 | ### Fixed 31 | - Diff dependency bounds 32 | 33 | [10.5]: https://github.com/cblp/crdt/compare/v10.4...v10.5 34 | 35 | ## [10.4] - 2019-02-27 36 | ### Added 37 | - Support for GHC 8.6 38 | 39 | ### Changed 40 | - Use IORef as a container for local time instead of TVar. 41 | 42 | [10.4]: https://github.com/cblp/crdt/compare/v10.3...v10.4 43 | 44 | ## [10.3] - 2018-08-03 45 | ### Added 46 | - Instance Semilattice (CvRDT) for Maybe 47 | 48 | [10.3]: https://github.com/cblp/crdt/compare/v10.2...v10.3 49 | 50 | ## [10.2] - 2018-06-08 51 | ### Fixed 52 | - Building with GHC 8.0 53 | 54 | [10.2]: https://github.com/cblp/crdt/compare/v10.1...v10.2 55 | 56 | ## [10.1] - 2018-06-08 57 | ### Added 58 | - Support for GHC 8.4 59 | 60 | [10.1]: https://github.com/cblp/crdt/compare/v10.0...v10.1 61 | 62 | ## [4.0] - 2017-11-30 63 | 64 | [4.0]: https://github.com/cblp/crdt/compare/3.0...4.0 65 | 66 | ## [3.0] - 2017-11-25 67 | 68 | [3.0]: https://github.com/cblp/crdt/compare/2.1...3.0 69 | 70 | ## [2.1] - 2017-10-08 71 | 72 | [2.1]: https://github.com/cblp/crdt/compare/2.0...2.1 73 | 74 | ## [2.0] - 2017-10-08 75 | 76 | [2.0]: https://github.com/cblp/crdt/compare/1.0...2.0 77 | 78 | ## [1.0] - 2017-10-03 79 | ### Added 80 | - CRDTs: 81 | - `CRDT.Cm.Counter` for the op-based counter. 82 | - Law test. 83 | - `CRDT.Cm.GSet` for the op-based G-set. 84 | - Op-based LWW with `Assign` op. 85 | - `CRDT.Cm.TPSet` for the op-based 2P-set. 86 | - Law test. 87 | - `CRDT.Cv.Max`. 88 | - Law test. 89 | - Class `Observe`. 90 | - Module `LamportClock` to work with Lamport clock simulation: 91 | - Types `Time`, `Timestamp`, `Pid`, `LamportClock`, `Process`. 92 | - Class `Clock`. 93 | - Functions `barrier`, `runLamportClock`, `runProcess`. 94 | - Module `Lens.Micro.Extra` with lens helpers. 95 | 96 | ### Changed 97 | - Reorganized modules: 98 | - Grouped into two groups: `CRDT.Cm` for Cm types and `CRDT.Cv` for Cv ones. 99 | - Removed `Internal` submodules; 100 | all guts are exported until it will become an issue. 101 | - `CmRDT` class: 102 | - Made it parameterized by 3 types: _payload_, _op_ and _update_. 103 | - Used `PartialOrd` (from `lattices:Algebra.PartialOrd`) of ops 104 | as a prerequisite. 105 | - Used `Observe` to compare only user-visible parts of CmRDT payload. 106 | - Renamed `update` to `updateDownstream` to be closer to the paper. 107 | - Added `updateAtSource` as written in the paper. 108 | - Added its precodition as the separate method `updateAtSourcePre`. 109 | - Allowed updates to be run in a `Clock`-constrained monad to get timestamps. 110 | - LWW: 111 | - Cv variant: 112 | - Made `initial` and `assign` dependent on `Clock` monad 113 | since they need timestamps and cannot rely on user-provided timestamps. 114 | - Module `Data.Semilattice`: 115 | - Renamed Semilattice specialization of Semigroup's `(<>)` from `slappend` 116 | to `merge` to show symmetry. 117 | - Moved `Arbitrary` orphan instances from `Instances` module into 118 | `ArbitraryOrphans` module. 119 | - CmRDT law test: 120 | - Used Lamport clock to check ops and update payloads at source. 121 | 122 | [1.0]: https://github.com/cblp/crdt/compare/0.5...1.0 123 | 124 | ## [0.5] - 2017-09-26 125 | ### Added 126 | - Exported `GSet` type. 127 | 128 | ### Changed 129 | - Cabal-file: 130 | - Shorten `copyright` section. 131 | 132 | [0.5]: https://github.com/cblp/crdt/compare/0.4...0.5 133 | 134 | ## [0.4] - 2017-09-26 135 | ### Added 136 | - Travis config. 137 | - HLint config. 138 | - README. 139 | - CRDTs: 140 | - `GSet` for G-set. 141 | - `Timestamp` type for simple natural timestamps. 142 | - In module `CRDT.LWW`: 143 | - Functions for LWW: 144 | - `point`. 145 | - `write`. 146 | - `query`. 147 | - Nikolay Loginov as an author. 148 | - Tests: 149 | - `GCounter`: 150 | - CmRDT variant: 151 | - Law. 152 | - Increment. 153 | - CvRDT variant: 154 | - Laws. 155 | - Increment. 156 | - `GSet`: 157 | - CvRDT laws. 158 | - Add. 159 | - `LWW`: 160 | - CmRDT instance: 161 | - Law. 162 | - Write latter. 163 | - Write former. 164 | - CvRDT instance: 165 | - Laws. 166 | - Write latter. 167 | - Write former. 168 | - `PNCounter`: 169 | - CmRDT variant: 170 | - Law. 171 | - Increment. 172 | - Decrement. 173 | - CvRDT variant: 174 | - Laws. 175 | - Increment. 176 | - Decrement. 177 | 178 | ### Changed 179 | - Module `Data.Semilattice`: 180 | - Renamed Semilattice specialization of Semigroup's `(<>)` from `(<>)` 181 | to `slappend`. 182 | - Moved law tests to the module `Test.Laws`. 183 | 184 | ### Removed 185 | - Common CmRDT `query` function. 186 | 187 | [0.4]: https://github.com/cblp/crdt/compare/0.3...0.4 188 | 189 | ## [0.3] - 2017-09-24 190 | ### Changed 191 | - Changed implemetation of `GCounter` from `Vector` to `IntMap`. 192 | 193 | [0.3]: https://github.com/cblp/crdt/compare/0.2...0.3 194 | 195 | ## [0.2] - 2017-05-15 196 | 197 | ### Added 198 | - Module `Data.Semilattice`: 199 | - Class `Semilattice`, the same as `CvRDT` was earlier. 200 | 201 | ### Changed 202 | - Renamed `CvRDT` class to `Semilattice`. 203 | Re-added `CvRDT` as an alias to `Semilattice`. 204 | - Renamed tests to reflect that CvRDT = Semilattice. 205 | 206 | [0.2]: https://github.com/cblp/crdt/compare/0.1...0.2 207 | 208 | ## [0.1] - 2017-05-15 209 | ### Added 210 | - Hackage package `crdt`. 211 | - Classes: 212 | - `CmRDT` 213 | - `CvRDT` 214 | - CRDTs: 215 | - `GCounter` for G-counter: 216 | - Cm variant. 217 | - Cv variant. 218 | - `LWW`. 219 | - `PNCounter` for PN-counter: 220 | - Cm variant. 221 | - Cv variant. 222 | - Tests: 223 | - CmRDT law. 224 | - CvRDT laws. 225 | - `GCounter`: 226 | - increment 227 | - `LWW`. 228 | - `PNCounter`: 229 | - Increment. 230 | - Decrement. 231 | - Stylish-haskell config. 232 | 233 | [0.1]: https://github.com/cblp/crdt/tree/0.1 234 | --------------------------------------------------------------------------------