diff --git a/crdt-event-fold.cabal b/crdt-event-fold.cabal --- a/crdt-event-fold.cabal +++ b/crdt-event-fold.cabal @@ -1,8 +1,6 @@ --- Initial crdt-event-fold.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - +cabal-version: 3.0 name: crdt-event-fold -version: 1.4.0.0 +version: 1.5.1.1 synopsis: Garbage collected event folding CRDT. description: Garbage collected event folding CRDT. Consistently apply arbitrary operations to replicated data. @@ -11,39 +9,42 @@ license-file: LICENSE author: Rick Owens maintainer: rick@owensmurray.com -copyright: 2020 Owens Murray, LLC. +copyright: 2022 Owens Murray, LLC. category: CRDT build-type: Simple extra-source-files: README.md -cabal-version: >=1.10 +common dependencies + build-depends: + , aeson >= 1.5.6.0 && < 1.6 + , base >= 4.14 && < 4.15 + , binary >= 0.8.8.0 && < 0.9 + , containers >= 0.6.5.1 && < 0.7 + , data-default-class >= 0.1.2.0 && < 0.2 + , data-dword >= 0.3.2.1 && < 0.4 + , exceptions >= 0.10.4 && < 0.11 + , monad-logger >= 0.3.36 && < 0.4 + , mtl >= 2.2.2 && < 2.3 + , transformers >= 0.5.6.2 && < 0.6 + library + import: dependencies exposed-modules: Data.CRDT.EventFold Data.CRDT.EventFold.Monad -- other-modules: -- other-extensions: - build-depends: - aeson >= 1.4.7.1 && < 1.5, - base >= 4.13 && < 4.14, - binary >= 0.8.7.0 && < 0.9, - containers >= 0.6.2.1 && < 0.7, - data-default-class >= 0.1.2.0 && < 0.2, - data-dword >= 0.3.2 && < 0.4, - monad-logger >= 0.3.35 && < 0.4, - mtl >= 2.2.2 && < 2.3, - transformers >= 0.5.6.2 && < 0.6 - hs-source-dirs: src - default-language: Haskell2010 + hs-source-dirs: src + default-language: Haskell2010 test-suite tests - main-is: test.hs - type: exitcode-stdio-1.0 + import: dependencies + main-is: test.hs + type: exitcode-stdio-1.0 hs-source-dirs: test - default-language: Haskell2010 + default-language: Haskell2010 build-depends: - base, - crdt-event-fold, - - hspec + , crdt-event-fold + , containers >= 0.6.5.1 && < 0.7 + , hspec >= 2.7.10 && < 2.8 diff --git a/src/Data/CRDT/EventFold.hs b/src/Data/CRDT/EventFold.hs --- a/src/Data/CRDT/EventFold.hs +++ b/src/Data/CRDT/EventFold.hs @@ -138,6 +138,7 @@ events, diffMerge, MergeError(..), + acknowledge, -- ** Participation participate, @@ -161,11 +162,13 @@ -- * Underlying Types EventFold, EventId, + bottomEid, Diff, ) where +import Control.Exception (Exception) import Data.Aeson (FromJSON(parseJSON), ToJSON(toEncoding, toJSON), FromJSONKey, ToJSONKey) import Data.Bifunctor (first) @@ -176,6 +179,7 @@ import Data.Maybe (catMaybes) import Data.Set ((\\), Set, member, union) import GHC.Generics (Generic) +import Type.Reflection (Typeable) import qualified Data.DoubleWord as DW import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map.Merge @@ -357,6 +361,7 @@ ) => Show (MergeError o p e) +instance (Typeable o, Typeable p, Typeable e, Show (Output e), Show o, Show p, Show e, Show (State e)) => Exception (MergeError o p e) {- | `Delta` is how we represent mutations to the event fold state. -} @@ -584,7 +589,7 @@ of Nothing -> Left (DiffTooSparse orig ep) Just (ef1, outputs1) -> - let (ef2, outputs2) = acknowledge participant ef1 + let (ef2, outputs2) = acknowledge_ participant ef1 in Right ( UpdateResult @@ -664,7 +669,7 @@ of Left err -> Left err Right (UpdateResult ef outputs _prop) -> - let (ef2, outputs2) = acknowledge participant (unEventFold ef) + let (ef2, outputs2) = acknowledge_ participant (unEventFold ef) in Right ( UpdateResult @@ -709,11 +714,32 @@ Returns the new 'EventFold' value, along with the output for all of the events that can now be considered "fully consistent". -} -acknowledge :: (Event e, Ord p) +acknowledge + :: ( Eq (Output e) + , Eq e + , Eq o + , Event e + , Ord p + ) => p + -> EventFold o p e + -> UpdateResult o p e +acknowledge p (EventFold ef) = + let (ef2, outputs) = acknowledge_ p ef + in + UpdateResult { + urEventFold = EventFold ef2, + urOutputs = outputs, + urNeedsPropagation = ef /= ef2 + } + + +{- | Internal version of 'acknowledge'. -} +acknowledge_ :: (Event e, Ord p) + => p -> EventFoldF o p e Identity -> (EventFoldF o p e Identity, Map (EventId p) (Output e)) -acknowledge p ef = +acknowledge_ p ef = {- First do a normal reduction, then do a special acknowledgement of the reduction error, if any. @@ -768,8 +794,8 @@ ( eid, let - (ef2, outputs1) = - acknowledge + (ef2, outputs) = + acknowledge_ self ef { psEvents = @@ -778,11 +804,10 @@ (Identity (Join peer), mempty) (psEvents ef) } - (ef3, outputs2) = acknowledge peer ef2 in UpdateResult { - urEventFold = EventFold ef3, - urOutputs = Map.union outputs1 outputs2, + urEventFold = EventFold ef2, + urOutputs = outputs, {- By definition, we have added some new information that needs propagating. @@ -806,7 +831,7 @@ disassociate peer (EventFold ef) = let (ef2, outputs) = - acknowledge + acknowledge_ peer ef { psEvents = @@ -855,7 +880,7 @@ eid, let (ef2, outputs) = - acknowledge + acknowledge_ p ( (unEventFold ef) { @@ -987,7 +1012,9 @@ this context, a participant is "diverging" if there is an event that the participant has not acknowledged but we are expecting it to acknowledge. Along with the participant, return the last known - `EventId` which that participant has acknowledged. + `EventId` which that participant has acknowledged, or 'BottomEid' + if the participant has a acknowledged no events, as may be the case + immediately after the participant joined replication. -} divergent :: forall o p e. (Ord p) => EventFold o p e -> Map p (EventId p) divergent @@ -1022,7 +1049,7 @@ ( unionWith max - (Map.insert p eid acc) + (Map.insert p BottomEid acc) (Map.fromList [(a, eid) | a <- Set.toList acks]), max maxEid eid ) @@ -1259,5 +1286,10 @@ case Map.minView (psEvents ef) of Just ((Identity (Error _ _), _), _) -> True _ -> False + + +{- | The bottom 'EventId', possibly useful for comparison in tests. -} +bottomEid :: EventId p +bottomEid = BottomEid diff --git a/src/Data/CRDT/EventFold/Monad.hs b/src/Data/CRDT/EventFold/Monad.hs --- a/src/Data/CRDT/EventFold/Monad.hs +++ b/src/Data/CRDT/EventFold/Monad.hs @@ -16,6 +16,7 @@ ) where +import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (MonadLogger, MonadLoggerIO) import Control.Monad.Reader (MonadReader(ask), ReaderT(runReaderT)) @@ -42,14 +43,10 @@ event :: e -> m (Output e, EventId p) {- | Perform a full merge. See 'EF.fullMerge'. -} - fullMerge - :: EventFold o p e - -> m (Either (MergeError o p e) ()) + fullMerge :: EventFold o p e -> m (Either (MergeError o p e) ()) {- | Perform a diff merge. See 'EF.diffMerge'. -} - diffMerge - :: Diff o p e - -> m (Either (MergeError o p e) ()) + diffMerge :: Diff o p e -> m (Either (MergeError o p e) ()) {- | Allow a new participant to join in the cluster. See 'EF.participate'. -} participate :: p -> m (EventId p) @@ -87,6 +84,7 @@ , MonadIO , MonadLogger , MonadLoggerIO + , MonadThrow ) instance MonadTrans (EventFoldT o p e) where lift = EventFoldT . lift . lift diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -11,9 +11,10 @@ import Data.CRDT.EventFold (Event(Output, State, apply), EventResult(Pure), UpdateResult(urEventFold, urNeedsPropagation, - urOutputs), EventFold, diffMerge, disassociate, divergent, event, - events, fullMerge, infimumValue, new, participate) + urOutputs), EventFold, acknowledge, bottomEid, diffMerge, disassociate, + divergent, event, events, fullMerge, infimumValue, new, participate) import Test.Hspec (describe, hspec, it, shouldBe, shouldNotBe) +import qualified Data.Map as Map data Ops @@ -29,7 +30,7 @@ main :: IO () -main = hspec $ +main = hspec $ do describe "EventFold" $ it "works in a specific contrived scenario" $ do {- New crdt with the participant 'a'. -} @@ -41,8 +42,16 @@ let (_eid, r) = participate 'a' 'b' a let a = urEventFold r let b = urEventFold r + show a `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = BottomEid, participants = fromList \"a\", stateValue = 0}, psEvents = fromList [(Eid 0 'a',(Identity (Join 'b'),fromList \"a\"))]}}" + show b `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = BottomEid, participants = fromList \"a\", stateValue = 0}, psEvents = fromList [(Eid 0 'a',(Identity (Join 'b'),fromList \"a\"))]}}" + + let r = acknowledge 'b' b + let b = urEventFold r + let Right r = diffMerge 'a' a (events 'a' b) + let a = urEventFold r show a `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = Eid 0 'a', participants = fromList \"ab\", stateValue = 0}, psEvents = fromList []}}" show b `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = Eid 0 'a', participants = fromList \"ab\", stateValue = 0}, psEvents = fromList []}}" + urOutputs r `shouldBe` mempty urNeedsPropagation r `shouldBe` True show (divergent a) `shouldBe` "fromList []" @@ -148,6 +157,8 @@ {- 'c' joins on 'a' -} let (_eid, r) = participate 'a' 'c' a let a = urEventFold r + let r = acknowledge 'c' a + let a = urEventFold r let c = urEventFold r show a `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = Eid 2 'a', participants = fromList \"ab\", stateValue = -3}, psEvents = fromList [(Eid 3 'a',(Identity (Event Inc),fromList \"ac\")),(Eid 4 'a',(Identity (Join 'c'),fromList \"ac\"))]}}" show b `shouldBe` "EventFold {unEventFold = EventFoldF {psOrigin = 0, psInfimum = Infimum {eventId = Eid 2 'a', participants = fromList \"ab\", stateValue = -3}, psEvents = fromList [(Eid 3 'b',(Identity (Event Inc),fromList \"b\"))]}}" @@ -311,4 +322,19 @@ show (divergent c) `shouldBe` "fromList []" show a `shouldBe` show b show a `shouldBe` show c + + describe "divergent" $ do + it "marks an unacked join as divergent" $ do + let + a = new 0 'a' :: EventFold Int Char Ops + b = urEventFold . snd . participate 'a' 'b' $ a + divergent b `shouldBe` Map.fromList [('b', bottomEid)] + it "does not mark an acked join as divergent" $ do + let + a = new 0 'a' :: EventFold Int Char Ops + b = urEventFold . snd . participate 'a' 'b' $ a + c = urEventFold . snd . participate 'a' 'c' $ b + d = urEventFold . acknowledge 'c' $ c + divergent d `shouldBe` Map.fromList [('b', bottomEid)] +