diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,1 +0,0 @@ -# mergeful diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/genvalidity-mergeful.cabal b/genvalidity-mergeful.cabal --- a/genvalidity-mergeful.cabal +++ b/genvalidity-mergeful.cabal @@ -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 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 diff --git a/src/Data/GenValidity/Mergeful/Collection.hs b/src/Data/GenValidity/Mergeful/Collection.hs --- a/src/Data/GenValidity/Mergeful/Collection.hs +++ b/src/Data/GenValidity/Mergeful/Collection.hs @@ -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) => diff --git a/src/Data/GenValidity/Mergeful/Item.hs b/src/Data/GenValidity/Mergeful/Item.hs --- a/src/Data/GenValidity/Mergeful/Item.hs +++ b/src/Data/GenValidity/Mergeful/Item.hs @@ -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 diff --git a/src/Data/GenValidity/Mergeful/Timed.hs b/src/Data/GenValidity/Mergeful/Timed.hs --- a/src/Data/GenValidity/Mergeful/Timed.hs +++ b/src/Data/GenValidity/Mergeful/Timed.hs @@ -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 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 @@ -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 diff --git a/test/Data/Mergeful/CollectionSpec.hs b/test/Data/Mergeful/CollectionSpec.hs --- a/test/Data/Mergeful/CollectionSpec.hs +++ b/test/Data/Mergeful/CollectionSpec.hs @@ -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 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 @@ -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 diff --git a/test/Data/Mergeful/TimedSpec.hs b/test/Data/Mergeful/TimedSpec.hs --- a/test/Data/Mergeful/TimedSpec.hs +++ b/test/Data/Mergeful/TimedSpec.hs @@ -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 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 @@ -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