mergeless-persistent (empty) → 0.0.0.0
raw patch · 8 files changed
+1118/−0 lines, 8 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, genvalidity, genvalidity-hspec, genvalidity-mergeless, genvalidity-persistent, hspec, mergeless, mergeless-persistent, microlens, monad-logger, mtl, path, path-io, persistent, persistent-sqlite, persistent-template, text, validity
Files
- mergeless-persistent.cabal +73/−0
- src/Data/Mergeless/Persistent.hs +332/−0
- test/Data/Mergeless/Persistent/SingleClientSpec.hs +165/−0
- test/Data/Mergeless/Persistent/TwoClientsSpec.hs +367/−0
- test/Spec.hs +1/−0
- test/TestUtils.hs +36/−0
- test/TestUtils/ClientDB.hs +79/−0
- test/TestUtils/ServerDB.hs +65/−0
+ mergeless-persistent.cabal view
@@ -0,0 +1,73 @@+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: 01b770a80d2be35f4a16d54d3e4100ecb434a544256ffd9ee5b3c27d6fee8657++name: mergeless-persistent+version: 0.0.0.0+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+license: MIT+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/mergeless++library+ exposed-modules:+ Data.Mergeless.Persistent+ other-modules:+ Paths_mergeless_persistent+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-redundant-constraints+ build-depends:+ base >=4.11 && <5+ , containers+ , mergeless+ , microlens+ , persistent+ default-language: Haskell2010++test-suite mergeless-persistent-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Mergeless.Persistent.SingleClientSpec+ Data.Mergeless.Persistent.TwoClientsSpec+ TestUtils+ TestUtils.ClientDB+ TestUtils.ServerDB+ Paths_mergeless_persistent+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.11 && <5+ , containers+ , genvalidity+ , genvalidity-hspec+ , genvalidity-mergeless+ , genvalidity-persistent+ , hspec+ , mergeless+ , mergeless-persistent+ , monad-logger+ , mtl+ , path+ , path-io+ , persistent+ , persistent-sqlite+ , persistent-template+ , text+ , validity+ default-language: Haskell2010
+ src/Data/Mergeless/Persistent.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Mergeless.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 qualified Data.Map as M+import Data.Maybe+import Data.Mergeless+import qualified Data.Set as S+import Database.Persist+import Database.Persist.Sql+import Lens.Micro++-- | Make a sync request on the client side+clientMakeSyncRequestQuery ::+ ( Ord sid,+ PersistEntity clientRecord,+ PersistField sid,+ PersistEntityBackend clientRecord ~ SqlBackend,+ MonadIO m+ ) =>+ -- | How to read a record+ (clientRecord -> a) ->+ -- | The server id field+ EntityField clientRecord (Maybe sid) ->+ -- | The deleted field+ EntityField clientRecord Bool ->+ SqlPersistT m (SyncRequest (Key clientRecord) sid a)+clientMakeSyncRequestQuery func serverIdField deletedField = do+ syncRequestAdded <-+ M.fromList . map (\(Entity cid ct) -> (cid, func ct))+ <$> selectList+ [ serverIdField ==. Nothing,+ deletedField ==. False+ ]+ []+ syncRequestSynced <-+ S.fromList . mapMaybe (\e -> e ^. fieldLens serverIdField)+ <$> selectList+ [ serverIdField !=. Nothing,+ deletedField ==. False+ ]+ []+ syncRequestDeleted <-+ S.fromList . mapMaybe (\e -> e ^. fieldLens serverIdField)+ <$> selectList+ [ serverIdField !=. Nothing,+ deletedField ==. True+ ]+ []+ 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) ->+ -- | The deleted field+ EntityField clientRecord Bool ->+ SyncResponse (Key clientRecord) sid a ->+ SqlPersistT m ()+clientMergeSyncResponseQuery func serverIdField deletedField = mergeSyncResponseCustom $ clientSyncProcessor func serverIdField deletedField++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) ->+ -- | The deleted field+ EntityField clientRecord Bool ->+ ClientSyncProcessor (Key clientRecord) sid a (SqlPersistT m)+clientSyncProcessor func serverIdField deletedField = 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]+ clientSyncProcessorSyncServerDeleted s = forM_ (S.toList s) $ \sid ->+ deleteWhere [serverIdField ==. Just sid]+ clientSyncProcessorSyncClientDeleted s = forM_ (S.toList s) $ \sid ->+ deleteWhere [serverIdField ==. Just sid, deletedField ==. True]++-- | 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+ serverSyncProcessorDeleteItems s = do+ mapM_ delete s+ pure s++-- | Process a sync query on the server side with a custom id.+serverProcessSyncWithCustomIdQuery ::+ ( Ord sid,+ PersistEntity record,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ MonadIO m+ ) =>+ -- | The action to generate new identifiers+ SqlPersistT m sid ->+ -- | The id field+ EntityField record 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 idField filters funcTo funcFrom = processServerSyncCustom $ serverSyncProcessorWithCustomId genId idField filters funcTo funcFrom++-- | A server sync processor that uses a custom key as the name+serverSyncProcessorWithCustomId ::+ ( Ord sid,+ PersistEntity record,+ PersistField sid,+ PersistEntityBackend record ~ SqlBackend,+ MonadIO m+ ) =>+ -- | The action to generate new identifiers+ SqlPersistT m sid ->+ -- | The id field+ EntityField record 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 idField 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+ serverSyncProcessorDeleteItems s = do+ forM_ s $ \sid -> deleteWhere [idField ==. sid]+ pure s++-- | 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) ->+ -- | Create an deleted synced record on the client side+ (sid -> clientRecord) ->+ ClientStore (Key clientRecord) sid a ->+ SqlPersistT m ()+setupClientQuery funcU funcS funcD ClientStore {..} = do+ forM_ (M.toList clientStoreAdded) $ \(cid, st) ->+ insertKey+ cid+ (funcU st)+ forM_ (M.toList clientStoreSynced) $ \(sid, st) ->+ insert_ (funcS sid st)+ forM_ (S.toList clientStoreDeleted) $ \sid ->+ insert_ (funcD sid)++-- | 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) ->+ -- | The deleted field+ EntityField clientRecord Bool ->+ SqlPersistT m (ClientStore (Key clientRecord) sid a)+clientGetStoreQuery func serverIdField deletedField = do+ clientStoreAdded <-+ M.fromList . map (\(Entity cid ct) -> (cid, func ct))+ <$> selectList+ [ serverIdField ==. Nothing,+ deletedField ==. False+ ]+ []+ clientStoreSynced <-+ M.fromList . mapMaybe (\e@(Entity _ ct) -> (,) <$> (e ^. fieldLens serverIdField) <*> pure (func ct))+ <$> selectList+ [ serverIdField !=. Nothing,+ deletedField ==. False+ ]+ []+ clientStoreDeleted <-+ S.fromList . mapMaybe (\e -> e ^. fieldLens serverIdField)+ <$> selectList+ [ serverIdField !=. Nothing,+ deletedField ==. True+ ]+ []+ 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/Mergeless/Persistent/SingleClientSpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Mergeless.Persistent.SingleClientSpec+ ( spec,+ )+where++import Control.Monad+import Control.Monad.Reader+import Data.GenValidity.Mergeless+import Data.List+import qualified Data.Map as M+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 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/Mergeless/Persistent/TwoClientsSpec.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Mergeless.Persistent.TwoClientsSpec+ ( spec,+ )+where++import Control.Monad+import Control.Monad.Reader+import Data.GenValidity.Mergeless ()+import qualified Data.Map as M+import Data.Mergeless+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 "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+ -- 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 = S.singleton uuid})+ 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 "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'++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,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,79 @@+{-# 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.Mergeless+import Data.Mergeless.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+ deleted Bool -- True means this item has been tombstoned++ 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 makeDeletedClientThing++clientGetStoreThingQuery :: SqlPersistT IO (ClientStore ClientThingId ServerThingId Thing)+clientGetStoreThingQuery = clientGetStoreQuery clientMakeThing ClientThingServerId ClientThingDeleted++clientMakeSyncRequestThingQuery :: SqlPersistT IO (SyncRequest ClientThingId ServerThingId Thing)+clientMakeSyncRequestThingQuery = clientMakeSyncRequestQuery clientMakeThing ClientThingServerId ClientThingDeleted++clientMergeSyncResponseThingQuery :: SyncResponse ClientThingId ServerThingId Thing -> SqlPersistT IO ()+clientMergeSyncResponseThingQuery = clientMergeSyncResponseQuery makeSyncedClientThing ClientThingServerId ClientThingDeleted++makeUnsyncedClientThing :: Thing -> ClientThing+makeUnsyncedClientThing Thing {..} =+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingDeleted = False,+ clientThingServerId = Nothing+ }++makeSyncedClientThing :: ServerThingId -> Thing -> ClientThing+makeSyncedClientThing sid Thing {..} =+ ClientThing+ { clientThingNumber = thingNumber,+ clientThingDeleted = False,+ clientThingServerId = Just sid+ }++makeDeletedClientThing :: ServerThingId -> ClientThing+makeDeletedClientThing sid =+ ClientThing+ { clientThingNumber = 0, -- dummy+ clientThingDeleted = True,+ clientThingServerId = Just sid+ }++clientMakeThing :: ClientThing -> Thing+clientMakeThing ClientThing {..} = Thing {thingNumber = clientThingNumber}
+ test/TestUtils/ServerDB.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestUtils.ServerDB where++import Data.GenValidity+import Data.Mergeless+import Data.Mergeless.Persistent+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 GenUnchecked 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 GenUnchecked 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}