mergeful-persistent 0.0.0.0 → 0.1.0.0
raw patch · 9 files changed
+145/−99 lines, 9 filesdep ~genvalidity
Dependency ranges changed: genvalidity
Files
- CHANGELOG.md +8/−0
- LICENSE +21/−0
- mergeful-persistent.cabal +8/−5
- src/Data/Mergeful/Persistent.hs +32/−19
- test/Data/Mergeful/Persistent/SingleClientSpec.hs +29/−29
- test/Data/Mergeful/Persistent/TwoClientsSpec.hs +34/−34
- test/TestUtils.hs +8/−6
- test/TestUtils/ClientDB.hs +1/−0
- test/TestUtils/ServerDB.hs +4/−6
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Changelog++## [0.1.0.0] - 2021-11-21++### Changed++* Compatibility with `genvalidity >=1.0.0.0`+
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020-2021 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
mergeful-persistent.cabal view
@@ -1,21 +1,24 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: d5a70b83d35c180b25e6452adc9f780212cdc2b24a168a7afcf01f3a841af65d+-- hash: 5657a1667a82a170333369c773c8638a88b0180dcfb0e4bc3ca27ae41b17d8c7 name: mergeful-persistent-version: 0.0.0.0+version: 0.1.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+copyright: Copyright: (c) 2021 Tom Sydney Kerckhove license: MIT+license-file: LICENSE build-type: Simple+extra-source-files:+ CHANGELOG.md source-repository head type: git@@ -55,7 +58,7 @@ QuickCheck , base >=4.11 && <5 , containers- , genvalidity+ , genvalidity >=1.0 , genvalidity-hspec , genvalidity-mergeful , genvalidity-persistent
src/Data/Mergeful/Persistent.hs view
@@ -42,8 +42,8 @@ import Control.Monad import Control.Monad.IO.Class-import qualified Data.Map as M import Data.Map (Map)+import qualified Data.Map as M import Data.Maybe import Data.Mergeful import Data.Set (Set)@@ -207,14 +207,15 @@ 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- ]- []+ 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@@ -232,14 +233,26 @@ 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) ->+ clientSyncProcessorSyncChangeConflictKeepLocal :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncChangeConflictKeepLocal _ = pure ()+ clientSyncProcessorSyncChangeConflictMerged :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncChangeConflictMerged m = forM_ (M.toList m) $ \(sid, Timed a st) -> updateWhere [serverIdField ==. Just sid] $ [ serverTimeField =. Just st, changedField =. True ] ++ recordUpdates a+ clientSyncProcessorSyncChangeConflictTakeRemote :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncChangeConflictTakeRemote = clientSyncProcessorSyncServerChanged+ clientSyncProcessorSyncClientDeletedConflictTakeRemoteChanged :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncClientDeletedConflictTakeRemoteChanged = clientSyncProcessorSyncServerAdded+ clientSyncProcessorSyncClientDeletedConflictStayDeleted :: Map sid (Timed a) -> SqlPersistT m ()+ clientSyncProcessorSyncClientDeletedConflictStayDeleted _ = pure ()+ clientSyncProcessorSyncServerDeletedConflictKeepLocalChange :: Set si -> SqlPersistT m ()+ clientSyncProcessorSyncServerDeletedConflictKeepLocalChange _ = pure ()+ clientSyncProcessorSyncServerDeletedConflictDelete :: Set sid -> SqlPersistT m ()+ clientSyncProcessorSyncServerDeletedConflictDelete = clientSyncProcessorSyncServerDeleted clientSyncProcessorSyncServerAdded :: Map sid (Timed a) -> SqlPersistT m () clientSyncProcessorSyncServerAdded m = insertMany_ $ map (uncurry makeSyncedClientThing) (M.toList m)@@ -357,7 +370,7 @@ -- | 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) ->+ (cid -> a -> record) -> -- | How to update a record given new data (a -> [Update record]) -> -- | A sync request@@ -393,7 +406,7 @@ -- | 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) ->+ (cid -> a -> record) -> -- | How to update a record given new data (a -> [Update record]) -> ServerSyncProcessor cid (Key record) a (SqlPersistT m)@@ -406,7 +419,7 @@ ServerSyncProcessor {..} :: ServerSyncProcessor cid (Key record) a (SqlPersistT m) where serverSyncProcessorRead = M.fromList . map (\(Entity i r) -> (i, unmakeFunc r)) <$> selectList filters []- serverSyncProcessorAddItem = insert . makeFunc+ serverSyncProcessorAddItem cid a = fmap Just $ insert $ makeFunc cid a serverSyncProcessorChangeItem si st a = update si $ (serverTimeField =. st) : recordUpdates a serverSyncProcessorDeleteItem = delete @@ -434,7 +447,7 @@ -- | 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) ->+ (cid -> sid -> a -> record) -> -- | How to update a record given new data (a -> [Update record]) -> -- | A sync request@@ -479,7 +492,7 @@ -- | 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) ->+ (cid -> sid -> a -> record) -> -- | How to update a record given new data (a -> [Update record]) -> ServerSyncProcessor cid sid a (SqlPersistT m)@@ -493,10 +506,10 @@ recordUpdates = ServerSyncProcessor {..} :: ServerSyncProcessor cid sid a (SqlPersistT m) where serverSyncProcessorRead = M.fromList . map (\(Entity _ record) -> unmakeFunc record) <$> selectList filters []- serverSyncProcessorAddItem a = do+ serverSyncProcessorAddItem cid a = do uuid <- uuidGen- insert_ $ makeFunc uuid a- pure uuid+ insert_ $ makeFunc cid uuid a+ pure (Just uuid) serverSyncProcessorChangeItem si st a = updateWhere [idField ==. si] $ (serverTimeField =. st) : recordUpdates a serverSyncProcessorDeleteItem si = deleteWhere [idField ==. si]
test/Data/Mergeful/Persistent/SingleClientSpec.hs view
@@ -20,30 +20,31 @@ {-# 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+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@@ -169,11 +170,10 @@ clientMergeSyncResponse :: ItemMergeStrategy Thing -> SResp -> T () clientMergeSyncResponse strat = runClientDB . clientMergeSyncResponseThingQuery strat -data TestEnv- = TestEnv- { testEnvClientPool :: ConnectionPool,- testEnvServerPool :: ConnectionPool- }+data TestEnv = TestEnv+ { testEnvClientPool :: ConnectionPool,+ testEnvServerPool :: ConnectionPool+ } oneClientSpec :: SpecWith TestEnv -> Spec oneClientSpec = around withTestEnv
test/Data/Mergeful/Persistent/TwoClientsSpec.hs view
@@ -20,33 +20,34 @@ {-# 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+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@@ -305,7 +306,7 @@ 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+ -- Client A merges the response mergeFunc A resp1 cAstore2 <- clientGetStore A lift $ cAstore2 `shouldBe` initialClientStore@@ -503,12 +504,11 @@ data Client = A | B deriving (Show, Eq) -data TestEnv- = TestEnv- { testEnvServerPool :: ConnectionPool,- testEnvClient1Pool :: ConnectionPool,- testEnvClient2Pool :: ConnectionPool- }+data TestEnv = TestEnv+ { testEnvServerPool :: ConnectionPool,+ testEnvClient1Pool :: ConnectionPool,+ testEnvClient2Pool :: ConnectionPool+ } twoClientsSpec :: SpecWith TestEnv -> Spec twoClientsSpec = around withTestEnv
test/TestUtils.hs view
@@ -25,12 +25,14 @@ withServerPool :: (ConnectionPool -> IO a) -> IO a withServerPool func =- runNoLoggingT $ withSqlitePool ":memory:" 1 $ \serverPool -> do- flip runSqlPool serverPool $ void $ runMigrationSilent migrateServer- liftIO $ func serverPool+ runNoLoggingT $+ withSqlitePool ":memory:" 1 $ \serverPool -> do+ flip runSqlPool serverPool $ void $ 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+ runNoLoggingT $+ withSqlitePool ":memory:" 1 $ \clientPool -> do+ flip runSqlPool clientPool $ void $ runMigrationSilent migrateClient+ liftIO $ func clientPool
test/TestUtils/ClientDB.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}
test/TestUtils/ServerDB.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -25,8 +27,6 @@ instance Validity Thing -instance GenUnchecked Thing- instance GenValid Thing share@@ -47,8 +47,6 @@ instance Validity ServerThing -instance GenUnchecked ServerThing- instance GenValid ServerThing setupServerThingQuery :: ServerStore ServerThingId Thing -> SqlPersistT IO ()@@ -69,5 +67,5 @@ serverRecordUpdates :: Thing -> [Update ServerThing] serverRecordUpdates Thing {..} = [ServerThingNumber =. thingNumber] -thingToServer :: Thing -> ServerThing-thingToServer Thing {..} = ServerThing {serverThingTime = initialServerTime, serverThingNumber = thingNumber}+thingToServer :: cid -> Thing -> ServerThing+thingToServer _ Thing {..} = ServerThing {serverThingTime = initialServerTime, serverThingNumber = thingNumber}