genvalidity-mergeful 0.2.0.0 → 0.3.0.0
raw patch · 13 files changed
+1059/−1103 lines, 13 filesdep ~genvaliditysetup-changed
Dependency ranges changed: genvalidity
Files
- CHANGELOG.md +5/−1
- LICENSE +1/−1
- README.md +0/−1
- Setup.hs +0/−3
- genvalidity-mergeful.cabal +5/−6
- src/Data/GenValidity/Mergeful/Collection.hs +3/−19
- src/Data/GenValidity/Mergeful/Item.hs +0/−10
- src/Data/GenValidity/Mergeful/Timed.hs +0/−4
- src/Data/GenValidity/Mergeful/Value.hs +0/−12
- test/Data/Mergeful/CollectionSpec.hs +706/−707
- test/Data/Mergeful/ItemSpec.hs +241/−241
- test/Data/Mergeful/TimedSpec.hs +2/−2
- test/Data/Mergeful/ValueSpec.hs +96/−96
CHANGELOG.md view
@@ -1,6 +1,10 @@ # Changelog -## [Unreleased]+## [0.3.0.0] - 2021-11-21++### Changed++* Compatibility with `genvalidity >=1.0.0.0` ## [0.1.0.0] - 2019-09-23
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018-2019 Tom Sydney Kerckhove+Copyright (c) 2018-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
− README.md
@@ -1,1 +0,0 @@-# mergeful
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
genvalidity-mergeful.cabal view
@@ -1,24 +1,23 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: cab74b20dcf0eadc6956a8ce9d4325af4494785285a9b5a43aa8fda713de2bb1+-- hash: 218b3a60cb86fcedf2942fea48c5ee2dc351c552cd48ca944629761753bfc87b name: genvalidity-mergeful-version: 0.2.0.0+version: 0.3.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 author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu-copyright: Copyright: (c) 2019-2020 Tom Sydney Kerckhove+copyright: Copyright: (c) 2019-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple extra-source-files:- README.md CHANGELOG.md source-repository head@@ -40,7 +39,7 @@ QuickCheck , base <5 , containers- , genvalidity+ , genvalidity >=1.0 , genvalidity-containers , genvalidity-time , mergeful
src/Data/GenValidity/Mergeful/Collection.hs view
@@ -16,13 +16,9 @@ import Data.Traversable import Test.QuickCheck -instance GenUnchecked ClientId--instance GenValid ClientId--instance- (GenUnchecked ci, GenUnchecked si, Ord ci, Ord si, GenUnchecked a) =>- GenUnchecked (ClientStore ci si a)+instance GenValid ClientId where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance (GenValid ci, GenValid si, Show ci, Show si, Ord ci, Ord si, GenValid a) =>@@ -40,17 +36,11 @@ pure ClientStore {..} shrinkValid = shrinkValidStructurally -instance (GenUnchecked si, Ord si, GenUnchecked a) => GenUnchecked (ServerStore si a)- instance (GenValid si, Show si, Ord si, GenValid a) => GenValid (ServerStore si a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance- (GenUnchecked ci, GenUnchecked si, Ord ci, Ord si, GenUnchecked a) =>- GenUnchecked (SyncRequest ci si a)--instance (GenValid ci, GenValid si, Show ci, Show si, Ord ci, Ord si, GenValid a) => GenValid (SyncRequest ci si a) where@@ -66,15 +56,9 @@ pure SyncRequest {..} shrinkValid = shrinkValidStructurally -instance GenUnchecked si => GenUnchecked (ClientAddition si)- instance GenValid si => GenValid (ClientAddition si) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance- (GenUnchecked ci, GenUnchecked si, Ord ci, Ord si, GenUnchecked a) =>- GenUnchecked (SyncResponse ci si a) instance (GenValid ci, GenValid si, Show ci, Show si, Ord ci, Ord si, GenValid a) =>
src/Data/GenValidity/Mergeful/Item.hs view
@@ -6,31 +6,21 @@ import Data.GenValidity.Mergeful.Timed () import Data.Mergeful.Item -instance GenUnchecked a => GenUnchecked (ItemMergeResult a)- instance GenValid a => GenValid (ItemMergeResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ClientItem a)- instance GenValid a => GenValid (ClientItem a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ServerItem a)- instance GenValid a => GenValid (ServerItem a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ItemSyncRequest a)- instance GenValid a => GenValid (ItemSyncRequest a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance GenUnchecked a => GenUnchecked (ItemSyncResponse a) instance GenValid a => GenValid (ItemSyncResponse a) where genValid = genValidStructurallyWithoutExtraChecking
src/Data/GenValidity/Mergeful/Timed.hs view
@@ -6,13 +6,9 @@ import Data.Mergeful.Timed import Test.QuickCheck -instance GenUnchecked a => GenUnchecked (Timed a)- instance GenValid a => GenValid (Timed a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance GenUnchecked ServerTime instance GenValid ServerTime where genValid = ServerTime <$> arbitrary
src/Data/GenValidity/Mergeful/Value.hs view
@@ -6,37 +6,25 @@ import Data.GenValidity.Mergeful.Timed () import Data.Mergeful.Value -instance GenUnchecked ChangedFlag- instance GenValid ChangedFlag where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ValueMergeResult a)- instance GenValid a => GenValid (ValueMergeResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ClientValue a)- instance GenValid a => GenValid (ClientValue a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ServerValue a)- instance GenValid a => GenValid (ServerValue a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (ValueSyncRequest a)- instance GenValid a => GenValid (ValueSyncRequest a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance GenUnchecked a => GenUnchecked (ValueSyncResponse a) instance GenValid a => GenValid (ValueSyncResponse a) where genValid = genValidStructurallyWithoutExtraChecking
test/Data/Mergeful/CollectionSpec.hs view
@@ -34,713 +34,712 @@ spec :: Spec spec = modifyMaxShrinks (min 0) $ do genValidSpec @ClientId- jsonSpecOnValid @ClientId- genValidSpec @(ClientStore ClientId Int Int)- jsonSpecOnValid @(ClientStore ClientId Int Int)- genValidSpec @(ServerStore Int Int)- jsonSpecOnValid @(ServerStore Int Int)- genValidSpec @(SyncRequest ClientId Int Int)- jsonSpecOnValid @(SyncRequest ClientId Int Int)- genValidSpec @(ClientAddition Int)- jsonSpecOnValid @(ClientAddition Int)- genValidSpec @(SyncResponse ClientId Int Int)- jsonSpecOnValid @(SyncResponse ClientId Int Int)- describe "initialClientStore"- $ it "is valid"- $ shouldBeValid- $ initialClientStore @ClientId @Int @Int- describe "addItemToClientStore" $ do- it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @ClientId @Int @Int)- it "makes the client store one bigger"- $ forAllValid- $ \cs ->- forAllValid $ \a ->- clientStoreSize @ClientId @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 @ClientId @Int @Int a cs- in a `elem` clientStoreAddedItems cs'- describe "markItemDeletedInClientStore" $ do- it "produces valid stores" $- producesValidsOnValids2 (markItemDeletedInClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int i cs- in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Nothing- describe "changeItemInClientStore" $ do- it "produces valid stores" $- producesValidsOnValids3 (changeItemInClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int i a cs- in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Just a- describe "deleteItemFromClientStore" $ do- it "produces valid stores" $- producesValidsOnValids2 (deleteItemFromClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int- describe "emptySyncResponse"- $ it "is valid"- $ shouldBeValid- $ emptySyncResponse @ClientId @Int @Int- describe "makeSyncRequest"- $ it "produces valid requests"- $ producesValidsOnValids (makeSyncRequest @ClientId @Int @Int)- describe "mergeAddedItems"- $ it "produces valid results"- $ producesValidsOnValids2 (mergeAddedItems @ClientId @Int @Int)- describe "mergeSyncedButChangedItems"- $ it "produces valid results"- $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)- describe "mergeDeletedItems"- $ it "produces valid results"- $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)- xdescribe "There must not be id conflicts" $ do- describe "mergeSyncResponseFromServer"- $ it "produces valid requests"- $ forAllValid- $ \store ->- forAllValid $ \response ->- let res = mergeSyncResponseFromServer @ClientId @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 "mergeSyncResponseFromClient"- $ it "produces valid requests"- $ forAllValid- $ \store ->- forAllValid $ \response ->- let res = mergeSyncResponseFromClient @ClientId @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 "mergeSyncResponseUsingCRDT"- $ it "produces valid requests"- $ forAllValid- $ \store ->- forAllValid $ \response ->- let res = mergeSyncResponseUsingCRDT @ClientId @Int @Int max 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 @ClientId @UUID genD (store :: ServerStore UUID Int) request- )- describe "Syncing with mergeSyncResponseFromClient" $ do- let strat = mergeFromClientStrategy- helperFunctionsSpec strat- mergeFunctionSpec @Int strat- noDataLossSpec @Int strat- xdescribe "does not hold" $ do- emptyResponseSpec @Int strat- noDivergenceSpec @Int strat- describe "Syncing with mergeSyncResponseFromServer" $ do- let strat = mergeFromServerStrategy- helperFunctionsSpec strat- mergeFunctionSpec @Int strat- noDivergenceSpec @Int strat- emptyResponseSpec @Int strat- noDifferentExceptForConflicts @Int strat mergeFromClientStrategy- xdescribe "does not hold" $ noDataLossSpec @Int strat- describe "Syncing with mergeSyncResponseUsingStrategy with a GCounter" $ do- let strat = mergeUsingCRDTStrategy max- helperFunctionsSpec strat- mergeFunctionSpec strat- noDataLossSpec strat- noDivergenceSpec strat- emptyResponseSpec strat- noDifferentExceptForConflicts strat mergeFromClientStrategy- noDifferentExceptForConflicts strat mergeFromServerStrategy--helperFunctionsSpec :: ItemMergeStrategy Int -> Spec-helperFunctionsSpec ItemMergeStrategy {..} = do- describe "mergeSyncedButChangedConflicts"- $ it "produces valid results"- $ producesValidsOnValids2 (mergeSyncedButChangedConflicts @Int @Int itemMergeStrategyMergeChangeConflict)- describe "mergeClientDeletedConflicts"- $ it "produces valid results"- $ producesValidsOnValids (mergeClientDeletedConflicts @Int @Int itemMergeStrategyMergeClientDeletedConflict)- describe "mergeServerDeletedConflicts"- $ it "produces valid results"- $ producesValidsOnValids (mergeServerDeletedConflicts @Int @Int itemMergeStrategyMergeServerDeletedConflict)--mergeFunctionSpec ::- forall a.- (Show a, Ord a, GenValid a) =>- ItemMergeStrategy a ->- Spec-mergeFunctionSpec strat = do- let mergeFunc = mergeSyncResponseUsingStrategy strat- 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, ClientAddition 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--noDataLossSpec ::- forall a.- (Show a, Ord a, GenValid a) =>- ItemMergeStrategy a ->- Spec-noDataLossSpec strat = do- let mergeFunc = mergeSyncResponseUsingStrategy strat- 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 (Timed i1 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 @ClientId @UUID 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 = mergeFunc 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 = mergeSyncResponseFromClient @ClientId @UUID cBstore1 resp2- -- Client does not update, but keeps its conflict- -- Client A and Client B now *do not* have the same store- lift $- cBstore2- `shouldBe` ( initialClientStore- { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)- }- )--noDivergenceSpec ::- forall a.- (Show a, Ord a, GenValid a) =>- ItemMergeStrategy a ->- Spec-noDivergenceSpec strat = do- let mergeFunc = mergeSyncResponseUsingStrategy strat- it "does not diverge after a conflict occurs"- $ forAllValid- $ \uuid ->- forAllValid $ \time1 ->- forAllValid $ \iS ->- forAllValid $ \iA ->- forAllValid $ \iB ->- evalDM $ do- let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed iS time1)}- -- The server has an item- -- The first client has synced it, and modified it.- let cAstore1 =- initialClientStore- { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iA time1)- }- -- The second client has synced it too, and modified it too.- let cBstore1 =- initialClientStore- { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)- }- -- Client A makes sync request 1- let req1 = makeSyncRequest @ClientId @UUID 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 iA time2)})- -- Client A merges the response- let cAstore2 = mergeFunc cAstore1 resp1- -- Client A has the item from the server because there was no conflict.- lift $- cAstore2- `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA 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 iA time2)})- sstore3 `shouldBe` sstore2- -- Client B merges the response- let cBstore2 = mergeFunc cBstore1 resp2- lift $ do- let expected = case itemMergeStrategyMergeChangeConflict strat iB iA of- KeepLocal -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)}- TakeRemote -> initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA time2)}- Merged im -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed im time2)}- cBstore2- `shouldBe` expected- -- In case of a previous merge, the synced item will still be changed, so we need to sync again with B and then with A- let req3 = makeSyncRequest cBstore2- (resp3, sstore4) <- processServerSync genD sstore3 req3- let cBstore3 = mergeFunc cBstore2 resp3- let req4 = makeSyncRequest cAstore2- (resp4, _) <- processServerSync genD sstore4 req4- let cAstore3 = mergeFunc cAstore2 resp4- lift $- cBstore3 `shouldBe` cAstore3--emptyResponseSpec ::- forall a.- (Show a, Eq a, Ord a, GenValid a) =>- ItemMergeStrategy a ->- Spec-emptyResponseSpec strat = do- let mergeFunc = mergeSyncResponseUsingStrategy strat- it "is returns an empty response on the second sync with no modifications"- $ forAllValid- $ \cstore1 ->- forAllValid $ \sstore1 ->- evalDM $ do- let req1 = makeSyncRequest @ClientId @UUID cstore1- (resp1, sstore2) <- processServerSync genD sstore1 req1- let cstore2 = mergeFunc cstore1 resp1- req2 = makeSyncRequest cstore2- (resp2, _) <- processServerSync genD sstore2 req2- lift $ resp2 `shouldBe` emptySyncResponse--noDifferentExceptForConflicts ::- forall a.- (Show a, Eq a, Ord a, GenValid a) =>- ItemMergeStrategy a ->- ItemMergeStrategy a ->- Spec-noDifferentExceptForConflicts strat1 strat2 = do- let mergeFunc1 = mergeSyncResponseUsingStrategy strat1- mergeFunc2 = mergeSyncResponseUsingStrategy strat2- describe "mergeSyncResponseFromServer"- $ it "only differs from mergeSyncResponseFromClient on conflicts"- $ forAllValid- $ \cstore ->- forAllValid $ \sresp@SyncResponse {..} -> do- let cstoreA = mergeFunc1 (cstore :: ClientStore ClientId UUID a) sresp- cstoreB = mergeFunc2 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 mergeFunc1 and mergeFunc2 that was somehow unrelated to the conflicts:",- "syncResponseConflicts:",- ppShow syncResponseConflicts,- "syncResponseConflictsClientDeleted:",- ppShow syncResponseConflictsClientDeleted,- "syncResponseConflictsServerDeleted:",- ppShow syncResponseConflictsServerDeleted,- "client store after mergeFunc1:",- ppShow cstoreA,- "client store after mergeFunc2:",- ppShow cstoreB- ]--newtype D m a- = D- { unD :: StateT StdGen m a- }+ jsonSpec @ClientId+ genValidSpec @(ClientStore ClientId Int Int)+ jsonSpec @(ClientStore ClientId Int Int)+ genValidSpec @(ServerStore Int Int)+ jsonSpec @(ServerStore Int Int)+ genValidSpec @(SyncRequest ClientId Int Int)+ jsonSpec @(SyncRequest ClientId Int Int)+ genValidSpec @(ClientAddition Int)+ jsonSpec @(ClientAddition Int)+ genValidSpec @(SyncResponse ClientId Int Int)+ jsonSpec @(SyncResponse ClientId Int Int)+ describe "initialClientStore" $+ it "is valid" $+ shouldBeValid $+ initialClientStore @ClientId @Int @Int+ describe "addItemToClientStore" $ do+ it "produces valid stores" $ producesValid2 (addItemToClientStore @ClientId @Int @Int)+ it "makes the client store one bigger" $+ forAllValid $+ \cs ->+ forAllValid $ \a ->+ clientStoreSize @ClientId @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 @ClientId @Int @Int a cs+ in a `elem` clientStoreAddedItems cs'+ describe "markItemDeletedInClientStore" $ do+ it "produces valid stores" $+ producesValid2 (markItemDeletedInClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int i cs+ in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Nothing+ describe "changeItemInClientStore" $ do+ it "produces valid stores" $+ producesValid3 (changeItemInClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int i a cs+ in M.lookup (Right i) (clientStoreItems cs') `shouldBe` Just a+ describe "deleteItemFromClientStore" $ do+ it "produces valid stores" $+ producesValid2 (deleteItemFromClientStore @ClientId @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 @ClientId @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 @ClientId @Int @Int+ describe "emptySyncResponse" $+ it "is valid" $+ shouldBeValid $+ emptySyncResponse @ClientId @Int @Int+ describe "makeSyncRequest" $+ it "produces valid requests" $+ producesValid (makeSyncRequest @ClientId @Int @Int)+ describe "mergeAddedItems" $+ it "produces valid results" $+ producesValid2 (mergeAddedItems @ClientId @Int @Int)+ describe "mergeSyncedButChangedItems" $+ it "produces valid results" $+ producesValid2 (mergeSyncedButChangedItems @Int @Int)+ describe "mergeDeletedItems" $+ it "produces valid results" $+ producesValid2 (mergeDeletedItems @Int @Int)+ xdescribe "There must not be id conflicts" $ do+ describe "mergeSyncResponseFromServer" $+ it "produces valid requests" $+ forAllValid $+ \store ->+ forAllValid $ \response ->+ let res = mergeSyncResponseFromServer @ClientId @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 "mergeSyncResponseFromClient" $+ it "produces valid requests" $+ forAllValid $+ \store ->+ forAllValid $ \response ->+ let res = mergeSyncResponseFromClient @ClientId @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 "mergeSyncResponseUsingCRDT" $+ it "produces valid requests" $+ forAllValid $+ \store ->+ forAllValid $ \response ->+ let res = mergeSyncResponseUsingCRDT @ClientId @Int @Int max 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" $+ producesValid2+ ( \store request ->+ evalD $ processServerSync @ClientId @UUID genD (store :: ServerStore UUID Int) request+ )+ describe "Syncing with mergeSyncResponseFromClient" $ do+ let strat = mergeFromClientStrategy+ helperFunctionsSpec strat+ mergeFunctionSpec @Int strat+ noDataLossSpec @Int strat+ xdescribe "does not hold" $ do+ emptyResponseSpec @Int strat+ noDivergenceSpec @Int strat+ describe "Syncing with mergeSyncResponseFromServer" $ do+ let strat = mergeFromServerStrategy+ helperFunctionsSpec strat+ mergeFunctionSpec @Int strat+ noDivergenceSpec @Int strat+ emptyResponseSpec @Int strat+ noDifferentExceptForConflicts @Int strat mergeFromClientStrategy+ xdescribe "does not hold" $ noDataLossSpec @Int strat+ describe "Syncing with mergeSyncResponseUsingStrategy with a GCounter" $ do+ let strat = mergeUsingCRDTStrategy max+ helperFunctionsSpec strat+ mergeFunctionSpec strat+ noDataLossSpec strat+ noDivergenceSpec strat+ emptyResponseSpec strat+ noDifferentExceptForConflicts strat mergeFromClientStrategy+ noDifferentExceptForConflicts strat mergeFromServerStrategy++helperFunctionsSpec :: ItemMergeStrategy Int -> Spec+helperFunctionsSpec ItemMergeStrategy {..} = do+ describe "mergeSyncedButChangedConflicts" $+ it "produces valid results" $+ producesValid2 (mergeSyncedButChangedConflicts @Int @Int itemMergeStrategyMergeChangeConflict)+ describe "mergeClientDeletedConflicts" $+ it "produces valid results" $+ producesValid (mergeClientDeletedConflicts @Int @Int itemMergeStrategyMergeClientDeletedConflict)+ describe "mergeServerDeletedConflicts" $+ it "produces valid results" $+ producesValid (mergeServerDeletedConflicts @Int @Int itemMergeStrategyMergeServerDeletedConflict)++mergeFunctionSpec ::+ forall a.+ (Show a, Ord a, GenValid a) =>+ ItemMergeStrategy a ->+ Spec+mergeFunctionSpec strat = do+ let mergeFunc = mergeSyncResponseUsingStrategy strat+ 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, ClientAddition 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++noDataLossSpec ::+ forall a.+ (Show a, Ord a, GenValid a) =>+ ItemMergeStrategy a ->+ Spec+noDataLossSpec strat = do+ let mergeFunc = mergeSyncResponseUsingStrategy strat+ 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 (Timed i1 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 @ClientId @UUID 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 = mergeFunc 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 = mergeSyncResponseFromClient @ClientId @UUID cBstore1 resp2+ -- Client does not update, but keeps its conflict+ -- Client A and Client B now *do not* have the same store+ lift $+ cBstore2+ `shouldBe` ( initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)+ }+ )++noDivergenceSpec ::+ forall a.+ (Show a, Ord a, GenValid a) =>+ ItemMergeStrategy a ->+ Spec+noDivergenceSpec strat = do+ let mergeFunc = mergeSyncResponseUsingStrategy strat+ it "does not diverge after a conflict occurs" $+ forAllValid $+ \uuid ->+ forAllValid $ \time1 ->+ forAllValid $ \iS ->+ forAllValid $ \iA ->+ forAllValid $ \iB ->+ evalDM $ do+ let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed iS time1)}+ -- The server has an item+ -- The first client has synced it, and modified it.+ let cAstore1 =+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iA time1)+ }+ -- The second client has synced it too, and modified it too.+ let cBstore1 =+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)+ }+ -- Client A makes sync request 1+ let req1 = makeSyncRequest @ClientId @UUID 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 iA time2)})+ -- Client A merges the response+ let cAstore2 = mergeFunc cAstore1 resp1+ -- Client A has the item from the server because there was no conflict.+ lift $+ cAstore2+ `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA 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 iA time2)})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeFunc cBstore1 resp2+ lift $ do+ let expected = case itemMergeStrategyMergeChangeConflict strat iB iA of+ KeepLocal -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)}+ TakeRemote -> initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA time2)}+ Merged im -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed im time2)}+ cBstore2+ `shouldBe` expected+ -- In case of a previous merge, the synced item will still be changed, so we need to sync again with B and then with A+ let req3 = makeSyncRequest cBstore2+ (resp3, sstore4) <- processServerSync genD sstore3 req3+ let cBstore3 = mergeFunc cBstore2 resp3+ let req4 = makeSyncRequest cAstore2+ (resp4, _) <- processServerSync genD sstore4 req4+ let cAstore3 = mergeFunc cAstore2 resp4+ lift $+ cBstore3 `shouldBe` cAstore3++emptyResponseSpec ::+ forall a.+ (Show a, Eq a, Ord a, GenValid a) =>+ ItemMergeStrategy a ->+ Spec+emptyResponseSpec strat = do+ let mergeFunc = mergeSyncResponseUsingStrategy strat+ it "is returns an empty response on the second sync with no modifications" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 ->+ evalDM $ do+ let req1 = makeSyncRequest @ClientId @UUID cstore1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let cstore2 = mergeFunc cstore1 resp1+ req2 = makeSyncRequest cstore2+ (resp2, _) <- processServerSync genD sstore2 req2+ lift $ resp2 `shouldBe` emptySyncResponse++noDifferentExceptForConflicts ::+ forall a.+ (Show a, Eq a, Ord a, GenValid a) =>+ ItemMergeStrategy a ->+ ItemMergeStrategy a ->+ Spec+noDifferentExceptForConflicts strat1 strat2 = do+ let mergeFunc1 = mergeSyncResponseUsingStrategy strat1+ mergeFunc2 = mergeSyncResponseUsingStrategy strat2+ describe "mergeSyncResponseFromServer" $+ it "only differs from mergeSyncResponseFromClient on conflicts" $+ forAllValid $+ \cstore ->+ forAllValid $ \sresp@SyncResponse {..} -> do+ let cstoreA = mergeFunc1 (cstore :: ClientStore ClientId UUID a) sresp+ cstoreB = mergeFunc2 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 mergeFunc1 and mergeFunc2 that was somehow unrelated to the conflicts:",+ "syncResponseConflicts:",+ ppShow syncResponseConflicts,+ "syncResponseConflictsClientDeleted:",+ ppShow syncResponseConflictsClientDeleted,+ "syncResponseConflictsServerDeleted:",+ ppShow syncResponseConflictsServerDeleted,+ "client store after mergeFunc1:",+ ppShow cstoreA,+ "client store after mergeFunc2:",+ ppShow cstoreB+ ]++newtype D m a = D+ { unD :: StateT StdGen m a+ } deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO) evalD :: D Identity a -> a
test/Data/Mergeful/ItemSpec.hs view
@@ -24,133 +24,133 @@ spec :: Spec spec = do genValidSpec @(ClientItem Int)- jsonSpecOnValid @(ClientItem Int)+ jsonSpec @(ClientItem Int) genValidSpec @(ServerItem Int)- jsonSpecOnValid @(ServerItem Int)+ jsonSpec @(ServerItem Int) genValidSpec @(ItemSyncRequest Int)- jsonSpecOnValid @(ItemSyncRequest Int)+ jsonSpec @(ItemSyncRequest Int) genValidSpec @(ItemSyncResponse Int)- jsonSpecOnValid @(ItemSyncResponse Int)- describe "makeItemSyncRequest"- $ it "produces valid requests"- $ producesValidsOnValids (makeItemSyncRequest @Int)- describe "mergeItemSyncResponseRaw"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeItemSyncResponseRaw @Int)- describe "mergeItemSyncResponseFromServer"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeItemSyncResponseFromServer @Int)- describe "mergeItemSyncResponseFromClient"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeItemSyncResponseFromClient @Int)- describe "mergeItemSyncResponseUsingCRDT"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeItemSyncResponseUsingCRDT @Int max)+ jsonSpec @(ItemSyncResponse Int)+ describe "makeItemSyncRequest" $+ it "produces valid requests" $+ producesValid (makeItemSyncRequest @Int)+ describe "mergeItemSyncResponseRaw" $+ it "produces valid client stores" $+ producesValid2 (mergeItemSyncResponseRaw @Int)+ describe "mergeItemSyncResponseFromServer" $+ it "produces valid client stores" $+ producesValid2 (mergeItemSyncResponseFromServer @Int)+ describe "mergeItemSyncResponseFromClient" $+ it "produces valid client stores" $+ producesValid2 (mergeItemSyncResponseFromClient @Int)+ describe "mergeItemSyncResponseUsingCRDT" $+ it "produces valid client stores" $+ producesValid2 (mergeItemSyncResponseUsingCRDT @Int max) describe "processServerItemSync" $ do- it "produces valid responses and stores" $ producesValidsOnValids2 (processServerItemSync @Int)+ it "produces valid responses and stores" $ producesValid2 (processServerItemSync @Int) it "makes no changes if the sync request reflects the state of the empty server" $ do let store1 = ServerEmpty req = ItemSyncRequestPoll let (resp, store2) = processServerItemSync @Int store1 req store2 `shouldBe` store1 resp `shouldBe` ItemSyncResponseInSyncEmpty- it "makes no changes if the sync request reflects the state of the full server"- $ forAllValid- $ \i ->- forAllValid $ \st -> do- let store1 = ServerFull $ Timed i st- req = ItemSyncRequestKnown st- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseInSyncFull+ it "makes no changes if the sync request reflects the state of the full server" $+ forAllValid $+ \i ->+ forAllValid $ \st -> do+ let store1 = ServerFull $ Timed i st+ req = ItemSyncRequestKnown st+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ItemSyncResponseInSyncFull describe "Client changes" $ do- it "adds the item that the client tells the server to add"- $ forAllValid- $ \i -> do- let store1 = ServerEmpty- req = ItemSyncRequestNew i- let (resp, store2) = processServerItemSync @Int store1 req- let time = initialServerTime- store2 `shouldBe` ServerFull (Timed i time)- resp `shouldBe` ItemSyncResponseClientAdded time- it "changes the item that the client tells the server to change"- $ forAllValid- $ \i ->- forAllValid $ \j ->+ it "adds the item that the client tells the server to add" $+ forAllValid $+ \i -> do+ let store1 = ServerEmpty+ req = ItemSyncRequestNew i+ let (resp, store2) = processServerItemSync @Int store1 req+ let time = initialServerTime+ store2 `shouldBe` ServerFull (Timed i time)+ resp `shouldBe` ItemSyncResponseClientAdded time+ it "changes the item that the client tells the server to change" $+ forAllValid $+ \i ->+ forAllValid $ \j ->+ forAllValid $ \st -> do+ let store1 = ServerFull (Timed i st)+ req = ItemSyncRequestKnownButChanged (Timed j st)+ let (resp, store2) = processServerItemSync @Int store1 req+ let time = incrementServerTime st+ store2 `shouldBe` ServerFull (Timed j time)+ resp `shouldBe` ItemSyncResponseClientChanged time+ it "deletes the item that the client tells the server to delete" $+ forAllValid $+ \i -> forAllValid $ \st -> do let store1 = ServerFull (Timed i st)- req = ItemSyncRequestKnownButChanged (Timed j st)+ req = ItemSyncRequestDeletedLocally st let (resp, store2) = processServerItemSync @Int store1 req- let time = incrementServerTime st- store2 `shouldBe` ServerFull (Timed j time)- resp `shouldBe` ItemSyncResponseClientChanged time- it "deletes the item that the client tells the server to delete"- $ forAllValid- $ \i ->- forAllValid $ \st -> do- let store1 = ServerFull (Timed i st)- req = ItemSyncRequestDeletedLocally st- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` ServerEmpty- resp `shouldBe` ItemSyncResponseClientDeleted+ store2 `shouldBe` ServerEmpty+ resp `shouldBe` ItemSyncResponseClientDeleted describe "Server changes" $ 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)- req = ItemSyncRequestPoll- 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"- $ forAllValid- $ \i ->- forAllSubsequent $ \(st, st') -> do- let store1 = ServerFull (Timed i st')+ 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)+ req = ItemSyncRequestPoll+ 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" $+ forAllValid $+ \i ->+ forAllSubsequent $ \(st, st') -> do+ let store1 = ServerFull (Timed i st')+ req = ItemSyncRequestKnown st+ 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" $+ forAllValid $+ \st -> do+ let store1 = ServerEmpty req = ItemSyncRequestKnown st 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"- $ forAllValid- $ \st -> do- let store1 = ServerEmpty- req = ItemSyncRequestKnown st- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseServerDeleted+ resp `shouldBe` ItemSyncResponseServerDeleted describe "Conflicts" $ do- it "notices a conflict if the client and server are trying to sync different items"- $ forAllValid- $ \i ->- forAllValid $ \j ->+ 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 = ServerFull (Timed i st')+ req = ItemSyncRequestKnownButChanged (Timed j st)+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ItemSyncResponseConflict (Timed i st')+ it+ "notices a server-deleted-conflict if the client has a deleted item and server has a modified item"+ $ forAllValid $+ \i -> forAllSubsequent $ \(st, st') -> do let store1 = ServerFull (Timed i st')- req = ItemSyncRequestKnownButChanged (Timed j st)+ req = ItemSyncRequestDeletedLocally st let (resp, store2) = processServerItemSync @Int store1 req store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseConflict (Timed i st')- it- "notices a server-deleted-conflict if the client has a deleted item and server has a modified item"- $ forAllValid- $ \i ->- forAllSubsequent $ \(st, st') -> do- let store1 = ServerFull (Timed i st')- req = ItemSyncRequestDeletedLocally st- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseConflictClientDeleted (Timed i st')+ resp `shouldBe` ItemSyncResponseConflictClientDeleted (Timed i st') it "notices a server-deleted-conflict if the client has a modified item and server has no item"- $ forAllValid- $ \i ->- forAllValid $ \st -> do- let store1 = ServerEmpty- req = ItemSyncRequestKnownButChanged (Timed i st)- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseConflictServerDeleted+ $ forAllValid $+ \i ->+ forAllValid $ \st -> do+ let store1 = ServerEmpty+ req = ItemSyncRequestKnownButChanged (Timed i st)+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ItemSyncResponseConflictServerDeleted describe "syncing" $ do describe "fromServer" $ do syncingSpec @Int mergeFromServer@@ -170,148 +170,148 @@ Spec syncingSpec mergeStrategy = do let mergeSyncResponse ci = mergeStrategy ci . mergeItemSyncResponseRaw ci- it "it always possible to add an item from scratch"- $ forAllValid- $ \i -> do- let cstore1 = ClientAdded i- let sstore1 = ServerEmpty- let req1 = makeItemSyncRequest cstore1- (resp1, sstore2) = processServerItemSync sstore1 req1- cstore2 = mergeSyncResponse cstore1 resp1- let time = initialServerTime- resp1 `shouldBe` ItemSyncResponseClientAdded time- sstore2 `shouldBe` ServerFull (Timed i time)- cstore2 `shouldBe` ClientItemSynced (Timed i time)- it "succesfully syncs an addition across to a second client"- $ forAllValid- $ \i -> do- let cAstore1 = ClientAdded i- -- Client B is empty- let cBstore1 = ClientEmpty- -- The server is empty- let sstore1 = ServerEmpty- -- Client A makes sync request 1- let req1 = makeItemSyncRequest cAstore1- -- The server processes sync request 1- let (resp1, sstore2) = processServerItemSync sstore1 req1- let time = initialServerTime- resp1 `shouldBe` ItemSyncResponseClientAdded time- sstore2 `shouldBe` ServerFull (Timed i time)- -- Client A merges the response- let cAstore2 = mergeSyncResponse cAstore1 resp1- cAstore2 `shouldBe` ClientItemSynced (Timed i time)- -- Client B makes sync request 2- let req2 = makeItemSyncRequest cBstore1- -- The server processes sync request 2- let (resp2, sstore3) = processServerItemSync sstore2 req2- resp2 `shouldBe` ItemSyncResponseServerAdded (Timed i time)- sstore3 `shouldBe` ServerFull (Timed i time)- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp2- cBstore2 `shouldBe` ClientItemSynced (Timed i time)- -- Client A and Client B now have the same store- cAstore2 `shouldBe` cBstore2- it "succesfully syncs a modification across to a second client"- $ forAllValid- $ \time1 ->- forAllValid $ \i ->- forAllValid $ \j -> do+ it "it always possible to add an item from scratch" $+ forAllValid $+ \i -> do+ let cstore1 = ClientAdded i+ let sstore1 = ServerEmpty+ let req1 = makeItemSyncRequest cstore1+ (resp1, sstore2) = processServerItemSync sstore1 req1+ cstore2 = mergeSyncResponse cstore1 resp1+ let time = initialServerTime+ resp1 `shouldBe` ItemSyncResponseClientAdded time+ sstore2 `shouldBe` ServerFull (Timed i time)+ cstore2 `shouldBe` ClientItemSynced (Timed i time)+ it "succesfully syncs an addition across to a second client" $+ forAllValid $+ \i -> do+ let cAstore1 = ClientAdded i+ -- Client B is empty+ let cBstore1 = ClientEmpty+ -- The server is empty+ let sstore1 = ServerEmpty+ -- Client A makes sync request 1+ let req1 = makeItemSyncRequest cAstore1+ -- The server processes sync request 1+ let (resp1, sstore2) = processServerItemSync sstore1 req1+ let time = initialServerTime+ resp1 `shouldBe` ItemSyncResponseClientAdded time+ sstore2 `shouldBe` ServerFull (Timed i time)+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ cAstore2 `shouldBe` ClientItemSynced (Timed i time)+ -- Client B makes sync request 2+ let req2 = makeItemSyncRequest cBstore1+ -- The server processes sync request 2+ let (resp2, sstore3) = processServerItemSync sstore2 req2+ resp2 `shouldBe` ItemSyncResponseServerAdded (Timed i time)+ sstore3 `shouldBe` ServerFull (Timed i time)+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ cBstore2 `shouldBe` ClientItemSynced (Timed i time)+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs a modification across to a second client" $+ forAllValid $+ \time1 ->+ forAllValid $ \i ->+ forAllValid $ \j -> do+ let cAstore1 = ClientItemSynced (Timed i time1)+ -- Client B had synced that same item, but has since modified it+ let cBstore1 = ClientItemSyncedButChanged (Timed j time1)+ -- The server is has the item that both clients had before+ let sstore1 = ServerFull (Timed i time1)+ -- Client B makes sync request 1+ let req1 = makeItemSyncRequest cBstore1+ -- The server processes sync request 1+ let (resp1, sstore2) = processServerItemSync sstore1 req1+ let time2 = incrementServerTime time1+ resp1 `shouldBe` ItemSyncResponseClientChanged time2+ sstore2 `shouldBe` ServerFull (Timed j time2)+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp1+ cBstore2 `shouldBe` ClientItemSynced (Timed j time2)+ -- Client A makes sync request 2+ let req2 = makeItemSyncRequest cAstore1+ -- The server processes sync request 2+ let (resp2, sstore3) = processServerItemSync sstore2 req2+ resp2 `shouldBe` ItemSyncResponseServerChanged (Timed j time2)+ sstore3 `shouldBe` ServerFull (Timed j time2)+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp2+ cAstore2 `shouldBe` ClientItemSynced (Timed j time2)+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs a deletion across to a second client" $+ forAllValid $+ \time1 ->+ forAllValid $ \i -> do let cAstore1 = ClientItemSynced (Timed i time1)- -- Client B had synced that same item, but has since modified it- let cBstore1 = ClientItemSyncedButChanged (Timed j time1)- -- The server is has the item that both clients had before+ -- Client B had synced that same item, but has since deleted it+ let cBstore1 = ClientDeleted time1+ -- The server still has the undeleted item let sstore1 = ServerFull (Timed i time1) -- Client B makes sync request 1 let req1 = makeItemSyncRequest cBstore1 -- The server processes sync request 1 let (resp1, sstore2) = processServerItemSync sstore1 req1- let time2 = incrementServerTime time1- resp1 `shouldBe` ItemSyncResponseClientChanged time2- sstore2 `shouldBe` ServerFull (Timed j time2)+ resp1 `shouldBe` ItemSyncResponseClientDeleted+ sstore2 `shouldBe` ServerEmpty -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp1- cBstore2 `shouldBe` ClientItemSynced (Timed j time2)+ cBstore2 `shouldBe` ClientEmpty -- Client A makes sync request 2 let req2 = makeItemSyncRequest cAstore1 -- The server processes sync request 2 let (resp2, sstore3) = processServerItemSync sstore2 req2- resp2 `shouldBe` ItemSyncResponseServerChanged (Timed j time2)- sstore3 `shouldBe` ServerFull (Timed j time2)+ resp2 `shouldBe` ItemSyncResponseServerDeleted+ sstore3 `shouldBe` ServerEmpty -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp2- cAstore2 `shouldBe` ClientItemSynced (Timed j time2)+ cAstore2 `shouldBe` ClientEmpty -- Client A and Client B now have the same store cAstore2 `shouldBe` cBstore2- it "succesfully syncs a deletion across to a second client"- $ forAllValid- $ \time1 ->- forAllValid $ \i -> do- let cAstore1 = ClientItemSynced (Timed i time1)- -- Client B had synced that same item, but has since deleted it- let cBstore1 = ClientDeleted time1- -- The server still has the undeleted item- let sstore1 = ServerFull (Timed i time1)- -- Client B makes sync request 1- let req1 = makeItemSyncRequest cBstore1- -- The server processes sync request 1- let (resp1, sstore2) = processServerItemSync sstore1 req1- resp1 `shouldBe` ItemSyncResponseClientDeleted- sstore2 `shouldBe` ServerEmpty- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp1- cBstore2 `shouldBe` ClientEmpty- -- Client A makes sync request 2- let req2 = makeItemSyncRequest cAstore1- -- The server processes sync request 2- let (resp2, sstore3) = processServerItemSync sstore2 req2- resp2 `shouldBe` ItemSyncResponseServerDeleted- sstore3 `shouldBe` ServerEmpty- -- Client A merges the response- let cAstore2 = mergeSyncResponse cAstore1 resp2- cAstore2 `shouldBe` ClientEmpty- -- Client A and Client B now have the same store- cAstore2 `shouldBe` cBstore2- it "does not run into a conflict if two clients both try to sync a deletion"- $ forAllValid- $ \time1 ->- forAllValid $ \i -> do- let cAstore1 = ClientDeleted time1- -- Both client a and client b delete an item.- let cBstore1 = ClientDeleted time1- -- The server still has the undeleted item- let sstore1 = ServerFull (Timed i time1)- -- Client A makes sync request 1- let req1 = makeItemSyncRequest cAstore1- -- The server processes sync request 1- let (resp1, sstore2) = processServerItemSync sstore1 req1- resp1 `shouldBe` ItemSyncResponseClientDeleted- sstore2 `shouldBe` ServerEmpty- -- Client A merges the response- let cAstore2 = mergeSyncResponse cAstore1 resp1- cAstore2 `shouldBe` ClientEmpty- -- Client B makes sync request 2- let req2 = makeItemSyncRequest cBstore1- -- The server processes sync request 2- let (resp2, sstore3) = processServerItemSync sstore2 req2- resp2 `shouldBe` ItemSyncResponseClientDeleted- sstore3 `shouldBe` ServerEmpty- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp2- cBstore2 `shouldBe` ClientEmpty- -- Client A and Client B now have the same store- cAstore2 `shouldBe` cBstore2- it "is idempotent with one client"- $ forAllValid- $ \cstore1 ->- forAllValid $ \sstore1 -> do- let req1 = makeItemSyncRequest cstore1- (resp1, sstore2) = processServerItemSync sstore1 req1- cstore2 = mergeSyncResponse cstore1 resp1- req2 = makeItemSyncRequest cstore2- (resp2, sstore3) = processServerItemSync sstore2 req2- cstore3 = mergeSyncResponse cstore2 resp2- cstore3 `shouldBe` cstore2- sstore3 `shouldBe` sstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $+ forAllValid $+ \time1 ->+ forAllValid $ \i -> do+ let cAstore1 = ClientDeleted time1+ -- Both client a and client b delete an item.+ let cBstore1 = ClientDeleted time1+ -- The server still has the undeleted item+ let sstore1 = ServerFull (Timed i time1)+ -- Client A makes sync request 1+ let req1 = makeItemSyncRequest cAstore1+ -- The server processes sync request 1+ let (resp1, sstore2) = processServerItemSync sstore1 req1+ resp1 `shouldBe` ItemSyncResponseClientDeleted+ sstore2 `shouldBe` ServerEmpty+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ cAstore2 `shouldBe` ClientEmpty+ -- Client B makes sync request 2+ let req2 = makeItemSyncRequest cBstore1+ -- The server processes sync request 2+ let (resp2, sstore3) = processServerItemSync sstore2 req2+ resp2 `shouldBe` ItemSyncResponseClientDeleted+ sstore3 `shouldBe` ServerEmpty+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ cBstore2 `shouldBe` ClientEmpty+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ it "is idempotent with one client" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 -> do+ let req1 = makeItemSyncRequest cstore1+ (resp1, sstore2) = processServerItemSync sstore1 req1+ cstore2 = mergeSyncResponse cstore1 resp1+ req2 = makeItemSyncRequest cstore2+ (resp2, sstore3) = processServerItemSync sstore2 req2+ cstore3 = mergeSyncResponse cstore2 resp2+ cstore3 `shouldBe` cstore2+ sstore3 `shouldBe` sstore2 emptyResponseSpec :: forall a.@@ -320,16 +320,16 @@ Spec emptyResponseSpec mergeStrategy = do let mergeSyncResponse ci = mergeStrategy ci . mergeItemSyncResponseRaw ci- it "is returns an empty response on the second sync with no modifications"- $ forAllValid- $ \cstore1 ->- forAllValid $ \sstore1 -> do- let req1 = makeItemSyncRequest cstore1- (resp1, sstore2) = processServerItemSync sstore1 req1- cstore2 = mergeSyncResponse cstore1 resp1- req2 = makeItemSyncRequest cstore2- (resp2, _) = processServerItemSync sstore2 req2- case resp2 of- ItemSyncResponseInSyncEmpty -> pure ()- ItemSyncResponseInSyncFull -> pure ()- _ -> expectationFailure $ "Sync response was not empty: " <> show resp2+ it "is returns an empty response on the second sync with no modifications" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 -> do+ let req1 = makeItemSyncRequest cstore1+ (resp1, sstore2) = processServerItemSync sstore1 req1+ cstore2 = mergeSyncResponse cstore1 resp1+ req2 = makeItemSyncRequest cstore2+ (resp2, _) = processServerItemSync sstore2 req2+ case resp2 of+ ItemSyncResponseInSyncEmpty -> pure ()+ ItemSyncResponseInSyncFull -> pure ()+ _ -> expectationFailure $ "Sync response was not empty: " <> show resp2
test/Data/Mergeful/TimedSpec.hs view
@@ -14,7 +14,7 @@ spec :: Spec spec = do genValidSpec @ServerTime- jsonSpecOnValid @ServerTime+ jsonSpec @ServerTime genValidSpec @(Timed Int)- jsonSpecOnValid @(Timed Int)+ jsonSpec @(Timed Int) describe "initialServerTime" $ it "is valid" $ shouldBeValid initialServerTime
test/Data/Mergeful/ValueSpec.hs view
@@ -23,107 +23,107 @@ spec :: Spec spec = do genValidSpec @(ClientValue Int)- jsonSpecOnValid @(ClientValue Int)+ jsonSpec @(ClientValue Int) genValidSpec @(ServerValue Int)- jsonSpecOnValid @(ServerValue Int)+ jsonSpec @(ServerValue Int) genValidSpec @(ValueSyncRequest Int)- jsonSpecOnValid @(ValueSyncRequest Int)+ jsonSpec @(ValueSyncRequest Int) genValidSpec @(ValueSyncResponse Int)- jsonSpecOnValid @(ValueSyncResponse Int)- describe "makeValueSyncRequest"- $ it "produces valid requests"- $ producesValidsOnValids (makeValueSyncRequest @Int)- describe "mergeValueSyncResponseRaw"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeValueSyncResponseRaw @Int)- describe "mergeValueSyncResponseIgnoreProblems"- $ it "produces valid client stores"- $ producesValidsOnValids2 (mergeValueSyncResponseIgnoreProblems @Int)+ jsonSpec @(ValueSyncResponse Int)+ describe "makeValueSyncRequest" $+ it "produces valid requests" $+ producesValid (makeValueSyncRequest @Int)+ describe "mergeValueSyncResponseRaw" $+ it "produces valid client stores" $+ producesValid2 (mergeValueSyncResponseRaw @Int)+ describe "mergeValueSyncResponseIgnoreProblems" $+ it "produces valid client stores" $+ producesValid2 (mergeValueSyncResponseIgnoreProblems @Int) describe "processServerValueSync" $ do- it "produces valid responses and stores" $ producesValidsOnValids2 (processServerValueSync @Int)- it "makes no changes if the sync request reflects the state of the server"- $ forAllValid- $ \i ->- forAllValid $ \st -> do- let store1 = ServerValue $ Timed i st- req = ValueSyncRequestKnown st- let (resp, store2) = processServerValueSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ValueSyncResponseInSync- describe "Client changes"- $ it "changes the item that the client tells the server to change"- $ forAllValid- $ \i ->- forAllValid $ \j ->+ it "produces valid responses and stores" $ producesValid2 (processServerValueSync @Int)+ it "makes no changes if the sync request reflects the state of the server" $+ forAllValid $+ \i -> 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 = ValueSyncRequestKnownButChanged (Timed j st)+ let store1 = ServerValue $ Timed i st+ req = ValueSyncRequestKnown st let (resp, store2) = processServerValueSync @Int store1 req store2 `shouldBe` store1- resp `shouldBe` ValueSyncResponseConflict (Timed i st')+ resp `shouldBe` ValueSyncResponseInSync+ 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" $+ 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 = ValueSyncRequestKnownButChanged (Timed j st)+ let (resp, store2) = processServerValueSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ValueSyncResponseConflict (Timed i st') describe "syncing" $ do- it "succesfully syncs a modification across to a second client"- $ forAllValid- $ \time1 ->- forAllValid $ \i ->- forAllValid $ \j -> do- let cAstore1 = ClientValue (Timed i time1) NotChanged- -- Client B had synced that same item, but has since modified it- let cBstore1 = ClientValue (Timed j time1) Changed- -- The server is has the item that both clients had before- let sstore1 = ServerValue (Timed i time1)- -- Client B makes sync request 1- let req1 = makeValueSyncRequest cBstore1- -- The server processes sync request 1- let (resp1, sstore2) = processServerValueSync @Int sstore1 req1- let time2 = incrementServerTime time1- resp1 `shouldBe` ValueSyncResponseClientChanged time2- sstore2 `shouldBe` ServerValue (Timed j time2)- -- Client B merges the response- let cBstore2 = mergeValueSyncResponseIgnoreProblems cBstore1 resp1- cBstore2 `shouldBe` ClientValue (Timed j time2) NotChanged- -- Client A makes sync request 2- let req2 = makeValueSyncRequest cAstore1- -- The server processes sync request 2- let (resp2, sstore3) = processServerValueSync sstore2 req2- resp2 `shouldBe` ValueSyncResponseServerChanged (Timed j time2)- sstore3 `shouldBe` ServerValue (Timed j time2)- -- Client A merges the response- let cAstore2 = mergeValueSyncResponseIgnoreProblems cAstore1 resp2- cAstore2 `shouldBe` ClientValue (Timed j time2) NotChanged- -- Client A and Client B now have the same store- cAstore2 `shouldBe` cBstore2- it "is idempotent with one client"- $ forAllValid- $ \cstore1 ->- forAllValid $ \sstore1 -> do- let req1 = makeValueSyncRequest (cstore1 :: ClientValue Int)- (resp1, sstore2) = processServerValueSync sstore1 req1- cstore2 = mergeValueSyncResponseIgnoreProblems cstore1 resp1- req2 = makeValueSyncRequest cstore2- (resp2, sstore3) = processServerValueSync sstore2 req2- cstore3 = mergeValueSyncResponseIgnoreProblems cstore2 resp2- cstore2 `shouldBe` cstore3- sstore2 `shouldBe` sstore3+ it "succesfully syncs a modification across to a second client" $+ forAllValid $+ \time1 ->+ forAllValid $ \i ->+ forAllValid $ \j -> do+ let cAstore1 = ClientValue (Timed i time1) NotChanged+ -- Client B had synced that same item, but has since modified it+ let cBstore1 = ClientValue (Timed j time1) Changed+ -- The server is has the item that both clients had before+ let sstore1 = ServerValue (Timed i time1)+ -- Client B makes sync request 1+ let req1 = makeValueSyncRequest cBstore1+ -- The server processes sync request 1+ let (resp1, sstore2) = processServerValueSync @Int sstore1 req1+ let time2 = incrementServerTime time1+ resp1 `shouldBe` ValueSyncResponseClientChanged time2+ sstore2 `shouldBe` ServerValue (Timed j time2)+ -- Client B merges the response+ let cBstore2 = mergeValueSyncResponseIgnoreProblems cBstore1 resp1+ cBstore2 `shouldBe` ClientValue (Timed j time2) NotChanged+ -- Client A makes sync request 2+ let req2 = makeValueSyncRequest cAstore1+ -- The server processes sync request 2+ let (resp2, sstore3) = processServerValueSync sstore2 req2+ resp2 `shouldBe` ValueSyncResponseServerChanged (Timed j time2)+ sstore3 `shouldBe` ServerValue (Timed j time2)+ -- Client A merges the response+ let cAstore2 = mergeValueSyncResponseIgnoreProblems cAstore1 resp2+ cAstore2 `shouldBe` ClientValue (Timed j time2) NotChanged+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ it "is idempotent with one client" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 -> do+ let req1 = makeValueSyncRequest (cstore1 :: ClientValue Int)+ (resp1, sstore2) = processServerValueSync sstore1 req1+ cstore2 = mergeValueSyncResponseIgnoreProblems cstore1 resp1+ req2 = makeValueSyncRequest cstore2+ (resp2, sstore3) = processServerValueSync sstore2 req2+ cstore3 = mergeValueSyncResponseIgnoreProblems cstore2 resp2+ cstore2 `shouldBe` cstore3+ sstore2 `shouldBe` sstore3