diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog + +## [0.1.0.0] - 2021-11-21 + +### Changed + +* Compatibility with `genvalidity >=1.0.0.0` + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/mergeful-persistent.cabal b/mergeful-persistent.cabal --- a/mergeful-persistent.cabal +++ b/mergeful-persistent.cabal @@ -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 diff --git a/src/Data/Mergeful/Persistent.hs b/src/Data/Mergeful/Persistent.hs --- a/src/Data/Mergeful/Persistent.hs +++ b/src/Data/Mergeful/Persistent.hs @@ -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] diff --git a/test/Data/Mergeful/Persistent/SingleClientSpec.hs b/test/Data/Mergeful/Persistent/SingleClientSpec.hs --- a/test/Data/Mergeful/Persistent/SingleClientSpec.hs +++ b/test/Data/Mergeful/Persistent/SingleClientSpec.hs @@ -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 diff --git a/test/Data/Mergeful/Persistent/TwoClientsSpec.hs b/test/Data/Mergeful/Persistent/TwoClientsSpec.hs --- a/test/Data/Mergeful/Persistent/TwoClientsSpec.hs +++ b/test/Data/Mergeful/Persistent/TwoClientsSpec.hs @@ -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 diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -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 diff --git a/test/TestUtils/ClientDB.hs b/test/TestUtils/ClientDB.hs --- a/test/TestUtils/ClientDB.hs +++ b/test/TestUtils/ClientDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/test/TestUtils/ServerDB.hs b/test/TestUtils/ServerDB.hs --- a/test/TestUtils/ServerDB.hs +++ b/test/TestUtils/ServerDB.hs @@ -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}