diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for mergeful + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# mergeful diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/genvalidity-mergeful.cabal b/genvalidity-mergeful.cabal new file mode 100644 --- /dev/null +++ b/genvalidity-mergeful.cabal @@ -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 +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 diff --git a/src/Data/GenValidity/Mergeful.hs b/src/Data/GenValidity/Mergeful.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeful.hs @@ -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 diff --git a/src/Data/GenValidity/Mergeful/Item.hs b/src/Data/GenValidity/Mergeful/Item.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeful/Item.hs @@ -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 diff --git a/src/Data/GenValidity/Mergeful/Timed.hs b/src/Data/GenValidity/Mergeful/Timed.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeful/Timed.hs @@ -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 diff --git a/src/Data/GenValidity/Mergeful/Value.hs b/src/Data/GenValidity/Mergeful/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeful/Value.hs @@ -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 diff --git a/test/Data/Mergeful/ItemSpec.hs b/test/Data/Mergeful/ItemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeful/ItemSpec.hs @@ -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 diff --git a/test/Data/Mergeful/TimedSpec.hs b/test/Data/Mergeful/TimedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeful/TimedSpec.hs @@ -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 diff --git a/test/Data/Mergeful/ValueSpec.hs b/test/Data/Mergeful/ValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeful/ValueSpec.hs @@ -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 diff --git a/test/Data/MergefulSpec.hs b/test/Data/MergefulSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MergefulSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}