diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Criterion.Main as Criterion + +import Data.GenValidity.Criterion +import Data.GenValidity.Mergeless () + +import Data.Mergeless.Collection +import Data.Mergeless.Item + +main :: IO () +main = + Criterion.defaultMain + [ bgroup + "Utils" + [ genValidBench @(Added Bool) + , genValidBench @(Synced Bool) + , genValidBench @(ClientAddition Int) + ] + , bgroup + "Item" + [ genValidBench @(ClientItem Bool) + , genValidBench @(ItemSyncRequest Bool) + , genValidBench @(ItemSyncResponse Bool) + , genValidBench @(ServerItem Bool) + ] + , bgroup + "Collection" + [ genValidBench @ClientId + , genValidBench @(ClientStore Int Bool) + , genValidBench @(SyncRequest Int Bool) + , genValidBench @(ClientAddition Int) + , genValidBench @(SyncResponse Int Bool) + , genValidBench @(ServerStore Int Bool) + ] + ] diff --git a/genvalidity-mergeless.cabal b/genvalidity-mergeless.cabal --- a/genvalidity-mergeless.cabal +++ b/genvalidity-mergeless.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 6e70257c58f9b084549d6af348ed63f6b22a88fc476bc7ccf0ccc1aa729f5891 +-- hash: 13b8526e5aa6ded49e51ebf12a1008ee6f2e8f428b081a7766bfc17ddeef7848 name: genvalidity-mergeless -version: 0.0.0.0 +version: 0.1.0.0 description: Please see the README on GitHub at homepage: https://github.com/NorfairKing/mergeless#readme bug-reports: https://github.com/NorfairKing/mergeless/issues @@ -14,10 +16,9 @@ copyright: Copyright: (c) 2018 Tom Sydney Kerckhove license: MIT build-type: Simple -cabal-version: >= 1.10 extra-source-files: - ChangeLog.md README.md + ChangeLog.md source-repository head type: git @@ -26,6 +27,8 @@ library exposed-modules: Data.GenValidity.Mergeless + Data.GenValidity.Mergeless.Collection + Data.GenValidity.Mergeless.Item other-modules: Paths_genvalidity_mergeless hs-source-dirs: @@ -33,17 +36,19 @@ build-depends: QuickCheck , base >=4.7 && <5 + , containers , genvalidity , genvalidity-containers , genvalidity-time - , mergeless + , mergeless >=0.2.0.0 default-language: Haskell2010 -test-suite genvalidity-mergeless-test +test-suite mergeless-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Data.MergelessSpec + Data.Mergeless.CollectionSpec + Data.Mergeless.ItemSpec Paths_genvalidity_mergeless hs-source-dirs: test @@ -55,12 +60,28 @@ , genvalidity-hspec , genvalidity-hspec-aeson , genvalidity-mergeless - , genvalidity-typed-uuid + , genvalidity-uuid , hspec , mergeless , mtl + , pretty-show , random , time - , typed-uuid , uuid + default-language: Haskell2010 + +benchmark genvalidity-mergeless-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_genvalidity_mergeless + hs-source-dirs: + bench + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , criterion + , genvalidity-criterion + , genvalidity-mergeless + , mergeless default-language: Haskell2010 diff --git a/src/Data/GenValidity/Mergeless.hs b/src/Data/GenValidity/Mergeless.hs --- a/src/Data/GenValidity/Mergeless.hs +++ b/src/Data/GenValidity/Mergeless.hs @@ -1,82 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.GenValidity.Mergeless where - -import Test.QuickCheck - -import Data.GenValidity -import Data.GenValidity.Containers () -import Data.GenValidity.Time () - -import Data.Mergeless - -instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) => - GenUnchecked (Store i a) - -instance (GenValid i, GenValid a, Ord i, Ord a) => GenValid (Store i a) where - genValid = (Store <$> genValid) `suchThat` isValid - -instance (GenInvalid i, GenInvalid a, Ord i, Ord a) => - GenInvalid (Store i a) - -instance (GenUnchecked i, GenUnchecked a) => GenUnchecked (StoreItem i a) - -instance (GenValid i, GenValid a) => GenValid (StoreItem i a) - -instance (GenInvalid i, GenInvalid a) => GenInvalid (StoreItem i a) - -instance GenUnchecked a => GenUnchecked (Added a) - -instance GenValid a => GenValid (Added a) where - genValid = (Added <$> genValid <*> genValid) `suchThat` isValid - -instance GenInvalid a => GenInvalid (Added a) - -instance (GenUnchecked i, GenUnchecked a) => GenUnchecked (Synced i a) - -instance (GenValid i, GenValid a) => GenValid (Synced i a) where - genValid = - (Synced <$> genValid <*> genValid <*> genValid <*> genValid) `suchThat` - isValid - -instance (GenInvalid i, GenInvalid a) => GenInvalid (Synced i a) - -instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) => - GenUnchecked (SyncRequest i a) - -instance (GenValid i, GenValid a, Ord i, Ord a) => - GenValid (SyncRequest i a) where - genValid = - (SyncRequest <$> genValid <*> genValid <*> genValid) `suchThat` isValid - -instance (GenInvalid i, GenInvalid a, Ord i, Ord a) => - GenInvalid (SyncRequest i a) - -instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) => - GenUnchecked (SyncResponse i a) - -instance (GenValid i, GenValid a, Ord i, Ord a) => - GenValid (SyncResponse i a) where - genValid = - (SyncResponse <$> genValid <*> genValid <*> genValid) `suchThat` isValid - -instance (GenInvalid i, GenInvalid a, Ord i, Ord a) => - GenInvalid (SyncResponse i a) - -instance GenUnchecked a => GenUnchecked (CentralItem a) - -instance GenValid a => GenValid (CentralItem a) where - genValid = - (CentralItem <$> genValid <*> genValid <*> genValid) `suchThat` isValid - -instance GenInvalid a => GenInvalid (CentralItem a) - -instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) => - GenUnchecked (CentralStore i a) - -instance (GenValid i, GenValid a, Ord i, Ord a) => - GenValid (CentralStore i a) where - genValid = (CentralStore <$> genValid) `suchThat` isValid +module Data.GenValidity.Mergeless + ( module Data.GenValidity.Mergeless.Collection + ) where -instance (GenInvalid i, GenInvalid a, Ord i, Ord a) => - GenInvalid (CentralStore i a) +import Data.GenValidity.Mergeless.Collection diff --git a/src/Data/GenValidity/Mergeless/Collection.hs b/src/Data/GenValidity/Mergeless/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeless/Collection.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.GenValidity.Mergeless.Collection where + +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) + +import Control.Monad + +import Data.GenValidity +import Data.GenValidity.Containers () +import Data.GenValidity.Time () +import Test.QuickCheck + +import Data.GenValidity.Mergeless.Item () +import Data.Mergeless + +instance GenUnchecked ClientId + +instance GenValid ClientId where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => + GenUnchecked (ClientStore i a) + +instance (GenValid i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (ClientStore i a) where + genValid = + sized $ \n -> do + (a, b, c) <- genSplit3 n + (s1, s2) <- resize (a + b) (genValid >>= splitSet) + clientStoreAdded <- resize c genValid + clientStoreSynced <- mapWithIds s1 + let clientStoreDeleted = s2 + pure ClientStore {..} + shrinkValid = shrinkValidStructurally + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, GenInvalid i, GenInvalid a, Ord i, Ord a) => + GenInvalid (ClientStore i a) + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => + GenUnchecked (SyncRequest i a) + +instance (GenValid i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (SyncRequest i a) where + genValid = + sized $ \n -> do + (a, b, c) <- genSplit3 n + (s1, s2) <- resize (a + b) (genValid >>= splitSet) + syncRequestAdded <- resize c genValid + let syncRequestSynced = s1 + let syncRequestDeleted = s2 + pure SyncRequest {..} + shrinkValid = shrinkValidStructurally + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, GenInvalid i, GenInvalid a, Ord i, Ord a) => + GenInvalid (SyncRequest i a) + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => + GenUnchecked (SyncResponse i a) + +instance (GenValid i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (SyncResponse i 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) + let syncResponseClientDeleted = s4 + syncResponseServerAdded <- mapWithIds s5 + let syncResponseServerDeleted = s6 + 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 $ forM (S.toList s) $ \i -> (,) i <$> genValid + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, GenInvalid i, GenInvalid a, Ord i, Ord a) => + GenInvalid (SyncResponse i a) + +instance (GenUnchecked i, GenUnchecked a, Ord i, Ord a) => GenUnchecked (ServerStore i a) + +instance (GenValid i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (ServerStore i a) where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + +instance (GenUnchecked i, GenUnchecked a, Show i, Show a, GenInvalid i, GenInvalid a, Ord i, Ord a) => + GenInvalid (ServerStore i a) + +genUnsyncedStore :: + forall i a. (Ord i, Ord a, GenValid i, GenValid a) + => Gen (ClientStore i a) +genUnsyncedStore = do + as <- genValid + pure $ emptyClientStore {clientStoreAdded = as} diff --git a/src/Data/GenValidity/Mergeless/Item.hs b/src/Data/GenValidity/Mergeless/Item.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Mergeless/Item.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.GenValidity.Mergeless.Item where + +import Data.GenValidity +import Data.GenValidity.Containers () +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 + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering diff --git a/test/Data/Mergeless/CollectionSpec.hs b/test/Data/Mergeless/CollectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeless/CollectionSpec.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Mergeless.CollectionSpec + ( spec + ) where + +import Data.Int (Int) +import Data.List +import qualified Data.Map.Strict as M +import Data.Ord +import qualified Data.Set as S +import GHC.Generics (Generic) +import System.Random + +import Control.Monad.State + +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Test.Validity.Aeson + +import Data.GenValidity.Mergeless.Collection () +import Data.GenValidity.UUID () +import Data.Mergeless.Collection +import Data.UUID + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +spec :: Spec +spec = do + genValidSpec @(ClientStore Int Int) + jsonSpecOnValid @(ClientStore Int Int) + genValidSpec @(SyncRequest Int Int) + jsonSpecOnValid @(SyncRequest Int Int) + genValidSpec @(SyncResponse Int Int) + jsonSpecOnValid @(SyncResponse Int Int) + genValidSpec @(ServerStore Int Int) + jsonSpecOnValid @(ServerStore Int Int) + describe "emptyStore" $ it "is valid" $ shouldBeValid (emptyClientStore @Int @Int) + describe "storeSize" $ do + it "does not crash" $ producesValidsOnValids (storeSize @Int @Int) + specify "adding an item makes the store bigger" $ + forAllValid $ \store -> + forAllValid $ \added -> do + let size1 = storeSize (store :: ClientStore 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) + 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) + 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) + describe "deleteUnsyncedFromClientStore" $ + it "produces valid stores" $ producesValidsOnValids2 (deleteUnsyncedFromClientStore @Int @Int) + describe "deleteSyncedFromClientStore" $ + it "produces valid stores" $ producesValidsOnValids2 (deleteSyncedFromClientStore @Int @Int) + describe "makeSyncRequest" $ + it "produces valid sync requests" $ producesValidsOnValids (makeSyncRequest @Int @Int) + describe "mergeSyncResponse" $ do + it "produces valid sync stores" $ producesValidsOnValids2 (mergeSyncResponse @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 (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 @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 i m. (Show i, Ord i, GenValid i, Show a, Ord a, GenValid a, MonadIO m) + => (forall r. m r -> IO r) + -> (ServerStore i a -> SyncRequest i a -> m (SyncResponse i a, ServerStore i a)) + -> Spec +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 -> + 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 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 + 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}) + -- 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 + -- 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 = S.singleton uuid}) + 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 "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 -> + 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 + } + 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/Data/Mergeless/ItemSpec.hs b/test/Data/Mergeless/ItemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeless/ItemSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.Mergeless.ItemSpec + ( spec + ) where + +import Data.Int (Int) + +import Test.Hspec +import Test.Validity +import Test.Validity.Aeson + +import Data.GenValidity.Mergeless.Item () +import Data.GenValidity.UUID () +import Data.Mergeless.Item + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +spec :: Spec +spec = do + eqSpecOnValid @(ClientItem Int) + genValidSpec @(ClientItem Int) + jsonSpecOnValid @(ClientItem Int) + eqSpecOnValid @(ItemSyncRequest Int) + genValidSpec @(ItemSyncRequest Int) + jsonSpecOnValid @(ItemSyncRequest Int) + eqSpecOnValid @(ItemSyncResponse Int) + genValidSpec @(ItemSyncResponse Int) + jsonSpecOnValid @(ItemSyncResponse Int) + eqSpecOnValid @(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) + describe "processItemSync" $ do + describe "Interaction" $ do + it "makes no changes if the sync request reflects the state of the empty server" $ do + let store1 = ServerItemEmpty + 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 $ \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 + 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 deleted item at the server side" $ do + let store1 = ServerItemEmpty + req = ItemSyncRequestKnown + let (resp, store2) = processServerItemSync @Int store1 req + 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 diff --git a/test/Data/MergelessSpec.hs b/test/Data/MergelessSpec.hs deleted file mode 100644 --- a/test/Data/MergelessSpec.hs +++ /dev/null @@ -1,471 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.MergelessSpec - ( spec - ) where - -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Time -import qualified Data.UUID.Typed as Typed -import GHC.Generics (Generic) -import System.Random - -import Control.Monad.State - -import Test.Hspec -import Test.QuickCheck -import Test.Validity -import Test.Validity.Aeson - -import Data.GenValidity.Mergeless () -import Data.GenValidity.UUID.Typed () -import Data.Mergeless -import Data.UUID.Typed - -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} - -spec :: Spec -spec = do - eqSpecOnValid @(Store Double Double) - ordSpecOnValid @(Store Double Double) - genValiditySpec @(Store Double Double) - jsonSpecOnValid @(Store Double Double) - eqSpecOnValid @(StoreItem Double Double) - ordSpecOnValid @(StoreItem Double Double) - genValiditySpec @(StoreItem Double Double) - jsonSpecOnValid @(StoreItem Double Double) - eqSpecOnValid @(Added Double) - ordSpecOnValid @(Added Double) - genValiditySpec @(Added Double) - jsonSpecOnValid @(Added Double) - eqSpecOnValid @(Synced Double Double) - ordSpecOnValid @(Synced Double Double) - genValiditySpec @(Synced Double Double) - jsonSpecOnValid @(Synced Double Double) - eqSpecOnValid @(SyncRequest Double Double) - ordSpecOnValid @(SyncRequest Double Double) - genValiditySpec @(SyncRequest Double Double) - jsonSpecOnValid @(SyncRequest Double Double) - eqSpecOnValid @(SyncResponse Double Double) - ordSpecOnValid @(SyncResponse Double Double) - genValiditySpec @(SyncResponse Double Double) - jsonSpecOnValid @(SyncResponse Double Double) - eqSpecOnValid @(CentralItem Double) - ordSpecOnValid @(CentralItem Double) - genValiditySpec @(CentralItem Double) - jsonSpecOnValid @(CentralItem Double) - eqSpecOnValid @(CentralStore Double Double) - ordSpecOnValid @(CentralStore Double Double) - genValiditySpec @(CentralStore Double Double) - jsonSpecOnValid @(CentralStore Double Double) - describe "makeSyncRequest" $ - it "produces valid sync requests" $ - producesValidsOnValids (makeSyncRequest @Double @Double) - describe "mergeSyncResponse" $ - it "produces valid sync stores" $ - producesValidsOnValids2 (mergeSyncResponse @Double @Double) - describe "processSyncWith" $ do - it - "makes no change if the sync request reflects the same local state with an empty sync response" $ - forAllValid $ \synct -> - forAllValid $ \sis -> do - let cs = CentralStore sis - let (sr, cs') = - evalD $ - processSyncWith @(UUID Double) @Double genD synct cs $ - SyncRequest S.empty (M.keysSet sis) S.empty - cs' `shouldBe` cs - sr `shouldBe` SyncResponse S.empty S.empty S.empty - it "deletes the deleted items" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sreq -> do - let (_, cs') = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - sreq - syncRequestUndeletedItems sreq `shouldSatisfy` - (not . - any - (`S.member` (M.keysSet $ centralStoreItems cs'))) - it "returns the items that were added in the sync response" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sreq -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - sreq - S.map syncedValue (syncResponseAddedItems sresp) `shouldBe` - S.map addedValue (syncRequestAddedItems sreq) - it "returns the single added item" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \ai -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - SyncRequest - { syncRequestAddedItems = S.singleton ai - , syncRequestSyncedItems = S.empty - , syncRequestUndeletedItems = S.empty - } - S.map syncedValue (syncResponseAddedItems sresp) `shouldBe` - S.singleton (addedValue ai) - it "adds the items that were added" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sreq -> do - let (_, cs') = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - sreq - S.map addedValue (syncRequestAddedItems sreq) `shouldSatisfy` - all - (`elem` (M.elems $ - M.map centralValue $ - centralStoreItems cs')) - it - "returns the single remotely added item if the sync request is empty and the central store has one item" $ - forAllValid $ \synct -> - forAllValid $ \(uuid, ci) -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - (CentralStore $ M.singleton uuid ci) - SyncRequest - { syncRequestAddedItems = S.empty - , syncRequestSyncedItems = S.empty - , syncRequestUndeletedItems = S.empty - } - S.map syncedValue (syncResponseNewRemoteItems sresp) `shouldBe` - S.singleton (centralValue ci) - it - "returns all remotely added items when no items are locally added or deleted" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sis -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - SyncRequest - { syncRequestAddedItems = S.empty - , syncRequestSyncedItems = sis - , syncRequestUndeletedItems = S.empty - } - S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe` - S.difference (M.keysSet $ centralStoreItems cs) sis - it "returns all remotely added items when no items are locally deleted " $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sis -> - forAllValid $ \ais -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - SyncRequest - { syncRequestAddedItems = ais - , syncRequestSyncedItems = sis - , syncRequestUndeletedItems = S.empty - } - S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe` - S.difference - (M.keysSet $ centralStoreItems cs) - sis - it - "returns all remotely added items that weren't deleted when no items are locally added " $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sis -> - forAllValid $ \dis -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - SyncRequest - { syncRequestAddedItems = S.empty - , syncRequestSyncedItems = sis - , syncRequestUndeletedItems = dis - } - S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe` - S.difference - (S.difference - (M.keysSet $ centralStoreItems cs) - dis) - sis - it "returns all remotely added items that weren't deleted" $ - forAllValid $ \synct -> - forAllValid $ \cs -> - forAllValid $ \sreq -> do - let (sresp, _) = - evalD $ - processSyncWith - @(UUID Double) - @Double - genD - synct - cs - sreq - S.map syncedUuid (syncResponseNewRemoteItems sresp) `shouldBe` - S.difference - (S.difference - (M.keysSet $ centralStoreItems cs) - (syncRequestUndeletedItems sreq)) - (syncRequestSyncedItems sreq) - it - "successfully syncs two clients using a central store when using incrementing words" $ - forAllValid $ \store1 -> - forAllValid $ \(synct1, synct2, synct3) -> do - let (s1, s2) = - evalI $ do - let central = CentralStore M.empty - let store2 = Store S.empty - let sreq1 = makeSyncRequest @Word @Double store1 - (sresp1, central') <- - processSyncWith genI synct1 central sreq1 - let store1' = mergeSyncResponse store1 sresp1 - let sreq2 = makeSyncRequest store2 - (sresp2, central'') <- - processSyncWith genI synct2 central' sreq2 - let store2' = mergeSyncResponse store2 sresp2 - let sreq3 = makeSyncRequest store1' - (sresp3, _) <- - processSyncWith genI synct3 central'' sreq3 - let store1'' = mergeSyncResponse store1' sresp3 - pure (store1'', store2') - s1 `shouldBe` s2 - it - "successfully syncs two clients using a central store when using deterministic UUIDs" $ - forAllValid $ \store1 -> - forAllValid $ \(synct1, synct2, synct3) -> do - let (s1, s2) = - evalD $ do - let central = CentralStore M.empty - let store2 = Store S.empty - let sreq1 = - makeSyncRequest - @(UUID Double) - @Double - store1 - (sresp1, central') <- - processSyncWith genD synct1 central sreq1 - let store1' = mergeSyncResponse store1 sresp1 - let sreq2 = makeSyncRequest store2 - (sresp2, central'') <- - processSyncWith genD synct2 central' sreq2 - let store2' = mergeSyncResponse store2 sresp2 - let sreq3 = makeSyncRequest store1' - (sresp3, _) <- - processSyncWith genD synct3 central'' sreq3 - let store1'' = mergeSyncResponse store1' sresp3 - pure (store1'', store2') - s1 `shouldBe` s2 - it - "produces valid results when building up a central store from nothing using incrementing words" $ - forAllValid $ \tups -> - shouldBeValid $ - evalI $ do - let initCentralStore = CentralStore M.empty - let go cs (store, synct) = do - let sreq = makeSyncRequest @Word @Double store - (_, central') <- processSyncWith genI synct cs sreq - pure central' - foldM - go - initCentralStore - (tups :: [(Store Word Double, UTCTime)]) - it - "produces valid results when building up a central store from nothing using deterministic UUIDs" $ - forAllValid $ \tups -> - shouldBeValid $ - evalD $ do - let initCentralStore = CentralStore M.empty - let go cs (store, synct) = do - let sreq = - makeSyncRequest @(UUID Double) @Double store - (_, central') <- processSyncWith genD synct cs sreq - pure central' - foldM - go - initCentralStore - (tups :: [(Store (UUID Double) Double, UTCTime)]) - -- This property does not hold. - xit "produces valid results when using incrementing words" $ - producesValidsOnValids3 $ \synct cs sr -> - evalI $ processSyncWith @Word @Double genI synct cs sr - it "produces valid results when using determinisitic UUIDs" $ - producesValidsOnValids3 $ \synct cs sr -> - evalD $ processSyncWith @(UUID Double) @Double genD synct cs sr - it "makes syncing idempotent with incrementing words" $ - forAllValid $ \synct1 -> - forAll (genValid `suchThat` (>= synct1)) $ \synct2 -> - forAllValid $ \central1 -> - forAllValid $ \local1 -> do - let d1 = 0 - let sreq1 = makeSyncRequest @Word @Double local1 - let ((sresp1, central2), d2) = - runI - (processSyncWith - genI - synct1 - central1 - sreq1) - d1 - let local2 = mergeSyncResponse local1 sresp1 - let sreq2 = makeSyncRequest local2 - let ((sresp2, central3), _) = - runI - (processSyncWith - genI - synct2 - central2 - sreq2) - d2 - let local3 = mergeSyncResponse local2 sresp2 - local2 `shouldBe` local3 - central2 `shouldBe` central3 - it "makes syncing idempotent with deterministic UUIDs" $ - forAllValid $ \synct1 -> - forAll (genValid `suchThat` (>= synct1)) $ \synct2 -> - forAllValid $ \central1 -> - forAllValid $ \local1 -> do - let d1 = mkStdGen 42 - let sreq1 = - makeSyncRequest - @(UUID Double) - @Double - local1 - let ((sresp1, central2), d2) = - runD - (processSyncWith - genD - synct1 - central1 - sreq1) - d1 - let local2 = mergeSyncResponse local1 sresp1 - let sreq2 = makeSyncRequest local2 - let ((sresp2, central3), _) = - runD - (processSyncWith - genD - synct2 - central2 - sreq2) - d2 - let local3 = mergeSyncResponse local2 sresp2 - local2 `shouldBe` local3 - central2 `shouldBe` central3 - it "makes syncing idempotent with random UUIDs" $ - forAllValid $ \synct1 -> - forAll (genValid `suchThat` (>= synct1)) $ \synct2 -> - forAllValid $ \central1 -> - forAllValid $ \local1 -> do - let sreq1 = - makeSyncRequest - @(UUID Double) - @Double - local1 - (sresp1, central2) <- - processSyncWith - nextRandomUUID - synct1 - central1 - sreq1 - let local2 = mergeSyncResponse local1 sresp1 - let sreq2 = makeSyncRequest local2 - (sresp2, central3) <- - processSyncWith - nextRandomUUID - synct2 - central2 - sreq2 - let local3 = mergeSyncResponse local2 sresp2 - local2 `shouldBe` local3 - central2 `shouldBe` central3 - describe "processSync" $ - it "makes syncing idempotent when using random UUIDs" $ - forAllValid $ \central1 -> - forAllValid $ \local1 -> do - let sreq1 = makeSyncRequest @(UUID Double) @Double local1 - (sresp1, central2) <- processSync nextRandomUUID central1 sreq1 - let local2 = mergeSyncResponse local1 sresp1 - let sreq2 = makeSyncRequest local2 - (sresp2, central3) <- processSync nextRandomUUID central2 sreq2 - let local3 = mergeSyncResponse local2 sresp2 - local2 `shouldBe` local3 - central2 `shouldBe` central3 - -newtype D a = D - { unD :: State StdGen a - } deriving (Generic, Functor, Applicative, Monad, MonadState StdGen) - -evalD :: D a -> a -evalD d = fst $ runD d $ mkStdGen 42 - -runD :: D a -> StdGen -> (a, StdGen) -runD = runState . unD - -genD :: D (Typed.UUID a) -genD = do - r <- get - let (u, r') = random r - put r' - pure u - -newtype I a = I - { unI :: State Word a - } deriving (Generic, Functor, Applicative, Monad, MonadState Word) - -evalI :: I a -> a -evalI i = fst $ runI i 0 - -runI :: I a -> Word -> (a, Word) -runI = runState . unI - -genI :: I Word -genI = do - i <- get - modify succ - pure i