diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Changelog + +## [Unreleased] + +## [0.1.0.0] - 2019-09-23 + +### Changed + +* Compatibility with validity-containers >=0.5 diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,3 +0,0 @@ -# Changelog for mergeful - -## Unreleased changes diff --git a/genvalidity-mergeful.cabal b/genvalidity-mergeful.cabal --- a/genvalidity-mergeful.cabal +++ b/genvalidity-mergeful.cabal @@ -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 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 diff --git a/src/Data/GenValidity/Mergeful.hs b/src/Data/GenValidity/Mergeful.hs --- a/src/Data/GenValidity/Mergeful.hs +++ b/src/Data/GenValidity/Mergeful.hs @@ -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 () diff --git a/src/Data/GenValidity/Mergeful/Collection.hs b/src/Data/GenValidity/Mergeful/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeful/Collection.hs @@ -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 diff --git a/src/Data/GenValidity/Mergeful/Value.hs b/src/Data/GenValidity/Mergeful/Value.hs --- a/src/Data/GenValidity/Mergeful/Value.hs +++ b/src/Data/GenValidity/Mergeful/Value.hs @@ -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 diff --git a/test/Data/Mergeful/CollectionSpec.hs b/test/Data/Mergeful/CollectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeful/CollectionSpec.hs @@ -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 diff --git a/test/Data/Mergeful/ItemSpec.hs b/test/Data/Mergeful/ItemSpec.hs --- a/test/Data/Mergeful/ItemSpec.hs +++ b/test/Data/Mergeful/ItemSpec.hs @@ -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 diff --git a/test/Data/Mergeful/ValueSpec.hs b/test/Data/Mergeful/ValueSpec.hs --- a/test/Data/Mergeful/ValueSpec.hs +++ b/test/Data/Mergeful/ValueSpec.hs @@ -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 -> diff --git a/test/Data/MergefulSpec.hs b/test/Data/MergefulSpec.hs deleted file mode 100644 --- a/test/Data/MergefulSpec.hs +++ /dev/null @@ -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