genvalidity-mergeless 0.2.0.0 → 0.3.0.0
raw patch · 7 files changed
+414/−457 lines, 7 filesdep ~genvalidity
Dependency ranges changed: genvalidity
Files
- ChangeLog.md +4/−2
- README.md +0/−1
- genvalidity-mergeless.cabal +5/−6
- src/Data/GenValidity/Mergeless/Collection.hs +7/−39
- src/Data/GenValidity/Mergeless/Item.hs +0/−8
- test/Data/Mergeless/CollectionSpec.hs +326/−328
- test/Data/Mergeless/ItemSpec.hs +72/−73
ChangeLog.md view
@@ -1,3 +1,5 @@-# Changelog for mergeless+# Changelog -## Unreleased changes+## [0.3.0.0] - 2021-11-21++* Compatibility with `genvalidity >=1.0.0.0`
− README.md
@@ -1,1 +0,0 @@-# mergeless
genvalidity-mergeless.cabal view
@@ -1,23 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 0fb32a64505d66389249b91ab33990a95c7b3f63032e84f0dc094e1439aec358+-- hash: 4b6341c3336455bb2bc44a9830d17efc0c100af6f394586da7a1297a1b9df83f name: genvalidity-mergeless-version: 0.2.0.0+version: 0.3.0.0 description: Please see the README on GitHub at <https://github.com/NorfairKing/mergeless#readme> homepage: https://github.com/NorfairKing/mergeless#readme bug-reports: https://github.com/NorfairKing/mergeless/issues author: Tom Sydney Kerckhove maintainer: syd.kerckhove@gmail.com-copyright: Copyright: (c) 2018-2020 Tom Sydney Kerckhove+copyright: Copyright: (c) 2018-2021 Tom Sydney Kerckhove license: MIT build-type: Simple extra-source-files:- README.md ChangeLog.md source-repository head@@ -37,7 +36,7 @@ QuickCheck , base >=4.7 && <5 , containers- , genvalidity+ , genvalidity >=1.0 , genvalidity-containers , genvalidity-time , mergeless >=0.2.0.0
src/Data/GenValidity/Mergeless/Collection.hs view
@@ -9,23 +9,17 @@ import Data.GenValidity.Containers () import Data.GenValidity.Mergeless.Item () import Data.GenValidity.Time ()-import qualified Data.Map as M import Data.Map (Map)+import qualified Data.Map as M import Data.Mergeless-import qualified Data.Set as S import Data.Set (Set)+import qualified Data.Set as S import Test.QuickCheck -instance GenUnchecked ClientId- instance GenValid ClientId where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) =>- GenUnchecked (ClientStore ci si a)- instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (ClientStore ci si a) where genValid = sized $ \n -> do@@ -37,14 +31,6 @@ pure ClientStore {..} shrinkValid = shrinkValidStructurally -instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, GenInvalid ci, GenInvalid si, GenInvalid a, Ord ci, Ord si, Ord a) =>- GenInvalid (ClientStore ci si a)--instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) =>- GenUnchecked (SyncRequest ci si a)- instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (SyncRequest ci si a) where genValid = sized $ \n -> do@@ -56,25 +42,17 @@ pure SyncRequest {..} shrinkValid = shrinkValidStructurally -instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, GenInvalid ci, GenInvalid si, GenInvalid a, Ord ci, Ord si, Ord a) =>- GenInvalid (SyncRequest ci si a)--instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) =>- GenUnchecked (SyncResponse ci si a)- instance (GenValid ci, GenValid si, GenValid a, Show ci, Show si, Show a, Ord ci, Ord si, Ord a) => GenValid (SyncResponse ci si a) where genValid = do (s1, s2) <- genValid >>= splitSet (s3, s4) <- splitSet s1 (s5, s6) <- splitSet s2 syncResponseClientAdded <-- fmap M.fromList- $ forM (S.toList s3)- $ \i -> do- cid <- genValid -- TODO maybe we can find a way to not generate duplicate client ids and speed up this generator, but it's fine for now.- pure (cid, i)+ fmap M.fromList $+ forM (S.toList s3) $+ \i -> do+ cid <- genValid -- TODO maybe we can find a way to not generate duplicate client ids and speed up this generator, but it's fine for now.+ pure (cid, i) let syncResponseClientDeleted = s4 syncResponseServerAdded <- mapWithIds s5 let syncResponseServerDeleted = s6@@ -92,19 +70,9 @@ mapWithIds :: (Ord i, GenValid a) => Set i -> Gen (Map i a) mapWithIds = traverse id . M.fromSet (const genValid) -instance- (GenUnchecked ci, GenUnchecked si, GenUnchecked a, Show ci, Show si, Show a, GenInvalid ci, GenInvalid si, GenInvalid a, Ord ci, Ord si, Ord a) =>- GenInvalid (SyncResponse ci si a)--instance (GenUnchecked si, GenUnchecked a, Ord si, Ord a) => GenUnchecked (ServerStore si a)- instance (GenValid si, GenValid a, Show si, Show a, Ord si, Ord a) => GenValid (ServerStore si a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering--instance- (GenUnchecked si, GenUnchecked a, Show si, Show a, GenInvalid si, GenInvalid a, Ord si, Ord a) =>- GenInvalid (ServerStore si a) genServerStoreFromSet :: (Ord si, GenValid v) => Set si -> Gen (ServerStore si v) genServerStoreFromSet s = ServerStore <$> mapWithIds s
src/Data/GenValidity/Mergeless/Item.hs view
@@ -8,25 +8,17 @@ import Data.GenValidity.Time () import Data.Mergeless.Item -instance GenUnchecked a => GenUnchecked (ClientItem a)- instance GenValid a => GenValid (ClientItem 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--instance GenUnchecked a => GenUnchecked (ServerItem a) instance GenValid a => GenValid (ServerItem a) where genValid = genValidStructurallyWithoutExtraChecking
test/Data/Mergeless/CollectionSpec.hs view
@@ -12,7 +12,6 @@ import Control.Monad.State import Data.GenValidity.Mergeless.Collection () import Data.GenValidity.UUID ()-import Data.Int (Int) import Data.List import qualified Data.Map.Strict as M import Data.Mergeless.Collection@@ -31,83 +30,83 @@ spec :: Spec spec = do genValidSpec @(ClientStore ClientId Int Int)- jsonSpecOnValid @(ClientStore ClientId Int Int)+ jsonSpec @(ClientStore ClientId Int Int) genValidSpec @(SyncRequest ClientId Int Int)- jsonSpecOnValid @(SyncRequest ClientId Int Int)+ jsonSpec @(SyncRequest ClientId Int Int) genValidSpec @(SyncResponse ClientId Int Int)- jsonSpecOnValid @(SyncResponse ClientId Int Int)+ jsonSpec @(SyncResponse ClientId Int Int) genValidSpec @(ServerStore Int Int)- jsonSpecOnValid @(ServerStore Int Int)+ jsonSpec @(ServerStore Int Int) describe "emptyStore" $ it "is valid" $ shouldBeValid (emptyClientStore @Int @Int @Int) describe "storeSize" $ do- it "does not crash" $ producesValidsOnValids (storeSize @Int @Int @Int)- specify "adding an item makes the store bigger"- $ forAllValid- $ \store ->- forAllValid $ \added -> do- let size1 = storeSize (store :: ClientStore Int Int Int)- let store' = addItemToClientStore added store- let size2 = storeSize store'- size2 `shouldBe` (size1 + 1)- specify "deleting an unsynced item after adding it leaves the store with the original size"- $ forAllValid- $ \store ->- forAllValid $ \added ->- let size1 = storeSize (store :: ClientStore Int Int Int)- store' = addItemToClientStore added store- in case sortOn (Down . fst) $ M.toList (clientStoreAdded store') of- [] -> expectationFailure "Expected a nonempty list"- (i, _) : _ ->- let store'' = deleteUnsyncedFromClientStore i store'- size2 = storeSize store''- in size2 `shouldBe` size1- specify "deleting a synced item after adding it leaves the store with the original size"- $ forAllValid- $ \store ->- forAll (genValid `suchThat` (\uuid -> not $ M.member uuid $ clientStoreSynced store)) $ \uuid ->- forAllValid $ \synced ->+ it "does not crash" $ producesValid (storeSize @Int @Int @Int)+ specify "adding an item makes the store bigger" $+ forAllValid $+ \store ->+ forAllValid $ \added -> do let size1 = storeSize (store :: ClientStore Int Int Int)- store' = store {clientStoreSynced = M.insert uuid synced $ clientStoreSynced store}- store'' = deleteSyncedFromClientStore uuid store'- size2 = storeSize store''- in size2 `shouldBe` size1- describe "addItemToClientStore"- $ it "produces valid stores"- $ producesValidsOnValids2 (addItemToClientStore @Int @Int @Int)- describe "deleteUnsyncedFromClientStore"- $ it "produces valid stores"- $ producesValidsOnValids2 (deleteUnsyncedFromClientStore @Int @Int @Int)- describe "deleteSyncedFromClientStore"- $ it "produces valid stores"- $ producesValidsOnValids2 (deleteSyncedFromClientStore @Int @Int @Int)- describe "emptySyncRequest"- $ it "is valid"- $ shouldBeValid (emptySyncRequest @Int @Int @Int)- describe "makeSyncRequest"- $ it "produces valid sync requests"- $ producesValidsOnValids (makeSyncRequest @Int @Int @Int)+ let store' = addItemToClientStore added store+ let size2 = storeSize store'+ size2 `shouldBe` (size1 + 1)+ specify "deleting an unsynced item after adding it leaves the store with the original size" $+ forAllValid $+ \store ->+ forAllValid $ \added ->+ let size1 = storeSize (store :: ClientStore Int Int Int)+ store' = addItemToClientStore added store+ in case sortOn (Down . fst) $ M.toList (clientStoreAdded store') of+ [] -> expectationFailure "Expected a nonempty list"+ (i, _) : _ ->+ let store'' = deleteUnsyncedFromClientStore i store'+ size2 = storeSize store''+ in size2 `shouldBe` size1+ specify "deleting a synced item after adding it leaves the store with the original size" $+ forAllValid $+ \store ->+ forAll (genValid `suchThat` (\uuid -> not $ M.member uuid $ clientStoreSynced store)) $ \uuid ->+ forAllValid $ \synced ->+ let size1 = storeSize (store :: ClientStore Int Int Int)+ store' = store {clientStoreSynced = M.insert uuid synced $ clientStoreSynced store}+ store'' = deleteSyncedFromClientStore uuid store'+ size2 = storeSize store''+ in size2 `shouldBe` size1+ describe "addItemToClientStore" $+ it "produces valid stores" $+ producesValid2 (addItemToClientStore @Int @Int @Int)+ describe "deleteUnsyncedFromClientStore" $+ it "produces valid stores" $+ producesValid2 (deleteUnsyncedFromClientStore @Int @Int @Int)+ describe "deleteSyncedFromClientStore" $+ it "produces valid stores" $+ producesValid2 (deleteSyncedFromClientStore @Int @Int @Int)+ describe "emptySyncRequest" $+ it "is valid" $+ shouldBeValid (emptySyncRequest @Int @Int @Int)+ describe "makeSyncRequest" $+ it "produces valid sync requests" $+ producesValid (makeSyncRequest @Int @Int @Int) describe "mergeSyncResponse" $ do- it "produces valid sync stores" $ producesValidsOnValids2 (mergeSyncResponse @Int @Int @Int)- it "adds the single item that the server tells it to add to an empty client store"- $ forAllValid- $ \cid ->- forAllValid $ \a ->- forAllValid $ \u -> do- let cstore1 = emptyClientStore {clientStoreAdded = M.singleton (cid :: ClientId) (a :: Int)}- resp = emptySyncResponse {syncResponseClientAdded = M.singleton cid (u :: Int)}- cstore2 = mergeSyncResponse cstore1 resp- clientStoreSynced cstore2 `shouldBe` M.singleton u a- it "deletes items that the server instructed to be deleted"- $ forAllValid- $ \cs ->- forAllValid $ \sr -> do- let cs' = mergeSyncResponse @ClientId @Int @Int cs sr- clientStoreDeleted cs'- `shouldBe` (clientStoreDeleted cs `S.difference` syncResponseClientDeleted sr)- describe "processServerSync"- $ describe "deterministic UUIDs"- $ serverSyncSpec @Int evalDM- $ processServerSync genD+ it "produces valid sync stores" $ producesValid2 (mergeSyncResponse @Int @Int @Int)+ it "adds the single item that the server tells it to add to an empty client store" $+ forAllValid $+ \cid ->+ forAllValid $ \a ->+ forAllValid $ \u -> do+ let cstore1 = emptyClientStore {clientStoreAdded = M.singleton (cid :: ClientId) (a :: Int)}+ resp = emptySyncResponse {syncResponseClientAdded = M.singleton cid (u :: Int)}+ cstore2 = mergeSyncResponse cstore1 resp+ clientStoreSynced cstore2 `shouldBe` M.singleton u a+ it "deletes items that the server instructed to be deleted" $+ forAllValid $+ \cs ->+ forAllValid $ \sr -> do+ let cs' = mergeSyncResponse @ClientId @Int @Int cs sr+ clientStoreDeleted cs'+ `shouldBe` (clientStoreDeleted cs `S.difference` syncResponseClientDeleted sr)+ describe "processServerSync" $+ describe "deterministic UUIDs" $+ serverSyncSpec @Int evalDM $+ processServerSync genD serverSyncSpec :: forall a si m.@@ -118,12 +117,38 @@ serverSyncSpec eval func = do describe "Single client" $ do describe "Single-item" $ do- it "succesfully downloads a single item from the server for an empty client"- $ forAllValid- $ \u ->- forAllValid $ \i ->+ it "succesfully downloads a single item from the server for an empty client" $+ forAllValid $+ \u ->+ forAllValid $ \i ->+ eval $ do+ let sstore1 = emptyServerStore {serverStoreItems = M.singleton u i}+ let cstore1 = emptyClientStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ sstore2 `shouldBe` sstore1+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads a single item to the server for an empty server" $+ forAllValid $+ \c ->+ forAllValid $ \i ->+ eval $ do+ let cstore1 = emptyClientStore {clientStoreAdded = M.singleton c i}+ let sstore1 = emptyServerStore+ let req = makeSyncRequest cstore1+ (resp, sstore2) <- func sstore1 req+ let cstore2 = mergeSyncResponse cstore1 resp+ liftIO $ do+ clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2+ sort (M.elems (clientStoreSynced cstore2))+ `shouldBe` sort (M.elems $ M.singleton c i)+ describe "Multi-item" $ do+ it "succesfully downloads everything from the server for an empty client" $+ forAllValid $+ \sstore1 -> eval $ do- let sstore1 = emptyServerStore {serverStoreItems = M.singleton u i} let cstore1 = emptyClientStore let req = makeSyncRequest cstore1 (resp, sstore2) <- func sstore1 req@@ -131,112 +156,206 @@ liftIO $ do sstore2 `shouldBe` sstore1 clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2- it "succesfully uploads a single item to the server for an empty server"- $ forAllValid- $ \c ->- forAllValid $ \i ->+ it "succesfully uploads everything to the server for an empty server" $+ forAllValid $+ \items -> eval $ do- let cstore1 = emptyClientStore {clientStoreAdded = M.singleton c i}+ let cstore1 = emptyClientStore {clientStoreAdded = items} let sstore1 = emptyServerStore let req = makeSyncRequest cstore1 (resp, sstore2) <- func sstore1 req let cstore2 = mergeSyncResponse cstore1 resp liftIO $ do clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2- sort (M.elems (clientStoreSynced cstore2))- `shouldBe` sort (M.elems $ M.singleton c i)- describe "Multi-item" $ do- it "succesfully downloads everything from the server for an empty client"- $ forAllValid- $ \sstore1 ->- eval $ do- let cstore1 = emptyClientStore- let req = makeSyncRequest cstore1- (resp, sstore2) <- func sstore1 req- let cstore2 = mergeSyncResponse cstore1 resp- liftIO $ do- sstore2 `shouldBe` sstore1- clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2- it "succesfully uploads everything to the server for an empty server"- $ forAllValid- $ \items ->- eval $ do- let cstore1 = emptyClientStore {clientStoreAdded = items}- let sstore1 = emptyServerStore- let req = makeSyncRequest cstore1- (resp, sstore2) <- func sstore1 req- let cstore2 = mergeSyncResponse cstore1 resp- liftIO $ do- clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2- sort (M.elems (clientStoreSynced cstore2)) `shouldBe` sort (M.elems items)- it "is idempotent with one client"- $ forAllValid- $ \cstore1 ->- forAllValid $ \sstore1 ->- eval $ do- let req1 = makeSyncRequest cstore1- (resp1, sstore2) <- func sstore1 req1- let cstore2 = mergeSyncResponse cstore1 resp1- req2 = makeSyncRequest cstore2- (resp2, sstore3) <- func sstore2 req2- let cstore3 = mergeSyncResponse cstore2 resp2- liftIO $ do- cstore2 `shouldBe` cstore3- sstore2 `shouldBe` sstore3+ sort (M.elems (clientStoreSynced cstore2)) `shouldBe` sort (M.elems items)+ it "is idempotent with one client" $+ forAllValid $+ \cstore1 ->+ forAllValid $ \sstore1 ->+ eval $ do+ let req1 = makeSyncRequest cstore1+ (resp1, sstore2) <- func sstore1 req1+ let cstore2 = mergeSyncResponse cstore1 resp1+ req2 = makeSyncRequest cstore2+ (resp2, sstore3) <- func sstore2 req2+ let cstore3 = mergeSyncResponse cstore2 resp2+ liftIO $ 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 ->- eval $ do- let cAstore1 = emptyClientStore {clientStoreAdded = M.singleton (ClientId 0) i}- -- Client B is empty- let cBstore1 = emptyClientStore- -- The server is empty- let sstore1 = emptyServerStore- -- Client A makes sync request 1- let req1 = makeSyncRequest cAstore1- -- The server processes sync request 1- (resp1, sstore2) <- func sstore1 req1- let addedItems = syncResponseClientAdded resp1- case M.toList addedItems of- [(ClientId 0, clientAdditionId)] -> do- let items = M.singleton clientAdditionId i- liftIO $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ it "successfully syncs an addition accross to a second client" $+ forAllValid $+ \i ->+ eval $ do+ let cAstore1 = emptyClientStore {clientStoreAdded = M.singleton (ClientId 0) i}+ -- Client B is empty+ let cBstore1 = emptyClientStore+ -- The server is empty+ let sstore1 = emptyServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ let addedItems = syncResponseClientAdded resp1+ case M.toList addedItems of+ [(ClientId 0, clientAdditionId)] -> do+ let items = M.singleton clientAdditionId i+ liftIO $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- func sstore2 req2+ liftIO $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- pPrint cBstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client A and Client B now have the same store+ liftIO $ cAstore2 `shouldBe` cBstore2+ _ -> liftIO $ expectationFailure "Should have found exactly one added item."+ it "succesfully syncs a deletion across to a second client" $+ forAllValid $+ \uuid ->+ forAllValid $ \i ->+ eval $ do+ let cAstore1 = emptyClientStore {clientStoreSynced = M.singleton uuid i}+ -- Client A has a synced item.+ -- Client B had synced that same item, but has since deleted it.+ let cBstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}+ -- The server still has the undeleted item+ let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i}+ -- Client B makes sync request 1+ let req1 = makeSyncRequest cBstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ liftIO $ do+ resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}+ sstore2 `shouldBe` emptyServerStore+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp1+ liftIO $ cBstore2 `shouldBe` emptyClientStore+ -- Client A makes sync request 2+ let req2 = makeSyncRequest cAstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- func sstore2 req2+ liftIO $ do+ resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}+ sstore3 `shouldBe` sstore2 -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp2+ liftIO $ cAstore2 `shouldBe` emptyClientStore+ -- Client A and Client B now have the same store+ liftIO $ cAstore2 `shouldBe` cBstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $+ forAllValid $+ \uuid ->+ forAllValid $ \i ->+ eval $ do+ let cAstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}+ -- Both client a and client b delete an item.+ let cBstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}+ -- The server still has the undeleted item+ let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i}+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ liftIO $ do+ resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})+ -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp1- liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ liftIO $ cAstore2 `shouldBe` emptyClientStore -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do- resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore3 `shouldBe` sstore2- -- pPrint cBstore2 -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp2- liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})- -- Client A and Client B now have the same store- liftIO $ cAstore2 `shouldBe` cBstore2- _ -> liftIO $ expectationFailure "Should have found exactly one added item."- it "succesfully syncs a deletion across to a second client"- $ forAllValid- $ \uuid ->- forAllValid $ \i ->+ liftIO $ do+ cBstore2 `shouldBe` emptyClientStore+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ describe "Multiple items" $ do+ it+ "makes no change if the sync request reflects the same local state with an empty sync response"+ $ forAllValid $+ \sis -> do+ let cs = ServerStore sis+ (sr, cs') <-+ eval $+ func cs $+ SyncRequest+ { syncRequestAdded = M.empty,+ syncRequestSynced = M.keysSet sis,+ syncRequestDeleted = S.empty+ }+ cs' `shouldBe` cs+ sr+ `shouldBe` SyncResponse+ { syncResponseClientAdded = M.empty,+ syncResponseClientDeleted = S.empty,+ syncResponseServerAdded = M.empty,+ syncResponseServerDeleted = S.empty+ }+ it "successfully syncs additions accross to a second client" $+ forAllValid $+ \is -> eval $ do- let cAstore1 = emptyClientStore {clientStoreSynced = M.singleton uuid i}- -- Client A has a synced item.- -- Client B had synced that same item, but has since deleted it.- let cBstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}+ let cAstore1 = emptyClientStore {clientStoreAdded = is}+ -- Client B is empty+ let cBstore1 = emptyClientStore+ -- The server is empty+ let sstore1 = emptyServerStore+ -- Client A makes sync request 1+ let req1 = makeSyncRequest cAstore1+ -- The server processes sync request 1+ (resp1, sstore2) <- func sstore1 req1+ -- Client A merges the response+ let cAstore2 = mergeSyncResponse cAstore1 resp1+ let items = clientStoreSynced cAstore2+ liftIO $ do+ clientStoreAdded cAstore2 `shouldBe` M.empty+ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client B makes sync request 2+ let req2 = makeSyncRequest cBstore1+ -- The server processes sync request 2+ (resp2, sstore3) <- func sstore2 req2+ liftIO $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ let cBstore2 = mergeSyncResponse cBstore1 resp2+ liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})+ -- Client A and Client B now have the same store+ liftIO $ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs deletions across to a second client" $+ forAllValid $+ \syncedItems ->+ eval $ do+ let itemIds = M.keysSet syncedItems+ let cAstore1 = emptyClientStore {clientStoreSynced = syncedItems}+ -- Client A has synced items+ -- Client B had synced the same items, but has since deleted them.+ let cBstore1 = emptyClientStore {clientStoreDeleted = itemIds} -- The server still has the undeleted item- let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i}+ let sstore1 = ServerStore {serverStoreItems = syncedItems} -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 liftIO $ do- resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}+ resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds} sstore2 `shouldBe` emptyServerStore -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp1@@ -246,31 +365,30 @@ -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do- resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}+ resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds} sstore3 `shouldBe` sstore2 -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp2 liftIO $ cAstore2 `shouldBe` emptyClientStore -- Client A and Client B now have the same store liftIO $ cAstore2 `shouldBe` cBstore2- it "does not run into a conflict if two clients both try to sync a deletion"- $ forAllValid- $ \uuid ->- forAllValid $ \i ->+ it "does not run into a conflict if two clients both try to sync a deletion" $+ forAllValid $+ \items -> eval $ do- let cAstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}- -- Both client a and client b delete an item.- let cBstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid}- -- The server still has the undeleted item- let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i}+ let cAstore1 = emptyClientStore {clientStoreDeleted = M.keysSet items}+ -- Both client a and client b delete their items.+ let cBstore1 = emptyClientStore {clientStoreDeleted = M.keysSet items}+ -- The server still has the undeleted items+ let sstore1 = ServerStore {serverStoreItems = items} -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 liftIO $ do- resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})- sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})- -- Client A merges the response+ 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 = mergeSyncResponse cAstore1 resp1 liftIO $ cAstore2 `shouldBe` emptyClientStore -- Client B makes sync request 2@@ -278,7 +396,7 @@ -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do- resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items}) sstore3 `shouldBe` sstore2 -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp2@@ -286,167 +404,47 @@ cBstore2 `shouldBe` emptyClientStore -- Client A and Client B now have the same store cAstore2 `shouldBe` cBstore2- describe "Multiple items" $ do- it- "makes no change if the sync request reflects the same local state with an empty sync response"- $ forAllValid- $ \sis -> do- let cs = ServerStore sis- (sr, cs') <-- eval- $ func cs- $ SyncRequest- { syncRequestAdded = M.empty,- syncRequestSynced = M.keysSet sis,- syncRequestDeleted = S.empty- }- cs' `shouldBe` cs- sr- `shouldBe` SyncResponse- { syncResponseClientAdded = M.empty,- syncResponseClientDeleted = S.empty,- syncResponseServerAdded = M.empty,- syncResponseServerDeleted = S.empty- }- it "successfully syncs additions accross to a second client"- $ forAllValid- $ \is ->- eval $ do- let cAstore1 = emptyClientStore {clientStoreAdded = is}- -- Client B is empty- let cBstore1 = emptyClientStore- -- The server is empty- let sstore1 = emptyServerStore- -- Client A makes sync request 1- let req1 = makeSyncRequest cAstore1- -- The server processes sync request 1- (resp1, sstore2) <- func sstore1 req1- -- Client A merges the response- let cAstore2 = mergeSyncResponse cAstore1 resp1- let items = clientStoreSynced cAstore2- liftIO $ do- clientStoreAdded cAstore2 `shouldBe` M.empty- sstore2 `shouldBe` (ServerStore {serverStoreItems = items})- liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})- -- Client B makes sync request 2- let req2 = makeSyncRequest cBstore1- -- The server processes sync request 2- (resp2, sstore3) <- func sstore2 req2- liftIO $ do- resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})- sstore3 `shouldBe` sstore2- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp2- liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items})- -- Client A and Client B now have the same store- liftIO $ cAstore2 `shouldBe` cBstore2- it "succesfully syncs deletions across to a second client"- $ forAllValid- $ \syncedItems ->- eval $ do- let itemIds = M.keysSet syncedItems- let cAstore1 = emptyClientStore {clientStoreSynced = syncedItems}- -- Client A has synced items- -- Client B had synced the same items, but has since deleted them.- let cBstore1 = emptyClientStore {clientStoreDeleted = itemIds}- -- 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) <- func sstore1 req1- liftIO $ do- resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}- sstore2 `shouldBe` emptyServerStore- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp1- liftIO $ cBstore2 `shouldBe` emptyClientStore- -- Client A makes sync request 2- let req2 = makeSyncRequest cAstore1- -- The server processes sync request 2- (resp2, sstore3) <- func sstore2 req2- liftIO $ do- resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}- sstore3 `shouldBe` sstore2- -- Client A merges the response- let cAstore2 = mergeSyncResponse cAstore1 resp2- liftIO $ cAstore2 `shouldBe` emptyClientStore- -- Client A and Client B now have the same store- liftIO $ cAstore2 `shouldBe` cBstore2- it "does not run into a conflict if two clients both try to sync a deletion"- $ forAllValid- $ \items ->- eval $ do- let cAstore1 = emptyClientStore {clientStoreDeleted = M.keysSet items}- -- Both client a and client b delete their items.- let cBstore1 = emptyClientStore {clientStoreDeleted = M.keysSet items}- -- The server still has the undeleted items- let sstore1 = ServerStore {serverStoreItems = items}- -- Client A makes sync request 1- let req1 = makeSyncRequest cAstore1- -- The server processes sync request 1- (resp1, sstore2) <- func sstore1 req1- liftIO $ 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 = mergeSyncResponse cAstore1 resp1- liftIO $ cAstore2 `shouldBe` emptyClientStore- -- Client B makes sync request 2- let req2 = makeSyncRequest cBstore1- -- The server processes sync request 2- (resp2, sstore3) <- func sstore2 req2- liftIO $ do- resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})- sstore3 `shouldBe` sstore2- -- Client B merges the response- let cBstore2 = mergeSyncResponse cBstore1 resp2- liftIO $ do- cBstore2 `shouldBe` emptyClientStore- -- Client A and Client B now have the same store- cAstore2 `shouldBe` cBstore2 describe "General properties" $ do- it "produces valid results"- $ forAllValid- $ \cs ->- forAllValid $ \sr -> do- res <- eval $ func cs sr- shouldBeValid res- it "successfully syncs two clients using a central store"- $ forAllValid- $ \store1 ->- eval $ do- let central = ServerStore M.empty- let store2 = emptyClientStore- let sreq1 = makeSyncRequest store1- (sresp1, central') <- func central sreq1- let store1' = mergeSyncResponse store1 sresp1- let sreq2 = makeSyncRequest store2- (sresp2, central'') <- func central' sreq2- let store2' = mergeSyncResponse store2 sresp2- let sreq3 = makeSyncRequest store1'- (sresp3, _) <- func central'' sreq3- let store1'' = mergeSyncResponse store1' sresp3- liftIO $ store1'' `shouldBe` store2'- it "ensures that syncing is idempotent"- $ forAllValid- $ \central1 ->- forAllValid $ \local1 ->+ it "produces valid results" $+ forAllValid $+ \cs ->+ forAllValid $ \sr -> do+ res <- eval $ func cs sr+ shouldBeValid res+ it "successfully syncs two clients using a central store" $+ forAllValid $+ \store1 -> eval $ do- let sreq1 = makeSyncRequest local1- (sresp1, central2) <- func central1 sreq1- let local2 = mergeSyncResponse local1 sresp1- let sreq2 = makeSyncRequest local2- (sresp2, central3) <- func central2 sreq2- let local3 = mergeSyncResponse local2 sresp2- liftIO $ do- local2 `shouldBe` local3- central2 `shouldBe` central3+ let central = ServerStore M.empty+ let store2 = emptyClientStore+ let sreq1 = makeSyncRequest store1+ (sresp1, central') <- func central sreq1+ let store1' = mergeSyncResponse store1 sresp1+ let sreq2 = makeSyncRequest store2+ (sresp2, central'') <- func central' sreq2+ let store2' = mergeSyncResponse store2 sresp2+ let sreq3 = makeSyncRequest store1'+ (sresp3, _) <- func central'' sreq3+ let store1'' = mergeSyncResponse store1' sresp3+ liftIO $ store1'' `shouldBe` store2'+ it "ensures that syncing is idempotent" $+ forAllValid $+ \central1 ->+ forAllValid $ \local1 ->+ eval $ do+ let sreq1 = makeSyncRequest local1+ (sresp1, central2) <- func central1 sreq1+ let local2 = mergeSyncResponse local1 sresp1+ let sreq2 = makeSyncRequest local2+ (sresp2, central3) <- func central2 sreq2+ let local3 = mergeSyncResponse local2 sresp2+ liftIO $ do+ local2 `shouldBe` local3+ central2 `shouldBe` central3 -newtype D m a- = D- { unD :: StateT StdGen m a- }+newtype D m a = D+ { unD :: StateT StdGen m a+ } deriving (Generic, Functor, Applicative, Monad, MonadState StdGen, MonadTrans, MonadIO) evalDM :: Functor m => D m a -> m a
test/Data/Mergeless/ItemSpec.hs view
@@ -7,7 +7,6 @@ import Data.GenValidity.Mergeless.Item () import Data.GenValidity.UUID ()-import Data.Int (Int) import Data.Mergeless.Item import Test.Hspec import Test.Validity@@ -17,27 +16,27 @@ spec :: Spec spec = do- eqSpecOnValid @(ClientItem Int)+ eqSpec @(ClientItem Int) genValidSpec @(ClientItem Int)- jsonSpecOnValid @(ClientItem Int)- eqSpecOnValid @(ItemSyncRequest Int)+ jsonSpec @(ClientItem Int)+ eqSpec @(ItemSyncRequest Int) genValidSpec @(ItemSyncRequest Int)- jsonSpecOnValid @(ItemSyncRequest Int)- eqSpecOnValid @(ItemSyncResponse Int)+ jsonSpec @(ItemSyncRequest Int)+ eqSpec @(ItemSyncResponse Int) genValidSpec @(ItemSyncResponse Int)- jsonSpecOnValid @(ItemSyncResponse Int)- eqSpecOnValid @(ServerItem Int)+ jsonSpec @(ItemSyncResponse Int)+ eqSpec @(ServerItem Int) genValidSpec @(ServerItem Int)- jsonSpecOnValid @(ServerItem Int)- describe "makeItemSyncrequest"- $ it "produces valid requests"- $ producesValidsOnValids (makeItemSyncRequest @Int)- describe "mergeItemSyncResponse"- $ it "produces valid client items"- $ producesValidsOnValids2 (mergeItemSyncResponse @Int)- describe "processItemSync"- $ it "produces valid tuples"- $ producesValidsOnValids2 (processServerItemSync @Int)+ jsonSpec @(ServerItem Int)+ describe "makeItemSyncrequest" $+ it "produces valid requests" $+ producesValid (makeItemSyncRequest @Int)+ describe "mergeItemSyncResponse" $+ it "produces valid client items" $+ producesValid2 (mergeItemSyncResponse @Int)+ describe "processItemSync" $+ it "produces valid tuples" $+ producesValid2 (processServerItemSync @Int) describe "processItemSync" $ do describe "Interaction" $ do it "makes no changes if the sync request reflects the state of the empty server" $ do@@ -46,40 +45,40 @@ 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- $ \s -> do- let store1 = ServerItemFull s- req = ItemSyncRequestKnown- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseInSyncFull+ it "makes no changes if the sync request reflects the state of the full server" $+ forAllValid $+ \s -> do+ let store1 = ServerItemFull s+ req = ItemSyncRequestKnown+ 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- $ \a -> do- let store1 = ServerItemEmpty- req = ItemSyncRequestNew a- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` ServerItemFull a- resp `shouldBe` ItemSyncResponseClientAdded- it "deletes the item that the client tells the server to delete"- $ forAllValid- $ \s -> do- let store1 = ServerItemFull s- req = ItemSyncRequestDeleted- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` ServerItemEmpty- resp `shouldBe` ItemSyncResponseClientDeleted+ it "adds the item that the client tells the server to add" $+ forAllValid $+ \a -> do+ let store1 = ServerItemEmpty+ req = ItemSyncRequestNew a+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` ServerItemFull a+ resp `shouldBe` ItemSyncResponseClientAdded+ it "deletes the item that the client tells the server to delete" $+ forAllValid $+ \s -> do+ let store1 = ServerItemFull s+ req = ItemSyncRequestDeleted+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` ServerItemEmpty+ resp `shouldBe` ItemSyncResponseClientDeleted describe "Server changes" $ do- it "tells the client that there is a new item at the server side"- $ forAllValid- $ \s -> do- let store1 = ServerItemFull s- req = ItemSyncRequestPoll- let (resp, store2) = processServerItemSync @Int store1 req- store2 `shouldBe` store1- resp `shouldBe` ItemSyncResponseServerAdded s+ it "tells the client that there is a new item at the server side" $+ forAllValid $+ \s -> do+ let store1 = ServerItemFull s+ req = ItemSyncRequestPoll+ let (resp, store2) = processServerItemSync @Int store1 req+ store2 `shouldBe` store1+ resp `shouldBe` ItemSyncResponseServerAdded s it "tells the client that there is a deleted item at the server side" $ do let store1 = ServerItemEmpty req = ItemSyncRequestKnown@@ -87,26 +86,26 @@ store2 `shouldBe` store1 resp `shouldBe` ItemSyncResponseServerDeleted describe "High level properties" $ do- it "it always possible to add an item from scratch"- $ forAllValid- $ \a -> do- let cstore1 = ClientAdded (a :: Int)- let sstore1 = ServerItemEmpty- let req1 = makeItemSyncRequest cstore1- (resp1, sstore2) = processServerItemSync sstore1 req1- cstore2 = mergeItemSyncResponse cstore1 resp1- resp1 `shouldBe` ItemSyncResponseClientAdded- sstore2 `shouldBe` ServerItemFull a- cstore2 `shouldBe` ClientSynced a- it "is idempotent with one client"- $ forAllValid- $ \si1 ->- forAllValid $ \ci1 -> do- let req1 = makeItemSyncRequest @Int ci1- (resp1, si2) = processServerItemSync si1 req1- ci2 = mergeItemSyncResponse ci1 resp1- req2 = makeItemSyncRequest ci2- (resp2, si3) = processServerItemSync si2 req2- ci3 = mergeItemSyncResponse ci2 resp2- ci3 `shouldBe` ci2- si3 `shouldBe` si2+ it "it always possible to add an item from scratch" $+ forAllValid $+ \a -> do+ let cstore1 = ClientAdded (a :: Int)+ let sstore1 = ServerItemEmpty+ let req1 = makeItemSyncRequest cstore1+ (resp1, sstore2) = processServerItemSync sstore1 req1+ cstore2 = mergeItemSyncResponse cstore1 resp1+ resp1 `shouldBe` ItemSyncResponseClientAdded+ sstore2 `shouldBe` ServerItemFull a+ cstore2 `shouldBe` ClientSynced a+ it "is idempotent with one client" $+ forAllValid $+ \si1 ->+ forAllValid $ \ci1 -> do+ let req1 = makeItemSyncRequest @Int ci1+ (resp1, si2) = processServerItemSync si1 req1+ ci2 = mergeItemSyncResponse ci1 resp1+ req2 = makeItemSyncRequest ci2+ (resp2, si3) = processServerItemSync si2 req2+ ci3 = mergeItemSyncResponse ci2 resp2+ ci3 `shouldBe` ci2+ si3 `shouldBe` si2