diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog +## [0.1.0.1] - 2023-10-09 + +* Compatibility with `GHC >= 9.8` + ## [0.1.0.0] - 2021-11-21 * Compatibility with `genvalidity >=1.0.0.0` diff --git a/mergeless-persistent.cabal b/mergeless-persistent.cabal --- a/mergeless-persistent.cabal +++ b/mergeless-persistent.cabal @@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -- --- hash: f34495620a66b0afde3562023ecc1fe4f5626f5d2c2b5f37ab0302b21d1033eb +-- hash: e752e691c265b4a6ac4adbd3796a90835cea1b1a935d91ae0ea4f9f6535e335e name: mergeless-persistent -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Support for using mergeless from persistent-based databases 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-2023 Tom Sydney Kerckhove license: MIT build-type: Simple extra-source-files: @@ -52,15 +52,16 @@ hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + sydtest-discover:sydtest-discover build-depends: QuickCheck , base >=4.11 && <5 , containers , genvalidity >=1.0 - , genvalidity-hspec , genvalidity-mergeless , genvalidity-persistent - , hspec + , genvalidity-sydtest , mergeless , mergeless-persistent , monad-logger @@ -70,6 +71,7 @@ , persistent , persistent-sqlite , persistent-template + , sydtest , text , validity default-language: Haskell2010 diff --git a/src/Data/Mergeless/Persistent.hs b/src/Data/Mergeless/Persistent.hs --- a/src/Data/Mergeless/Persistent.hs +++ b/src/Data/Mergeless/Persistent.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#if !MIN_VERSION_persistent(2,14,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module Data.Mergeless.Persistent ( -- * Client side @@ -86,6 +92,7 @@ ( PersistEntity clientRecord, PersistField sid, PersistEntityBackend clientRecord ~ SqlBackend, + SafeToInsert clientRecord, MonadIO m ) => -- | Create an un-deleted synced record on the client side @@ -102,6 +109,7 @@ ( PersistEntity clientRecord, PersistField sid, PersistEntityBackend clientRecord ~ SqlBackend, + SafeToInsert clientRecord, MonadIO m ) => -- | Create an un-deleted synced record on the client side @@ -126,6 +134,7 @@ serverProcessSyncQuery :: ( PersistEntity record, PersistEntityBackend record ~ SqlBackend, + SafeToInsert record, MonadIO m ) => -- | Filters to select the relevant items @@ -144,6 +153,7 @@ serverSyncProcessor :: ( PersistEntity record, PersistEntityBackend record ~ SqlBackend, + SafeToInsert record, MonadIO m ) => -- | Filters to select the relevant items @@ -170,6 +180,7 @@ PersistEntity record, PersistField sid, PersistEntityBackend record ~ SqlBackend, + SafeToInsert record, MonadIO m ) => -- | The action to generate new identifiers @@ -194,6 +205,7 @@ PersistEntity record, PersistField sid, PersistEntityBackend record ~ SqlBackend, + SafeToInsert record, MonadIO m ) => -- | The action to generate new identifiers @@ -228,6 +240,7 @@ setupUnsyncedClientQuery :: ( PersistEntity clientRecord, PersistEntityBackend clientRecord ~ SqlBackend, + SafeToInsert clientRecord, MonadIO m ) => -- | How to insert a _new_ record @@ -242,6 +255,7 @@ setupClientQuery :: ( PersistEntity clientRecord, PersistEntityBackend clientRecord ~ SqlBackend, + SafeToInsert clientRecord, MonadIO m ) => -- | Create an un-deleted unsynced record on the client side @@ -330,3 +344,7 @@ ServerStore (Key record) a -> SqlPersistT m () setupServerQuery func ServerStore {..} = forM_ (M.toList serverStoreItems) $ \(i, e) -> void $ insertKey i $ func e + +#if !MIN_VERSION_persistent(2,14,0) +type SafeToInsert a = a ~ a +#endif diff --git a/test/Data/Mergeless/Persistent/SingleClientSpec.hs b/test/Data/Mergeless/Persistent/SingleClientSpec.hs --- a/test/Data/Mergeless/Persistent/SingleClientSpec.hs +++ b/test/Data/Mergeless/Persistent/SingleClientSpec.hs @@ -15,81 +15,81 @@ import Data.Mergeless import Data.Mergeless.Persistent import Database.Persist.Sql -import Test.Hspec -import Test.Hspec.QuickCheck import Test.QuickCheck -import Test.Validity +import Test.Syd hiding (runTest) +import Test.Syd.Validity import TestUtils {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} spec :: Spec -spec = modifyMaxShrinks (const 0) $ oneClientSpec $ do - describe "sanity" $ do - describe "setupClient & clientGetStore" $ do - it "roundtrips" $ \te -> forAllValid $ \cstore -> runTest te $ do - setupClient cstore - cstore' <- clientGetStore - liftIO $ cstore' `shouldBe` cstore - describe "setupServer & serverGetStore" $ do - it "roundtrips" $ \te -> forAllValid $ \sstore -> runTest te $ do - setupServer sstore - sstore' <- serverGetStore - liftIO $ sstore' `shouldBe` sstore - describe "Single item" $ do - it "Succesfully downloads a single item from the server for an empty client" $ \te -> - forAllValid $ \(sid, si) -> runTest te $ do - setupServer $ ServerStore $ M.singleton sid si - (_, sstore1, sstore2, cstore2) <- sync - liftIO $ do - sstore2 `shouldBe` sstore1 - clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 - it "succesfully uploads a single item to the server for an empty server" $ \te -> - forAllValid $ \si -> - runTest te $ - do - setupUnsyncedClient [si] - (_, _, sstore2, cstore2) <- sync - liftIO $ do - clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 - sort (M.elems (clientStoreSynced cstore2)) - `shouldBe` [si] - describe "Multiple items" $ do - it "succesfully downloads everything from the server for an empty client" $ \te -> forAllValid $ \sis -> - runTest te $ do - setupServer sis - (_, sstore1, sstore2, cstore2) <- sync - liftIO $ do - sstore2 `shouldBe` sstore1 - clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 - it "succesfully uploads everything to the server for an empty server" $ \te -> forAllValid $ \sis -> - runTest te $ do - setupUnsyncedClient sis - (_, _, sstore2, cstore2) <- sync - liftIO $ do - clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 - sort (M.elems (clientStoreSynced cstore2)) `shouldBe` sort sis - it "produces valid stores" $ \te -> forAllValid $ \sids -> - forAll (genClientStoreFromSet sids) $ \cs -> - forAll (genServerStoreFromSet sids) $ \ss -> - runTest te $ do - setupServer ss - setupClient cs - (_, _, cstore2, sstore2) <- sync - liftIO $ do - shouldBeValid cstore2 - shouldBeValid sstore2 - it "is idempotent with one client" $ \te -> forAllValid $ \sids -> - forAll (genClientStoreFromSet sids) $ \cs -> - forAll (genServerStoreFromSet sids) $ \ss -> - runTest te $ do - setupServer ss - setupClient cs - void sync - (cstore2, sstore2, sstore3, cstore3) <- sync - liftIO $ do - cstore3 `shouldBe` cstore2 - sstore3 `shouldBe` sstore2 +spec = modifyMaxShrinks (const 0) $ + oneClientSpec $ do + describe "sanity" $ do + describe "setupClient & clientGetStore" $ do + it "roundtrips" $ \te -> forAllValid $ \cstore -> runTest te $ do + setupClient cstore + cstore' <- clientGetStore + liftIO $ cstore' `shouldBe` cstore + describe "setupServer & serverGetStore" $ do + it "roundtrips" $ \te -> forAllValid $ \sstore -> runTest te $ do + setupServer sstore + sstore' <- serverGetStore + liftIO $ sstore' `shouldBe` sstore + describe "Single item" $ do + it "Succesfully downloads a single item from the server for an empty client" $ \te -> + forAllValid $ \(sid, si) -> runTest te $ do + setupServer $ ServerStore $ M.singleton sid si + (_, sstore1, sstore2, cstore2) <- sync + liftIO $ do + sstore2 `shouldBe` sstore1 + clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 + it "succesfully uploads a single item to the server for an empty server" $ \te -> + forAllValid $ \si -> + runTest te $ + do + setupUnsyncedClient [si] + (_, _, sstore2, cstore2) <- sync + liftIO $ do + clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 + sort (M.elems (clientStoreSynced cstore2)) + `shouldBe` [si] + describe "Multiple items" $ do + it "succesfully downloads everything from the server for an empty client" $ \te -> forAllValid $ \sis -> + runTest te $ do + setupServer sis + (_, sstore1, sstore2, cstore2) <- sync + liftIO $ do + sstore2 `shouldBe` sstore1 + clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 + it "succesfully uploads everything to the server for an empty server" $ \te -> forAllValid $ \sis -> + runTest te $ do + setupUnsyncedClient sis + (_, _, sstore2, cstore2) <- sync + liftIO $ do + clientStoreSynced cstore2 `shouldBe` serverStoreItems sstore2 + sort (M.elems (clientStoreSynced cstore2)) `shouldBe` sort sis + it "produces valid stores" $ \te -> forAllValid $ \sids -> + forAll (genClientStoreFromSet sids) $ \cs -> + forAll (genServerStoreFromSet sids) $ \ss -> + runTest te $ do + setupServer ss + setupClient cs + (_, _, cstore2, sstore2) <- sync + liftIO $ do + shouldBeValid cstore2 + shouldBeValid sstore2 + it "is idempotent with one client" $ \te -> forAllValid $ \sids -> + forAll (genClientStoreFromSet sids) $ \cs -> + forAll (genServerStoreFromSet sids) $ \ss -> + runTest te $ do + setupServer ss + setupClient cs + void sync + (cstore2, sstore2, sstore3, cstore3) <- sync + liftIO $ do + cstore3 `shouldBe` cstore2 + sstore3 `shouldBe` sstore2 type T a = ReaderT TestEnv IO a @@ -149,14 +149,15 @@ clientMergeSyncResponse :: SResp -> T () clientMergeSyncResponse = runClientDB . clientMergeSyncResponseThingQuery -data TestEnv - = TestEnv - { testEnvClientPool :: ConnectionPool, - testEnvServerPool :: ConnectionPool - } +data TestEnv = TestEnv + { testEnvClientPool :: !ConnectionPool, + testEnvServerPool :: !ConnectionPool + } oneClientSpec :: SpecWith TestEnv -> Spec -oneClientSpec = around withTestEnv +oneClientSpec = + modifyMaxSuccess (`div` 10) + . around withTestEnv withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv func = diff --git a/test/Data/Mergeless/Persistent/TwoClientsSpec.hs b/test/Data/Mergeless/Persistent/TwoClientsSpec.hs --- a/test/Data/Mergeless/Persistent/TwoClientsSpec.hs +++ b/test/Data/Mergeless/Persistent/TwoClientsSpec.hs @@ -14,71 +14,203 @@ import Data.Mergeless import qualified Data.Set as S import Database.Persist.Sql -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.Validity +import Test.Syd hiding (runTest) +import Test.Syd.Validity import TestUtils {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} spec :: Spec -spec = modifyMaxShrinks (const 0) $ twoClientsSpec $ do - describe "sanity" $ do - describe "setupClient & clientGetStore" $ do - it "roundtrips" $ \te -> forAllValid $ \cstore -> runTest te $ do - setupClient A cstore - cstore' <- clientGetStore A - liftIO $ cstore' `shouldBe` cstore - describe "setupServer & serverGetStore" $ do - it "roundtrips" $ \te -> forAllValid $ \sstore -> runTest te $ do - setupServer sstore - sstore' <- serverGetStore - liftIO $ sstore' `shouldBe` sstore - describe "Single item" $ do - it "successfully syncs an addition accross to a second client" $ - \te -> - forAllValid $ \st -> runTest te $ do - setupUnsyncedClient A [st] - setupUnsyncedClient B [] - setupServer emptyServerStore - req1 <- clientMakeSyncRequest A - resp1 <- serverProcessSync req1 - sstore2 <- serverGetStore - case M.toList (syncResponseClientAdded resp1) of - [(_, clientAdditionId)] -> do - let items = M.singleton clientAdditionId st - liftIO $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items}) +spec = + twoClientsSpec $ do + describe "sanity" $ do + describe "setupClient & clientGetStore" $ do + it "roundtrips" $ \te -> forAllValid $ \cstore -> runTest te $ do + setupClient A cstore + cstore' <- clientGetStore A + liftIO $ cstore' `shouldBe` cstore + describe "setupServer & serverGetStore" $ do + it "roundtrips" $ \te -> forAllValid $ \sstore -> runTest te $ do + setupServer sstore + sstore' <- serverGetStore + liftIO $ sstore' `shouldBe` sstore + describe "Single item" $ do + it "successfully syncs an addition accross to a second client" $ + \te -> + forAllValid $ \st -> runTest te $ do + setupUnsyncedClient A [st] + setupUnsyncedClient B [] + setupServer emptyServerStore + req1 <- clientMakeSyncRequest A + resp1 <- serverProcessSync req1 + sstore2 <- serverGetStore + case M.toList (syncResponseClientAdded resp1) of + [(_, clientAdditionId)] -> do + let items = M.singleton clientAdditionId st + liftIO $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items}) + clientMergeSyncResponse A resp1 + cAstore2 <- clientGetStore A + liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items}) + req2 <- clientMakeSyncRequest B + resp2 <- serverProcessSync req2 + sstore3 <- serverGetStore + liftIO $ do + resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items}) + sstore3 `shouldBe` sstore2 + clientMergeSyncResponse B resp2 + cBstore2 <- clientGetStore B + liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items}) + liftIO $ cAstore2 `shouldBe` cBstore2 + _ -> liftIO $ expectationFailure "Should have found exactly one added item." + it "succesfully syncs a deletion across to a second client" $ + \te -> forAllValid $ \uuid -> + forAllValid $ \i -> + runTest te $ do + setupClient A $ emptyClientStore {clientStoreSynced = M.singleton uuid i} + -- Client A has a synced item. + -- Client B had synced that same item, but has since deleted it. + setupClient B $ emptyClientStore {clientStoreDeleted = S.singleton uuid} + -- The server still has the undeleted item + setupServer $ ServerStore {serverStoreItems = M.singleton uuid i} + -- Client B makes sync request 1 + req1 <- clientMakeSyncRequest B + -- The server processes sync request 1 + resp1 <- serverProcessSync req1 + sstore2 <- serverGetStore + liftIO $ do + resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid} + sstore2 `shouldBe` emptyServerStore + -- Client B merges the response + clientMergeSyncResponse B resp1 + cBstore2 <- clientGetStore B + liftIO $ cBstore2 `shouldBe` emptyClientStore + -- Client A makes sync request 2 + req2 <- clientMakeSyncRequest A + -- The server processes sync request 2 + resp2 <- serverProcessSync req2 + sstore3 <- serverGetStore + liftIO $ do + resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid} + sstore3 `shouldBe` sstore2 + -- Client A merges the response + clientMergeSyncResponse A resp2 + cAstore2 <- clientGetStore A + 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" $ + \te -> forAllValid $ \uuid -> + forAllValid $ \i -> + runTest te $ do + setupClient A $ emptyClientStore {clientStoreDeleted = S.singleton uuid} + -- Both client a and client b delete an item. + setupClient B $ emptyClientStore {clientStoreDeleted = S.singleton uuid} + -- The server still has the undeleted item + setupServer $ ServerStore {serverStoreItems = M.singleton uuid i} + -- Client A makes sync request 1 + req1 <- clientMakeSyncRequest A + -- The server processes sync request 1 + resp1 <- serverProcessSync req1 + sstore2 <- serverGetStore + liftIO $ do + resp1 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) + sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty}) + -- Client A merges the response clientMergeSyncResponse A resp1 cAstore2 <- clientGetStore A - liftIO $ cAstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items}) + liftIO $ cAstore2 `shouldBe` emptyClientStore + -- Client B makes sync request 2 req2 <- clientMakeSyncRequest B + -- The server processes sync request 2 resp2 <- serverProcessSync req2 sstore3 <- serverGetStore liftIO $ do - resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items}) + resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) sstore3 `shouldBe` sstore2 + -- Client B merges the response clientMergeSyncResponse B resp2 cBstore2 <- clientGetStore B - liftIO $ cBstore2 `shouldBe` (emptyClientStore {clientStoreSynced = items}) - liftIO $ cAstore2 `shouldBe` cBstore2 - _ -> liftIO $ expectationFailure "Should have found exactly one added item." - it "succesfully syncs a deletion across to a second client" $ - \te -> 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" + $ \te -> + forAllValid $ \sis -> runTest te $ do + let cs = ServerStore sis + setupServer cs + sr <- + serverProcessSync + SyncRequest + { syncRequestAdded = M.empty, + syncRequestSynced = M.keysSet sis, + syncRequestDeleted = S.empty + } + cs' <- serverGetStore + liftIO $ + do + 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" $ + \te -> forAllValid $ \is -> runTest te $ do - setupClient A $ emptyClientStore {clientStoreSynced = M.singleton uuid i} - -- Client A has a synced item. - -- Client B had synced that same item, but has since deleted it. - setupClient B $ emptyClientStore {clientStoreDeleted = S.singleton uuid} + setupClient A $ emptyClientStore {clientStoreAdded = is} + -- Client B is empty + setupClient B emptyClientStore + -- The server is empty + setupServer emptyServerStore + -- Client A makes sync request 1 + req1 <- clientMakeSyncRequest A + -- The server processes sync request 1 + resp1 <- serverProcessSync req1 + sstore2 <- serverGetStore + -- Client A merges the response + clientMergeSyncResponse A resp1 + cAstore2 <- clientGetStore A + 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 + req2 <- clientMakeSyncRequest B + -- The server processes sync request 2 + resp2 <- serverProcessSync req2 + sstore3 <- serverGetStore + liftIO $ do + resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items}) + sstore3 `shouldBe` sstore2 + -- Client B merges the response + clientMergeSyncResponse B resp2 + cBstore2 <- clientGetStore B + 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" $ \te -> + forAllValid $ \syncedItems -> + runTest te $ do + let itemIds = M.keysSet syncedItems + -- Client A has synced items + setupClient A $ emptyClientStore {clientStoreSynced = syncedItems} + -- Client B had synced the same items, but has since deleted them. + setupClient B $ emptyClientStore {clientStoreDeleted = itemIds} -- The server still has the undeleted item - setupServer $ ServerStore {serverStoreItems = M.singleton uuid i} + setupServer $ ServerStore {serverStoreItems = syncedItems} -- Client B makes sync request 1 req1 <- clientMakeSyncRequest B -- The server processes sync request 1 resp1 <- serverProcessSync req1 sstore2 <- serverGetStore liftIO $ do - resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid} + resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds} sstore2 `shouldBe` emptyServerStore -- Client B merges the response clientMergeSyncResponse B resp1 @@ -90,7 +222,7 @@ resp2 <- serverProcessSync req2 sstore3 <- serverGetStore liftIO $ do - resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid} + resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds} sstore3 `shouldBe` sstore2 -- Client A merges the response clientMergeSyncResponse A resp2 @@ -98,24 +230,23 @@ 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" $ - \te -> forAllValid $ \uuid -> - forAllValid $ \i -> + it "does not run into a conflict if two clients both try to sync a deletion" $ + \te -> forAllValid $ \items -> runTest te $ do - setupClient A $ emptyClientStore {clientStoreDeleted = S.singleton uuid} - -- Both client a and client b delete an item. - setupClient B $ emptyClientStore {clientStoreDeleted = S.singleton uuid} - -- The server still has the undeleted item - setupServer $ ServerStore {serverStoreItems = M.singleton uuid i} + setupClient A $ emptyClientStore {clientStoreDeleted = M.keysSet items} + -- Both client a and client b delete their items. + setupClient B $ emptyClientStore {clientStoreDeleted = M.keysSet items} + -- The server still has the undeleted items + setupServer $ ServerStore {serverStoreItems = items} -- Client A makes sync request 1 req1 <- clientMakeSyncRequest A -- The server processes sync request 1 resp1 <- serverProcessSync req1 sstore2 <- serverGetStore 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 clientMergeSyncResponse A resp1 cAstore2 <- clientGetStore A liftIO $ cAstore2 `shouldBe` emptyClientStore @@ -125,7 +256,7 @@ resp2 <- serverProcessSync req2 sstore3 <- serverGetStore liftIO $ do - resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}) + resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items}) sstore3 `shouldBe` sstore2 -- Client B merges the response clientMergeSyncResponse B resp2 @@ -134,150 +265,19 @@ 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" - $ \te -> - forAllValid $ \sis -> runTest te $ do - let cs = ServerStore sis - setupServer cs - sr <- - serverProcessSync - SyncRequest - { syncRequestAdded = M.empty, - syncRequestSynced = M.keysSet sis, - syncRequestDeleted = S.empty - } - cs' <- serverGetStore - liftIO $ - do - 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" $ - \te -> forAllValid $ \is -> - runTest te $ do - setupClient A $ emptyClientStore {clientStoreAdded = is} - -- Client B is empty - setupClient B emptyClientStore - -- The server is empty - setupServer emptyServerStore - -- Client A makes sync request 1 - req1 <- clientMakeSyncRequest A - -- The server processes sync request 1 - resp1 <- serverProcessSync req1 - sstore2 <- serverGetStore - -- Client A merges the response - clientMergeSyncResponse A resp1 - cAstore2 <- clientGetStore A - 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 - req2 <- clientMakeSyncRequest B - -- The server processes sync request 2 - resp2 <- serverProcessSync req2 - sstore3 <- serverGetStore - liftIO $ do - resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items}) - sstore3 `shouldBe` sstore2 - -- Client B merges the response - clientMergeSyncResponse B resp2 - cBstore2 <- clientGetStore B - 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" $ \te -> - forAllValid $ \syncedItems -> - runTest te $ do - let itemIds = M.keysSet syncedItems - -- Client A has synced items - setupClient A $ emptyClientStore {clientStoreSynced = syncedItems} - -- Client B had synced the same items, but has since deleted them. - setupClient B $ emptyClientStore {clientStoreDeleted = itemIds} - -- The server still has the undeleted item - setupServer $ ServerStore {serverStoreItems = syncedItems} - -- Client B makes sync request 1 - req1 <- clientMakeSyncRequest B - -- The server processes sync request 1 - resp1 <- serverProcessSync req1 - sstore2 <- serverGetStore - liftIO $ do - resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds} - sstore2 `shouldBe` emptyServerStore - -- Client B merges the response - clientMergeSyncResponse B resp1 - cBstore2 <- clientGetStore B - liftIO $ cBstore2 `shouldBe` emptyClientStore - -- Client A makes sync request 2 - req2 <- clientMakeSyncRequest A - -- The server processes sync request 2 - resp2 <- serverProcessSync req2 - sstore3 <- serverGetStore - liftIO $ do - resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds} - sstore3 `shouldBe` sstore2 - -- Client A merges the response - clientMergeSyncResponse A resp2 - cAstore2 <- clientGetStore A - 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" $ - \te -> forAllValid $ \items -> - runTest te $ do - setupClient A $ emptyClientStore {clientStoreDeleted = M.keysSet items} - -- Both client a and client b delete their items. - setupClient B $ emptyClientStore {clientStoreDeleted = M.keysSet items} - -- The server still has the undeleted items - setupServer $ ServerStore {serverStoreItems = items} - -- Client A makes sync request 1 - req1 <- clientMakeSyncRequest A - -- The server processes sync request 1 - resp1 <- serverProcessSync req1 - sstore2 <- serverGetStore - 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 - clientMergeSyncResponse A resp1 - cAstore2 <- clientGetStore A - liftIO $ cAstore2 `shouldBe` emptyClientStore - -- Client B makes sync request 2 - req2 <- clientMakeSyncRequest B - -- The server processes sync request 2 - resp2 <- serverProcessSync req2 - sstore3 <- serverGetStore - liftIO $ do - resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items}) - sstore3 `shouldBe` sstore2 - -- Client B merges the response - clientMergeSyncResponse B resp2 - cBstore2 <- clientGetStore B - liftIO $ do - cBstore2 `shouldBe` emptyClientStore - -- Client A and Client B now have the same store - cAstore2 `shouldBe` cBstore2 - describe "General properties" - $ it "successfully syncs two clients using a central store" - $ \te -> - forAllValid $ \store1 -> - runTest te $ - do - setupServer $ ServerStore M.empty - setupClient A store1 - setupClient B emptyClientStore - void $ sync A - (_, _, _, store2') <- sync B - (_, _, _, store1'') <- sync A - liftIO $ store1'' `shouldBe` store2' + describe "General properties" $ + it "successfully syncs two clients using a central store" $ + \te -> + forAllValid $ \store1 -> + runTest te $ + do + setupServer $ ServerStore M.empty + setupClient A store1 + setupClient B emptyClientStore + void $ sync A + (_, _, _, store2') <- sync B + (_, _, _, store1'') <- sync A + liftIO $ store1'' `shouldBe` store2' type T a = ReaderT TestEnv IO a @@ -343,15 +343,16 @@ data Client = A | B deriving (Show, Eq) -data TestEnv - = TestEnv - { testEnvServerPool :: ConnectionPool, - testEnvClient1Pool :: ConnectionPool, - testEnvClient2Pool :: ConnectionPool - } +data TestEnv = TestEnv + { testEnvServerPool :: !ConnectionPool, + testEnvClient1Pool :: !ConnectionPool, + testEnvClient2Pool :: !ConnectionPool + } twoClientsSpec :: SpecWith TestEnv -> Spec -twoClientsSpec = around withTestEnv +twoClientsSpec = + modifyMaxSuccess (`div` 10) + . around withTestEnv withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv func = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -25,12 +25,14 @@ withServerPool :: (ConnectionPool -> IO a) -> IO a withServerPool func = - runNoLoggingT $ withSqlitePool ":memory:" 1 $ \serverPool -> do - flip runSqlPool serverPool $ void $ runMigrationSilent migrateServer - liftIO $ func serverPool + runNoLoggingT $ + withSqlitePool ":memory:" 1 $ \serverPool -> do + flip runSqlPool serverPool $ void $ runMigrationQuiet migrateServer + liftIO $ func serverPool withClientPool :: (ConnectionPool -> IO a) -> IO a withClientPool func = - runNoLoggingT $ withSqlitePool ":memory:" 1 $ \clientPool -> do - flip runSqlPool clientPool $ void $ runMigrationSilent migrateClient - liftIO $ func clientPool + runNoLoggingT $ + withSqlitePool ":memory:" 1 $ \clientPool -> do + flip runSqlPool clientPool $ void $ runMigrationQuiet migrateClient + liftIO $ func clientPool diff --git a/test/TestUtils/ClientDB.hs b/test/TestUtils/ClientDB.hs --- a/test/TestUtils/ClientDB.hs +++ b/test/TestUtils/ClientDB.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module TestUtils.ClientDB where diff --git a/test/TestUtils/ServerDB.hs b/test/TestUtils/ServerDB.hs --- a/test/TestUtils/ServerDB.hs +++ b/test/TestUtils/ServerDB.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module TestUtils.ServerDB where