mergeless-persistent 0.1.0.0 → 0.1.0.1

raw patch · 9 files changed

+329/−295 lines, 9 filesdep +genvalidity-sydtestdep +sydtestdep −genvalidity-hspecdep −hspecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: genvalidity-sydtest, sydtest

Dependencies removed: genvalidity-hspec, hspec

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• mergeless-persistent.cabal +8/−6
• src/Data/Mergeless/Persistent.hs +18/−0
• test/Data/Mergeless/Persistent/SingleClientSpec.hs +76/−75
• test/Data/Mergeless/Persistent/TwoClientsSpec.hs +208/−207
• test/Spec.hs +1/−1
• test/TestUtils.hs +8/−6
• test/TestUtils/ClientDB.hs +3/−0
• test/TestUtils/ServerDB.hs +3/−0

@@ -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`

@@ -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

@@ -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                    

@@ -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 =

@@ -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 =

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}

@@ -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

@@ -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

@@ -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