diff --git a/mergeless-persistent.cabal b/mergeless-persistent.cabal new file mode 100644 --- /dev/null +++ b/mergeless-persistent.cabal @@ -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 diff --git a/src/Data/Mergeless/Persistent.hs b/src/Data/Mergeless/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeless/Persistent.hs @@ -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 diff --git a/test/Data/Mergeless/Persistent/SingleClientSpec.hs b/test/Data/Mergeless/Persistent/SingleClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeless/Persistent/SingleClientSpec.hs @@ -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 diff --git a/test/Data/Mergeless/Persistent/TwoClientsSpec.hs b/test/Data/Mergeless/Persistent/TwoClientsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Mergeless/Persistent/TwoClientsSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -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 diff --git a/test/TestUtils/ClientDB.hs b/test/TestUtils/ClientDB.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils/ClientDB.hs @@ -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} diff --git a/test/TestUtils/ServerDB.hs b/test/TestUtils/ServerDB.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils/ServerDB.hs @@ -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}