diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Criterion.Main as Criterion +import Data.GenValidity.Criterion +import Data.GenValidity.Mergeful () +import Data.Mergeful.Collection +import Data.Mergeful.Item +import Data.Mergeful.Value + +main :: IO () +main = + Criterion.defaultMain + [ bgroup "Utils" [genValidBench @ServerTime, genValidBench @(Timed Bool)], + bgroup + "Value" + [ genValidBench @ChangedFlag, + genValidBench @(ValueMergeResult Bool), + genValidBench @(ClientValue Bool), + genValidBench @(ValueSyncRequest Bool), + genValidBench @(ValueSyncResponse Bool), + genValidBench @(ServerValue Bool) + ], + bgroup + "Item" + [ genValidBench @(ItemMergeResult Bool), + genValidBench @(ClientItem Bool), + genValidBench @(ItemSyncRequest Bool), + genValidBench @(ItemSyncResponse Bool), + genValidBench @(ServerItem Bool) + ], + bgroup + "Collection" + [ genValidBench @ClientId, + genValidBench @(ClientStore ClientId Int Bool), + genValidBench @(SyncRequest ClientId Int Bool), + genValidBench @(ClientAddition Int), + genValidBench @(SyncResponse ClientId Int Bool), + genValidBench @(ServerStore Int Bool) + ] + ] diff --git a/genvalidity-mergeful.cabal b/genvalidity-mergeful.cabal --- a/genvalidity-mergeful.cabal +++ b/genvalidity-mergeful.cabal @@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 86196b99586836b920b517c4273efac7cc705762e7ff8c445e911cfdafe35620 +-- hash: cab74b20dcf0eadc6956a8ce9d4325af4494785285a9b5a43aa8fda713de2bb1 name: genvalidity-mergeful -version: 0.1.0.0 +version: 0.2.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 Tom Sydney Kerckhove +copyright: Copyright: (c) 2019-2020 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple @@ -38,7 +38,7 @@ src build-depends: QuickCheck - , base >=4.7 && <5 + , base <5 , containers , genvalidity , genvalidity-containers @@ -60,7 +60,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck - , base >=4.7 && <5 + , base <5 , containers , genvalidity-hspec , genvalidity-hspec-aeson @@ -73,4 +73,20 @@ , random , time , uuid + default-language: Haskell2010 + +benchmark mergeful-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_genvalidity_mergeful + hs-source-dirs: + bench + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base <5 + , criterion + , genvalidity-criterion + , genvalidity-mergeful + , mergeful default-language: Haskell2010 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 @@ -1,35 +1,36 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.GenValidity.Mergeful.Collection where +import Data.GenValidity +import Data.GenValidity.Containers () +import Data.GenValidity.Mergeful.Item () +import Data.GenValidity.Time () import Data.Map (Map) import qualified Data.Map as M +import Data.Mergeful import Data.Set (Set) import qualified Data.Set as S - import Data.Traversable - -import Data.GenValidity -import Data.GenValidity.Containers () -import Data.GenValidity.Time () - import Test.QuickCheck -import Data.GenValidity.Mergeful.Item () - -import Data.Mergeful - instance GenUnchecked ClientId instance GenValid ClientId -instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ClientStore i a) +instance + (GenUnchecked ci, GenUnchecked si, Ord ci, Ord si, GenUnchecked a) => + GenUnchecked (ClientStore ci si a) -instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (ClientStore i a) where +instance + (GenValid ci, GenValid si, Show ci, Show si, Ord ci, Ord si, GenValid a) => + GenValid (ClientStore ci si a) + where genValid = (`suchThat` isValid) $ do - identifiers <- scale (* 3) genValid + identifiers <- genValid (s1, s2) <- splitSet identifiers (s3, s4) <- splitSet s1 clientStoreAddedItems <- genValid @@ -39,18 +40,23 @@ pure ClientStore {..} shrinkValid = shrinkValidStructurally -instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ServerStore i a) +instance (GenUnchecked si, Ord si, GenUnchecked a) => GenUnchecked (ServerStore si a) -instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (ServerStore i a) where +instance (GenValid si, Show si, Ord si, GenValid a) => GenValid (ServerStore si a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncRequest i a) +instance + (GenUnchecked ci, GenUnchecked si, Ord ci, Ord si, GenUnchecked a) => + GenUnchecked (SyncRequest ci si a) -instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (SyncRequest i a) where +instance + (GenValid ci, GenValid si, Show ci, Show si, Ord ci, Ord si, GenValid a) => + GenValid (SyncRequest ci si a) + where genValid = (`suchThat` isValid) $ do - identifiers <- scale (* 3) genValid + identifiers <- genValid (s1, s2) <- splitSet identifiers (s3, s4) <- splitSet s1 syncRequestNewItems <- genValid @@ -60,12 +66,23 @@ pure SyncRequest {..} shrinkValid = shrinkValidStructurally -instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncResponse i a) +instance GenUnchecked si => GenUnchecked (ClientAddition si) -instance (GenValid i, Show i, Ord i, GenValid a) => GenValid (SyncResponse i a) where +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) => + GenValid (SyncResponse ci si a) + where genValid = (`suchThat` isValid) $ do - identifiers <- scale (* 10) genValid + identifiers <- scale (* 2) genValid (s01, s02) <- splitSet identifiers (s03, s04) <- splitSet s01 (s05, s06) <- splitSet s02 @@ -75,10 +92,11 @@ (s13, s14) <- splitSet s06 (s15, s16) <- splitSet s07 syncResponseClientAdded <- - do m <- genValid :: Gen (Map ClientId ()) - if S.null s08 - then pure M.empty - else forM m $ \() -> (,) <$> elements (S.toList s08) <*> genValid + do + m <- genValid :: Gen (Map ci ()) + if S.null s08 + then pure M.empty + else forM m $ \() -> ClientAddition <$> elements (S.toList s08) <*> genValid syncResponseClientChanged <- mapWithIds s09 let syncResponseClientDeleted = s10 syncResponseServerAdded <- mapWithIds s11 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 @@ -3,10 +3,14 @@ module Data.GenValidity.Mergeful.Item where import Data.GenValidity - +import Data.GenValidity.Mergeful.Timed () import Data.Mergeful.Item -import Data.GenValidity.Mergeful.Timed () +instance GenUnchecked a => GenUnchecked (ItemMergeResult a) + +instance GenValid a => GenValid (ItemMergeResult a) where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance GenUnchecked a => GenUnchecked (ClientItem a) 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 @@ -3,8 +3,8 @@ module Data.GenValidity.Mergeful.Timed where import Data.GenValidity - import Data.Mergeful.Timed +import Test.QuickCheck instance GenUnchecked a => GenUnchecked (Timed a) @@ -15,5 +15,10 @@ instance GenUnchecked ServerTime instance GenValid ServerTime where - genValid = genValidStructurallyWithoutExtraChecking + genValid = ServerTime <$> arbitrary + + -- Use the quickcheck generator to produce Word64s + -- This will hide the failures around maxBound for Word64 + -- but that's fine in this case. + -- See also the comment for the 'ServerTime' constructor. shrinkValid = shrinkValidStructurallyWithoutExtraFiltering 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 @@ -3,14 +3,20 @@ module Data.GenValidity.Mergeful.Value where import Data.GenValidity - -import Data.Mergeful.Value - import Data.GenValidity.Mergeful.Timed () +import Data.Mergeful.Value instance GenUnchecked ChangedFlag -instance GenValid 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) 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 @@ -2,295 +2,247 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Data.Mergeful.CollectionSpec - ( spec - ) where + ( spec, + ) +where +import Control.Monad.State import Data.Functor.Identity +import Data.GenValidity.Mergeful () +import Data.GenValidity.Mergeful.Item () +import Data.GenValidity.UUID () import Data.List import qualified Data.Map as M +import Data.Mergeful import qualified Data.Set as S import Data.UUID import GHC.Generics (Generic) import System.Random -import Text.Show.Pretty - -import Control.Monad.State - import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck import Test.Validity import Test.Validity.Aeson - -import Data.GenValidity.UUID () - -import Data.Mergeful -import Data.Mergeful.Timed - -import Data.GenValidity.Mergeful () -import Data.GenValidity.Mergeful.Item () +import Text.Show.Pretty {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} spec :: Spec -spec = do +spec = modifyMaxShrinks (min 0) $ do genValidSpec @ClientId jsonSpecOnValid @ClientId - genValidSpec @(ClientStore Int Int) - jsonSpecOnValid @(ClientStore Int Int) + genValidSpec @(ClientStore ClientId Int Int) + jsonSpecOnValid @(ClientStore ClientId Int Int) genValidSpec @(ServerStore Int Int) jsonSpecOnValid @(ServerStore Int Int) - genValidSpec @(SyncRequest Int Int) - jsonSpecOnValid @(SyncRequest Int Int) - genValidSpec @(SyncResponse Int Int) - jsonSpecOnValid @(SyncResponse Int Int) - describe "initialClientStore" $ it "is valid" $ shouldBeValid $ initialClientStore @Int @Int + 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 @Int @Int) - it "makes the client store one bigger" $ - forAllValid $ \cs -> + it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @ClientId @Int @Int) + it "makes the client store one bigger" + $ forAllValid + $ \cs -> forAllValid $ \a -> - clientStoreSize @Int @Int (addItemToClientStore a cs) `shouldBe` (clientStoreSize cs + 1) - it "ensures that the added item is in fact in the result" $ - forAllValid $ \cs -> + 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 @Int @Int a cs + let cs' = addItemToClientStore @ClientId @Int @Int a cs in a `elem` clientStoreAddedItems cs' describe "markItemDeletedInClientStore" $ do - it "produces valid stores" $ producesValidsOnValids2 (markItemDeletedInClientStore @Int @Int) + 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 @Int @Int (markItemDeletedInClientStore i cs) + 1) `shouldBe` - clientStoreSize cs + (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 @Int @Int i cs + 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 @Int @Int) + 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 @Int @Int (changeItemInClientStore i a cs) `shouldBe` - clientStoreSize cs + 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 @Int @Int i a cs + 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 @Int @Int) + 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 @Int @Int (deleteItemFromClientStore cid cs) + 1) `shouldBe` - clientStoreSize cs + (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 @Int @Int - describe "emptySyncResponse" $ it "is valid" $ shouldBeValid $ emptySyncResponse @Int @Int - describe "makeSyncRequest" $ - it "produces valid requests" $ producesValidsOnValids (makeSyncRequest @Int @Int) - describe "mergeAddedItems" $ - it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int) - describe "mergeSyncedButChangedItems" $ - it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int) - describe "mergeAddedItems" $ - it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int) - describe "mergeSyncedButChangedItems" $ - it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int) - describe "mergeDeletedItems" $ - it "produces valid results" $ producesValidsOnValids2 (mergeDeletedItems @Int @Int) - describe "mergeSyncResponseIgnoreProblems" $ - it "produces valid requests" $ - forAllValid $ \store -> - forAllValid $ \response -> - let res = mergeSyncResponseIgnoreProblems @Int @Int store response - in case prettyValidate res of - Right _ -> pure () - Left err -> - expectationFailure $ - unlines - [ "Store:" - , ppShow store - , "Response:" - , ppShow response - , "Invalid result:" - , ppShow res - , "error:" - , err - ] - describe "processServerSync" $ - it "produces valid tuples of a response and a store" $ - producesValidsOnValids2 - (\store request -> evalD $ processServerSync genD (store :: ServerStore UUID Int) request) - describe "Syncing with mergeSyncResponseIgnoreProblems" $ do - mergeFunctionSpec @Int mergeSyncResponseIgnoreProblems - it "does not lose data after a conflict occurs" $ - forAllValid $ \uuid -> - forAllValid $ \time1 -> - forAllValid $ \i1 -> - forAllValid $ \i2 -> - forAllValid $ \i3 -> - evalDM $ do - let sstore1 = - ServerStore - {serverStoreItems = M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)} - -- The server has an item - -- The first client has synced it, and modified it. - let cAstore1 = - initialClientStore - {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)} - -- The second client has synced it too, and modified it too. - let cBstore1 = - initialClientStore - {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)} - -- Client A makes sync request 1 - let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 - (resp1, sstore2) <- processServerSync genD sstore1 req1 - let time2 = incrementServerTime time1 - -- The server updates the item accordingly - lift $ do - resp1 `shouldBe` - (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}) - sstore2 `shouldBe` - (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)}) - -- Client A merges the response - let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1 - lift $ - cAstore2 `shouldBe` - (initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)}) - -- Client B makes sync request 2 - let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 - (resp2, sstore3) <- processServerSync genD sstore2 req2 - -- The server reports a conflict and does not change its store - lift $ do - resp2 `shouldBe` - (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed i2 time2)}) - sstore3 `shouldBe` sstore2 - -- Client B merges the response - let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2 - -- Client does not update, but keeps its conflict - lift $ - cBstore2 `shouldBe` - (initialClientStore - {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}) - -- Client A and Client B now *do not* have the same store + describe "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 - mergeFunctionSpec @Int mergeSyncResponseFromServer - describe "mergeSyncResponseFromServer" $ - it "only differs from mergeSyncResponseIgnoreProblems on conflicts" $ - forAllValid $ \cstore -> - forAllValid $ \sresp@SyncResponse {..} -> do - let cstoreA = mergeSyncResponseFromServer (cstore :: ClientStore UUID Int) sresp - cstoreB = mergeSyncResponseIgnoreProblems cstore sresp - if cstoreA == cstoreB - then pure () - else unless - (or - [ not (M.null syncResponseConflicts) - , not (M.null syncResponseConflictsClientDeleted) - , not (S.null syncResponseConflictsServerDeleted) - ]) $ - expectationFailure $ - unlines - [ "There was a difference between mergeSyncResponseFromServer and mergeSyncResponseIgnoreProblems that was somehow unrelated to the conflicts:" - , "syncResponseConflicts:" - , ppShow syncResponseConflicts - , "syncResponseConflictsClientDeleted:" - , ppShow syncResponseConflictsClientDeleted - , "syncResponseConflictsServerDeleted:" - , ppShow syncResponseConflictsServerDeleted - , "client store after mergeSyncResponseFromServer:" - , ppShow cstoreA - , "client store after mergeSyncResponseIgnoreProblems:" - , ppShow cstoreB - ] - it "does not diverge after a conflict occurs" $ - forAllValid $ \uuid -> - forAllValid $ \time1 -> - forAllValid $ \i1 -> - forAllValid $ \i2 -> - forAllValid $ \i3 -> - evalDM $ do - let sstore1 = - ServerStore - {serverStoreItems = M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)} - -- The server has an item - -- The first client has synced it, and modified it. - let cAstore1 = - initialClientStore - {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)} - -- The second client has synced it too, and modified it too. - let cBstore1 = - initialClientStore - {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)} - -- Client A makes sync request 1 - let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 - (resp1, sstore2) <- processServerSync genD sstore1 req1 - let time2 = incrementServerTime time1 - -- The server updates the item accordingly - lift $ do - resp1 `shouldBe` - (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}) - sstore2 `shouldBe` - (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)}) - -- Client A merges the response - let cAstore2 = mergeSyncResponseFromServer cAstore1 resp1 - lift $ - cAstore2 `shouldBe` - (initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)}) - -- Client B makes sync request 2 - let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 - (resp2, sstore3) <- processServerSync genD sstore2 req2 - -- The server reports a conflict and does not change its store - lift $ do - resp2 `shouldBe` - (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed i2 time2)}) - sstore3 `shouldBe` sstore2 - -- Client B merges the response - let cBstore2 = mergeSyncResponseFromServer cBstore1 resp2 - -- Client does not update, but keeps its conflict - lift $ do - cBstore2 `shouldBe` - (initialClientStore - {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)}) - -- Client A and Client B now have the same store - cBstore2 `shouldBe` cAstore2 - describe "Syncing with mergeSyncResponseUsingStrategy with a GCounter" $ - mergeFunctionSpec @Int $ - mergeSyncResponseUsingStrategy - ItemMergeStrategy - { itemMergeStrategyMergeChangeConflict = - \clientItem (Timed serverItem t) -> Timed (max clientItem serverItem) t - , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem - , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing - } + 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) - => (forall i. Ord i => - ClientStore i a -> SyncResponse i a -> ClientStore i a) - -> Spec -mergeFunctionSpec mergeFunc = do - describe "Single client" $ - describe "Multi-item" $ do - it "succesfully downloads everything from the server for an empty client" $ - forAllValid $ \sstore1 -> + 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 @@ -299,8 +251,9 @@ lift $ do sstore2 `shouldBe` sstore1 clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2 - it "succesfully uploads everything to the server for an empty server" $ - forAllValid $ \items -> + it "succesfully uploads everything to the server for an empty server" + $ forAllValid + $ \items -> evalDM $ do let cstore1 = initialClientStore {clientStoreAddedItems = items} let sstore1 = initialServerStore @@ -308,11 +261,12 @@ (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) + 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 -> + it "is idempotent with one client" + $ forAllValid + $ \cstore1 -> forAllValid $ \sstore1 -> evalDM $ do let req1 = makeSyncRequest cstore1 @@ -326,262 +280,467 @@ sstore2 `shouldBe` sstore3 describe "Multiple clients" $ do describe "Single-item" $ do - it "successfully syncs an addition accross to a second client" $ - forAllValid $ \i -> + 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 + -- Client B is empty let cBstore1 = initialClientStore - -- The server is empty + -- The server is empty let sstore1 = initialServerStore - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- processServerSync genD sstore1 req1 let addedItems = syncResponseClientAdded resp1 case M.toList addedItems of - [(ClientId 0, (uuid, st))] -> do + [(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 + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp1 lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items}) - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- 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 + -- 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 + -- 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 -> + 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 + { 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 + { 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 + -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 - -- The server processes sync request 1 + -- 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 + 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 + 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 + -- The server processes sync request 2 (resp2, sstore3) <- processServerSync genD sstore2 req2 lift $ do - resp2 `shouldBe` - emptySyncResponse - {syncResponseServerChanged = M.singleton uuid (Timed j time2)} + resp2 + `shouldBe` emptySyncResponse + { syncResponseServerChanged = M.singleton uuid (Timed j time2) + } sstore3 `shouldBe` sstore2 - -- Client A merges the response + -- 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 + 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 -> + 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. + -- 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 + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)} - -- Client B makes sync request 1 + -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 - -- The server processes sync request 1 + -- 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 + -- Client B merges the response let cBstore2 = mergeFunc cBstore1 resp1 lift $ cBstore2 `shouldBe` initialClientStore - -- Client A makes sync request 2 + -- Client A makes sync request 2 let req2 = makeSyncRequest cAstore1 - -- The server processes sync request 2 + -- 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 + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp2 lift $ cAstore2 `shouldBe` initialClientStore - -- Client A and Client B now have the same store + -- 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 -> + 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. + -- Both client a and client b delete an item. let cBstore1 = initialClientStore {clientStoreDeletedItems = M.singleton uuid time1} - -- The server still has the undeleted item + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)} - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- processServerSync genD sstore1 req1 lift $ do - resp1 `shouldBe` - (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) + resp1 + `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) - -- Client A merges the response + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp1 lift $ cAstore2 `shouldBe` initialClientStore - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- processServerSync genD sstore2 req2 lift $ do - resp2 `shouldBe` - (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) + resp2 + `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore3 `shouldBe` sstore2 - -- Client B merges the response + -- 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 + -- 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 -> + it "successfully syncs additions accross to a second client" + $ forAllValid + $ \is -> evalDM $ do let cAstore1 = initialClientStore {clientStoreAddedItems = is} - -- Client B is empty + -- Client B is empty let cBstore1 = initialClientStore - -- The server is empty + -- The server is empty let sstore1 = initialServerStore - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- 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 + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp1 lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items}) - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- 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 + -- 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 + -- 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 -> + 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. + -- 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 + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = syncedItems} - -- Client B makes sync request 1 + -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 - -- The server processes sync request 1 + -- 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 + -- Client B merges the response let cBstore2 = mergeFunc cBstore1 resp1 lift $ cBstore2 `shouldBe` initialClientStore - -- Client A makes sync request 2 + -- Client A makes sync request 2 let req2 = makeSyncRequest cAstore1 - -- The server processes sync request 2 + -- 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 + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp2 lift $ cAstore2 `shouldBe` initialClientStore - -- Client A and Client B now have the same store + -- 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 -> + 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. + -- 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 + -- The server still has the undeleted items let sstore1 = ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items} - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- 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 + -- Client A merges the response let cAstore2 = mergeFunc cAstore1 resp1 lift $ cAstore2 `shouldBe` initialClientStore - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- 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 + -- 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 + -- Client A and Client B now have the same store cAstore2 `shouldBe` cBstore2 -newtype D m a = - D - { unD :: StateT StdGen m a - } +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 @@ -1,19 +1,19 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module Data.Mergeful.ItemSpec - ( spec - ) where + ( spec, + ) +where +import Data.GenValidity.Mergeful.Item () +import Data.Mergeful.Item +import Data.Mergeful.Timed import Test.Hspec import Test.QuickCheck import Test.Validity import Test.Validity.Aeson -import Data.Mergeful.Item -import Data.Mergeful.Timed - -import Data.GenValidity.Mergeful.Item () - {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} forAllSubsequent :: Testable prop => ((ServerTime, ServerTime) -> prop) -> Property @@ -31,13 +31,21 @@ jsonSpecOnValid @(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 "mergeItemSyncResponseIgnoreProblems" $ - it "produces valid client stores" $ - producesValidsOnValids2 (mergeItemSyncResponseIgnoreProblems @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) describe "processServerItemSync" $ do it "produces valid responses and stores" $ producesValidsOnValids2 (processServerItemSync @Int) it "makes no changes if the sync request reflects the state of the empty server" $ do @@ -46,8 +54,9 @@ 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 -> + 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 @@ -55,16 +64,18 @@ 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 + 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 -> + 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) @@ -73,8 +84,9 @@ 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 -> + 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 @@ -82,32 +94,36 @@ 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 -> + 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 -> + 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 + 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 describe "Conflicts" $ do - it "notices a conflict if the client and server are trying to sync different items" $ - forAllValid $ \i -> + 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') @@ -116,8 +132,9 @@ 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 -> + "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 @@ -125,8 +142,9 @@ store2 `shouldBe` store1 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 -> + "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) @@ -134,139 +152,184 @@ store2 `shouldBe` store1 resp `shouldBe` ItemSyncResponseConflictServerDeleted describe "syncing" $ do - it "it always possible to add an item from scratch" $ - forAllValid $ \i -> do - let cstore1 = ClientAdded (i :: Int) - let sstore1 = ServerEmpty - let req1 = makeItemSyncRequest cstore1 - (resp1, sstore2) = processServerItemSync sstore1 req1 - cstore2 = mergeItemSyncResponseIgnoreProblems 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 @Int sstore1 req1 - let time = initialServerTime - resp1 `shouldBe` ItemSyncResponseClientAdded time - sstore2 `shouldBe` ServerFull (Timed i time) - -- Client A merges the response - let cAstore2 = mergeItemSyncResponseIgnoreProblems 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 = mergeItemSyncResponseIgnoreProblems 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 @Int sstore1 req1 - let time2 = incrementServerTime time1 - resp1 `shouldBe` ItemSyncResponseClientChanged time2 - sstore2 `shouldBe` ServerFull (Timed j time2) - -- Client B merges the response - let cBstore2 = mergeItemSyncResponseIgnoreProblems 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 = mergeItemSyncResponseIgnoreProblems 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 + describe "fromServer" $ do + syncingSpec @Int mergeFromServer + emptyResponseSpec @Int mergeFromServer + describe "fromClient" $ do + syncingSpec @Int mergeFromClient + xdescribe "does not hold" $ emptyResponseSpec @Int mergeFromClient + describe "gadt" $ do + let merge = mergeUsingCRDT @Int max + syncingSpec merge + emptyResponseSpec merge + +syncingSpec :: + forall a. + (Show a, Eq a, GenValid a) => + (ClientItem a -> ItemMergeResult a -> ClientItem a) -> + 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 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 + -- 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 @Int sstore1 req1 - resp1 `shouldBe` ItemSyncResponseClientDeleted - sstore2 `shouldBe` ServerEmpty + 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 = mergeItemSyncResponseIgnoreProblems cBstore1 resp1 - cBstore2 `shouldBe` ClientEmpty + 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` ItemSyncResponseServerDeleted - sstore3 `shouldBe` ServerEmpty - -- Client A merges the response - let cAstore2 = mergeItemSyncResponseIgnoreProblems 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 @Int sstore1 req1 - resp1 `shouldBe` ItemSyncResponseClientDeleted - sstore2 `shouldBe` ServerEmpty + resp2 `shouldBe` ItemSyncResponseServerChanged (Timed j time2) + sstore3 `shouldBe` ServerFull (Timed j time2) -- Client A merges the response - let cAstore2 = mergeItemSyncResponseIgnoreProblems 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 = mergeItemSyncResponseIgnoreProblems cBstore1 resp2 - cBstore2 `shouldBe` ClientEmpty + 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 "is idempotent with one client" $ - forAllValid $ \cstore1 -> - forAllValid $ \sstore1 -> do - let req1 = makeItemSyncRequest (cstore1 :: ClientItem Int) - (resp1, sstore2) = processServerItemSync sstore1 req1 - cstore2 = mergeItemSyncResponseIgnoreProblems cstore1 resp1 - req2 = makeItemSyncRequest cstore2 - (resp2, sstore3) = processServerItemSync sstore2 req2 - cstore3 = mergeItemSyncResponseIgnoreProblems cstore2 resp2 - cstore2 `shouldBe` cstore3 - sstore2 `shouldBe` sstore3 + 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 + +emptyResponseSpec :: + forall a. + (Show a, Eq a, GenValid a) => + (ClientItem a -> ItemMergeResult a -> ClientItem a) -> + 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 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 @@ -1,16 +1,15 @@ {-# LANGUAGE TypeApplications #-} module Data.Mergeful.TimedSpec - ( spec - ) where + ( spec, + ) +where +import Data.GenValidity.Mergeful.Item () +import Data.Mergeful.Timed import Test.Hspec import Test.Validity import Test.Validity.Aeson - -import Data.Mergeful.Timed - -import Data.GenValidity.Mergeful.Item () spec :: Spec spec = do 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 @@ -1,19 +1,18 @@ {-# LANGUAGE TypeApplications #-} module Data.Mergeful.ValueSpec - ( spec - ) where + ( spec, + ) +where +import Data.GenValidity.Mergeful.Value () +import Data.Mergeful.Timed +import Data.Mergeful.Value import Test.Hspec import Test.QuickCheck import Test.Validity import Test.Validity.Aeson -import Data.Mergeful.Timed -import Data.Mergeful.Value - -import Data.GenValidity.Mergeful.Value () - {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} forAllSubsequent :: Testable prop => ((ServerTime, ServerTime) -> prop) -> Property @@ -31,26 +30,30 @@ jsonSpecOnValid @(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) + 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) 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 -> + 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 -> + 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) @@ -59,18 +62,20 @@ 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 -> + 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 -> + 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') @@ -79,8 +84,9 @@ store2 `shouldBe` store1 resp `shouldBe` ValueSyncResponseConflict (Timed i st') describe "syncing" $ do - it "succesfully syncs a modification across to a second client" $ - forAllValid $ \time1 -> + it "succesfully syncs a modification across to a second client" + $ forAllValid + $ \time1 -> forAllValid $ \i -> forAllValid $ \j -> do let cAstore1 = ClientValue (Timed i time1) NotChanged @@ -109,8 +115,9 @@ 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 -> + it "is idempotent with one client" + $ forAllValid + $ \cstore1 -> forAllValid $ \sstore1 -> do let req1 = makeValueSyncRequest (cstore1 :: ClientValue Int) (resp1, sstore2) = processServerValueSync sstore1 req1