mergeful-persistent (empty) → 0.0.0.0
raw patch · 8 files changed
+1598/−0 lines, 8 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, genvalidity, genvalidity-hspec, genvalidity-mergeful, genvalidity-persistent, hspec, mergeful, mergeful-persistent, microlens, monad-logger, mtl, path, path-io, persistent, persistent-sqlite, persistent-template, text, validity, validity-persistent
Files
- mergeful-persistent.cabal +75/−0
- src/Data/Mergeful/Persistent.hs +529/−0
- test/Data/Mergeful/Persistent/SingleClientSpec.hs +185/−0
- test/Data/Mergeful/Persistent/TwoClientsSpec.hs +527/−0
- test/Spec.hs +1/−0
- test/TestUtils.hs +36/−0
- test/TestUtils/ClientDB.hs +172/−0
- test/TestUtils/ServerDB.hs +73/−0
+ mergeful-persistent.cabal view
@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d5a70b83d35c180b25e6452adc9f780212cdc2b24a168a7afcf01f3a841af65d++name: mergeful-persistent+version: 0.0.0.0+synopsis: Support for using mergeful from persistent-based databases+homepage: https://github.com/NorfairKing/mergeful#readme+bug-reports: https://github.com/NorfairKing/mergeful/issues+author: Tom Sydney Kerckhove+maintainer: syd.kerckhove@gmail.com+copyright: Copyright: (c) 2020 Tom Sydney Kerckhove+license: MIT+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/mergeful++library+ exposed-modules:+ Data.Mergeful.Persistent+ other-modules:+ Paths_mergeful_persistent+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-redundant-constraints+ build-depends:+ base >=4.11 && <5+ , containers+ , mergeful+ , microlens+ , mtl+ , persistent+ default-language: Haskell2010++test-suite mergeful-persistent-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Mergeful.Persistent.SingleClientSpec+ Data.Mergeful.Persistent.TwoClientsSpec+ TestUtils+ TestUtils.ClientDB+ TestUtils.ServerDB+ Paths_mergeful_persistent+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.11 && <5+ , containers+ , genvalidity+ , genvalidity-hspec+ , genvalidity-mergeful+ , genvalidity-persistent+ , hspec+ , mergeful+ , mergeful-persistent+ , monad-logger+ , mtl+ , path+ , path-io+ , persistent+ , persistent-sqlite+ , persistent-template+ , text+ , validity+ , validity-persistent+ default-language: Haskell2010
+ src/Data/Mergeful/Persistent.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Mergeful.Persistent+ ( -- * Client side+ clientMakeSyncRequestQuery,+ clientMergeSyncResponseQuery,++ -- ** Raw processors+ clientSyncProcessor,++ -- ** Merging+ ItemMergeStrategy (..),+ mergeFromServerStrategy,+ mergeFromClientStrategy,+ mergeUsingCRDTStrategy,++ -- * Server side+ serverProcessSyncQuery,+ serverProcessSyncWithCustomIdQuery,++ -- ** Raw processors+ serverSyncProcessor,+ serverSyncWithCustomIdProcessor,++ -- * Utils++ -- ** Client side+ setupClientQuery,+ clientGetStoreQuery,++ -- ** Server side+ setupServerQuery,+ serverGetStoreQuery,+ )+where++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe+import Data.Mergeful+import Data.Set (Set)+import qualified Data.Set as S+import Database.Persist+import Database.Persist.Sql++deriving instance PersistField ServerTime++deriving instance PersistFieldSql ServerTime++-- | Make a sync request+clientMakeSyncRequestQuery ::+ forall record sid a m.+ ( Ord sid,+ PersistEntity record,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The server id field+ EntityField record (Maybe sid) ->+ -- | The server time field+ EntityField record (Maybe ServerTime) ->+ -- | The changed flag+ EntityField record Bool ->+ -- | The deleted flag+ EntityField record Bool ->+ -- | How to read an unsynced client item+ (record -> a) ->+ -- | How to read a synced client item that's been changed+ (record -> (sid, Timed a)) ->+ -- | How to read a synced or deleted client item+ (record -> (sid, ServerTime)) ->+ SqlPersistT m (SyncRequest (Key record) sid a)+clientMakeSyncRequestQuery+ serverIdField+ serverTimeField+ changedField+ deletedField+ unmakeUnsyncedClientThing+ unmakeSyncedClientThing+ unmakeDeletedClientThing = do+ syncRequestNewItems <-+ M.fromList . map (\(Entity cid r) -> (cid, unmakeUnsyncedClientThing r))+ <$> selectList+ [ serverIdField ==. Nothing,+ serverTimeField ==. Nothing+ ]+ []+ syncRequestKnownItems <-+ M.fromList . map (unmakeDeletedClientThing . entityVal)+ <$> selectList+ [ serverIdField !=. Nothing,+ serverTimeField !=. Nothing,+ changedField ==. False,+ deletedField ==. False+ ]+ []+ syncRequestKnownButChangedItems <-+ M.fromList . map (unmakeSyncedClientThing . entityVal)+ <$> selectList+ [ serverIdField !=. Nothing,+ serverTimeField !=. Nothing,+ changedField ==. True,+ deletedField ==. False+ ]+ []+ syncRequestDeletedItems <-+ M.fromList . map (unmakeDeletedClientThing . entityVal)+ <$> selectList+ [ deletedField ==. True+ ]+ []+ pure SyncRequest {..}++-- Merge a sync response+clientMergeSyncResponseQuery ::+ forall record sid a m.+ ( Ord sid,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The server id field+ EntityField record (Maybe sid) ->+ -- | The server time field+ EntityField record (Maybe ServerTime) ->+ -- | The changed flag+ EntityField record Bool ->+ -- | The deleted flag+ EntityField record Bool ->+ -- | How to build a synced record from a server id and a timed item+ (sid -> Timed a -> record) ->+ -- | How to read a synced record back into a server id and a timed item+ (record -> (sid, Timed a)) ->+ -- | How to update a row with new data+ --+ -- You only need to perform the updates that have anything to do with the data to sync.+ -- The housekeeping updates are already taken care of.+ (a -> [Update record]) ->+ -- | The merge strategy.+ ItemMergeStrategy a ->+ -- | The sync response to merge+ SyncResponse (Key record) sid a ->+ SqlPersistT m ()+clientMergeSyncResponseQuery+ serverIdField+ serverTimeField+ changedField+ deletedField+ makeSyncedClientThing+ unmakeSyncedClientThing+ recordUpdates+ strat =+ mergeSyncResponseCustom strat $+ clientSyncProcessor+ serverIdField+ serverTimeField+ changedField+ deletedField+ makeSyncedClientThing+ unmakeSyncedClientThing+ recordUpdates++clientSyncProcessor ::+ forall record sid a m.+ ( Ord sid,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The server id field+ EntityField record (Maybe sid) ->+ -- | The server time field+ EntityField record (Maybe ServerTime) ->+ -- | The changed flag+ EntityField record Bool ->+ -- | The deleted flag+ EntityField record Bool ->+ -- | How to build a synced record from a server id and a timed item+ (sid -> Timed a -> record) ->+ -- | How to read a synced record back into a server id and a timed item+ (record -> (sid, Timed a)) ->+ -- | How to update a row with new data+ --+ -- You only need to perform the updates that have anything to do with the data to sync.+ -- The housekeeping updates are already taken care of.+ (a -> [Update record]) ->+ ClientSyncProcessor (Key record) sid a (SqlPersistT m)+clientSyncProcessor+ serverIdField+ serverTimeField+ changedField+ deletedField+ makeSyncedClientThing+ unmakeSyncedClientThing+ recordUpdates = ClientSyncProcessor {..}+ where+ clientSyncProcessorQuerySyncedButChangedValues :: Set sid -> SqlPersistT m (Map sid (Timed a))+ clientSyncProcessorQuerySyncedButChangedValues si = fmap (M.fromList . map (\(Entity _ r) -> unmakeSyncedClientThing r) . catMaybes) $ forM (S.toList si) $ \sid ->+ selectFirst+ [ serverIdField ==. Just sid,+ serverTimeField !=. Nothing,+ changedField ==. True,+ deletedField ==. False+ ]+ []+ clientSyncProcessorSyncClientAdded :: Map (Key record) (ClientAddition sid) -> SqlPersistT m ()+ clientSyncProcessorSyncClientAdded m = forM_ (M.toList m) $ \(cid, ClientAddition {..}) ->+ update+ cid+ [ serverIdField =. Just clientAdditionId,+ serverTimeField =. Just clientAdditionServerTime+ ]+ clientSyncProcessorSyncClientChanged :: Map sid ServerTime -> SqlPersistT m ()+ clientSyncProcessorSyncClientChanged m = forM_ (M.toList m) $ \(sid, st) ->+ updateWhere+ [serverIdField ==. Just sid]+ [ serverTimeField =. Just st,+ changedField =. False+ ]+ clientSyncProcessorSyncClientDeleted :: Set sid -> SqlPersistT m ()+ clientSyncProcessorSyncClientDeleted s = forM_ (S.toList s) $ \sid ->+ deleteWhere [serverIdField ==. Just sid]+ clientSyncProcessorSyncMergedConflict :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncMergedConflict m = forM_ (M.toList m) $ \(sid, Timed a st) ->+ updateWhere+ [serverIdField ==. Just sid]+ $ [ serverTimeField =. Just st,+ changedField =. True+ ]+ ++ recordUpdates a+ clientSyncProcessorSyncServerAdded :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncServerAdded m =+ insertMany_ $ map (uncurry makeSyncedClientThing) (M.toList m)+ clientSyncProcessorSyncServerChanged :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncServerChanged m = forM_ (M.toList m) $ \(sid, Timed a st) -> do+ updateWhere+ [serverIdField ==. Just sid]+ $ [ serverTimeField =. Just st,+ changedField =. False+ ]+ ++ recordUpdates a+ clientSyncProcessorSyncServerDeleted :: Set sid -> SqlPersistT m ()+ clientSyncProcessorSyncServerDeleted s = forM_ (S.toList s) $ \sid ->+ deleteWhere [serverIdField ==. Just sid]++-- | Set up a client store.+--+-- You shouldn't need this.+setupClientQuery ::+ forall record sid a m.+ ( PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ (a -> record) ->+ (sid -> Timed a -> record) ->+ (sid -> Timed a -> record) ->+ (sid -> ServerTime -> record) ->+ ClientStore (Key record) sid a ->+ SqlPersistT m ()+setupClientQuery makeUnsyncedClientThing makeSyncedClientThing makeSyncedButChangedClientThing makeDeletedClientThing ClientStore {..} = do+ forM_ (M.toList clientStoreAddedItems) $ \(cid, t) ->+ insertKey cid $ makeUnsyncedClientThing t+ forM_ (M.toList clientStoreSyncedItems) $ \(sid, tt) ->+ insert_ $ makeSyncedClientThing sid tt+ forM_ (M.toList clientStoreSyncedButChangedItems) $ \(sid, tt) ->+ insert_ $ makeSyncedButChangedClientThing sid tt+ forM_ (M.toList clientStoreDeletedItems) $ \(sid, st) -> insert_ $ makeDeletedClientThing sid st++-- | Get the client store.+--+-- You shouldn't need this.+clientGetStoreQuery ::+ forall record sid a m.+ ( Ord sid,+ PersistEntity record,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ EntityField record (Maybe sid) ->+ EntityField record (Maybe ServerTime) ->+ EntityField record Bool ->+ EntityField record Bool ->+ (record -> a) ->+ (record -> (sid, Timed a)) ->+ (record -> (sid, ServerTime)) ->+ SqlPersistT m (ClientStore (Key record) sid a)+clientGetStoreQuery+ serverIdField+ serverTimeField+ changedField+ deletedField+ unmakeUnsyncedClientThing+ unmakeSyncedClientThing+ unmakeDeletedClientThing = do+ clientStoreAddedItems <-+ M.fromList . map (\(Entity cid cr) -> (cid, unmakeUnsyncedClientThing cr))+ <$> selectList+ [ serverIdField ==. Nothing,+ serverTimeField ==. Nothing+ ]+ []+ clientStoreSyncedItems <-+ M.fromList . map (unmakeSyncedClientThing . entityVal)+ <$> selectList+ [ serverIdField !=. Nothing,+ serverTimeField !=. Nothing,+ changedField ==. False,+ deletedField ==. False+ ]+ []+ clientStoreSyncedButChangedItems <-+ M.fromList . map (unmakeSyncedClientThing . entityVal)+ <$> selectList+ [ serverIdField !=. Nothing,+ serverTimeField !=. Nothing,+ changedField ==. True,+ deletedField ==. False+ ]+ []+ clientStoreDeletedItems <-+ M.fromList . map (unmakeDeletedClientThing . entityVal)+ <$> selectList+ [ deletedField ==. True+ ]+ []+ pure ClientStore {..}++-- | Process a sync request on the server side+serverProcessSyncQuery ::+ forall cid record a m.+ ( PersistEntity record,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The server time field+ EntityField record ServerTime ->+ -- | The filters to select the relevant records+ --+ -- Use this if you want per-user syncing+ [Filter record] ->+ -- | How to load an item from the database+ (record -> Timed a) ->+ -- | How to add an item in the database with initial server time+ (a -> record) ->+ -- | How to update a record given new data+ (a -> [Update record]) ->+ -- | A sync request+ SyncRequest cid (Key record) a ->+ SqlPersistT m (SyncResponse cid (Key record) a)+serverProcessSyncQuery+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates =+ processServerSyncCustom $+ serverSyncProcessor+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates++serverSyncProcessor ::+ forall cid record a m.+ ( PersistEntity record,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The server time field+ EntityField record ServerTime ->+ -- | The filters to select the relevant records+ --+ -- Use this if you want per-user syncing+ [Filter record] ->+ -- | How to load an item from the database+ (record -> Timed a) ->+ -- | How to add an item in the database with initial server time+ (a -> record) ->+ -- | How to update a record given new data+ (a -> [Update record]) ->+ ServerSyncProcessor cid (Key record) a (SqlPersistT m)+serverSyncProcessor+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates =+ ServerSyncProcessor {..} :: ServerSyncProcessor cid (Key record) a (SqlPersistT m)+ where+ serverSyncProcessorRead = M.fromList . map (\(Entity i r) -> (i, unmakeFunc r)) <$> selectList filters []+ serverSyncProcessorAddItem = insert . makeFunc+ serverSyncProcessorChangeItem si st a = update si $ (serverTimeField =. st) : recordUpdates a+ serverSyncProcessorDeleteItem = delete++-- | Process a sync request on the server side with a custom id field+--+-- You can use this function if you want to use a UUID as your id instead of the sqlkey of the item.+serverProcessSyncWithCustomIdQuery ::+ forall cid sid record a m.+ ( Ord sid,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The custom id field+ EntityField record sid ->+ -- | The generator to generate the custom id field+ SqlPersistT m sid ->+ -- | The server time field+ EntityField record ServerTime ->+ -- | The filters to select the relevant records+ --+ -- Use this if you want per-user syncing+ [Filter record] ->+ -- | How to load an item from the database+ (record -> (sid, Timed a)) ->+ -- | How to add an item in the database with initial server time+ (sid -> a -> record) ->+ -- | How to update a record given new data+ (a -> [Update record]) ->+ -- | A sync request+ SyncRequest cid sid a ->+ SqlPersistT m (SyncResponse cid sid a)+serverProcessSyncWithCustomIdQuery+ idField+ uuidGen+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates =+ processServerSyncCustom $+ serverSyncWithCustomIdProcessor+ idField+ uuidGen+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates++serverSyncWithCustomIdProcessor ::+ forall cid sid record a m.+ ( Ord sid,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ ToBackendKey SqlBackend record,+ MonadIO m+ ) =>+ -- | The custom id field+ EntityField record sid ->+ -- | The generator to generate the custom id field+ SqlPersistT m sid ->+ -- | The server time field+ EntityField record ServerTime ->+ -- | The filters to select the relevant records+ --+ -- Use this if you want per-user syncing+ [Filter record] ->+ -- | How to load an item from the database+ (record -> (sid, Timed a)) ->+ -- | How to add an item in the database with 'initialServerTime'+ (sid -> a -> record) ->+ -- | How to update a record given new data+ (a -> [Update record]) ->+ ServerSyncProcessor cid sid a (SqlPersistT m)+serverSyncWithCustomIdProcessor+ idField+ uuidGen+ serverTimeField+ filters+ unmakeFunc+ makeFunc+ recordUpdates = ServerSyncProcessor {..} :: ServerSyncProcessor cid sid a (SqlPersistT m)+ where+ serverSyncProcessorRead = M.fromList . map (\(Entity _ record) -> unmakeFunc record) <$> selectList filters []+ serverSyncProcessorAddItem a = do+ uuid <- uuidGen+ insert_ $ makeFunc uuid a+ pure uuid+ serverSyncProcessorChangeItem si st a = updateWhere [idField ==. si] $ (serverTimeField =. st) : recordUpdates a+ serverSyncProcessorDeleteItem si = deleteWhere [idField ==. si]++-- | Set up the server store+--+-- You shouldn't need this.+setupServerQuery ::+ forall sid record a.+ ( PersistEntity record,+ PersistEntityBackend record ~ SqlBackend+ ) =>+ (sid -> Timed a -> Entity record) ->+ ServerStore sid a ->+ SqlPersistT IO ()+setupServerQuery func ServerStore {..} =+ forM_ (M.toList serverStoreItems) $ \(sid, tt) ->+ let (Entity k r) = func sid tt+ in insertKey k r++-- | Get the server store+--+-- You shouldn't need this.+serverGetStoreQuery ::+ ( Ord sid,+ PersistEntity record,+ PersistEntityBackend record ~ SqlBackend+ ) =>+ (Entity record -> (sid, Timed a)) ->+ SqlPersistT IO (ServerStore sid a)+serverGetStoreQuery func = ServerStore . M.fromList . map func <$> selectList [] []
+ test/Data/Mergeful/Persistent/SingleClientSpec.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Mergeful.Persistent.SingleClientSpec+ ( spec,+ )+where++import Control.Monad.Reader+import Data.List+import qualified Data.Map as M+import Data.Mergeful+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) $ 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 "mergeFromServerStrategy" $ do+ let strat = mergeFromServerStrategy+ mergeFunctionSpec strat+ emptyResponseSpec strat+ describe "mergeFromClientStrategy" $ do+ let strat = mergeFromClientStrategy+ mergeFunctionSpec strat+ xdescribe "does not hold" $ emptyResponseSpec strat+ describe "mergeUsingCRDTStrategy" $ do+ let strat = mergeUsingCRDTStrategy max+ mergeFunctionSpec strat+ emptyResponseSpec strat++mergeFunctionSpec :: ItemMergeStrategy Thing -> SpecWith TestEnv+mergeFunctionSpec strat = do+ let mergeFunc = clientMergeSyncResponse strat+ describe "Single Client" $ do+ describe "Single item" $ do+ it "succesfully downloads an item from the server for an empty client" $ \te ->+ forAllValid $ \uuid ->+ forAllValid $ \tst -> runTest te $ do+ let sstore1 = ServerStore $ M.singleton uuid tst+ setupClient initialClientStore+ setupServer sstore1+ req <- clientMakeSyncRequest+ resp <- serverProcessSync req+ sstore2 <- serverGetStore+ mergeFunc resp+ cstore2 <- clientGetStore+ lift $ do+ sstore2 `shouldBe` sstore1+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads an item to the server for an empty server" $ \te ->+ forAllValid $ \cid ->+ forAllValid $ \t ->+ runTest te $ do+ let cstore1 = initialClientStore {clientStoreAddedItems = M.singleton cid t}+ let sstore1 = initialServerStore+ setupClient cstore1+ setupServer sstore1+ req <- clientMakeSyncRequest+ resp <- serverProcessSync req+ sstore2 <- serverGetStore+ mergeFunc resp+ cstore2 <- clientGetStore+ lift $ do+ sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2)))+ `shouldBe` sort [t]+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+ describe "Multiple items" $ do+ it "succesfully downloads an item from the server for an empty client" $ \te ->+ forAllValid $ \sstore1 -> runTest te $ do+ setupClient initialClientStore+ setupServer sstore1+ req <- clientMakeSyncRequest+ resp <- serverProcessSync req+ sstore2 <- serverGetStore+ mergeFunc resp+ cstore2 <- clientGetStore+ lift $ do+ sstore2 `shouldBe` sstore1+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2+ it "succesfully uploads everything to the server for an empty server" $ \te ->+ forAllValid $ \items ->+ runTest te $ do+ let cstore1 = initialClientStore {clientStoreAddedItems = items}+ let sstore1 = initialServerStore+ setupClient cstore1+ setupServer sstore1+ req <- clientMakeSyncRequest+ resp <- serverProcessSync req+ sstore2 <- serverGetStore+ mergeFunc resp+ cstore2 <- clientGetStore+ lift $ do+ sort (M.elems (M.map timedValue (clientStoreSyncedItems cstore2)))+ `shouldBe` sort (M.elems items)+ clientStoreSyncedItems cstore2 `shouldBe` serverStoreItems sstore2++emptyResponseSpec :: ItemMergeStrategy Thing -> SpecWith TestEnv+emptyResponseSpec strat = do+ let mergeFunc = clientMergeSyncResponse strat+ it "is returns an empty response on the second sync with no modifications" $ \te -> forAllValid $ \cstore1 -> forAllValid $ \sstore1 ->+ runTest te $ do+ setupClient cstore1+ setupServer sstore1+ req1 <- clientMakeSyncRequest+ resp1 <- serverProcessSync req1+ mergeFunc resp1+ req2 <- clientMakeSyncRequest+ resp2 <- serverProcessSync req2+ lift $ resp2 `shouldBe` emptySyncResponse++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++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 :: ItemMergeStrategy Thing -> SResp -> T ()+clientMergeSyncResponse strat = runClientDB . clientMergeSyncResponseThingQuery strat++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/Mergeful/Persistent/TwoClientsSpec.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Mergeful.Persistent.TwoClientsSpec+ ( spec,+ )+where++import Control.Monad.Reader+import qualified Data.Map as M+import Data.Mergeful+import qualified Data.Set as S+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 "mergeFromServerStrategy" $ do+ let strat = mergeFromServerStrategy+ mergeFunctionSpec strat+ noDivergenceSpec strat+ xdescribe "Does not hold" $ noDataLossSpec strat+ describe "mergeFromClientStrategy" $ do+ let strat = mergeFromClientStrategy+ mergeFunctionSpec strat+ noDataLossSpec strat+ xdescribe "Does not hold" $ noDivergenceSpec strat+ describe "mergeUsingCRDTStrategy" $ do+ let strat = mergeUsingCRDTStrategy max+ mergeFunctionSpec strat+ noDataLossSpec strat+ noDivergenceSpec strat++mergeFunctionSpec :: ItemMergeStrategy Thing -> SpecWith TestEnv+mergeFunctionSpec strat = do+ let mergeFunc = clientMergeSyncResponse strat+ describe "Multiple clients" $ do+ describe "Single item" $ do+ it "successfully syncs an addition accross to a second client" $ \te -> forAllValid $ \k -> forAllValid $ \i -> runTest te $ do+ -- Client A has one item+ setupClient A $ initialClientStore {clientStoreAddedItems = M.singleton k i}+ -- Client B is empty+ setupClient B initialClientStore+ -- The server is empty+ setupServer initialServerStore+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ let addedItems = syncResponseClientAdded resp1+ case M.toList addedItems of+ [(k', ClientAddition uuid st)] -> do+ lift $ k' `shouldBe` k+ let time = initialServerTime+ lift $ st `shouldBe` time+ let items = M.singleton uuid (Timed i st)+ lift $ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ mergeFunc B resp2+ cBstore2 <- clientGetStore B+ lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ _ ->+ lift $+ expectationFailure+ "Should have found exactly one added item."+ it "successfully syncs a modification accross to a second client" $ \te -> forAllValid $ \uuid -> forAllValid $ \i -> forAllValid $ \j -> forAllValid $ \time1 ->+ runTest te $ do+ -- Client A has a synced item.+ setupClient A $+ initialClientStore+ { clientStoreSyncedItems = M.singleton uuid (Timed i time1)+ }+ -- Client B had synced that same item, but has since modified it+ setupClient B $+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed j time1)+ }+ -- The server is has the item that both clients had before+ setupServer $ ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+ -- Client B makes sync request 1+ req1 <- clientMakeSyncRequest B+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ let time2 = incrementServerTime time1+ lift $ do+ resp1+ `shouldBe` emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2}+ sstore2+ `shouldBe` ServerStore {serverStoreItems = M.singleton uuid (Timed j time2)}+ -- Client B merges the response+ mergeFunc B resp1+ cBstore2 <- clientGetStore B+ lift $+ cBstore2+ `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+ -- Client A makes sync request 2+ req2 <- clientMakeSyncRequest A+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2+ `shouldBe` emptySyncResponse+ { syncResponseServerChanged = M.singleton uuid (Timed j time2)+ }+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ mergeFunc A resp2+ cAstore2 <- clientGetStore A+ lift $+ cAstore2+ `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed j time2)}+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs a deletion across to a second client" $ \te -> forAllValid $ \uuid -> forAllValid $ \time1 -> forAllValid $ \i ->+ runTest te $ do+ setupClient A $+ initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i time1)}+ -- Client A has a synced item.+ -- Client B had synced that same item, but has since deleted it.+ setupClient B $ initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+ -- The server still has the undeleted item+ setupServer $ ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+ -- Client B makes sync request 1+ req1 <- clientMakeSyncRequest B+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ lift $ do+ resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = S.singleton uuid}+ sstore2 `shouldBe` initialServerStore+ -- Client B merges the response+ mergeFunc B resp1+ cBstore2 <- clientGetStore B+ lift $ cBstore2 `shouldBe` initialClientStore+ -- Client A makes sync request 2+ req2 <- clientMakeSyncRequest A+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = S.singleton uuid}+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ mergeFunc A resp2+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $ \te -> forAllValid $ \uuid -> forAllValid $ \time1 -> forAllValid $ \i ->+ runTest te $ do+ setupClient A $ initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+ -- Both client a and client b delete an item.+ setupClient B $ initialClientStore {clientStoreDeletedItems = M.singleton uuid time1}+ -- The server still has the undeleted item+ setupServer $ ServerStore {serverStoreItems = M.singleton uuid (Timed i time1)}+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ lift $ do+ resp1+ `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ sstore2 `shouldBe` (ServerStore {serverStoreItems = M.empty})+ -- Client A merges the response+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2+ `shouldBe` (emptySyncResponse {syncResponseClientDeleted = S.singleton uuid})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ mergeFunc B resp2+ cBstore2 <- clientGetStore B+ lift $ do+ cBstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2+ describe "Multiple items" $ do+ it "successfully syncs additions accross to a second client" $ \te -> forAllValid $ \is ->+ runTest te $ do+ setupClient A $ initialClientStore {clientStoreAddedItems = is}+ -- Client B is empty+ setupClient B initialClientStore+ -- The server is empty+ setupServer initialServerStore+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ let (rest, items) = mergeAddedItems is (syncResponseClientAdded resp1)+ lift $ do+ rest `shouldBe` M.empty+ sstore2 `shouldBe` (ServerStore {serverStoreItems = items})+ -- Client A merges the response+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseServerAdded = items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ mergeFunc B resp2+ cBstore2 <- clientGetStore B+ lift $ cBstore2 `shouldBe` (initialClientStore {clientStoreSyncedItems = items})+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "succesfully syncs deletions across to a second client" $ \te -> forAllValid $ \items -> forAllValid $ \time1 ->+ runTest te $ do+ let syncedItems = M.map (\i -> Timed i time1) items+ itemTimes = M.map (const time1) items+ itemIds = M.keysSet items+ setupClient A $ initialClientStore {clientStoreSyncedItems = syncedItems}+ -- Client A has synced items+ -- Client B had synced the same items, but has since deleted them.+ setupClient B $ initialClientStore {clientStoreDeletedItems = itemTimes}+ -- 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+ lift $ do+ resp1 `shouldBe` emptySyncResponse {syncResponseClientDeleted = itemIds}+ sstore2 `shouldBe` initialServerStore+ -- Client B merges the response+ mergeFunc B resp1+ cBstore2 <- clientGetStore B+ lift $ cBstore2 `shouldBe` initialClientStore+ -- Client A makes sync request 2+ req2 <- clientMakeSyncRequest A+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2 `shouldBe` emptySyncResponse {syncResponseServerDeleted = itemIds}+ sstore3 `shouldBe` sstore2+ -- Client A merges the response+ mergeFunc A resp2+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ lift $ cAstore2 `shouldBe` cBstore2+ it "does not run into a conflict if two clients both try to sync a deletion" $ \te -> forAllValid $ \items -> forAllValid $ \time1 ->+ runTest te $ do+ setupClient A $+ initialClientStore {clientStoreDeletedItems = M.map (const time1) items}+ -- Both client a and client b delete their items.+ setupClient B $+ initialClientStore {clientStoreDeletedItems = M.map (const time1) items}+ -- The server still has the undeleted items+ setupServer $ ServerStore {serverStoreItems = M.map (\i -> Timed i time1) items}+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ lift $ 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+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ lift $ cAstore2 `shouldBe` initialClientStore+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ lift $ do+ resp2 `shouldBe` (emptySyncResponse {syncResponseClientDeleted = M.keysSet items})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ mergeFunc B resp2+ cBstore2 <- clientGetStore B+ lift $ do+ cBstore2 `shouldBe` initialClientStore+ -- Client A and Client B now have the same store+ cAstore2 `shouldBe` cBstore2++noDataLossSpec ::+ ItemMergeStrategy Thing ->+ SpecWith TestEnv+noDataLossSpec strat = do+ let mergeFunc = clientMergeSyncResponse strat+ it "does not lose data after a conflict occurs" $ \te -> forAllValid $ \uuid -> forAllValid $ \time1 -> forAllValid $ \i1 -> forAllValid $ \i2 -> forAllValid $ \i3 ->+ runTest te $ do+ setupServer $ ServerStore {serverStoreItems = M.singleton uuid (Timed i1 time1)}+ -- The server has an item+ -- The first client has synced it, and modified it.+ setupClient A $+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i2 time1)+ }+ -- The second client has synced it too, and modified it too.+ setupClient B $+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)+ }+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ let time2 = incrementServerTime time1+ -- The server updates the item accordingly+ lift $ do+ resp1+ `shouldBe` (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+ sstore2+ `shouldBe` (ServerStore {serverStoreItems = M.singleton uuid (Timed i2 time2)})+ -- Client A merges the response+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ lift $+ cAstore2+ `shouldBe` (initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed i2 time2)})+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ -- The server reports a conflict and does not change its store+ lift $ do+ resp2+ `shouldBe` (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed i2 time2)})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ clientMergeSyncResponse mergeFromClientStrategy B resp2+ cBstore2 <- clientGetStore B+ -- Client does not update, but keeps its conflict+ -- Client A and Client B now *do not* have the same store+ lift $+ cBstore2+ `shouldBe` ( initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed i3 time1)+ }+ )++noDivergenceSpec :: ItemMergeStrategy Thing -> SpecWith TestEnv+noDivergenceSpec strat = do+ let mergeFunc = clientMergeSyncResponse strat+ it "does not diverge after a conflict occurs" $ \te ->+ forAllValid $ \uuid -> forAllValid $ \time1 -> forAllValid $ \iS -> forAllValid $ \iA ->+ forAllValid $ \iB ->+ runTest te $ do+ setupServer $ ServerStore {serverStoreItems = M.singleton uuid (Timed iS time1)}+ -- The server has an item+ -- The first client has synced it, and modified it.+ setupClient A $+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iA time1)+ }+ -- The second client has synced it too, and modified it too.+ setupClient B $+ initialClientStore+ { clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)+ }+ -- Client A makes sync request 1+ req1 <- clientMakeSyncRequest A+ -- The server processes sync request 1+ resp1 <- serverProcessSync req1+ sstore2 <- serverGetStore+ let time2 = incrementServerTime time1+ -- The server updates the item accordingly+ lift $ do+ resp1+ `shouldBe` (emptySyncResponse {syncResponseClientChanged = M.singleton uuid time2})+ sstore2+ `shouldBe` (ServerStore {serverStoreItems = M.singleton uuid (Timed iA time2)})+ -- Client A merges the response+ mergeFunc A resp1+ cAstore2 <- clientGetStore A+ -- Client A has the item from the server because there was no conflict.+ lift $+ cAstore2+ `shouldBe` initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA time2)}+ -- Client B makes sync request 2+ req2 <- clientMakeSyncRequest B+ -- The server processes sync request 2+ resp2 <- serverProcessSync req2+ sstore3 <- serverGetStore+ -- The server reports a conflict and does not change its store+ lift $ do+ resp2+ `shouldBe` (emptySyncResponse {syncResponseConflicts = M.singleton uuid (Timed iA time2)})+ sstore3 `shouldBe` sstore2+ -- Client B merges the response+ mergeFunc B resp2+ cBstore2 <- clientGetStore B+ lift $ do+ let expected = case itemMergeStrategyMergeChangeConflict strat iB iA of+ KeepLocal -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed iB time1)}+ TakeRemote -> initialClientStore {clientStoreSyncedItems = M.singleton uuid (Timed iA time2)}+ Merged im -> initialClientStore {clientStoreSyncedButChangedItems = M.singleton uuid (Timed im time2)}+ cBstore2+ `shouldBe` expected+ -- In case of a previous merge, the synced item will still be changed, so we need to sync again with B and then with A+ req3 <- clientMakeSyncRequest B+ resp3 <- serverProcessSync req3+ mergeFunc B resp3+ cBstore3 <- clientGetStore B+ req4 <- clientMakeSyncRequest A+ resp4 <- serverProcessSync req4+ mergeFunc A resp4+ cAstore3 <- clientGetStore A+ lift $+ cBstore3 `shouldBe` cAstore3++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++setupClient :: Client -> CS -> T ()+setupClient client = runClientDB client . setupClientThingQuery++setupServer :: SS -> T ()+setupServer = runServerDB . setupServerThingQuery++clientGetStore :: Client -> T CS+clientGetStore client = runClientDB client clientGetStoreThingQuery++clientMakeSyncRequest :: Client -> T SReq+clientMakeSyncRequest client = runClientDB client clientMakeSyncRequestThingQuery++serverGetStore :: T SS+serverGetStore = runServerDB serverGetStoreThingQuery++serverProcessSync :: SReq -> T SResp+serverProcessSync = runServerDB . serverProcessSyncThingQuery++clientMergeSyncResponse :: ItemMergeStrategy Thing -> Client -> SResp -> T ()+clientMergeSyncResponse strat client = runClientDB client . clientMergeSyncResponseThingQuery strat++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,36 @@+{-# 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,172 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestUtils.ClientDB where++import Data.Maybe+import Data.Mergeful+import Data.Mergeful.Persistent+import Data.Validity+import Data.Validity.Persist ()+import Database.Persist.Sql+import Database.Persist.TH+import GHC.Generics (Generic)+import TestUtils.ServerDB++share+ [mkPersist sqlSettings, mkMigrate "migrateClient"]+ [persistLowerCase|++ClientThing+ -- All the fields of 'Thing' go here.+ number Int+ serverId ServerThingId Maybe -- Nothing means it's not been synced+ serverTime ServerTime Maybe -- Nothing means it's not been synced+ deleted Bool -- True means this item has been tombstoned, and it must have been synced before.+ changed Bool -- True means it's been changed after it's been synced, it must have been synced before.++ ClientUniqueServerId serverId !force++ deriving Show+ deriving Eq+ deriving Ord+ deriving Generic++|]++instance Validity ClientThing where+ validate ct@ClientThing {..} =+ mconcat+ [ genericValidate ct,+ declare "The server id and time are either both Nothing or both Just" $ case (clientThingServerId, clientThingServerTime) of+ (Nothing, Nothing) -> True+ (Just _, Just _) -> True+ (Just _, Nothing) -> True+ (Nothing, Just _) -> True,+ declare "If it has been deleted, then it must have been synced" $+ if clientThingDeleted+ then isJust clientThingServerId+ else True,+ declare+ "If it has been changed, then it must have been synced before"+ $ if clientThingChanged+ then isJust clientThingServerId+ else True+ ]++setupUnsyncedClientQuery :: [Thing] -> SqlPersistT IO ()+setupUnsyncedClientQuery = mapM_ $ \Thing {..} ->+ insert_+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingServerId = Nothing,+ clientThingServerTime = Nothing,+ clientThingDeleted = False,+ clientThingChanged = False+ }++setupClientThingQuery :: ClientStore ClientThingId ServerThingId Thing -> SqlPersistT IO ()+setupClientThingQuery = setupClientQuery makeUnsyncedClientThing makeSyncedClientThing makeSyncedButChangedClientThing makeDeletedClientThing++clientGetStoreThingQuery :: SqlPersistT IO (ClientStore ClientThingId ServerThingId Thing)+clientGetStoreThingQuery =+ clientGetStoreQuery+ ClientThingServerId+ ClientThingServerTime+ ClientThingChanged+ ClientThingDeleted+ unmakeUnsyncedClientThing+ unmakeSyncedClientThing+ unmakeDeletedClientThing++clientMakeSyncRequestThingQuery :: SqlPersistT IO (SyncRequest ClientThingId ServerThingId Thing)+clientMakeSyncRequestThingQuery =+ clientMakeSyncRequestQuery+ ClientThingServerId+ ClientThingServerTime+ ClientThingChanged+ ClientThingDeleted+ unmakeUnsyncedClientThing+ unmakeSyncedClientThing+ unmakeDeletedClientThing++clientMergeSyncResponseThingQuery :: ItemMergeStrategy Thing -> SyncResponse ClientThingId ServerThingId Thing -> SqlPersistT IO ()+clientMergeSyncResponseThingQuery =+ clientMergeSyncResponseQuery+ ClientThingServerId+ ClientThingServerTime+ ClientThingChanged+ ClientThingDeleted+ makeSyncedClientThing+ unmakeSyncedClientThing+ clientThingRecordUpdates++unmakeUnsyncedClientThing :: ClientThing -> Thing+unmakeUnsyncedClientThing ClientThing {..} = Thing {thingNumber = clientThingNumber}++makeUnsyncedClientThing :: Thing -> ClientThing+makeUnsyncedClientThing Thing {..} =+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingDeleted = False,+ clientThingServerId = Nothing,+ clientThingChanged = False,+ clientThingServerTime = Nothing+ }++unmakeSyncedClientThing :: ClientThing -> (ServerThingId, Timed Thing)+unmakeSyncedClientThing ClientThing {..} =+ ( fromJust clientThingServerId,+ Timed+ { timedValue = Thing {thingNumber = clientThingNumber},+ timedTime = fromJust clientThingServerTime+ }+ )++makeSyncedClientThing :: ServerThingId -> Timed Thing -> ClientThing+makeSyncedClientThing sid (Timed Thing {..} st) =+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingServerId = Just sid,+ clientThingServerTime = Just st,+ clientThingChanged = False,+ clientThingDeleted = False+ }++makeSyncedButChangedClientThing :: ServerThingId -> Timed Thing -> ClientThing+makeSyncedButChangedClientThing sid (Timed Thing {..} st) =+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingServerId = Just sid,+ clientThingServerTime = Just st,+ clientThingChanged = True,+ clientThingDeleted = False+ }++unmakeDeletedClientThing :: ClientThing -> (ServerThingId, ServerTime)+unmakeDeletedClientThing ClientThing {..} =+ (fromJust clientThingServerId, fromJust clientThingServerTime)++makeDeletedClientThing :: ServerThingId -> ServerTime -> ClientThing+makeDeletedClientThing sid st =+ ClientThing+ { clientThingNumber = 0, -- dummy+ clientThingServerId = Just sid,+ clientThingServerTime = Just st,+ clientThingChanged = False, -- dummy+ clientThingDeleted = True+ }++clientMakeThing :: ClientThing -> Thing+clientMakeThing ClientThing {..} = Thing {thingNumber = clientThingNumber}++clientThingRecordUpdates :: Thing -> [Update ClientThing]+clientThingRecordUpdates Thing {..} = [ClientThingNumber =. thingNumber]
+ test/TestUtils/ServerDB.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestUtils.ServerDB where++import Data.GenValidity+import Data.GenValidity.Mergeful ()+import Data.Mergeful+import Data.Mergeful.Persistent+import Database.Persist.Sql+import Database.Persist.TH+import GHC.Generics (Generic)++-- The thing that we'll synchronise on+newtype Thing = Thing {thingNumber :: Int}+ deriving (Show, Eq, Ord, Generic)++instance Validity Thing++instance GenUnchecked Thing++instance GenValid Thing++share+ [mkPersist sqlSettings, mkMigrate "migrateServer"]+ [persistLowerCase|++ServerThing+ -- All the fields of 'Thing' go here.+ number Int+ time ServerTime++ deriving Show+ deriving Eq+ deriving Ord+ deriving Generic++|]++instance Validity ServerThing++instance GenUnchecked ServerThing++instance GenValid ServerThing++setupServerThingQuery :: ServerStore ServerThingId Thing -> SqlPersistT IO ()+setupServerThingQuery = setupServerQuery serverUnmakeThing++serverGetStoreThingQuery :: SqlPersistT IO (ServerStore ServerThingId Thing)+serverGetStoreThingQuery = serverGetStoreQuery (\(Entity sid sr) -> (sid, serverMakeThing sr))++serverProcessSyncThingQuery :: forall ci. Ord ci => SyncRequest ci ServerThingId Thing -> SqlPersistT IO (SyncResponse ci ServerThingId Thing)+serverProcessSyncThingQuery = serverProcessSyncQuery ServerThingTime [] serverMakeThing thingToServer serverRecordUpdates++serverMakeThing :: ServerThing -> Timed Thing+serverMakeThing ServerThing {..} = Timed {timedValue = Thing {thingNumber = serverThingNumber}, timedTime = serverThingTime}++serverUnmakeThing :: ServerThingId -> Timed Thing -> Entity ServerThing+serverUnmakeThing sid Timed {..} = Entity sid $ ServerThing {serverThingNumber = thingNumber timedValue, serverThingTime = timedTime}++serverRecordUpdates :: Thing -> [Update ServerThing]+serverRecordUpdates Thing {..} = [ServerThingNumber =. thingNumber]++thingToServer :: Thing -> ServerThing+thingToServer Thing {..} = ServerThing {serverThingTime = initialServerTime, serverThingNumber = thingNumber}