genvalidity-mergeful (empty) → 0.0.0.0
raw patch · 14 files changed
+1273/−0 lines, 14 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, genvalidity, genvalidity-containers, genvalidity-hspec, genvalidity-hspec-aeson, genvalidity-mergeful, genvalidity-time, genvalidity-uuid, hspec, mergeful, mtl, pretty-show, random, time, uuid
Files
- ChangeLog.md +3/−0
- LICENSE +21/−0
- README.md +1/−0
- Setup.hs +3/−0
- genvalidity-mergeful.cabal +75/−0
- src/Data/GenValidity/Mergeful.hs +102/−0
- src/Data/GenValidity/Mergeful/Item.hs +33/−0
- src/Data/GenValidity/Mergeful/Timed.hs +19/−0
- src/Data/GenValidity/Mergeful/Value.hs +35/−0
- test/Data/Mergeful/ItemSpec.hs +272/−0
- test/Data/Mergeful/TimedSpec.hs +21/−0
- test/Data/Mergeful/ValueSpec.hs +122/−0
- test/Data/MergefulSpec.hs +565/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for mergeful++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018-2019 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,1 @@+# mergeful
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ genvalidity-mergeful.cabal view
@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: dec5147002ec3be045920638188c5c8157bfce8d1d6778dd8186b06b56fa110d++name: genvalidity-mergeful+version: 0.0.0.0+description: Please see the README on GitHub at <https://github.com/NorfairKing/mergeful#readme>+homepage: https://github.com/NorfairKing/mergeful#readme+bug-reports: https://github.com/NorfairKing/mergeful/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright: (c) 2019 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/mergeful++library+ exposed-modules:+ Data.GenValidity.Mergeful+ Data.GenValidity.Mergeful.Item+ Data.GenValidity.Mergeful.Timed+ Data.GenValidity.Mergeful.Value+ other-modules:+ Paths_genvalidity_mergeful+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , containers+ , genvalidity+ , genvalidity-containers+ , genvalidity-time+ , mergeful+ default-language: Haskell2010++test-suite mergeful-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Mergeful.ItemSpec+ Data.Mergeful.TimedSpec+ Data.Mergeful.ValueSpec+ Data.MergefulSpec+ Paths_genvalidity_mergeful+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , containers+ , genvalidity-hspec+ , genvalidity-hspec-aeson+ , genvalidity-mergeful+ , genvalidity-uuid+ , hspec+ , mergeful+ , mtl+ , pretty-show+ , random+ , time+ , uuid+ default-language: Haskell2010
+ src/Data/GenValidity/Mergeful.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeful where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S++import Data.Traversable++import Data.GenValidity+import Data.GenValidity.Containers ()+import Data.GenValidity.Time ()++import Test.QuickCheck++import Data.GenValidity.Mergeful.Item ()++import Data.Mergeful++instance GenUnchecked ClientId++instance GenValid ClientId++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ClientStore i a)++instance (GenValid i, Ord i, GenValid a) => GenValid (ClientStore i a) where+ genValid =+ (`suchThat` isValid) $ do+ identifiers <- scale (* 3) genValid+ (s1, s2) <- splitSet identifiers+ (s3, s4) <- splitSet s1+ clientStoreAddedItems <- genValid+ clientStoreSyncedItems <- mapWithIds s2+ clientStoreSyncedButChangedItems <- mapWithIds s3+ clientStoreDeletedItems <- mapWithIds s4+ pure ClientStore {..}+ shrinkValid = shrinkValidStructurally++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (ServerStore i a)++instance (GenValid i, Ord i, GenValid a) => GenValid (ServerStore i a) where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncRequest i a)++instance (GenValid i, Ord i, GenValid a) => GenValid (SyncRequest i a) where+ genValid =+ (`suchThat` isValid) $ do+ identifiers <- scale (* 3) genValid+ (s1, s2) <- splitSet identifiers+ (s3, s4) <- splitSet s1+ syncRequestNewItems <- genValid+ syncRequestKnownItems <- mapWithIds s2+ syncRequestKnownButChangedItems <- mapWithIds s3+ syncRequestDeletedItems <- mapWithIds s4+ pure SyncRequest {..}+ shrinkValid = shrinkValidStructurally++instance (GenUnchecked i, Ord i, GenUnchecked a) => GenUnchecked (SyncResponse i a)++instance (GenValid i, Ord i, GenValid a) => GenValid (SyncResponse i a) where+ genValid =+ (`suchThat` isValid) $ do+ identifiers <- scale (* 10) genValid+ (s01, s02) <- splitSet identifiers+ (s03, s04) <- splitSet s01+ (s05, s06) <- splitSet s02+ (s07, s08) <- splitSet s03+ (s09, s10) <- splitSet s04+ (s11, s12) <- splitSet s05+ (s13, s14) <- splitSet s06+ (s15, s16) <- splitSet s07+ syncResponseClientAdded <-+ do m <- (genValid :: Gen (Map ClientId ()))+ if S.null s08+ then pure M.empty+ else forM m $ \() -> (,) <$> elements (S.toList s08) <*> genValid+ syncResponseClientChanged <- mapWithIds s09+ let syncResponseClientDeleted = s10+ syncResponseServerAdded <- mapWithIds s11+ syncResponseServerChanged <- mapWithIds s12+ let syncResponseServerDeleted = s13+ syncResponseConflicts <- mapWithIds s14+ syncResponseConflictsClientDeleted <- mapWithIds s15+ let syncResponseConflictsServerDeleted = s16+ pure SyncResponse {..}+ shrinkValid = shrinkValidStructurally++splitSet :: Ord i => Set i -> Gen (Set i, Set i)+splitSet s =+ if S.null s+ then pure (S.empty, S.empty)+ else do+ a <- elements $ S.toList s+ pure $ S.split a s++mapWithIds :: (Ord i, GenValid a) => Set i -> Gen (Map i a)+mapWithIds s = fmap M.fromList $ for (S.toList s) $ \i -> (,) i <$> genValid
+ src/Data/GenValidity/Mergeful/Item.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeful.Item where++import Data.GenValidity++import Data.Mergeful.Item++import Data.GenValidity.Mergeful.Timed ()++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+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
+ src/Data/GenValidity/Mergeful/Timed.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeful.Timed where++import Data.GenValidity++import Data.Mergeful.Timed++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 = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
+ src/Data/GenValidity/Mergeful/Value.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.GenValidity.Mergeful.Value where++import Data.GenValidity++import Data.Mergeful.Value++import Data.GenValidity.Mergeful.Timed ()++instance GenUnchecked ChangedFlag+instance GenValid ChangedFlag+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+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
+ test/Data/Mergeful/ItemSpec.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE TypeApplications #-}++module Data.Mergeful.ItemSpec+ ( spec+ ) where++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+forAllSubsequent func =+ forAllValid $ \st ->+ forAllShrink (genValid `suchThat` (> st)) (filter (> st) . shrinkValid) $ \st' -> func (st, st')++spec :: Spec+spec = do+ genValidSpec @(ClientItem Int)+ jsonSpecOnValid @(ClientItem Int)+ genValidSpec @(ServerItem Int)+ jsonSpecOnValid @(ServerItem Int)+ genValidSpec @(ItemSyncRequest Int)+ 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 "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+ 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+ 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 ->+ 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 = ItemSyncRequestDeletedLocally st+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` ServerEmpty+ resp `shouldBe` ItemSyncResponseClientDeleted+ describe "Server changes" $ do+ it "tells the client that there is a new item at the server side" $ do+ 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" $ do+ 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" $ do+ 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 ->+ 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 = ItemSyncRequestDeletedLocally st+ let (resp, store2) = processServerItemSync @Int store1 req+ 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 ->+ 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+ 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+ 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 @Int sstore1 req1+ resp1 `shouldBe` ItemSyncResponseClientDeleted+ sstore2 `shouldBe` ServerEmpty+ -- Client B merges the response+ let cBstore2 = mergeItemSyncResponseIgnoreProblems 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 = 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+ -- 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+ -- 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
+ test/Data/Mergeful/TimedSpec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeApplications #-}++module Data.Mergeful.TimedSpec+ ( spec+ ) where++import Test.Hspec+import Test.Validity+import Test.Validity.Aeson++import Data.Mergeful.Timed++import Data.GenValidity.Mergeful.Item ()++spec :: Spec+spec = do+ genValidSpec @ServerTime+ jsonSpecOnValid @ServerTime+ genValidSpec @(Timed Int)+ jsonSpecOnValid @(Timed Int)+ describe "initialServerTime" $ it "is valid" $ shouldBeValid initialServerTime
+ test/Data/Mergeful/ValueSpec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TypeApplications #-}++module Data.Mergeful.ValueSpec+ ( spec+ ) where++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+forAllSubsequent func =+ forAllValid $ \st ->+ forAllShrink (genValid `suchThat` (> st)) (filter (> st) . shrinkValid) $ \st' -> func (st, st')++spec :: Spec+spec = do+ genValidSpec @(ClientValue Int)+ jsonSpecOnValid @(ClientValue Int)+ genValidSpec @(ServerValue Int)+ jsonSpecOnValid @(ServerValue Int)+ genValidSpec @(ValueSyncRequest Int)+ 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 "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" $ do+ it "changes the item that the client tells the server to change" $+ forAllValid $ \i ->+ forAllValid $ \j ->+ forAllValid $ \st -> do+ let store1 = ServerValue (Timed i st)+ req = ValueSyncRequestKnownButChanged (Timed j st)+ let (resp, store2) = processServerValueSync @Int store1 req+ let time = incrementServerTime st+ store2 `shouldBe` ServerValue (Timed j time)+ resp `shouldBe` ValueSyncResponseClientChanged time+ describe "Server changes" $ do+ it "tells the client that there is a modified item at the server side" $ do+ forAllValid $ \i ->+ 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" $ do+ it "notices a conflict if the client and server are trying to sync different items" $+ forAllValid $ \i ->+ forAllValid $ \j ->+ forAllSubsequent $ \(st, st') -> do+ let store1 = ServerValue (Timed i st')+ req = ValueSyncRequestKnownButChanged (Timed j st)+ let (resp, store2) = processServerValueSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ValueSyncResponseConflict (Timed i st')+ 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
+ test/Data/MergefulSpec.hs view
@@ -0,0 +1,565 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++module Data.MergefulSpec+ ( spec+ ) where++import Data.Functor.Identity+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.Set as S+import Data.UUID+import GHC.Generics (Generic)+import System.Random+import Text.Show.Pretty++import Control.Monad.State++import Test.Hspec+import Test.Validity+import Test.Validity.Aeson++import Data.GenValidity.UUID ()++import Data.Mergeful+import Data.Mergeful.Timed++import Data.GenValidity.Mergeful ()+import Data.GenValidity.Mergeful.Item ()++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++spec :: Spec+spec = do+ genValidSpec @ClientId+ jsonSpecOnValid @ClientId+ genValidSpec @(ClientStore Int Int)+ jsonSpecOnValid @(ClientStore Int Int)+ genValidSpec @(ServerStore Int Int)+ jsonSpecOnValid @(ServerStore Int Int)+ genValidSpec @(SyncRequest Int Int)+ jsonSpecOnValid @(SyncRequest Int Int)+ genValidSpec @(SyncResponse Int Int)+ jsonSpecOnValid @(SyncResponse Int Int)+ describe "initialClientStore" $ it "is valid" $ shouldBeValid $ initialClientStore @Int @Int+ describe "addItemToClientStore" $+ it "produces valid stores" $ producesValidsOnValids2 (addItemToClientStore @Int @Int)+ describe "markItemDeletedInClientStore" $+ it "produces valid stores" $ producesValidsOnValids2 (markItemDeletedInClientStore @Int @Int)+ describe "changeItemInClientStore" $+ it "produces valid stores" $ producesValidsOnValids3 (changeItemInClientStore @Int @Int)+ describe "deleteItemFromClientStore" $+ it "produces valid stores" $ producesValidsOnValids2 (deleteItemFromClientStore @Int @Int)+ describe "initialServerStore" $ it "is valid" $ shouldBeValid $ initialServerStore @Int @Int+ describe "initialSyncRequest" $ it "is valid" $ shouldBeValid $ initialSyncRequest @Int @Int+ describe "emptySyncResponse" $ it "is valid" $ shouldBeValid $ emptySyncResponse @Int @Int+ describe "makeSyncRequest" $+ it "produces valid requests" $ producesValidsOnValids (makeSyncRequest @Int @Int)+ describe "mergeAddedItems" $+ it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)+ describe "mergeSyncedButChangedItems" $+ it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)+ describe "mergeAddedItems" $+ it "produces valid results" $ producesValidsOnValids2 (mergeAddedItems @Int @Int)+ describe "mergeSyncedButChangedItems" $+ it "produces valid results" $ producesValidsOnValids2 (mergeSyncedButChangedItems @Int @Int)+ describe "mergeDeletedItems" $+ it "produces valid results" $ producesValidsOnValids2 (mergeDeletedItems @Int @Int)+ describe "mergeSyncResponseIgnoreProblems" $+ it "produces valid requests" $+ forAllValid $ \store ->+ forAllValid $ \response ->+ let res = mergeSyncResponseIgnoreProblems @Int @Int store response+ in case prettyValidate res of+ Right _ -> pure ()+ Left err ->+ expectationFailure $+ unlines+ [ "Store:"+ , ppShow store+ , "Response:"+ , ppShow response+ , "Invalid result:"+ , ppShow res+ , "error:"+ , err+ ]+ describe "mergeSyncResponseFromServer" $ do+ it "only differs from mergeSyncResponseIgnoreProblems on conflicts" $+ forAllValid $ \cstore ->+ forAllValid $ \sresp@SyncResponse {..} -> do+ let cstoreA = mergeSyncResponseFromServer (cstore :: ClientStore (UUID) Int) sresp+ cstoreB = mergeSyncResponseIgnoreProblems cstore sresp+ if cstoreA == cstoreB+ then pure ()+ else unless+ (or+ [ not (M.null syncResponseConflicts)+ , not (M.null syncResponseConflictsClientDeleted)+ , not (S.null syncResponseConflictsServerDeleted)+ ]) $+ expectationFailure $+ unlines+ [ "There was a difference between mergeSyncResponseFromServer and mergeSyncResponseIgnoreProblems that was somehow unrelated to the conflicts:"+ , "syncResponseConflicts:"+ , ppShow syncResponseConflicts+ , "syncResponseConflictsClientDeleted:"+ , ppShow syncResponseConflictsClientDeleted+ , "syncResponseConflictsServerDeleted:"+ , ppShow syncResponseConflictsServerDeleted+ , "client store after mergeSyncResponseFromServer:"+ , ppShow cstoreA+ , "client store after mergeSyncResponseIgnoreProblems:"+ , ppShow cstoreB+ ]+ describe "processServerSync with mergeSyncResponseIgnoreProblems" $ do+ it "produces valid tuples of a response and a store" $+ producesValidsOnValids2+ (\store request -> evalD $ processServerSync genD (store :: ServerStore (UUID) Int) request)+ describe "Single client" $ do+ describe "Multi-item" $ do+ it "succesfully downloads everything from the server for an empty client" $+ forAllValid $ \sstore1 ->+ evalDM $ do+ let cstore1 = initialClientStore :: ClientStore (UUID) Int+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- processServerSync genD sstore1 req+ let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp+ lift $ do+ sstore2 `shouldBe` sstore1+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads everything to the server for an empty server" $+ forAllValid $ \items ->+ evalDM $ do+ let cstore1 = initialClientStore {clientStoreAddedItems = items}+ let sstore1 = initialServerStore :: ServerStore (UUID) Int+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- processServerSync genD sstore1 req+ let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp+ lift $ do+ sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2))) `shouldBe`+ sort (M.elems items)+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+ it "is idempotent with one client" $+ forAllValid $ \cstore1 ->+ forAllValid $ \sstore1 ->+ evalDM $ do+ let req1 = makeSyncRequest (cstore1 :: ClientStore (UUID) Int)+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let cstore2 = mergeSyncResponseIgnoreProblems cstore1 resp1+ req2 = makeSyncRequest cstore2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ let cstore3 = mergeSyncResponseIgnoreProblems cstore2 resp2+ lift $ do+ cstore2 `shouldBe` cstore3+ sstore2 `shouldBe` sstore3+ describe "Multiple clients" $ do+ describe "Single-item" $ do+ it "successfully syncs an addition accross to a second client" $+ forAllValid $ \i ->+ evalDM $ do+ let cAstore1 = initialClientStore {clientStoreAddedItems = M.singleton (ClientId 0) i}+ -- Client B is empty+ let cBstore1 = initialClientStore :: ClientStore (UUID) Int+ -- The server is empty+ let sstore1 = initialServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let addedItems = syncResponseClientAdded resp1+ case M.toList addedItems of+ [(ClientId 0, (uuid, st))] -> do+ let time = initialServerTime+ lift $ st `shouldBe` time+ let items = M.singleton uuid (Timed i st)+ lift $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+ lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+ lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ _ -> lift $ expectationFailure "Should have found exactly one added item."+ it "successfully syncs a modification accross to a second client" $+ forAllValid $ \uuid ->+ forAllValid $ \i ->+ forAllValid $ \j ->+ forAllValid $ \time1 ->+ evalDM $ do+ let cAstore1 =+ initialClientStore+ { clientStoreSyncedItems =+ M.singleton (uuid :: UUID) (Timed (i :: Int) time1)+ }+ -- Client B had synced that same item, but has since modified it+ let cBstore1 =+ initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed j time1)}+ -- The server is has the item that both clients had before+ let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+ -- Client B makes sync request 1+ let req1 = makeSyncRequest cBstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let time2 = incrementServerTime time1+ lift $ do+ resp1 `shouldBe`+ emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}+ sstore2 `shouldBe`+ ServerStore {serverStoreItems = M.singleton uuid (Timed j time2)}+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1+ lift $+ cBstore2 `shouldBe`+ initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+ -- Client A makes sync request 2+ let req2 = makeSyncRequest cAstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe`+ emptySyncResponse+ {syncResponseServerChanged = M.singleton uuid (Timed j time2)}+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2+ lift $+ cAstore2 `shouldBe`+ initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs a deletion across to a second client" $+ forAllValid $ \uuid ->+ forAllValid $ \time1 ->+ forAllValid $ \i ->+ evalDM $ do+ let cAstore1 =+ initialClientStore+ { clientStoreSyncedItems =+ M.singleton (uuid :: UUID) (Timed (i :: Int) time1)+ }+ -- Client A has a synced item.+ -- Client B had synced that same item, but has since deleted it.+ let cBstore1 =+ initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+ -- The server still has the undeleted item+ let sstore1 = ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+ -- Client B makes sync request 1+ let req1 = makeSyncRequest cBstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ lift $ do+ resp1 `shouldBe`+ emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}+ sstore2 `shouldBe` initialServerStore+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1+ lift $ cBstore2 `shouldBe` initialClientStore+ -- Client A makes sync request 2+ let req2 = makeSyncRequest cAstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe`+ emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $+ forAllValid $ \uuid ->+ forAllValid $ \time1 ->+ forAllValid $ \i ->+ evalDM $ do+ let cAstore1 =+ initialClientStore+ {clientStoreDeletedItems = M.singleton (uuid :: UUID) time1}+ -- Both client a and client b delete an item.+ let cBstore1 =+ initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+ -- The server still has the undeleted item+ let sstore1 =+ ServerStore {serverStoreItems = M.singleton uuid (Timed (i :: Int) time1)}+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ lift $ do+ resp1 `shouldBe`+ (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe`+ (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+ lift $ do+ cBstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ it "does not lose data after a conflict occurs" $+ forAllValid $ \uuid ->+ forAllValid $ \time1 ->+ forAllValid $ \i1 ->+ forAllValid $ \i2 ->+ forAllValid $ \i3 ->+ evalDM $ do+ let sstore1 =+ ServerStore+ { serverStoreItems =+ M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)+ }+ -- The server has an item+ -- The first client has synced it, and modified it.+ let cAstore1 =+ initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}+ -- The second client has synced it too, and modified it too.+ let cBstore1 =+ initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let time2 = incrementServerTime time1+ -- The server updates the item accordingly+ lift $ do+ resp1 `shouldBe`+ (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+ sstore2 `shouldBe`+ (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+ lift $+ cAstore2 `shouldBe`+ (initialClientStore+ {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ -- The server reports a conflict and does not change its store+ lift $ do+ resp2 `shouldBe`+ (emptySyncResponse+ {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+ -- Client does not update, but keeps its conflict+ lift $ do+ cBstore2 `shouldBe`+ (initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)})+ -- Client A and Client B now *do not* have the same store+ describe "Multiple items" $ do+ it "successfully syncs additions accross to a second client" $+ forAllValid $ \is ->+ evalDM $ do+ let cAstore1 = initialClientStore {clientStoreAddedItems = is}+ -- Client B is empty+ let cBstore1 = initialClientStore :: ClientStore (UUID) Int+ -- The server is empty+ let sstore1 = initialServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let (rest, items) = mergeAddedItems is (syncResponseClientAdded resp1)+ lift $ do+ rest `shouldBe` M.empty+ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+ lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+ lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs deletions across to a second client" $+ forAllValid $ \items ->+ forAllValid $ \time1 ->+ evalDM $ do+ let syncedItems = M.map (\i -> Timed i time1) (items :: Map (UUID) Int)+ itemTimes = M.map (const time1) items+ itemIds = M.keysSet items+ let cAstore1 = initialClientStore {clientStoreSyncedItems = syncedItems}+ -- Client A has synced items+ -- Client B had synced the same items, but has since deleted them.+ let cBstore1 = initialClientStore {clientStoreDeletedItems = itemTimes}+ -- The server still has the undeleted item+ let sstore1 = ServerStore {serverStoreItems = syncedItems}+ -- Client B makes sync request 1+ let req1 = makeSyncRequest cBstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ lift $ do+ resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}+ sstore2 `shouldBe` initialServerStore+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp1+ lift $ cBstore2 `shouldBe` initialClientStore+ -- Client A makes sync request 2+ let req2 = makeSyncRequest cAstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp2+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $+ forAllValid $ \items ->+ forAllValid $ \time1 ->+ evalDM $ do+ let cAstore1 =+ initialClientStore+ {clientStoreDeletedItems = M.map (const time1) (items :: Map (UUID) Int)}+ -- Both client a and client b delete their items.+ let cBstore1 =+ initialClientStore {clientStoreDeletedItems = M.map (const time1) items}+ -- The server still has the undeleted items+ let sstore1 = ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items}+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ lift $ do+ resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})+ sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) -- TODO will probably need some sort of tombstoning.+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseIgnoreProblems cAstore1 resp1+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseIgnoreProblems cBstore1 resp2+ lift $ do+ cBstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ describe "processServerSync with mergeSyncResponseFromServer" $ do+ describe "Multiple clients" $ do+ describe "Single-item" $ do+ it "does not diverge after a conflict occurs" $+ forAllValid $ \uuid ->+ forAllValid $ \time1 ->+ forAllValid $ \i1 ->+ forAllValid $ \i2 ->+ forAllValid $ \i3 ->+ evalDM $ do+ let sstore1 =+ ServerStore+ { serverStoreItems =+ M.singleton (uuid :: UUID) (Timed (i1 :: Int) time1)+ }+ -- The server has an item+ -- The first client has synced it, and modified it.+ let cAstore1 =+ initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)}+ -- The second client has synced it too, and modified it too.+ let cBstore1 =+ initialClientStore+ {clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)}+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- processServerSync genD sstore1 req1+ let time2 = incrementServerTime time1+ -- The server updates the item accordingly+ lift $ do+ resp1 `shouldBe`+ (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+ sstore2 `shouldBe`+ (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponseFromServer cAstore1 resp1+ lift $+ cAstore2 `shouldBe`+ (initialClientStore+ {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- processServerSync genD sstore2 req2+ -- The server reports a conflict and does not change its store+ lift $ do+ resp2 `shouldBe`+ (emptySyncResponse+ {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponseFromServer cBstore1 resp2+ -- Client does not update, but keeps its conflict+ lift $ do+ cBstore2 `shouldBe`+ (initialClientStore+ {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+ -- Client A and Client B now have the same store+ cBstore2 `shouldBe` cAstore2++newtype D m a =+ D+ { unD :: StateT StdGen m a+ }+ deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO)++evalD :: D Identity a -> a+evalD = runIdentity . evalDM++-- runD :: D Identity a -> StdGen -> (a, StdGen)+-- runD = runState . unD+evalDM :: Functor m => D m a -> m a+evalDM d = fst <$> runDM d (mkStdGen 42)++runDM :: D m a -> StdGen -> m (a, StdGen)+runDM = runStateT . unD++genD :: Monad m => D m UUID+genD = do+ r <- get+ let (u, r') = random r+ put r'+ pure u
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}