genvalidity-mergeful 0.0.0.0 → 0.1.0.0

raw patch · 10 files changed

+752/−700 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• ChangeLog.md +0/−3
• genvalidity-mergeful.cabal +6/−5
• src/Data/GenValidity/Mergeful.hs +2/−99
• src/Data/GenValidity/Mergeful/Collection.hs +102/−0
• src/Data/GenValidity/Mergeful/Value.hs +2/−0
• test/Data/Mergeful/CollectionSpec.hs +603/−0
• test/Data/Mergeful/ItemSpec.hs +3/−3
• test/Data/Mergeful/ValueSpec.hs +25/−25
• test/Data/MergefulSpec.hs +0/−565

@@ -0,0 +1,9 @@+# Changelog++## [Unreleased]++## [0.1.0.0] - 2019-09-23++### Changed++* Compatibility with validity-containers >=0.5

@@ -1,3 +0,0 @@-# Changelog for mergeful--## Unreleased changes

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: dec5147002ec3be045920638188c5c8157bfce8d1d6778dd8186b06b56fa110d+-- hash: 86196b99586836b920b517c4273efac7cc705762e7ff8c445e911cfdafe35620  name:           genvalidity-mergeful-version:        0.0.0.0+version:        0.1.0.0 description:    Please see the README on GitHub at <https://github.com/NorfairKing/mergeful#readme> homepage:       https://github.com/NorfairKing/mergeful#readme bug-reports:    https://github.com/NorfairKing/mergeful/issues@@ -19,7 +19,7 @@ build-type:     Simple extra-source-files:     README.md-    ChangeLog.md+    CHANGELOG.md  source-repository head   type: git@@ -28,6 +28,7 @@ library   exposed-modules:       Data.GenValidity.Mergeful+      Data.GenValidity.Mergeful.Collection       Data.GenValidity.Mergeful.Item       Data.GenValidity.Mergeful.Timed       Data.GenValidity.Mergeful.Value@@ -49,10 +50,10 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Data.Mergeful.CollectionSpec       Data.Mergeful.ItemSpec       Data.Mergeful.TimedSpec       Data.Mergeful.ValueSpec-      Data.MergefulSpec       Paths_genvalidity_mergeful   hs-source-dirs:       test

@@ -1,102 +1,5 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- module Data.GenValidity.Mergeful where -import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S--import Data.Traversable--import Data.GenValidity-import Data.GenValidity.Containers ()-import Data.GenValidity.Time ()--import Test.QuickCheck-+import Data.GenValidity.Mergeful.Collection () import Data.GenValidity.Mergeful.Item ()--import Data.Mergeful--instance GenUnchecked ClientId--instance GenValid ClientId--instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ClientStore i a)--instance (GenValid i, Ord i, GenValid a) => GenValid (ClientStore i a) where-  genValid =-    (`suchThat` isValid) $ do-      identifiers <- scale (* 3) genValid-      (s1, s2) <- splitSet identifiers-      (s3, s4) <- splitSet s1-      clientStoreAddedItems <- genValid-      clientStoreSyncedItems <- mapWithIds s2-      clientStoreSyncedButChangedItems <- mapWithIds s3-      clientStoreDeletedItems <- mapWithIds s4-      pure ClientStore {..}-  shrinkValid = shrinkValidStructurally--instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ServerStore i a)--instance (GenValid i, Ord i, GenValid a) => GenValid (ServerStore i a) where-  genValid = genValidStructurallyWithoutExtraChecking-  shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncRequest i a)--instance (GenValid i, Ord i, GenValid a) => GenValid (SyncRequest i a) where-  genValid =-    (`suchThat` isValid) $ do-      identifiers <- scale (* 3) genValid-      (s1, s2) <- splitSet identifiers-      (s3, s4) <- splitSet s1-      syncRequestNewItems <- genValid-      syncRequestKnownItems <- mapWithIds s2-      syncRequestKnownButChangedItems <- mapWithIds s3-      syncRequestDeletedItems <- mapWithIds s4-      pure SyncRequest {..}-  shrinkValid = shrinkValidStructurally--instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncResponse i a)--instance (GenValid i, Ord i, GenValid a) => GenValid (SyncResponse i a) where-  genValid =-    (`suchThat` isValid) $ do-      identifiers <- scale (* 10) genValid-      (s01, s02) <- splitSet identifiers-      (s03, s04) <- splitSet s01-      (s05, s06) <- splitSet s02-      (s07, s08) <- splitSet s03-      (s09, s10) <- splitSet s04-      (s11, s12) <- splitSet s05-      (s13, s14) <- splitSet s06-      (s15, s16) <- splitSet s07-      syncResponseClientAdded <--        do m <- (genValid :: Gen (Map ClientId ()))-           if S.null s08-             then pure M.empty-             else forM m $ \() -> (,) <$> elements (S.toList s08) <*> genValid-      syncResponseClientChanged <- mapWithIds s09-      let syncResponseClientDeleted = s10-      syncResponseServerAdded <- mapWithIds s11-      syncResponseServerChanged <- mapWithIds s12-      let syncResponseServerDeleted = s13-      syncResponseConflicts <- mapWithIds s14-      syncResponseConflictsClientDeleted <- mapWithIds s15-      let syncResponseConflictsServerDeleted = s16-      pure SyncResponse {..}-  shrinkValid = shrinkValidStructurally--splitSet :: Ord i => Set i -> Gen (Set i, Set i)-splitSet s =-  if S.null s-    then pure (S.empty, S.empty)-    else do-      a <- elements $ S.toList s-      pure $ S.split a s--mapWithIds :: (Ord i, GenValid a) => Set i -> Gen (Map i a)-mapWithIds s = fmap M.fromList $ for (S.toList s) $ \i -> (,) i <$> genValid+import Data.GenValidity.Mergeful.Value ()

@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeful.Collection where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S++import Data.Traversable++import Data.GenValidity+import Data.GenValidity.Containers ()+import Data.GenValidity.Time ()++import Test.QuickCheck++import Data.GenValidity.Mergeful.Item ()++import Data.Mergeful++instance GenUnchecked ClientId++instance GenValid ClientId++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ClientStore i a)++instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (ClientStore i a) where+  genValid =+    (`suchThat` isValid) $ do+      identifiers <- scale (* 3) genValid+      (s1, s2) <- splitSet identifiers+      (s3, s4) <- splitSet s1+      clientStoreAddedItems <- genValid+      clientStoreSyncedItems <- mapWithIds s2+      clientStoreSyncedButChangedItems <- mapWithIds s3+      clientStoreDeletedItems <- mapWithIds s4+      pure ClientStore {..}+  shrinkValid = shrinkValidStructurally++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ServerStore i a)++instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (ServerStore i a) where+  genValid = genValidStructurallyWithoutExtraChecking+  shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncRequest i a)++instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (SyncRequest i a) where+  genValid =+    (`suchThat` isValid) $ do+      identifiers <- scale (* 3) genValid+      (s1, s2) <- splitSet identifiers+      (s3, s4) <- splitSet s1+      syncRequestNewItems <- genValid+      syncRequestKnownItems <- mapWithIds s2+      syncRequestKnownButChangedItems <- mapWithIds s3+      syncRequestDeletedItems <- mapWithIds s4+      pure SyncRequest {..}+  shrinkValid = shrinkValidStructurally++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncResponse i a)++instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (SyncResponse i a) where+  genValid =+    (`suchThat` isValid) $ do+      identifiers <- scale (* 10) genValid+      (s01, s02) <- splitSet identifiers+      (s03, s04) <- splitSet s01+      (s05, s06) <- splitSet s02+      (s07, s08) <- splitSet s03+      (s09, s10) <- splitSet s04+      (s11, s12) <- splitSet s05+      (s13, s14) <- splitSet s06+      (s15, s16) <- splitSet s07+      syncResponseClientAdded <-+        do m <- genValid :: Gen (Map ClientId ())+           if S.null s08+             then pure M.empty+             else forM m $ \() -> (,) <$> elements (S.toList s08) <*> genValid+      syncResponseClientChanged <- mapWithIds s09+      let syncResponseClientDeleted = s10+      syncResponseServerAdded <- mapWithIds s11+      syncResponseServerChanged <- mapWithIds s12+      let syncResponseServerDeleted = s13+      syncResponseConflicts <- mapWithIds s14+      syncResponseConflictsClientDeleted <- mapWithIds s15+      let syncResponseConflictsServerDeleted = s16+      pure SyncResponse {..}+  shrinkValid = shrinkValidStructurally++splitSet :: Ord i => Set i -> Gen (Set i, Set i)+splitSet s =+  if S.null s+    then pure (S.empty, S.empty)+    else do+      a <- elements $ S.toList s+      pure $ S.split a s++mapWithIds :: (Ord i, GenValid a) => Set i -> Gen (Map i a)+mapWithIds s = fmap M.fromList $ for (S.toList s) $ \i -> (,) i <$> genValid

@@ -9,7 +9,9 @@ import Data.GenValidity.Mergeful.Timed ()  instance GenUnchecked ChangedFlag+ instance GenValid ChangedFlag+ instance GenUnchecked a => GenUnchecked (ClientValue a)  instance GenValid a => GenValid (ClientValue a) where

@@ -0,0 +1,603 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++module Data.Mergeful.CollectionSpec+  ( spec+  ) where++import Data.Functor.Identity+import Data.List+import qualified Data.Map as M+import qualified Data.Set as S+import Data.UUID+import GHC.Generics (Generic)+import System.Random+import Text.Show.Pretty++import Control.Monad.State++import Test.Hspec+import Test.QuickCheck+import Test.Validity+import Test.Validity.Aeson++import Data.GenValidity.UUID ()++import Data.Mergeful+import Data.Mergeful.Timed++import Data.GenValidity.Mergeful ()+import Data.GenValidity.Mergeful.Item ()++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++spec :: Spec+spec = do+  genValidSpec @ClientId+  jsonSpecOnValid @ClientId+  genValidSpec @(ClientStore Int Int)+  jsonSpecOnValid @(ClientStore Int Int)+  genValidSpec @(ServerStore Int Int)+  jsonSpecOnValid @(ServerStore Int Int)+  genValidSpec @(SyncRequest Int Int)+  jsonSpecOnValid @(SyncRequest Int Int)+  genValidSpec @(SyncResponse Int Int)+  jsonSpecOnValid @(SyncResponse Int Int)+  describe "initialClientStore" $ it "is valid" $ shouldBeValid $ initialClientStore @Int @Int+  describe "addItemToClientStore" $ do+    it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @Int @Int)+    it "makes the client store one bigger" $+      forAllValid $ \cs ->+        forAllValid $ \a ->+          clientStoreSize @Int @Int (addItemToClientStore a cs) `shouldBe` (clientStoreSize cs + 1)+    it "ensures that the added item is in fact in the result" $+      forAllValid $ \cs ->+        forAllValid $ \a ->+          let cs' = addItemToClientStore @Int @Int a cs+           in a `elem` clientStoreAddedItems cs'+  describe "markItemDeletedInClientStore" $ do+    it "produces valid stores" $ producesValidsOnValids2 (markItemDeletedInClientStore @Int @Int)+    it "makes the client store one smaller" $+      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0+       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->+            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->+              (clientStoreSize @Int @Int (markItemDeletedInClientStore i cs) + 1) `shouldBe`+              clientStoreSize cs+    it "ensures that the added item is in fact not in the result" $+      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0+       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->+            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->+              let cs' = markItemDeletedInClientStore @Int @Int i cs+               in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Nothing+  describe "changeItemInClientStore" $ do+    it "produces valid stores" $ producesValidsOnValids3 (changeItemInClientStore @Int @Int)+    it "doesn't change the size of the client store" $+      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0+       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->+            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->+              forAllValid $ \a ->+                clientStoreSize @Int @Int (changeItemInClientStore i a cs) `shouldBe`+                clientStoreSize cs+    it "ensures that the changed item is in fact in the result" $+      let p cs = S.size (clientStoreUndeletedSyncIdSet cs) > 0+       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->+            forAll (elements $ S.toList $ clientStoreUndeletedSyncIdSet cs) $ \i ->+              forAllValid $ \a ->+                let cs' = changeItemInClientStore @Int @Int i a cs+                 in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Just a+  describe "deleteItemFromClientStore" $ do+    it "produces valid stores" $ producesValidsOnValids2 (deleteItemFromClientStore @Int @Int)+    it "makes the client store one smaller" $+      let p cs = S.size (clientStoreClientIdSet cs) > 0+       in forAllShrink (genValid `suchThat` p) (filter p . shrinkValid) $ \cs ->+            forAll (elements $ S.toList $ clientStoreClientIdSet cs) $ \cid ->+              (clientStoreSize @Int @Int (deleteItemFromClientStore cid cs) + 1) `shouldBe`+              clientStoreSize cs+  describe "initialServerStore" $ it "is valid" $ shouldBeValid $ initialServerStore @Int @Int+  describe "initialSyncRequest" $ it "is valid" $ shouldBeValid $ initialSyncRequest @Int @Int+  describe "emptySyncResponse" $ it "is valid" $ shouldBeValid $ emptySyncResponse @Int @Int+  describe "makeSyncRequest" $+    it "produces valid requests" $ producesValidsOnValids (makeSyncRequest @Int @Int)+  describe "mergeAddedItems" $+    it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)+  describe "mergeSyncedButChangedItems" $+    it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)+  describe "mergeAddedItems" $+    it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)+  describe "mergeSyncedButChangedItems" $+    it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)+  describe "mergeDeletedItems" $+    it "produces valid results" $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)+  describe "mergeSyncResponseIgnoreProblems" $+    it "produces valid requests" $+    forAllValid $ \store ->+      forAllValid $ \response ->+        let res = mergeSyncResponseIgnoreProblems @Int @Int store response+         in case prettyValidate res of+              Right _ -> pure ()+              Left err ->+                expectationFailure $+                unlines+                  [ "Store:"+                  , ppShow store+                  , "Response:"+                  , ppShow response+                  , "Invalid result:"+                  , ppShow res+                  , "error:"+                  , err+                  ]+  describe "processServerSync" $+    it "produces valid tuples of a response and a store" $+    producesValidsOnValids2+      (\store request -> evalD $ processServerSync genD (store :: ServerStore UUID Int) request)+  describe "Syncing with mergeSyncResponseIgnoreProblems" $ do+    mergeFunctionSpec @Int mergeSyncResponseIgnoreProblems+    it "does not lose data after a conflict occurs" $+      forAllValid $ \uuid ->+        forAllValid $ \time1 ->+          forAllValid $ \i1 ->+            forAllValid $ \i2 ->+              forAllValid $ \i3 ->+                evalDM $ do+                  let sstore1 =+                        ServerStore+                          {serverStoreItems = M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)}+                      -- The server has an item+                      -- The first client has synced it, and modified it.+                  let cAstore1 =+                        initialClientStore+                          {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}+                      -- The second client has synced it too, and modified it too.+                  let cBstore1 =+                        initialClientStore+                          {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}+                      -- Client A makes sync request 1+                  let req1 = makeSyncRequest cAstore1+                      -- The server processes sync request 1+                  (resp1, sstore2) <- processServerSync genD sstore1 req1+                  let time2 = incrementServerTime time1+                      -- The server updates the item accordingly+                  lift $ do+                    resp1 `shouldBe`+                      (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+                    sstore2 `shouldBe`+                      (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})+                      -- Client A merges the response+                  let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+                  lift $+                    cAstore2 `shouldBe`+                    (initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+                      -- Client B makes sync request 2+                  let req2 = makeSyncRequest cBstore1+                      -- The server processes sync request 2+                  (resp2, sstore3) <- processServerSync genD sstore2 req2+                      -- The server reports a conflict and does not change its store+                  lift $ do+                    resp2 `shouldBe`+                      (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})+                    sstore3 `shouldBe` sstore2+                      -- Client B merges the response+                  let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+                      -- Client does not update, but keeps its conflict+                  lift $+                    cBstore2 `shouldBe`+                    (initialClientStore+                       {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)})+                      -- Client A and Client B now *do not* have the same store+  describe "Syncing with mergeSyncResponseFromServer" $ do+    mergeFunctionSpec @Int mergeSyncResponseFromServer+    describe "mergeSyncResponseFromServer" $+      it "only differs from mergeSyncResponseIgnoreProblems on conflicts" $+      forAllValid $ \cstore ->+        forAllValid $ \sresp@SyncResponse {..} -> do+          let cstoreA = mergeSyncResponseFromServer (cstore :: ClientStore UUID Int) sresp+              cstoreB = mergeSyncResponseIgnoreProblems cstore sresp+          if cstoreA == cstoreB+            then pure ()+            else unless+                   (or+                      [ not (M.null syncResponseConflicts)+                      , not (M.null syncResponseConflictsClientDeleted)+                      , not (S.null syncResponseConflictsServerDeleted)+                      ]) $+                 expectationFailure $+                 unlines+                   [ "There was a difference between mergeSyncResponseFromServer and mergeSyncResponseIgnoreProblems that was somehow unrelated to the conflicts:"+                   , "syncResponseConflicts:"+                   , ppShow syncResponseConflicts+                   , "syncResponseConflictsClientDeleted:"+                   , ppShow syncResponseConflictsClientDeleted+                   , "syncResponseConflictsServerDeleted:"+                   , ppShow syncResponseConflictsServerDeleted+                   , "client store after mergeSyncResponseFromServer:"+                   , ppShow cstoreA+                   , "client store after mergeSyncResponseIgnoreProblems:"+                   , ppShow cstoreB+                   ]+    it "does not diverge after a conflict occurs" $+      forAllValid $ \uuid ->+        forAllValid $ \time1 ->+          forAllValid $ \i1 ->+            forAllValid $ \i2 ->+              forAllValid $ \i3 ->+                evalDM $ do+                  let sstore1 =+                        ServerStore+                          {serverStoreItems = M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)}+                      -- The server has an item+                      -- The first client has synced it, and modified it.+                  let cAstore1 =+                        initialClientStore+                          {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}+                      -- The second client has synced it too, and modified it too.+                  let cBstore1 =+                        initialClientStore+                          {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}+                      -- Client A makes sync request 1+                  let req1 = makeSyncRequest cAstore1+                      -- The server processes sync request 1+                  (resp1, sstore2) <- processServerSync genD sstore1 req1+                  let time2 = incrementServerTime time1+                      -- The server updates the item accordingly+                  lift $ do+                    resp1 `shouldBe`+                      (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+                    sstore2 `shouldBe`+                      (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})+                      -- Client A merges the response+                  let cAstore2 = mergeSyncResponseFromServer cAstore1 resp1+                  lift $+                    cAstore2 `shouldBe`+                    (initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+                      -- Client B makes sync request 2+                  let req2 = makeSyncRequest cBstore1+                      -- The server processes sync request 2+                  (resp2, sstore3) <- processServerSync genD sstore2 req2+                      -- The server reports a conflict and does not change its store+                  lift $ do+                    resp2 `shouldBe`+                      (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})+                    sstore3 `shouldBe` sstore2+                      -- Client B merges the response+                  let cBstore2 = mergeSyncResponseFromServer cBstore1 resp2+                      -- Client does not update, but keeps its conflict+                  lift $ do+                    cBstore2 `shouldBe`+                      (initialClientStore+                         {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+                        -- Client A and Client B now have the same store+                    cBstore2 `shouldBe` cAstore2+  describe "Syncing with mergeSyncResponseUsingStrategy with a GCounter" $+    mergeFunctionSpec @Int $+    mergeSyncResponseUsingStrategy+      ItemMergeStrategy+        { itemMergeStrategyMergeChangeConflict =+            \clientItem (Timed serverItem t) -> Timed (max clientItem serverItem) t+        , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem+        , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing+        }++mergeFunctionSpec ::+     forall a. (Show a, Ord a, GenValid a)+  => (forall i. Ord i =>+                  ClientStore i a -> SyncResponse i a -> ClientStore i a)+  -> Spec+mergeFunctionSpec mergeFunc = do+  describe "Single client" $+    describe "Multi-item" $ do+      it "succesfully downloads everything from the server for an empty client" $+        forAllValid $ \sstore1 ->+          evalDM $ do+            let cstore1 = initialClientStore+            let req = makeSyncRequest cstore1+            (resp, sstore2) <- processServerSync genD sstore1 req+            let cstore2 = mergeFunc cstore1 resp+            lift $ do+              sstore2 `shouldBe` sstore1+              clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+      it "succesfully uploads everything to the server for an empty server" $+        forAllValid $ \items ->+          evalDM $ do+            let cstore1 = initialClientStore {clientStoreAddedItems = items}+            let sstore1 = initialServerStore+            let req = makeSyncRequest cstore1+            (resp, sstore2) <- processServerSync genD sstore1 req+            let cstore2 = mergeFunc cstore1 resp+            lift $ do+              sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2))) `shouldBe`+                sort (M.elems items)+              clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+      it "is idempotent with one client" $+        forAllValid $ \cstore1 ->+          forAllValid $ \sstore1 ->+            evalDM $ do+              let req1 = makeSyncRequest cstore1+              (resp1, sstore2) <- processServerSync genD sstore1 req1+              let cstore2 = mergeFunc cstore1 resp1+                  req2 = makeSyncRequest cstore2+              (resp2, sstore3) <- processServerSync genD sstore2 req2+              let cstore3 = mergeFunc cstore2 resp2+              lift $ do+                cstore2 `shouldBe` cstore3+                sstore2 `shouldBe` sstore3+  describe "Multiple clients" $ do+    describe "Single-item" $ do+      it "successfully syncs an addition accross to a second client" $+        forAllValid $ \i ->+          evalDM $ do+            let cAstore1 = initialClientStore {clientStoreAddedItems = M.singleton (ClientId 0) i}+              -- Client B is empty+            let cBstore1 = initialClientStore+              -- The server is empty+            let sstore1 = initialServerStore+              -- Client A makes sync request 1+            let req1 = makeSyncRequest cAstore1+              -- The server processes sync request 1+            (resp1, sstore2) <- processServerSync genD sstore1 req1+            let addedItems = syncResponseClientAdded resp1+            case M.toList addedItems of+              [(ClientId 0, (uuid, st))] -> do+                let time = initialServerTime+                lift $ st `shouldBe` time+                let items = M.singleton uuid (Timed i st)+                lift $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+                  -- Client A merges the response+                let cAstore2 = mergeFunc cAstore1 resp1+                lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+                  -- Client B makes sync request 2+                let req2 = makeSyncRequest cBstore1+                  -- The server processes sync request 2+                (resp2, sstore3) <- processServerSync genD sstore2 req2+                lift $ do+                  resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+                  sstore3 `shouldBe` sstore2+                  -- Client B merges the response+                let cBstore2 = mergeFunc cBstore1 resp2+                lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+                  -- Client A and Client B now have the same store+                lift $ cAstore2 `shouldBe` cBstore2+              _ -> lift $ expectationFailure "Should have found exactly one added item."+      it "successfully syncs a modification accross to a second client" $+        forAllValid $ \uuid ->+          forAllValid $ \i ->+            forAllValid $ \j ->+              forAllValid $ \time1 ->+                evalDM $ do+                  let cAstore1 =+                        initialClientStore+                          {clientStoreSyncedItems = M.singleton uuid (Timed i time1)}+                    -- Client B had synced that same item, but has since modified it+                  let cBstore1 =+                        initialClientStore+                          {clientStoreSyncedButChangedItems = M.singleton uuid (Timed j time1)}+                    -- The server is has the item that both clients had before+                  let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+                    -- Client B makes sync request 1+                  let req1 = makeSyncRequest cBstore1+                    -- The server processes sync request 1+                  (resp1, sstore2) <- processServerSync genD sstore1 req1+                  let time2 = incrementServerTime time1+                  lift $ do+                    resp1 `shouldBe`+                      emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}+                    sstore2 `shouldBe`+                      ServerStore {serverStoreItems = M.singleton uuid (Timed j time2)}+                    -- Client B merges the response+                  let cBstore2 = mergeFunc cBstore1 resp1+                  lift $+                    cBstore2 `shouldBe`+                    initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+                    -- Client A makes sync request 2+                  let req2 = makeSyncRequest cAstore1+                    -- The server processes sync request 2+                  (resp2, sstore3) <- processServerSync genD sstore2 req2+                  lift $ do+                    resp2 `shouldBe`+                      emptySyncResponse+                        {syncResponseServerChanged = M.singleton uuid (Timed j time2)}+                    sstore3 `shouldBe` sstore2+                    -- Client A merges the response+                  let cAstore2 = mergeFunc cAstore1 resp2+                  lift $+                    cAstore2 `shouldBe`+                    initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+                    -- Client A and Client B now have the same store+                  lift $ cAstore2 `shouldBe` cBstore2+      it "succesfully syncs a deletion across to a second client" $+        forAllValid $ \uuid ->+          forAllValid $ \time1 ->+            forAllValid $ \i ->+              evalDM $ do+                let cAstore1 =+                      initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i time1)}+                  -- Client A has a synced item.+                  -- Client B had synced that same item, but has since deleted it.+                let cBstore1 = initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+                  -- The server still has the undeleted item+                let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+                  -- Client B makes sync request 1+                let req1 = makeSyncRequest cBstore1+                  -- The server processes sync request 1+                (resp1, sstore2) <- processServerSync genD sstore1 req1+                lift $ do+                  resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}+                  sstore2 `shouldBe` initialServerStore+                  -- Client B merges the response+                let cBstore2 = mergeFunc cBstore1 resp1+                lift $ cBstore2 `shouldBe` initialClientStore+                  -- Client A makes sync request 2+                let req2 = makeSyncRequest cAstore1+                  -- The server processes sync request 2+                (resp2, sstore3) <- processServerSync genD sstore2 req2+                lift $ do+                  resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}+                  sstore3 `shouldBe` sstore2+                  -- Client A merges the response+                let cAstore2 = mergeFunc cAstore1 resp2+                lift $ cAstore2 `shouldBe` initialClientStore+                  -- Client A and Client B now have the same store+                lift $ cAstore2 `shouldBe` cBstore2+      it "does not run into a conflict if two clients both try to sync a deletion" $+        forAllValid $ \uuid ->+          forAllValid $ \time1 ->+            forAllValid $ \i ->+              evalDM $ do+                let cAstore1 = initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+                  -- Both client a and client b delete an item.+                let cBstore1 = initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+                  -- The server still has the undeleted item+                let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+                  -- Client A makes sync request 1+                let req1 = makeSyncRequest cAstore1+                  -- The server processes sync request 1+                (resp1, sstore2) <- processServerSync genD sstore1 req1+                lift $ do+                  resp1 `shouldBe`+                    (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+                  sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})+                  -- Client A merges the response+                let cAstore2 = mergeFunc cAstore1 resp1+                lift $ cAstore2 `shouldBe` initialClientStore+                  -- Client B makes sync request 2+                let req2 = makeSyncRequest cBstore1+                  -- The server processes sync request 2+                (resp2, sstore3) <- processServerSync genD sstore2 req2+                lift $ do+                  resp2 `shouldBe`+                    (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+                  sstore3 `shouldBe` sstore2+                  -- Client B merges the response+                let cBstore2 = mergeFunc cBstore1 resp2+                lift $ do+                  cBstore2 `shouldBe` initialClientStore+                    -- Client A and Client B now have the same store+                  cAstore2 `shouldBe` cBstore2+    describe "Multiple items" $ do+      it "successfully syncs additions accross to a second client" $+        forAllValid $ \is ->+          evalDM $ do+            let cAstore1 = initialClientStore {clientStoreAddedItems = is}+              -- Client B is empty+            let cBstore1 = initialClientStore+              -- The server is empty+            let sstore1 = initialServerStore+              -- Client A makes sync request 1+            let req1 = makeSyncRequest cAstore1+              -- The server processes sync request 1+            (resp1, sstore2) <- processServerSync genD sstore1 req1+            let (rest, items) = mergeAddedItems is (syncResponseClientAdded resp1)+            lift $ do+              rest `shouldBe` M.empty+              sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+              -- Client A merges the response+            let cAstore2 = mergeFunc cAstore1 resp1+            lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+              -- Client B makes sync request 2+            let req2 = makeSyncRequest cBstore1+              -- The server processes sync request 2+            (resp2, sstore3) <- processServerSync genD sstore2 req2+            lift $ do+              resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+              sstore3 `shouldBe` sstore2+              -- Client B merges the response+            let cBstore2 = mergeFunc cBstore1 resp2+            lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+              -- Client A and Client B now have the same store+            lift $ cAstore2 `shouldBe` cBstore2+      it "succesfully syncs deletions across to a second client" $+        forAllValid $ \items ->+          forAllValid $ \time1 ->+            evalDM $ do+              let syncedItems = M.map (\i -> Timed i time1) items+                  itemTimes = M.map (const time1) items+                  itemIds = M.keysSet items+              let cAstore1 = initialClientStore {clientStoreSyncedItems = syncedItems}+                -- Client A has synced items+                -- Client B had synced the same items, but has since deleted them.+              let cBstore1 = initialClientStore {clientStoreDeletedItems = itemTimes}+                -- The server still has the undeleted item+              let sstore1 = ServerStore {serverStoreItems = syncedItems}+                -- Client B makes sync request 1+              let req1 = makeSyncRequest cBstore1+                -- The server processes sync request 1+              (resp1, sstore2) <- processServerSync genD sstore1 req1+              lift $ do+                resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}+                sstore2 `shouldBe` initialServerStore+                -- Client B merges the response+              let cBstore2 = mergeFunc cBstore1 resp1+              lift $ cBstore2 `shouldBe` initialClientStore+                -- Client A makes sync request 2+              let req2 = makeSyncRequest cAstore1+                -- The server processes sync request 2+              (resp2, sstore3) <- processServerSync genD sstore2 req2+              lift $ do+                resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}+                sstore3 `shouldBe` sstore2+                -- Client A merges the response+              let cAstore2 = mergeFunc cAstore1 resp2+              lift $ cAstore2 `shouldBe` initialClientStore+                -- Client A and Client B now have the same store+              lift $ cAstore2 `shouldBe` cBstore2+      it "does not run into a conflict if two clients both try to sync a deletion" $+        forAllValid $ \items ->+          forAllValid $ \time1 ->+            evalDM $ do+              let cAstore1 =+                    initialClientStore {clientStoreDeletedItems = M.map (const time1) items}+                -- Both client a and client b delete their items.+              let cBstore1 =+                    initialClientStore {clientStoreDeletedItems = M.map (const time1) items}+                -- The server still has the undeleted items+              let sstore1 = ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items}+                -- Client A makes sync request 1+              let req1 = makeSyncRequest cAstore1+                -- The server processes sync request 1+              (resp1, sstore2) <- processServerSync genD sstore1 req1+              lift $ do+                resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})+                sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) -- TODO will probably need some sort of tombstoning.+                -- Client A merges the response+              let cAstore2 = mergeFunc cAstore1 resp1+              lift $ cAstore2 `shouldBe` initialClientStore+                -- Client B makes sync request 2+              let req2 = makeSyncRequest cBstore1+                -- The server processes sync request 2+              (resp2, sstore3) <- processServerSync genD sstore2 req2+              lift $ do+                resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})+                sstore3 `shouldBe` sstore2+                -- Client B merges the response+              let cBstore2 = mergeFunc cBstore1 resp2+              lift $ do+                cBstore2 `shouldBe` initialClientStore+                  -- Client A and Client B now have the same store+                cAstore2 `shouldBe` cBstore2++newtype D m a =+  D+    { unD :: StateT StdGen m a+    }+  deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO)++evalD :: D Identity a -> a+evalD = runIdentity . evalDM++-- runD :: D Identity a -> StdGen -> (a, StdGen)+-- runD = runState . unD+evalDM :: Functor m => D m a -> m a+evalDM d = fst <$> runDM d (mkStdGen 42)++runDM :: D m a -> StdGen -> m (a, StdGen)+runDM = runStateT . unD++genD :: Monad m => D m UUID+genD = do+  r <- get+  let (u, r') = random r+  put r'+  pure u

@@ -82,7 +82,7 @@             store2 `shouldBe` ServerEmpty             resp `shouldBe` ItemSyncResponseClientDeleted     describe "Server changes" $ do-      it "tells the client that there is a new item at the server side" $ do+      it "tells the client that there is a new item at the server side" $         forAllValid $ \i ->           forAllValid $ \st -> do             let store1 = ServerFull (Timed i st)@@ -90,7 +90,7 @@             let (resp, store2) = processServerItemSync @Int store1 req             store2 `shouldBe` store1             resp `shouldBe` ItemSyncResponseServerAdded (Timed i st)-      it "tells the client that there is a modified item at the server side" $ do+      it "tells the client that there is a modified item at the server side" $         forAllValid $ \i ->           forAllSubsequent $ \(st, st') -> do             let store1 = ServerFull (Timed i st')@@ -98,7 +98,7 @@             let (resp, store2) = processServerItemSync @Int store1 req             store2 `shouldBe` store1             resp `shouldBe` ItemSyncResponseServerChanged (Timed i st')-      it "tells the client that there is a deleted item at the server side" $ do+      it "tells the client that there is a deleted item at the server side" $         forAllValid $ \st -> do           let store1 = ServerEmpty               req = ItemSyncRequestKnown st

@@ -48,36 +48,36 @@           let (resp, store2) = processServerValueSync @Int store1 req           store2 `shouldBe` store1           resp `shouldBe` ValueSyncResponseInSync-    describe "Client changes" $ do+    describe "Client changes" $       it "changes the item that the client tells the server to change" $-        forAllValid $ \i ->-          forAllValid $ \j ->-            forAllValid $ \st -> do-              let store1 = ServerValue (Timed i st)-                  req = ValueSyncRequestKnownButChanged (Timed j st)-              let (resp, store2) = processServerValueSync @Int store1 req-              let time = incrementServerTime st-              store2 `shouldBe` ServerValue (Timed j time)-              resp `shouldBe` ValueSyncResponseClientChanged time-    describe "Server changes" $ do-      it "tells the client that there is a modified item at the server side" $ do-        forAllValid $ \i ->+      forAllValid $ \i ->+        forAllValid $ \j ->+          forAllValid $ \st -> do+            let store1 = ServerValue (Timed i st)+                req = ValueSyncRequestKnownButChanged (Timed j st)+            let (resp, store2) = processServerValueSync @Int store1 req+            let time = incrementServerTime st+            store2 `shouldBe` ServerValue (Timed j time)+            resp `shouldBe` ValueSyncResponseClientChanged time+    describe "Server changes" $+      it "tells the client that there is a modified item at the server side" $+      forAllValid $ \i ->+        forAllSubsequent $ \(st, st') -> do+          let store1 = ServerValue (Timed i st')+              req = ValueSyncRequestKnown st+          let (resp, store2) = processServerValueSync @Int store1 req+          store2 `shouldBe` store1+          resp `shouldBe` ValueSyncResponseServerChanged (Timed i st')+    describe "Conflicts" $+      it "notices a conflict if the client and server are trying to sync different items" $+      forAllValid $ \i ->+        forAllValid $ \j ->           forAllSubsequent $ \(st, st') -> do             let store1 = ServerValue (Timed i st')-                req = ValueSyncRequestKnown st+                req = ValueSyncRequestKnownButChanged (Timed j st)             let (resp, store2) = processServerValueSync @Int store1 req             store2 `shouldBe` store1-            resp `shouldBe` ValueSyncResponseServerChanged (Timed i st')-    describe "Conflicts" $ do-      it "notices a conflict if the client and server are trying to sync different items" $-        forAllValid $ \i ->-          forAllValid $ \j ->-            forAllSubsequent $ \(st, st') -> do-              let store1 = ServerValue (Timed i st')-                  req = ValueSyncRequestKnownButChanged (Timed j st)-              let (resp, store2) = processServerValueSync @Int store1 req-              store2 `shouldBe` store1-              resp `shouldBe` ValueSyncResponseConflict (Timed i st')+            resp `shouldBe` ValueSyncResponseConflict (Timed i st')   describe "syncing" $ do     it "succesfully syncs a modification across to a second client" $       forAllValid $ \time1 ->

@@ -1,565 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}--module Data.MergefulSpec-  ( spec-  ) where--import Data.Functor.Identity-import Data.List-import Data.Map (Map)-import qualified Data.Map as M-import qualified Data.Set as S-import Data.UUID-import GHC.Generics (Generic)-import System.Random-import Text.Show.Pretty--import Control.Monad.State--import Test.Hspec-import Test.Validity-import Test.Validity.Aeson--import Data.GenValidity.UUID ()--import Data.Mergeful-import Data.Mergeful.Timed--import Data.GenValidity.Mergeful ()-import Data.GenValidity.Mergeful.Item ()--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}--spec :: Spec-spec = do-  genValidSpec @ClientId-  jsonSpecOnValid @ClientId-  genValidSpec @(ClientStore Int Int)-  jsonSpecOnValid @(ClientStore Int Int)-  genValidSpec @(ServerStore Int Int)-  jsonSpecOnValid @(ServerStore Int Int)-  genValidSpec @(SyncRequest Int Int)-  jsonSpecOnValid @(SyncRequest Int Int)-  genValidSpec @(SyncResponse Int Int)-  jsonSpecOnValid @(SyncResponse Int Int)-  describe "initialClientStore" $ it "is valid" $ shouldBeValid $ initialClientStore @Int @Int-  describe "addItemToClientStore" $-    it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @Int @Int)-  describe "markItemDeletedInClientStore" $-    it "produces valid stores" $ producesValidsOnValids2 (markItemDeletedInClientStore @Int @Int)-  describe "changeItemInClientStore" $-    it "produces valid stores" $ producesValidsOnValids3 (changeItemInClientStore @Int @Int)-  describe "deleteItemFromClientStore" $-    it "produces valid stores" $ producesValidsOnValids2 (deleteItemFromClientStore @Int @Int)-  describe "initialServerStore" $ it "is valid" $ shouldBeValid $ initialServerStore @Int @Int-  describe "initialSyncRequest" $ it "is valid" $ shouldBeValid $ initialSyncRequest @Int @Int-  describe "emptySyncResponse" $ it "is valid" $ shouldBeValid $ emptySyncResponse @Int @Int-  describe "makeSyncRequest" $-    it "produces valid requests" $ producesValidsOnValids (makeSyncRequest @Int @Int)-  describe "mergeAddedItems" $-    it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)-  describe "mergeSyncedButChangedItems" $-    it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)-  describe "mergeAddedItems" $-    it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)-  describe "mergeSyncedButChangedItems" $-    it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)-  describe "mergeDeletedItems" $-    it "produces valid results" $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)-  describe "mergeSyncResponseIgnoreProblems" $-    it "produces valid requests" $-    forAllValid $ \store ->-      forAllValid $ \response ->-        let res = mergeSyncResponseIgnoreProblems @Int @Int store response-         in case prettyValidate res of-              Right _ -> pure ()-              Left err ->-                expectationFailure $-                unlines-                  [ "Store:"-                  , ppShow store-                  , "Response:"-                  , ppShow response-                  , "Invalid result:"-                  , ppShow res-                  , "error:"-                  , err-                  ]-  describe "mergeSyncResponseFromServer" $ do-    it "only differs from mergeSyncResponseIgnoreProblems on conflicts" $-      forAllValid $ \cstore ->-        forAllValid $ \sresp@SyncResponse {..} -> do-          let cstoreA = mergeSyncResponseFromServer (cstore :: ClientStore (UUID) Int) sresp-              cstoreB = mergeSyncResponseIgnoreProblems cstore sresp-          if cstoreA == cstoreB-            then pure ()-            else unless-                   (or-                      [ not (M.null syncResponseConflicts)-                      , not (M.null syncResponseConflictsClientDeleted)-                      , not (S.null syncResponseConflictsServerDeleted)-                      ]) $-                 expectationFailure $-                 unlines-                   [ "There was a difference between mergeSyncResponseFromServer and mergeSyncResponseIgnoreProblems that was somehow unrelated to the conflicts:"-                   , "syncResponseConflicts:"-                   , ppShow syncResponseConflicts-                   , "syncResponseConflictsClientDeleted:"-                   , ppShow syncResponseConflictsClientDeleted-                   , "syncResponseConflictsServerDeleted:"-                   , ppShow syncResponseConflictsServerDeleted-                   , "client store after mergeSyncResponseFromServer:"-                   , ppShow cstoreA-                   , "client store after mergeSyncResponseIgnoreProblems:"-                   , ppShow cstoreB-                   ]-  describe "processServerSync with mergeSyncResponseIgnoreProblems" $ do-    it "produces valid tuples of a response and a store" $-      producesValidsOnValids2-        (\store request -> evalD $ processServerSync genD (store :: ServerStore (UUID) Int) request)-    describe "Single client" $ do-      describe "Multi-item" $ do-        it "succesfully downloads everything from the server for an empty client" $-          forAllValid $ \sstore1 ->-            evalDM $ do-              let cstore1 = initialClientStore :: ClientStore (UUID) Int-              let req = makeSyncRequest cstore1-              (resp, sstore2) <- processServerSync genD sstore1 req-              let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp-              lift $ do-                sstore2 `shouldBe` sstore1-                clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2-        it "succesfully uploads everything to the server for an empty server" $-          forAllValid $ \items ->-            evalDM $ do-              let cstore1 = initialClientStore {clientStoreAddedItems = items}-              let sstore1 = initialServerStore :: ServerStore (UUID) Int-              let req = makeSyncRequest cstore1-              (resp, sstore2) <- processServerSync genD sstore1 req-              let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp-              lift $ do-                sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2))) `shouldBe`-                  sort (M.elems items)-                clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2-        it "is idempotent with one client" $-          forAllValid $ \cstore1 ->-            forAllValid $ \sstore1 ->-              evalDM $ do-                let req1 = makeSyncRequest (cstore1 :: ClientStore (UUID) Int)-                (resp1, sstore2) <- processServerSync genD sstore1 req1-                let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp1-                    req2 = makeSyncRequest cstore2-                (resp2, sstore3) <- processServerSync genD sstore2 req2-                let cstore3 = mergeSyncResponseIgnoreProblems cstore2 resp2-                lift $ do-                  cstore2 `shouldBe` cstore3-                  sstore2 `shouldBe` sstore3-    describe "Multiple clients" $ do-      describe "Single-item" $ do-        it "successfully syncs an addition accross to a second client" $-          forAllValid $ \i ->-            evalDM $ do-              let cAstore1 = initialClientStore {clientStoreAddedItems = M.singleton (ClientId 0) i}-              -- Client B is empty-              let cBstore1 = initialClientStore :: ClientStore (UUID) Int-              -- The server is empty-              let sstore1 = initialServerStore-              -- Client A makes sync request 1-              let req1 = makeSyncRequest cAstore1-              -- The server processes sync request 1-              (resp1, sstore2) <- processServerSync genD sstore1 req1-              let addedItems = syncResponseClientAdded resp1-              case M.toList addedItems of-                [(ClientId 0, (uuid, st))] -> do-                  let time = initialServerTime-                  lift $ st `shouldBe` time-                  let items = M.singleton uuid (Timed i st)-                  lift $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})-                  -- Client A merges the response-                  let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1-                  lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})-                  -- Client B makes sync request 2-                  let req2 = makeSyncRequest cBstore1-                  -- The server processes sync request 2-                  (resp2, sstore3) <- processServerSync genD sstore2 req2-                  lift $ do-                    resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})-                    sstore3 `shouldBe` sstore2-                  -- Client B merges the response-                  let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2-                  lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})-                  -- Client A and Client B now have the same store-                  lift $ cAstore2 `shouldBe` cBstore2-                _ -> lift $ expectationFailure "Should have found exactly one added item."-        it "successfully syncs a modification accross to a second client" $-          forAllValid $ \uuid ->-            forAllValid $ \i ->-              forAllValid $ \j ->-                forAllValid $ \time1 ->-                  evalDM $ do-                    let cAstore1 =-                          initialClientStore-                            { clientStoreSyncedItems =-                                M.singleton (uuid :: UUID) (Timed (i :: Int) time1)-                            }-                    -- Client B had synced that same item, but has since modified it-                    let cBstore1 =-                          initialClientStore-                            {clientStoreSyncedButChangedItems = M.singleton uuid (Timed j time1)}-                    -- The server is has the item that both clients had before-                    let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}-                    -- Client B makes sync request 1-                    let req1 = makeSyncRequest cBstore1-                    -- The server processes sync request 1-                    (resp1, sstore2) <- processServerSync genD sstore1 req1-                    let time2 = incrementServerTime time1-                    lift $ do-                      resp1 `shouldBe`-                        emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}-                      sstore2 `shouldBe`-                        ServerStore {serverStoreItems = M.singleton uuid (Timed j time2)}-                    -- Client B merges the response-                    let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1-                    lift $-                      cBstore2 `shouldBe`-                      initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}-                    -- Client A makes sync request 2-                    let req2 = makeSyncRequest cAstore1-                    -- The server processes sync request 2-                    (resp2, sstore3) <- processServerSync genD sstore2 req2-                    lift $ do-                      resp2 `shouldBe`-                        emptySyncResponse-                          {syncResponseServerChanged = M.singleton uuid (Timed j time2)}-                      sstore3 `shouldBe` sstore2-                    -- Client A merges the response-                    let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2-                    lift $-                      cAstore2 `shouldBe`-                      initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}-                    -- Client A and Client B now have the same store-                    lift $ cAstore2 `shouldBe` cBstore2-        it "succesfully syncs a deletion across to a second client" $-          forAllValid $ \uuid ->-            forAllValid $ \time1 ->-              forAllValid $ \i ->-                evalDM $ do-                  let cAstore1 =-                        initialClientStore-                          { clientStoreSyncedItems =-                              M.singleton (uuid :: UUID) (Timed (i :: Int) time1)-                          }-                  -- Client A has a synced item.-                  -- Client B had synced that same item, but has since deleted it.-                  let cBstore1 =-                        initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}-                  -- The server still has the undeleted item-                  let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}-                  -- Client B makes sync request 1-                  let req1 = makeSyncRequest cBstore1-                  -- The server processes sync request 1-                  (resp1, sstore2) <- processServerSync genD sstore1 req1-                  lift $ do-                    resp1 `shouldBe`-                      emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}-                    sstore2 `shouldBe` initialServerStore-                  -- Client B merges the response-                  let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1-                  lift $ cBstore2 `shouldBe` initialClientStore-                  -- Client A makes sync request 2-                  let req2 = makeSyncRequest cAstore1-                  -- The server processes sync request 2-                  (resp2, sstore3) <- processServerSync genD sstore2 req2-                  lift $ do-                    resp2 `shouldBe`-                      emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}-                    sstore3 `shouldBe` sstore2-                  -- Client A merges the response-                  let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2-                  lift $ cAstore2 `shouldBe` initialClientStore-                  -- Client A and Client B now have the same store-                  lift $ cAstore2 `shouldBe` cBstore2-        it "does not run into a conflict if two clients both try to sync a deletion" $-          forAllValid $ \uuid ->-            forAllValid $ \time1 ->-              forAllValid $ \i ->-                evalDM $ do-                  let cAstore1 =-                        initialClientStore-                          {clientStoreDeletedItems = M.singleton (uuid :: UUID) time1}-                  -- Both client a and client b delete an item.-                  let cBstore1 =-                        initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}-                  -- The server still has the undeleted item-                  let sstore1 =-                        ServerStore {serverStoreItems = M.singleton uuid (Timed (i :: Int) time1)}-                  -- Client A makes sync request 1-                  let req1 = makeSyncRequest cAstore1-                  -- The server processes sync request 1-                  (resp1, sstore2) <- processServerSync genD sstore1 req1-                  lift $ do-                    resp1 `shouldBe`-                      (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})-                    sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})-                  -- Client A merges the response-                  let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1-                  lift $ cAstore2 `shouldBe` initialClientStore-                  -- Client B makes sync request 2-                  let req2 = makeSyncRequest cBstore1-                  -- The server processes sync request 2-                  (resp2, sstore3) <- processServerSync genD sstore2 req2-                  lift $ do-                    resp2 `shouldBe`-                      (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})-                    sstore3 `shouldBe` sstore2-                  -- Client B merges the response-                  let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2-                  lift $ do-                    cBstore2 `shouldBe` initialClientStore-                    -- Client A and Client B now have the same store-                    cAstore2 `shouldBe` cBstore2-        it "does not lose data after a conflict occurs" $-          forAllValid $ \uuid ->-            forAllValid $ \time1 ->-              forAllValid $ \i1 ->-                forAllValid $ \i2 ->-                  forAllValid $ \i3 ->-                    evalDM $ do-                      let sstore1 =-                            ServerStore-                              { serverStoreItems =-                                  M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)-                              }-                      -- The server has an item-                      -- The first client has synced it, and modified it.-                      let cAstore1 =-                            initialClientStore-                              {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}-                      -- The second client has synced it too, and modified it too.-                      let cBstore1 =-                            initialClientStore-                              {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}-                      -- Client A makes sync request 1-                      let req1 = makeSyncRequest cAstore1-                      -- The server processes sync request 1-                      (resp1, sstore2) <- processServerSync genD sstore1 req1-                      let time2 = incrementServerTime time1-                      -- The server updates the item accordingly-                      lift $ do-                        resp1 `shouldBe`-                          (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})-                        sstore2 `shouldBe`-                          (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})-                      -- Client A merges the response-                      let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1-                      lift $-                        cAstore2 `shouldBe`-                        (initialClientStore-                           {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})-                      -- Client B makes sync request 2-                      let req2 = makeSyncRequest cBstore1-                      -- The server processes sync request 2-                      (resp2, sstore3) <- processServerSync genD sstore2 req2-                      -- The server reports a conflict and does not change its store-                      lift $ do-                        resp2 `shouldBe`-                          (emptySyncResponse-                             {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})-                        sstore3 `shouldBe` sstore2-                      -- Client B merges the response-                      let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2-                      -- Client does not update, but keeps its conflict-                      lift $ do-                        cBstore2 `shouldBe`-                          (initialClientStore-                             {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)})-                      -- Client A and Client B now *do not* have the same store-      describe "Multiple items" $ do-        it "successfully syncs additions accross to a second client" $-          forAllValid $ \is ->-            evalDM $ do-              let cAstore1 = initialClientStore {clientStoreAddedItems = is}-              -- Client B is empty-              let cBstore1 = initialClientStore :: ClientStore (UUID) Int-              -- The server is empty-              let sstore1 = initialServerStore-              -- Client A makes sync request 1-              let req1 = makeSyncRequest cAstore1-              -- The server processes sync request 1-              (resp1, sstore2) <- processServerSync genD sstore1 req1-              let (rest, items) = mergeAddedItems is (syncResponseClientAdded resp1)-              lift $ do-                rest `shouldBe` M.empty-                sstore2 `shouldBe` (ServerStore {serverStoreItems = items})-              -- Client A merges the response-              let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1-              lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})-              -- Client B makes sync request 2-              let req2 = makeSyncRequest cBstore1-              -- The server processes sync request 2-              (resp2, sstore3) <- processServerSync genD sstore2 req2-              lift $ do-                resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})-                sstore3 `shouldBe` sstore2-              -- Client B merges the response-              let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2-              lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})-              -- Client A and Client B now have the same store-              lift $ cAstore2 `shouldBe` cBstore2-        it "succesfully syncs deletions across to a second client" $-          forAllValid $ \items ->-            forAllValid $ \time1 ->-              evalDM $ do-                let syncedItems = M.map (\i -> Timed i time1) (items :: Map (UUID) Int)-                    itemTimes = M.map (const time1) items-                    itemIds = M.keysSet items-                let cAstore1 = initialClientStore {clientStoreSyncedItems = syncedItems}-                -- Client A has synced items-                -- Client B had synced the same items, but has since deleted them.-                let cBstore1 = initialClientStore {clientStoreDeletedItems = itemTimes}-                -- The server still has the undeleted item-                let sstore1 = ServerStore {serverStoreItems = syncedItems}-                -- Client B makes sync request 1-                let req1 = makeSyncRequest cBstore1-                -- The server processes sync request 1-                (resp1, sstore2) <- processServerSync genD sstore1 req1-                lift $ do-                  resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}-                  sstore2 `shouldBe` initialServerStore-                -- Client B merges the response-                let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1-                lift $ cBstore2 `shouldBe` initialClientStore-                -- Client A makes sync request 2-                let req2 = makeSyncRequest cAstore1-                -- The server processes sync request 2-                (resp2, sstore3) <- processServerSync genD sstore2 req2-                lift $ do-                  resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}-                  sstore3 `shouldBe` sstore2-                -- Client A merges the response-                let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2-                lift $ cAstore2 `shouldBe` initialClientStore-                -- Client A and Client B now have the same store-                lift $ cAstore2 `shouldBe` cBstore2-        it "does not run into a conflict if two clients both try to sync a deletion" $-          forAllValid $ \items ->-            forAllValid $ \time1 ->-              evalDM $ do-                let cAstore1 =-                      initialClientStore-                        {clientStoreDeletedItems = M.map (const time1) (items :: Map (UUID) Int)}-                -- Both client a and client b delete their items.-                let cBstore1 =-                      initialClientStore {clientStoreDeletedItems = M.map (const time1) items}-                -- The server still has the undeleted items-                let sstore1 = ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items}-                -- Client A makes sync request 1-                let req1 = makeSyncRequest cAstore1-                -- The server processes sync request 1-                (resp1, sstore2) <- processServerSync genD sstore1 req1-                lift $ do-                  resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})-                  sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) -- TODO will probably need some sort of tombstoning.-                -- Client A merges the response-                let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1-                lift $ cAstore2 `shouldBe` initialClientStore-                -- Client B makes sync request 2-                let req2 = makeSyncRequest cBstore1-                -- The server processes sync request 2-                (resp2, sstore3) <- processServerSync genD sstore2 req2-                lift $ do-                  resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})-                  sstore3 `shouldBe` sstore2-                -- Client B merges the response-                let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2-                lift $ do-                  cBstore2 `shouldBe` initialClientStore-                  -- Client A and Client B now have the same store-                  cAstore2 `shouldBe` cBstore2-  describe "processServerSync with mergeSyncResponseFromServer" $ do-    describe "Multiple clients" $ do-      describe "Single-item" $ do-        it "does not diverge after a conflict occurs" $-          forAllValid $ \uuid ->-            forAllValid $ \time1 ->-              forAllValid $ \i1 ->-                forAllValid $ \i2 ->-                  forAllValid $ \i3 ->-                    evalDM $ do-                      let sstore1 =-                            ServerStore-                              { serverStoreItems =-                                  M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)-                              }-                      -- The server has an item-                      -- The first client has synced it, and modified it.-                      let cAstore1 =-                            initialClientStore-                              {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}-                      -- The second client has synced it too, and modified it too.-                      let cBstore1 =-                            initialClientStore-                              {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}-                      -- Client A makes sync request 1-                      let req1 = makeSyncRequest cAstore1-                      -- The server processes sync request 1-                      (resp1, sstore2) <- processServerSync genD sstore1 req1-                      let time2 = incrementServerTime time1-                      -- The server updates the item accordingly-                      lift $ do-                        resp1 `shouldBe`-                          (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})-                        sstore2 `shouldBe`-                          (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})-                      -- Client A merges the response-                      let cAstore2 = mergeSyncResponseFromServer cAstore1 resp1-                      lift $-                        cAstore2 `shouldBe`-                        (initialClientStore-                           {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})-                      -- Client B makes sync request 2-                      let req2 = makeSyncRequest cBstore1-                      -- The server processes sync request 2-                      (resp2, sstore3) <- processServerSync genD sstore2 req2-                      -- The server reports a conflict and does not change its store-                      lift $ do-                        resp2 `shouldBe`-                          (emptySyncResponse-                             {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})-                        sstore3 `shouldBe` sstore2-                      -- Client B merges the response-                      let cBstore2 = mergeSyncResponseFromServer cBstore1 resp2-                      -- Client does not update, but keeps its conflict-                      lift $ do-                        cBstore2 `shouldBe`-                          (initialClientStore-                             {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})-                        -- Client A and Client B now have the same store-                        cBstore2 `shouldBe` cAstore2--newtype D m a =-  D-    { unD :: StateT StdGen m a-    }-  deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO)--evalD :: D Identity a -> a-evalD = runIdentity . evalDM---- runD :: D Identity a -> StdGen -> (a, StdGen)--- runD = runState . unD-evalDM :: Functor m => D m a -> m a-evalDM d = fst <$> runDM d (mkStdGen 42)--runDM :: D m a -> StdGen -> m (a, StdGen)-runDM = runStateT . unD--genD :: Monad m => D m UUID-genD = do-  r <- get-  let (u, r') = random r-  put r'-  pure u