diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,14 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Main where import Criterion.Main as Criterion - import Data.GenValidity.Criterion import Data.GenValidity.Mergeless () - import Data.Mergeless.Collection import Data.Mergeless.Item @@ -16,25 +14,18 @@ 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 + [ 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) + [ genValidBench @ClientId, + genValidBench @(ClientStore ClientId Int Bool), + genValidBench @(SyncRequest ClientId Int Bool), + genValidBench @(SyncResponse ClientId Int Bool), + genValidBench @(ServerStore Int Bool) ] ] diff --git a/genvalidity-mergeless.cabal b/genvalidity-mergeless.cabal --- a/genvalidity-mergeless.cabal +++ b/genvalidity-mergeless.cabal @@ -4,16 +4,16 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 13b8526e5aa6ded49e51ebf12a1008ee6f2e8f428b081a7766bfc17ddeef7848 +-- hash: 0fb32a64505d66389249b91ab33990a95c7b3f63032e84f0dc094e1439aec358 name: genvalidity-mergeless -version: 0.1.0.0 +version: 0.2.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 author: Tom Sydney Kerckhove maintainer: syd.kerckhove@gmail.com -copyright: Copyright: (c) 2018 Tom Sydney Kerckhove +copyright: Copyright: (c) 2018-2020 Tom Sydney Kerckhove license: MIT build-type: Simple extra-source-files: 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,7 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.GenValidity.Mergeless - ( module Data.GenValidity.Mergeless.Collection - ) where + ( module Data.GenValidity.Mergeless.Collection, + ) +where import Data.GenValidity.Mergeless.Collection diff --git a/src/Data/GenValidity/Mergeless/Collection.hs b/src/Data/GenValidity/Mergeless/Collection.hs --- a/src/Data/GenValidity/Mergeless/Collection.hs +++ b/src/Data/GenValidity/Mergeless/Collection.hs @@ -4,20 +4,17 @@ 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.GenValidity.Time () +import qualified Data.Map as M +import Data.Map (Map) import Data.Mergeless +import qualified Data.Set as S +import Data.Set (Set) +import Test.QuickCheck instance GenUnchecked ClientId @@ -25,10 +22,11 @@ genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance (GenUnchecked i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => - GenUnchecked (ClientStore i a) +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 i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (ClientStore i a) where +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 (a, b, c) <- genSplit3 n @@ -39,13 +37,15 @@ 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 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 i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => - GenUnchecked (SyncRequest i 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 i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (SyncRequest i a) where +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 (a, b, c) <- genSplit3 n @@ -56,22 +56,25 @@ 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 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 i, GenUnchecked a, Show i, Show a, Ord i, Ord a) => - GenUnchecked (SyncResponse i 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 i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (SyncResponse i a) where +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 @@ -87,23 +90,37 @@ 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 +mapWithIds = traverse id . M.fromSet (const genValid) -instance (GenUnchecked i, GenUnchecked a, Show i, Show a, GenInvalid i, GenInvalid a, Ord i, Ord a) => - GenInvalid (SyncResponse i a) +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 i, GenUnchecked a, Ord i, Ord a) => GenUnchecked (ServerStore i a) +instance (GenUnchecked si, GenUnchecked a, Ord si, Ord a) => GenUnchecked (ServerStore si a) -instance (GenValid i, GenValid a, Show i, Show a, Ord i, Ord a) => GenValid (ServerStore i a) where +instance (GenValid si, GenValid a, Show si, Show a, Ord si, Ord a) => GenValid (ServerStore si 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) +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 + genUnsyncedStore :: - forall i a. (Ord i, Ord a, GenValid i, GenValid a) - => Gen (ClientStore i a) + forall ci si a. + (Show ci, Ord ci, Ord si, Ord a, GenValid ci, GenValid si, GenValid a) => + Gen (ClientStore ci si a) genUnsyncedStore = do as <- genValid pure $ emptyClientStore {clientStoreAdded = as} + +genClientStoreFromSet :: (Show ci, Ord ci, Ord si, GenValid ci, GenValid v) => Set si -> Gen (ClientStore ci si v) +genClientStoreFromSet s = do + (s1, s2) <- splitSet s + clientStoreAdded <- genValid + clientStoreSynced <- mapWithIds s1 + let clientStoreDeleted = s2 + pure ClientStore {..} diff --git a/src/Data/GenValidity/Mergeless/Item.hs b/src/Data/GenValidity/Mergeless/Item.hs --- a/src/Data/GenValidity/Mergeless/Item.hs +++ b/src/Data/GenValidity/Mergeless/Item.hs @@ -6,7 +6,6 @@ import Data.GenValidity import Data.GenValidity.Containers () import Data.GenValidity.Time () - import Data.Mergeless.Item instance GenUnchecked a => GenUnchecked (ClientItem a) diff --git a/test/Data/Mergeless/CollectionSpec.hs b/test/Data/Mergeless/CollectionSpec.hs --- a/test/Data/Mergeless/CollectionSpec.hs +++ b/test/Data/Mergeless/CollectionSpec.hs @@ -5,108 +5,122 @@ {-# LANGUAGE TypeApplications #-} module Data.Mergeless.CollectionSpec - ( spec - ) where + ( spec, + ) +where +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 import Data.Ord import qualified Data.Set as S +import Data.UUID 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 @(ClientStore ClientId Int Int) + jsonSpecOnValid @(ClientStore ClientId Int Int) + genValidSpec @(SyncRequest ClientId Int Int) + jsonSpecOnValid @(SyncRequest ClientId Int Int) + genValidSpec @(SyncResponse ClientId Int Int) + jsonSpecOnValid @(SyncResponse ClientId Int Int) genValidSpec @(ServerStore Int Int) jsonSpecOnValid @(ServerStore Int Int) - describe "emptyStore" $ it "is valid" $ shouldBeValid (emptyClientStore @Int @Int) + describe "emptyStore" $ it "is valid" $ shouldBeValid (emptyClientStore @Int @Int @Int) describe "storeSize" $ do - it "does not crash" $ producesValidsOnValids (storeSize @Int @Int) - specify "adding an item makes the store bigger" $ - forAllValid $ \store -> + 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) + 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 -> + 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) + 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, _):_ -> + (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 -> + 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) + 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) - 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 "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) 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 -> + 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 (a :: Int)} + 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 -> + 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 + 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 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 + forall a si m. + (Show si, Ord si, GenValid si, Show a, Ord a, GenValid a, MonadIO m) => + (forall r. m r -> IO r) -> + (ServerStore si a -> SyncRequest ClientId si a -> m (SyncResponse ClientId si a, ServerStore si 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 -> + 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} @@ -117,8 +131,9 @@ 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 -> + 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} @@ -128,11 +143,12 @@ 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) + 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 -> + it "succesfully downloads everything from the server for an empty client" + $ forAllValid + $ \sstore1 -> eval $ do let cstore1 = emptyClientStore let req = makeSyncRequest cstore1 @@ -141,8 +157,9 @@ liftIO $ do sstore2 `shouldBe` sstore1 clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 - it "succesfully uploads everything to the server for an empty server" $ - forAllValid $ \items -> + it "succesfully uploads everything to the server for an empty server" + $ forAllValid + $ \items -> eval $ do let cstore1 = emptyClientStore {clientStoreAdded = items} let sstore1 = emptyServerStore @@ -152,8 +169,9 @@ 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 -> + it "is idempotent with one client" + $ forAllValid + $ \cstore1 -> forAllValid $ \sstore1 -> eval $ do let req1 = makeSyncRequest cstore1 @@ -167,227 +185,236 @@ sstore2 `shouldBe` sstore3 describe "Multiple clients" $ do describe "Single-item" $ do - it "successfully syncs an addition accross to a second client" $ - forAllValid $ \i -> + it "successfully syncs an addition accross to a second client" + $ forAllValid + $ \i -> eval $ do let cAstore1 = emptyClientStore {clientStoreAdded = M.singleton (ClientId 0) i} - -- Client B is empty + -- Client B is empty let cBstore1 = emptyClientStore - -- The server is empty + -- The server is empty let sstore1 = emptyServerStore - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- 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 + -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp1 liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items}) - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items}) sstore3 `shouldBe` sstore2 -- pPrint cBstore2 - -- Client B merges the response + -- 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 + -- 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 -> + 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. + -- 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 + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i} - -- Client B makes sync request 1 + -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 liftIO $ do resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid} sstore2 `shouldBe` emptyServerStore - -- Client B merges the response + -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp1 liftIO $ cBstore2 `shouldBe` emptyClientStore - -- Client A makes sync request 2 + -- Client A makes sync request 2 let req2 = makeSyncRequest cAstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid} sstore3 `shouldBe` sstore2 - -- Client A merges the response + -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp2 liftIO $ cAstore2 `shouldBe` emptyClientStore - -- Client A and Client B now have the same store + -- 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 -> + 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. + -- Both client a and client b delete an item. let cBstore1 = emptyClientStore {clientStoreDeleted = S.singleton uuid} - -- The server still has the undeleted item + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = M.singleton uuid i} - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 liftIO $ do resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) - -- Client A merges the response + -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp1 liftIO $ cAstore2 `shouldBe` emptyClientStore - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore3 `shouldBe` sstore2 - -- Client B merges the response + -- 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 + -- 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 + "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 - } + 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 + 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 -> + it "successfully syncs additions accross to a second client" + $ forAllValid + $ \is -> eval $ do let cAstore1 = emptyClientStore {clientStoreAdded = is} - -- Client B is empty + -- Client B is empty let cBstore1 = emptyClientStore - -- The server is empty + -- The server is empty let sstore1 = emptyServerStore - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 - -- Client A merges the response + -- 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 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- 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 + -- 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 + -- 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 -> + 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. + -- 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 + -- The server still has the undeleted item let sstore1 = ServerStore {serverStoreItems = syncedItems} - -- Client B makes sync request 1 + -- Client B makes sync request 1 let req1 = makeSyncRequest cBstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- func sstore1 req1 liftIO $ do resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds} sstore2 `shouldBe` emptyServerStore - -- Client B merges the response + -- Client B merges the response let cBstore2 = mergeSyncResponse cBstore1 resp1 liftIO $ cBstore2 `shouldBe` emptyClientStore - -- Client A makes sync request 2 + -- Client A makes sync request 2 let req2 = makeSyncRequest cAstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds} sstore3 `shouldBe` sstore2 - -- Client A merges the response + -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp2 liftIO $ cAstore2 `shouldBe` emptyClientStore - -- Client A and Client B now have the same store + -- 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 -> + 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. + -- Both client a and client b delete their items. let cBstore1 = emptyClientStore {clientStoreDeleted = M.keysSet items} - -- The server still has the undeleted items + -- The server still has the undeleted items let sstore1 = ServerStore {serverStoreItems = items} - -- Client A makes sync request 1 + -- Client A makes sync request 1 let req1 = makeSyncRequest cAstore1 - -- The server processes sync request 1 + -- The server processes sync request 1 (resp1, sstore2) <- 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 + -- Client A merges the response let cAstore2 = mergeSyncResponse cAstore1 resp1 liftIO $ cAstore2 `shouldBe` emptyClientStore - -- Client B makes sync request 2 + -- Client B makes sync request 2 let req2 = makeSyncRequest cBstore1 - -- The server processes sync request 2 + -- The server processes sync request 2 (resp2, sstore3) <- func sstore2 req2 liftIO $ do resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items}) sstore3 `shouldBe` sstore2 - -- Client B merges the response + -- 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 + -- Client A and Client B now have the same store cAstore2 `shouldBe` cBstore2 describe "General properties" $ do - it "produces valid results" $ - forAllValid $ \cs -> + 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 -> + it "successfully syncs two clients using a central store" + $ forAllValid + $ \store1 -> eval $ do let central = ServerStore M.empty let store2 = emptyClientStore @@ -401,8 +428,9 @@ (sresp3, _) <- func central'' sreq3 let store1'' = mergeSyncResponse store1' sresp3 liftIO $ store1'' `shouldBe` store2' - it "ensures that syncing is idempotent" $ - forAllValid $ \central1 -> + it "ensures that syncing is idempotent" + $ forAllValid + $ \central1 -> forAllValid $ \local1 -> eval $ do let sreq1 = makeSyncRequest local1 @@ -415,16 +443,12 @@ 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) --- 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) diff --git a/test/Data/Mergeless/ItemSpec.hs b/test/Data/Mergeless/ItemSpec.hs --- a/test/Data/Mergeless/ItemSpec.hs +++ b/test/Data/Mergeless/ItemSpec.hs @@ -1,19 +1,18 @@ {-# LANGUAGE TypeApplications #-} module Data.Mergeless.ItemSpec - ( spec - ) where + ( spec, + ) +where +import Data.GenValidity.Mergeless.Item () +import Data.GenValidity.UUID () import Data.Int (Int) - +import Data.Mergeless.Item 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 @@ -30,12 +29,15 @@ 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 "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 @@ -44,31 +46,35 @@ 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 + 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 + 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 + 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 + 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 @@ -81,8 +87,9 @@ store2 `shouldBe` store1 resp `shouldBe` ItemSyncResponseServerDeleted describe "High level properties" $ do - it "it always possible to add an item from scratch" $ - forAllValid $ \a -> 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 @@ -91,8 +98,9 @@ resp1 `shouldBe` ItemSyncResponseClientAdded sstore2 `shouldBe` ServerItemFull a cstore2 `shouldBe` ClientSynced a - it "is idempotent with one client" $ - forAllValid $ \si1 -> + it "is idempotent with one client" + $ forAllValid + $ \si1 -> forAllValid $ \ci1 -> do let req1 = makeItemSyncRequest @Int ci1 (resp1, si2) = processServerItemSync si1 req1