packages feed

appendful-persistent (empty) → 0.0.0.0

raw patch · 8 files changed

+916/−0 lines, 8 filesdep +QuickCheckdep +appendfuldep +appendful-persistent

Dependencies added: QuickCheck, appendful, appendful-persistent, base, containers, genvalidity, genvalidity-appendful, genvalidity-hspec, genvalidity-persistent, hspec, microlens, monad-logger, mtl, path, path-io, persistent, persistent-sqlite, persistent-template, text, validity

Files

+ appendful-persistent.cabal view
@@ -0,0 +1,71 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name:           appendful-persistent+version:        0.0.0.0+description:    Persistent integration for ppend-only cooperative agreement+homepage:       https://github.com/NorfairKing/appendful#readme+bug-reports:    https://github.com/NorfairKing/appendful/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright: (c) 2020-2022 Tom Sydney Kerckhove+license:        MIT+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/NorfairKing/appendful++library+  exposed-modules:+      Data.Appendful.Persistent+  other-modules:+      Paths_appendful_persistent+  hs-source-dirs:+      src+  ghc-options: -Wall -fwarn-redundant-constraints+  build-depends:+      appendful+    , base >=4.11 && <5+    , containers+    , microlens+    , persistent+  default-language: Haskell2010++test-suite appendful-persistent-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.Appendful.Persistent.SingleClientSpec+      Data.Appendful.Persistent.TwoClientsSpec+      TestUtils+      TestUtils.ClientDB+      TestUtils.ServerDB+      Paths_appendful_persistent+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , appendful+    , appendful-persistent+    , base >=4.11 && <5+    , containers+    , genvalidity+    , genvalidity-appendful+    , genvalidity-hspec+    , genvalidity-persistent+    , hspec+    , monad-logger+    , mtl+    , path+    , path-io+    , persistent+    , persistent-sqlite+    , persistent-template+    , text+    , validity+  default-language: Haskell2010
+ src/Data/Appendful/Persistent.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Appendful.Persistent+  ( -- * Client side+    clientMakeSyncRequestQuery,+    clientMergeSyncResponseQuery,++    -- ** Raw processors+    clientSyncProcessor,++    -- * Server side+    serverProcessSyncQuery,+    serverProcessSyncWithCustomIdQuery,++    -- ** Sync processors+    serverSyncProcessor,+    serverSyncProcessorWithCustomId,++    -- * Utils++    -- ** Client side+    setupUnsyncedClientQuery,+    setupClientQuery,+    clientGetStoreQuery,++    -- ** Server side side+    serverGetStoreQuery,+    setupServerQuery,+  )+where++import Control.Monad+import Control.Monad.IO.Class+import Data.Appendful+import qualified Data.Map as M+import Data.Maybe+import Database.Persist+import Database.Persist.Sql+import Lens.Micro++-- | Make a sync request on the client side+clientMakeSyncRequestQuery ::+  forall sid clientRecord a m.+  ( PersistEntity clientRecord,+    PersistField sid,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | How to read a record+  (clientRecord -> a) ->+  -- | The server id field+  EntityField clientRecord (Maybe sid) ->+  SqlPersistT m (SyncRequest (Key clientRecord) sid a)+clientMakeSyncRequestQuery func serverIdField = do+  syncRequestAdded <-+    M.fromList . map (\(Entity cid ct) -> (cid, func ct))+      <$> selectList+        [serverIdField ==. Nothing]+        []+  syncRequestMaximumSynced <-+    ((\e -> e ^. fieldLens serverIdField) =<<)+      <$> selectFirst+        [serverIdField !=. Nothing]+        [Desc serverIdField] ::+      SqlPersistT m (Maybe sid)+  pure SyncRequest {..}++-- | Merge a sync response on the client side+clientMergeSyncResponseQuery ::+  ( PersistEntity clientRecord,+    PersistField sid,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | Create an un-deleted synced record on the client side+  (sid -> a -> clientRecord) ->+  -- | The server id field+  EntityField clientRecord (Maybe sid) ->+  SyncResponse (Key clientRecord) sid a ->+  SqlPersistT m ()+clientMergeSyncResponseQuery func serverIdField = mergeSyncResponseCustom $ clientSyncProcessor func serverIdField++clientSyncProcessor ::+  ( PersistEntity clientRecord,+    PersistField sid,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | Create an un-deleted synced record on the client side+  (sid -> a -> clientRecord) ->+  -- | The server id field+  EntityField clientRecord (Maybe sid) ->+  ClientSyncProcessor (Key clientRecord) sid a (SqlPersistT m)+clientSyncProcessor func serverIdField = ClientSyncProcessor {..}+  where+    clientSyncProcessorSyncServerAdded m = forM_ (M.toList m) $ \(si, st) ->+      insert_ $ func si st+    clientSyncProcessorSyncClientAdded m = forM_ (M.toList m) $ \(cid, sid) ->+      update cid [serverIdField =. Just sid]++-- | Process a sync query on the server side.+serverProcessSyncQuery ::+  ( PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | Filters to select the relevant items+  --+  -- Use these if you have multiple users and you want to sync per-user+  [Filter record] ->+  -- | How to read a record+  (record -> a) ->+  -- | How to insert a _new_ record+  (a -> record) ->+  SyncRequest ci (Key record) a ->+  SqlPersistT m (SyncResponse ci (Key record) a)+serverProcessSyncQuery filters funcTo funcFrom = processServerSyncCustom $ serverSyncProcessor filters funcTo funcFrom++-- | A server sync processor that uses the sqlkey of the record as the name+serverSyncProcessor ::+  ( PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | Filters to select the relevant items+  --+  -- Use these if you have multiple users and you want to sync per-user+  [Filter record] ->+  -- | How to read a record+  (record -> a) ->+  -- | How to insert a _new_ record+  (a -> record) ->+  ServerSyncProcessor ci (Key record) a (SqlPersistT m)+serverSyncProcessor filters funcTo funcFrom =+  ServerSyncProcessor {..}+  where+    serverSyncProcessorRead = M.fromList . map (\(Entity i record) -> (i, funcTo record)) <$> selectList filters []+    serverSyncProcessorAddItems = mapM $ insert . funcFrom++-- | Process a sync query on the server side with a custom id.+serverProcessSyncWithCustomIdQuery ::+  ( Ord sid,+    PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | The action to generate new identifiers+  SqlPersistT m sid ->+  -- | Filters to select the relevant items+  --+  -- Use these if you have multiple users and you want to sync per-user+  [Filter record] ->+  -- | How to read a record+  (record -> (sid, a)) ->+  -- | How to insert a _new_ record+  (sid -> a -> record) ->+  SyncRequest ci sid a ->+  SqlPersistT m (SyncResponse ci sid a)+serverProcessSyncWithCustomIdQuery genId filters funcTo funcFrom = processServerSyncCustom $ serverSyncProcessorWithCustomId genId filters funcTo funcFrom++-- | A server sync processor that uses a custom key as the name+serverSyncProcessorWithCustomId ::+  ( Ord sid,+    PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | The action to generate new identifiers+  SqlPersistT m sid ->+  -- | Filters to select the relevant items+  --+  -- Use these if you have multiple users and you want to sync per-user+  [Filter record] ->+  -- | How to read a record+  (record -> (sid, a)) ->+  -- | How to insert a _new_ record+  (sid -> a -> record) ->+  ServerSyncProcessor ci sid a (SqlPersistT m)+serverSyncProcessorWithCustomId genId filters funcTo funcFrom =+  ServerSyncProcessor {..}+  where+    serverSyncProcessorRead = M.fromList . map (funcTo . entityVal) <$> selectList filters []+    serverSyncProcessorAddItems = mapM $ \a -> do+      sid <- genId+      let record = funcFrom sid a+      insert_ record+      pure sid++-- | Setup an unsynced client store+--+-- You shouldn't need this.+setupUnsyncedClientQuery ::+  ( PersistEntity clientRecord,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | How to insert a _new_ record+  (a -> clientRecord) ->+  [a] ->+  SqlPersistT m ()+setupUnsyncedClientQuery func = mapM_ (insert . func)++-- | Setup a client store+--+-- You shouldn't need this.+setupClientQuery ::+  ( PersistEntity clientRecord,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | Create an un-deleted unsynced record on the client side+  (a -> clientRecord) ->+  -- | Create an un-deleted synced record on the client side+  (sid -> a -> clientRecord) ->+  ClientStore (Key clientRecord) sid a ->+  SqlPersistT m ()+setupClientQuery funcU funcS ClientStore {..} = do+  forM_ (M.toList clientStoreAdded) $ \(cid, st) ->+    insertKey+      cid+      (funcU st)+  forM_ (M.toList clientStoreSynced) $ \(sid, st) ->+    insert_ (funcS sid st)++-- | Get a client store+--+-- You shouldn't need this.+clientGetStoreQuery ::+  ( Ord sid,+    PersistEntity clientRecord,+    PersistField sid,+    PersistEntityBackend clientRecord ~ SqlBackend,+    MonadIO m+  ) =>+  -- | How to red a record+  (clientRecord -> a) ->+  -- | The server id field+  EntityField clientRecord (Maybe sid) ->+  SqlPersistT m (ClientStore (Key clientRecord) sid a)+clientGetStoreQuery func serverIdField = do+  clientStoreAdded <-+    M.fromList . map (\(Entity cid ct) -> (cid, func ct))+      <$> selectList+        [ serverIdField ==. Nothing+        ]+        []+  clientStoreSynced <-+    M.fromList . mapMaybe (\e@(Entity _ ct) -> (,) <$> (e ^. fieldLens serverIdField) <*> pure (func ct))+      <$> selectList+        [ serverIdField !=. Nothing+        ]+        []+  pure ClientStore {..}++-- | Get the server store from the database+--+-- You shouldn't need this.+serverGetStoreQuery ::+  ( PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | How to read a record+  (record -> a) ->+  SqlPersistT m (ServerStore (Key record) a)+serverGetStoreQuery func = ServerStore . M.fromList . map (\(Entity stid st) -> (stid, func st)) <$> selectList [] []++-- | Set up a server store in the database.+--+-- You shouldn't need this.+-- This uses 'insertKey' function and is therefore unsafe.+setupServerQuery ::+  ( PersistEntity record,+    PersistEntityBackend record ~ SqlBackend,+    MonadIO m+  ) =>+  -- | How to write a record+  (a -> record) ->+  ServerStore (Key record) a ->+  SqlPersistT m ()+setupServerQuery func ServerStore {..} = forM_ (M.toList serverStoreItems) $ \(i, e) -> void $ insertKey i $ func e
+ test/Data/Appendful/Persistent/SingleClientSpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Appendful.Persistent.SingleClientSpec+  ( spec,+  )+where++import Control.Monad+import Control.Monad.Reader+import Data.Appendful+import Data.Appendful.Persistent+import Data.GenValidity.Appendful+import Data.List+import qualified Data.Map as M+import Database.Persist.Sql+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.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++type T a = ReaderT TestEnv IO a++runTest :: TestEnv -> T a -> IO a+runTest = flip runReaderT++runClientDB :: SqlPersistT IO a -> T a+runClientDB func = do+  pool <- asks testEnvClientPool+  liftIO $ runSqlPool func pool++runServerDB :: SqlPersistT IO a -> T a+runServerDB func = do+  pool <- asks testEnvServerPool+  liftIO $ runSqlPool func pool++type CS = ClientStore ClientThingId ServerThingId Thing++type SReq = SyncRequest ClientThingId ServerThingId Thing++type SS = ServerStore ServerThingId Thing++type SResp = SyncResponse ClientThingId ServerThingId Thing++sync :: T (CS, SS, SS, CS)+sync = do+  cstore1 <- clientGetStore+  req <- clientMakeSyncRequest+  sstore1 <- serverGetStore+  resp <- serverProcessSync req+  sstore2 <- serverGetStore+  clientMergeSyncResponse resp+  cstore2 <- clientGetStore+  pure (cstore1, sstore1, sstore2, cstore2)++setupUnsyncedClient :: [Thing] -> T ()+setupUnsyncedClient = runClientDB . setupUnsyncedClientQuery makeUnsyncedClientThing++setupClient :: CS -> T ()+setupClient = runClientDB . setupClientThingQuery++setupServer :: SS -> T ()+setupServer = runServerDB . setupServerThingQuery++clientGetStore :: T CS+clientGetStore = runClientDB clientGetStoreThingQuery++clientMakeSyncRequest :: T SReq+clientMakeSyncRequest = runClientDB clientMakeSyncRequestThingQuery++serverGetStore :: T SS+serverGetStore = runServerDB serverGetStoreThingQuery++serverProcessSync :: SReq -> T SResp+serverProcessSync = runServerDB . serverProcessSyncThingQuery++clientMergeSyncResponse :: SResp -> T ()+clientMergeSyncResponse = runClientDB . clientMergeSyncResponseThingQuery++data TestEnv = TestEnv+  { testEnvClientPool :: ConnectionPool,+    testEnvServerPool :: ConnectionPool+  }++oneClientSpec :: SpecWith TestEnv -> Spec+oneClientSpec = around withTestEnv++withTestEnv :: (TestEnv -> IO a) -> IO a+withTestEnv func =+  withServerPool $ \serverPool -> withClientPool $ \clientPool -> do+    let tenv = TestEnv {testEnvClientPool = clientPool, testEnvServerPool = serverPool}+    liftIO $ func tenv
+ test/Data/Appendful/Persistent/TwoClientsSpec.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Appendful.Persistent.TwoClientsSpec+  ( spec,+  )+where++import Control.Monad+import Control.Monad.Reader+import Data.Appendful+import Data.GenValidity.Appendful ()+import qualified Data.Map as M+import Database.Persist.Sql+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.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})+                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."+    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,+                    syncRequestMaximumSynced = fst <$> M.lookupMax sis+                  }+            cs' <- serverGetStore+            liftIO $+              do+                cs' `shouldBe` cs+                sr+                  `shouldBe` SyncResponse+                    { syncResponseClientAdded = M.empty,+                      syncResponseServerAdded = M.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+    describe "General properties" $+      it "successfully syncs two clients using a central store" $+        \te ->+          forAllValid $ \addedItems ->+            runTest te $+              do+                setupServer $ ServerStore M.empty+                let store1 = emptyClientStore {clientStoreAdded = addedItems}+                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++runTest :: TestEnv -> T a -> IO a+runTest = flip runReaderT++runClientDB :: Client -> SqlPersistT IO a -> T a+runClientDB num func = do+  pool <- asks $ case num of+    A -> testEnvClient1Pool+    B -> testEnvClient2Pool+  liftIO $ runSqlPool func pool++runServerDB :: SqlPersistT IO a -> T a+runServerDB func = do+  pool <- asks testEnvServerPool+  liftIO $ runSqlPool func pool++type CS = ClientStore ClientThingId ServerThingId Thing++type SReq = SyncRequest ClientThingId ServerThingId Thing++type SS = ServerStore ServerThingId Thing++type SResp = SyncResponse ClientThingId ServerThingId Thing++sync :: Client -> T (CS, SS, SS, CS)+sync n = do+  cstore1 <- clientGetStore n+  req <- clientMakeSyncRequest n+  sstore1 <- serverGetStore+  resp <- serverProcessSync req+  sstore2 <- serverGetStore+  clientMergeSyncResponse n resp+  cstore2 <- clientGetStore n+  pure (cstore1, sstore1, sstore2, cstore2)++setupUnsyncedClient :: Client -> [Thing] -> T ()+setupUnsyncedClient n =+  runClientDB n . setupUnsyncedClientThingQuery++setupClient :: Client -> CS -> T ()+setupClient n = runClientDB n . setupClientThingQuery++setupServer :: SS -> T ()+setupServer = runServerDB . setupServerThingQuery++clientGetStore :: Client -> T CS+clientGetStore n = runClientDB n clientGetStoreThingQuery++clientMakeSyncRequest :: Client -> T SReq+clientMakeSyncRequest n = runClientDB n clientMakeSyncRequestThingQuery++serverGetStore :: T SS+serverGetStore = runServerDB serverGetStoreThingQuery++serverProcessSync :: SReq -> T SResp+serverProcessSync = runServerDB . serverProcessSyncThingQuery++clientMergeSyncResponse :: Client -> SResp -> T ()+clientMergeSyncResponse n = runClientDB n . clientMergeSyncResponseThingQuery++data Client = A | B+  deriving (Show, Eq)++data TestEnv = TestEnv+  { testEnvServerPool :: ConnectionPool,+    testEnvClient1Pool :: ConnectionPool,+    testEnvClient2Pool :: ConnectionPool+  }++twoClientsSpec :: SpecWith TestEnv -> Spec+twoClientsSpec = around withTestEnv++withTestEnv :: (TestEnv -> IO a) -> IO a+withTestEnv func =+  withServerPool $ \serverPool ->+    withClientPool $ \client1Pool ->+      withClientPool $ \client2Pool -> do+        let tenv =+              TestEnv+                { testEnvServerPool = serverPool,+                  testEnvClient1Pool = client1Pool,+                  testEnvClient2Pool = client2Pool+                }+        liftIO $ func tenv
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestUtils.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TestUtils+  ( module TestUtils,+    module TestUtils.ServerDB,+    module TestUtils.ClientDB,+  )+where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.GenValidity.Persist ()+import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sqlite+import TestUtils.ClientDB+import TestUtils.ServerDB++withServerPool :: (ConnectionPool -> IO a) -> IO a+withServerPool func =+  runNoLoggingT $+    withSqlitePool ":memory:" 1 $ \serverPool -> do+      flip runSqlPool serverPool $ void $ runMigrationSilent 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
+ test/TestUtils/ClientDB.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestUtils.ClientDB where++import Data.Appendful+import Data.Appendful.Persistent+import Database.Persist.Sql+import Database.Persist.TH+import GHC.Generics (Generic)+import TestUtils.ServerDB++share+  [mkPersist sqlSettings, mkMigrate "migrateClient"]+  [persistLowerCase|++ClientThing+  number Int+  serverId ServerThingId Maybe -- Nothing means it's not been synced++  ClientUniqueServerId serverId !force++  deriving Show+  deriving Eq+  deriving Ord+  deriving Generic++|]++setupUnsyncedClientThingQuery :: [Thing] -> SqlPersistT IO ()+setupUnsyncedClientThingQuery = setupUnsyncedClientQuery makeUnsyncedClientThing++setupClientThingQuery :: ClientStore ClientThingId ServerThingId Thing -> SqlPersistT IO ()+setupClientThingQuery = setupClientQuery makeUnsyncedClientThing makeSyncedClientThing++clientGetStoreThingQuery :: SqlPersistT IO (ClientStore ClientThingId ServerThingId Thing)+clientGetStoreThingQuery = clientGetStoreQuery clientMakeThing ClientThingServerId++clientMakeSyncRequestThingQuery :: SqlPersistT IO (SyncRequest ClientThingId ServerThingId Thing)+clientMakeSyncRequestThingQuery = clientMakeSyncRequestQuery clientMakeThing ClientThingServerId++clientMergeSyncResponseThingQuery :: SyncResponse ClientThingId ServerThingId Thing -> SqlPersistT IO ()+clientMergeSyncResponseThingQuery = clientMergeSyncResponseQuery makeSyncedClientThing ClientThingServerId++makeUnsyncedClientThing :: Thing -> ClientThing+makeUnsyncedClientThing Thing {..} =+  ClientThing+    { clientThingNumber = thingNumber,+      clientThingServerId = Nothing+    }++makeSyncedClientThing :: ServerThingId -> Thing -> ClientThing+makeSyncedClientThing sid Thing {..} =+  ClientThing+    { clientThingNumber = thingNumber,+      clientThingServerId = Just sid+    }++clientMakeThing :: ClientThing -> Thing+clientMakeThing ClientThing {..} = Thing {thingNumber = clientThingNumber}
+ test/TestUtils/ServerDB.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestUtils.ServerDB where++import Data.Appendful+import Data.Appendful.Persistent+import Data.GenValidity+import Database.Persist.Sql+import Database.Persist.TH+import GHC.Generics (Generic)++newtype Thing = Thing+  { thingNumber :: Int+  }+  deriving (Show, Eq, Ord, Generic)++instance Validity Thing++instance GenValid Thing++share+  [mkPersist sqlSettings, mkMigrate "migrateServer"]+  [persistLowerCase|++ServerThing+  number Int++  deriving Show+  deriving Eq+  deriving Ord+  deriving Generic++|]++instance Validity ServerThing++instance GenValid ServerThing++setupServerThingQuery :: ServerStore ServerThingId Thing -> SqlPersistT IO ()+setupServerThingQuery = setupServerQuery makeServerThing++serverGetStoreThingQuery :: SqlPersistT IO (ServerStore ServerThingId Thing)+serverGetStoreThingQuery = serverGetStoreQuery serverMakeThing++serverProcessSyncThingQuery :: Ord cid => SyncRequest cid ServerThingId Thing -> SqlPersistT IO (SyncResponse cid ServerThingId Thing)+serverProcessSyncThingQuery = serverProcessSyncQuery [] serverMakeThing makeServerThing++serverMakeThing :: ServerThing -> Thing+serverMakeThing ServerThing {..} = Thing {thingNumber = serverThingNumber}++makeServerThing :: Thing -> ServerThing+makeServerThing Thing {..} = ServerThing {serverThingNumber = thingNumber}