diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,19 @@ ## [Unreleased] +## [0.2.0.0] - 2020-05-21 + +## Added + +* processServerSyncCustom and related +* mergeSyncResponseCustom and related + +### Changed + +* Another parameter: the client id so that you can use an sql id as the client id. + This likely means that none of your code that works with mergeful-0.1 will compile anymore + but it is easy to fix by adding the right parameter. + ## [0.1.0.0] - 2019-09-23 ### Changed diff --git a/mergeful.cabal b/mergeful.cabal --- a/mergeful.cabal +++ b/mergeful.cabal @@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 165daa0156c2d4d4295cd5dbfa2b75914c44985aca486dca68525510afa932ce +-- hash: 5c04518a45f3748d42c829e645b69f607f23450b79fa96bcd6c567976b0465b7 name: mergeful -version: 0.1.0.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/NorfairKing/mergeful#readme bug-reports: https://github.com/NorfairKing/mergeful/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2019 Tom Sydney Kerckhove +copyright: Copyright: (c) 2019-2020 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple @@ -36,10 +36,12 @@ Paths_mergeful hs-source-dirs: src + ghc-options: -Wall -fwarn-redundant-constraints build-depends: aeson , base >=4.7 && <5 , containers + , deepseq , mtl , text , time diff --git a/src/Data/Mergeful.hs b/src/Data/Mergeful.hs --- a/src/Data/Mergeful.hs +++ b/src/Data/Mergeful.hs @@ -1,5 +1,6 @@ module Data.Mergeful - ( module Data.Mergeful.Collection - ) where + ( module Data.Mergeful.Collection, + ) +where import Data.Mergeful.Collection diff --git a/src/Data/Mergeful/Collection.hs b/src/Data/Mergeful/Collection.hs --- a/src/Data/Mergeful/Collection.hs +++ b/src/Data/Mergeful/Collection.hs @@ -1,757 +1,966 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | A way to synchronise a single item with safe merge conflicts. --- --- The setup is as follows: --- --- * A central server is set up to synchronise with --- * Each client synchronises with the central server, but never with eachother --- --- --- --- = A client should operate as follows: --- --- The client starts with an 'initialClientStore'. --- --- * The client produces a 'SyncRequest' with 'makeSyncRequest'. --- * The client sends that request to the central server and gets a 'SyncResponse'. --- * The client then updates its local store with 'mergeSyncResponseIgnoreProblems'. --- --- --- = The central server should operate as follows: --- --- The server starts with an 'initialServerStore'. --- --- * The server accepts a 'SyncRequest'. --- * The server performs operations according to the functionality of 'processServerSync'. --- * The server respons with a 'SyncResponse'. --- --- --- WARNING: --- This whole approach can break down if a server resets its server times --- or if a client syncs with two different servers using the same server times. -module Data.Mergeful.Collection - ( initialClientStore - , clientStoreSize - , clientStoreClientIdSet - , clientStoreUndeletedSyncIdSet - , clientStoreSyncIdSet - , clientStoreItems - , addItemToClientStore - , markItemDeletedInClientStore - , changeItemInClientStore - , deleteItemFromClientStore - , initialSyncRequest - , makeSyncRequest - , mergeSyncResponseIgnoreProblems - , mergeSyncResponseFromServer - -- * Custom merging - , ItemMergeStrategy(..) - , mergeSyncResponseUsingStrategy - -- * Server side - , initialServerStore - , processServerSync - -- * Types, for reference - , ClientStore(..) - , SyncRequest(..) - , SyncResponse(..) - , emptySyncResponse - , ServerStore(..) - , ClientId(..) - -- * Utility functions for implementing client-side merging - , mergeAddedItems - , mergeSyncedButChangedItems - , mergeDeletedItems - -- * Utility functions for implementing server-side responding - , addToSyncResponse - ) where - -import GHC.Generics (Generic) - -import Data.Aeson -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import Data.Validity -import Data.Validity.Containers () -import Data.Word - -import Control.Applicative -import Control.Monad - -import Data.Mergeful.Item -import Data.Mergeful.Timed - --- | A Client-side identifier for items. --- --- These only need to be unique at the client. -newtype ClientId = - ClientId - { unClientId :: Word64 - } - deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey) - -instance Validity ClientId - -data ClientStore i a = - ClientStore - { clientStoreAddedItems :: Map ClientId a - -- ^ These items are new locally but have not been synced to the server yet. - , clientStoreSyncedItems :: Map i (Timed a) - -- ^ These items have been synced at their respective 'ServerTime's. - , clientStoreSyncedButChangedItems :: Map i (Timed a) - -- ^ These items have been synced at their respective 'ServerTime's - -- but modified locally since then. - , clientStoreDeletedItems :: Map i ServerTime - -- ^ These items have been deleted locally after they were synced - -- but the server has not been notified of that yet. - } - deriving (Show, Eq, Generic) - -instance (Validity i, Show i, Ord i, Validity a) => Validity (ClientStore i a) where - validate cs@ClientStore {..} = - mconcat - [ genericValidate cs - , declare "There are no duplicate IDs" $ - distinct $ - concat - [ M.keys clientStoreSyncedItems - , M.keys clientStoreSyncedButChangedItems - , M.keys clientStoreDeletedItems - ] - ] - -instance (Ord i, FromJSONKey i, FromJSON a) => FromJSON (ClientStore i a) where - parseJSON = - withObject "ClientStore" $ \o -> - ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty <*> - o .:? "changed" .!= M.empty <*> - o .:? "deleted" .!= M.empty - -instance (ToJSONKey i, ToJSON a) => ToJSON (ClientStore i a) where - toJSON ClientStore {..} = - object $ - catMaybes - [ jNull "added" clientStoreAddedItems - , jNull "synced" clientStoreSyncedItems - , jNull "changed" clientStoreSyncedButChangedItems - , jNull "deleted" clientStoreDeletedItems - ] - --- | A client store to start with. --- --- This store contains no items. -initialClientStore :: ClientStore i a -initialClientStore = - ClientStore - { clientStoreAddedItems = M.empty - , clientStoreSyncedItems = M.empty - , clientStoreSyncedButChangedItems = M.empty - , clientStoreDeletedItems = M.empty - } - --- | The number of items in a client store --- --- This does not count the deleted items, so that they really look deleted.. -clientStoreSize :: ClientStore i a -> Word -clientStoreSize ClientStore {..} = - fromIntegral $ - sum - [ M.size clientStoreAddedItems - , M.size clientStoreSyncedItems - , M.size clientStoreSyncedButChangedItems - ] - --- | The set of client ids. --- --- These are only the client ids of the added items that have not been synced yet. -clientStoreClientIdSet :: ClientStore i a -> Set ClientId -clientStoreClientIdSet ClientStore {..} = M.keysSet clientStoreAddedItems - --- | The set of server ids. --- --- This does not include the ids of items that have been marked as deleted. -clientStoreUndeletedSyncIdSet :: Ord i => ClientStore i a -> Set i -clientStoreUndeletedSyncIdSet ClientStore {..} = - S.unions [M.keysSet clientStoreSyncedItems, M.keysSet clientStoreSyncedButChangedItems] - --- | The set of server ids. --- --- This includes the ids of items that have been marked as deleted. -clientStoreSyncIdSet :: Ord i => ClientStore i a -> Set i -clientStoreSyncIdSet ClientStore {..} = - S.unions - [ M.keysSet clientStoreSyncedItems - , M.keysSet clientStoreSyncedButChangedItems - , M.keysSet clientStoreDeletedItems - ] - --- | The set of items in the client store --- --- This map does not include items that have been marked as deleted. -clientStoreItems :: Ord i => ClientStore i a -> Map (Either ClientId i) a -clientStoreItems ClientStore {..} = - M.unions - [ M.mapKeys Left clientStoreAddedItems - , M.mapKeys Right $ M.map timedValue clientStoreSyncedItems - , M.mapKeys Right $ M.map timedValue clientStoreSyncedButChangedItems - ] - --- | Add an item to a client store as an added item. --- --- This will take care of the uniqueness constraint of the 'ClientId's in the map. -addItemToClientStore :: a -> ClientStore i a -> ClientStore i a -addItemToClientStore a cs = - let oldAddedItems = clientStoreAddedItems cs - newAddedItems = - let newKey = - ClientId $ - if M.null oldAddedItems - then 0 - else let (ClientId k, _) = M.findMax oldAddedItems - in succ k - in M.insert newKey a oldAddedItems - in cs {clientStoreAddedItems = newAddedItems} - --- | Mark an item deleted in a client store. --- --- This function will not delete the item, but mark it as deleted instead. -markItemDeletedInClientStore :: Ord i => i -> ClientStore i a -> ClientStore i a -markItemDeletedInClientStore u cs = - let oldSyncedItems = clientStoreSyncedItems cs - oldChangedItems = clientStoreSyncedButChangedItems cs - oldDeletedItems = clientStoreDeletedItems cs - mItem = M.lookup u oldSyncedItems <|> M.lookup u oldChangedItems - in case mItem of - Nothing -> cs - Just t -> - let newSyncedItems = M.delete u oldSyncedItems - newChangedItems = M.delete u oldChangedItems - newDeletedItems = M.insert u (timedTime t) oldDeletedItems - in cs - { clientStoreSyncedItems = newSyncedItems - , clientStoreSyncedButChangedItems = newChangedItems - , clientStoreDeletedItems = newDeletedItems - } - --- | Replace the given item with a new value. --- --- This function will correctly mark the item as changed, if it exist. --- --- It will not add an item to the store with the given id, because the --- server may not have been the origin of that id. -changeItemInClientStore :: Ord i => i -> a -> ClientStore i a -> ClientStore i a -changeItemInClientStore i a cs = - case M.lookup i (clientStoreSyncedItems cs) of - Just t -> - cs - { clientStoreSyncedItems = M.delete i (clientStoreSyncedItems cs) - , clientStoreSyncedButChangedItems = - M.insert i (t {timedValue = a}) (clientStoreSyncedButChangedItems cs) - } - Nothing -> - case M.lookup i (clientStoreSyncedButChangedItems cs) of - Nothing -> cs - Just _ -> - cs - { clientStoreSyncedButChangedItems = - M.adjust (\t -> t {timedValue = a}) i (clientStoreSyncedButChangedItems cs) - } - --- | Delete an unsynced item from a client store. --- --- This function will immediately delete the item, because it has never been synced. -deleteItemFromClientStore :: ClientId -> ClientStore i a -> ClientStore i a -deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)} - -newtype ServerStore i a = - ServerStore - { serverStoreItems :: Map i (Timed a) - -- ^ A map of items, named using an 'i', together with the 'ServerTime' at which - -- they were last synced. - } - deriving (Show, Eq, Generic, FromJSON, ToJSON) - -instance (Validity i, Show i, Ord i, Validity a) => Validity (ServerStore i a) - --- | A server store to start with --- --- This store contains no items. -initialServerStore :: ServerStore i a -initialServerStore = ServerStore {serverStoreItems = M.empty} - -data SyncRequest i a = - SyncRequest - { syncRequestNewItems :: Map ClientId a - -- ^ These items are new locally but have not been synced to the server yet. - , syncRequestKnownItems :: Map i ServerTime - -- ^ These items have been synced at their respective 'ServerTime's. - , syncRequestKnownButChangedItems :: Map i (Timed a) - -- ^ These items have been synced at their respective 'ServerTime's - -- but modified locally since then. - , syncRequestDeletedItems :: Map i ServerTime - -- ^ These items have been deleted locally after they were synced - -- but the server has not been notified of that yet. - } - deriving (Show, Eq, Generic) - -instance (Validity i, Show i, Ord i, Validity a) => Validity (SyncRequest i a) where - validate sr@SyncRequest {..} = - mconcat - [ genericValidate sr - , declare "There are no duplicate IDs" $ - distinct $ - concat - [ M.keys syncRequestKnownItems - , M.keys syncRequestKnownButChangedItems - , M.keys syncRequestDeletedItems - ] - ] - -instance (Ord i, FromJSONKey i, FromJSON a) => FromJSON (SyncRequest i a) where - parseJSON = - withObject "SyncRequest" $ \o -> - SyncRequest <$> o .:? "new" .!= M.empty <*> o .:? "synced" .!= M.empty <*> - o .:? "changed" .!= M.empty <*> - o .:? "deleted" .!= M.empty - -instance (ToJSONKey i, ToJSON a) => ToJSON (SyncRequest i a) where - toJSON SyncRequest {..} = - object $ - catMaybes - [ jNull "new" syncRequestNewItems - , jNull "synced" syncRequestKnownItems - , jNull "changed" syncRequestKnownButChangedItems - , jNull "deleted" syncRequestDeletedItems - ] - --- | An intial 'SyncRequest' to start with. --- --- It just asks the server to send over whatever it knows. -initialSyncRequest :: SyncRequest i a -initialSyncRequest = - SyncRequest - { syncRequestNewItems = M.empty - , syncRequestKnownItems = M.empty - , syncRequestKnownButChangedItems = M.empty - , syncRequestDeletedItems = M.empty - } - -data SyncResponse i a = - SyncResponse - { syncResponseClientAdded :: Map ClientId (i, ServerTime) - -- ^ The client added these items and server has succesfully been made aware of that. - -- - -- The client needs to update their server times - , syncResponseClientChanged :: Map i ServerTime - -- ^ The client changed these items and server has succesfully been made aware of that. - -- - -- The client needs to update their server times - , syncResponseClientDeleted :: Set i - -- ^ The client deleted these items and server has succesfully been made aware of that. - -- - -- The client can delete them from its deleted items - , syncResponseServerAdded :: Map i (Timed a) - -- ^ These items have been added on the server side - -- - -- The client should add them too. - , syncResponseServerChanged :: Map i (Timed a) - -- ^ These items have been modified on the server side. - -- - -- The client should modify them too. - , syncResponseServerDeleted :: Set i - -- ^ These items were deleted on the server side - -- - -- The client should delete them too - , syncResponseConflicts :: Map i (Timed a) - -- ^ These are conflicts where the server and the client both have an item, but it is different. - -- - -- The server kept its part of each, the client can either take whatever the server gave them - -- or deal with the conflicts somehow, and then try to re-sync. - , syncResponseConflictsClientDeleted :: Map i (Timed a) - -- ^ These are conflicts where the server has an item but the client does not. - -- - -- The server kept its item, the client can either take whatever the server gave them - -- or deal with the conflicts somehow, and then try to re-sync. - , syncResponseConflictsServerDeleted :: Set i - -- ^ These are conflicts where the server has no item but the client has a modified item. - -- - -- The server left its item deleted, the client can either delete its items too - -- or deal with the conflicts somehow, and then try to re-sync. - } - deriving (Show, Eq, Generic) - -instance (Validity i, Show i, Ord i, Validity a) => Validity (SyncResponse i a) where - validate sr@SyncResponse {..} = - mconcat - [ genericValidate sr - , declare "There are no duplicate IDs" $ - distinct $ - concat - [ map (\(_, (i, _)) -> i) $ M.toList syncResponseClientAdded - , M.keys syncResponseClientChanged - , S.toList syncResponseClientDeleted - , M.keys syncResponseServerAdded - , M.keys syncResponseServerChanged - , S.toList syncResponseServerDeleted - , M.keys syncResponseConflicts - , M.keys syncResponseConflictsClientDeleted - , S.toList syncResponseConflictsServerDeleted - ] - ] - -instance (Ord i, FromJSON i, FromJSONKey i, FromJSON a) => FromJSON (SyncResponse i a) where - parseJSON = - withObject "SyncResponse" $ \o -> - SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty <*> - o .:? "client-deleted" .!= S.empty <*> - o .:? "server-added" .!= M.empty <*> - o .:? "server-changed" .!= M.empty <*> - o .:? "server-deleted" .!= S.empty <*> - o .:? "conflict" .!= M.empty <*> - o .:? "conflict-client-deleted" .!= M.empty <*> - o .:? "conflict-server-deleted" .!= S.empty - -instance (ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (SyncResponse i a) where - toJSON SyncResponse {..} = - object $ - catMaybes - [ jNull "client-added" syncResponseClientAdded - , jNull "client-changed" syncResponseClientChanged - , jNull "client-deleted" syncResponseClientDeleted - , jNull "server-added" syncResponseServerAdded - , jNull "server-changed" syncResponseServerChanged - , jNull "server-deleted" syncResponseServerDeleted - , jNull "conflict" syncResponseConflicts - , jNull "conflict-client-deleted" syncResponseConflictsClientDeleted - , jNull "conflict-server-deleted" syncResponseConflictsServerDeleted - ] - -emptySyncResponse :: SyncResponse i a -emptySyncResponse = - SyncResponse - { syncResponseClientAdded = M.empty - , syncResponseClientChanged = M.empty - , syncResponseClientDeleted = S.empty - , syncResponseServerAdded = M.empty - , syncResponseServerChanged = M.empty - , syncResponseServerDeleted = S.empty - , syncResponseConflicts = M.empty - , syncResponseConflictsClientDeleted = M.empty - , syncResponseConflictsServerDeleted = S.empty - } - -jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value) -jNull n s = - if null s - then Nothing - else Just $ n .= s - --- | Produce an 'SyncRequest' from a 'ClientStore'. --- --- Send this to the server for synchronisation. -makeSyncRequest :: ClientStore i a -> SyncRequest i a -makeSyncRequest ClientStore {..} = - SyncRequest - { syncRequestNewItems = clientStoreAddedItems - , syncRequestKnownItems = M.map timedTime clientStoreSyncedItems - , syncRequestKnownButChangedItems = clientStoreSyncedButChangedItems - , syncRequestDeletedItems = clientStoreDeletedItems - } - --- | Merge an 'SyncResponse' into the current 'ClientStore'. --- --- This function ignores any problems that may occur. --- In the case of a conclict, it will just not update the client item. --- The next sync request will then produce a conflict again. --- --- Pro: No data will be lost --- --- __Con: Clients will diverge when conflicts occur.__ -mergeSyncResponseIgnoreProblems :: Ord i => ClientStore i a -> SyncResponse i a -> ClientStore i a -mergeSyncResponseIgnoreProblems cs SyncResponse {..} = - let (addedItemsLeftovers, newSyncedItems) = - mergeAddedItems (clientStoreAddedItems cs) syncResponseClientAdded - (syncedButNotChangedLeftovers, newModifiedItems) = - mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) syncResponseClientChanged - deletedItemsLeftovers = - mergeDeletedItems (clientStoreDeletedItems cs) syncResponseClientDeleted - synced = - M.unions - [ newSyncedItems - , syncResponseServerAdded - , syncResponseServerChanged - , newModifiedItems - , clientStoreSyncedItems cs - ] - in ClientStore - { clientStoreAddedItems = addedItemsLeftovers - , clientStoreSyncedButChangedItems = syncedButNotChangedLeftovers `M.difference` synced - , clientStoreDeletedItems = deletedItemsLeftovers `M.difference` synced - , clientStoreSyncedItems = - synced `M.difference` M.fromSet (const ()) syncResponseServerDeleted - } - --- | Merge an 'SyncResponse' into the current 'ClientStore' with the given merge strategy. --- --- In order for clients to converge on the same collection correctly, this function must be: --- --- * Associative --- * Idempotent --- * The same on all clients --- --- This function ignores mismatches. -mergeSyncResponseUsingStrategy :: - Ord i => ItemMergeStrategy a -> ClientStore i a -> SyncResponse i a -> ClientStore i a -mergeSyncResponseUsingStrategy ItemMergeStrategy {..} cs SyncResponse {..} = - let (addedItemsLeftovers, newSyncedItems) = - mergeAddedItems (clientStoreAddedItems cs) syncResponseClientAdded - (syncedButNotChangedLeftovers, newModifiedItems) = - mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) syncResponseClientChanged - deletedItemsLeftovers = - mergeDeletedItems (clientStoreDeletedItems cs) syncResponseClientDeleted - synced = - M.unions - [ newSyncedItems - , syncResponseServerAdded - , syncResponseServerChanged - -- Merge the synced but changed (the only ones that could have caused a conflict) - -- with the ones that the response indicated were a conflict. - , M.intersectionWith - itemMergeStrategyMergeChangeConflict - (M.map timedValue $ clientStoreSyncedButChangedItems cs) - syncResponseConflicts - -- Of the items that the server changed but the client deleted, - -- keep the ones that the strategy wants to keep. - , M.mapMaybe id $ - M.intersectionWith - (\_ t -> itemMergeStrategyMergeClientDeletedConflict t) - (clientStoreDeletedItems cs) - syncResponseConflictsClientDeleted - , newModifiedItems - , clientStoreSyncedItems cs - ] - -- | The synced but changed items that were not acknowledged as changed, - -- minus the ones that the strategy decided to delete. - newSyncedButChangedItems = - syncedButNotChangedLeftovers `M.difference` - M.fromSet (const ()) syncResponseConflictsServerDeleted - in ClientStore - { clientStoreAddedItems = addedItemsLeftovers - , clientStoreSyncedButChangedItems = newSyncedButChangedItems `M.difference` synced - , clientStoreDeletedItems = deletedItemsLeftovers `M.difference` synced - , clientStoreSyncedItems = - synced `M.difference` M.fromSet (const ()) syncResponseServerDeleted - } - --- | Merge an 'SyncResponse' into the current 'ClientStore' by taking whatever the server gave the client. --- --- Pro: Clients will converge on the same value. --- --- __Con: Conflicting updates will be lost.__ -mergeSyncResponseFromServer :: Ord i => ClientStore i a -> SyncResponse i a -> ClientStore i a -mergeSyncResponseFromServer = - mergeSyncResponseUsingStrategy - ItemMergeStrategy - { itemMergeStrategyMergeChangeConflict = \_ serverItem -> serverItem - , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem - , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing - } - --- | Merge the local added items with the ones that the server has acknowledged as added. -mergeAddedItems :: - forall i a. Ord i - => Map ClientId a - -> Map ClientId (i, ServerTime) - -> (Map ClientId a, Map i (Timed a)) -mergeAddedItems local added = M.foldlWithKey go (M.empty, M.empty) local - where - go :: (Map ClientId a, Map i (Timed a)) -> ClientId -> a -> (Map ClientId a, Map i (Timed a)) - go (as, m) i a = - case M.lookup i added of - Nothing -> (M.insert i a as, m) - Just (k, st) -> (as, M.insert k (Timed {timedValue = a, timedTime = st}) m) - --- | Merge the local synced but changed items with the ones that the server has acknowledged as changed. -mergeSyncedButChangedItems :: - forall i a. Ord i - => Map i (Timed a) - -> Map i ServerTime - -> (Map i (Timed a), Map i (Timed a)) -mergeSyncedButChangedItems local changed = M.foldlWithKey go (M.empty, M.empty) local - where - go :: (Map i (Timed a), Map i (Timed a)) -> i -> Timed a -> (Map i (Timed a), Map i (Timed a)) - go (m1, m2) k t = - case M.lookup k changed of - Nothing -> (M.insert k t m1, m2) - Just st' -> (m1, M.insert k (t {timedTime = st'}) m2) - --- | Merge the local deleted items with the ones that the server has acknowledged as deleted. -mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b -mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s - -data Identifier i - = OnlyServer i - | BothServerAndClient i ClientId - deriving (Show, Eq, Ord, Generic) - -instance Validity i => Validity (Identifier i) - --- | Serve an 'SyncRequest' using the current 'ServerStore', producing an 'SyncResponse' and a new 'ServerStore'. -processServerSync :: - forall i a m. (Ord i, Monad m) - => m i -- ^ The action that is guaranteed to generate unique identifiers - -> ServerStore i a - -> SyncRequest i a - -> m (SyncResponse i a, ServerStore i a) -processServerSync genId ServerStore {..} sr@SyncRequest {..} - -- Make tuples of requests for all of the items that only had a client identifier. - = do - let unidentifedPairs :: Map ClientId (ServerItem a, ItemSyncRequest a) - unidentifedPairs = M.map (\a -> (ServerEmpty, ItemSyncRequestNew a)) syncRequestNewItems - -- Make tuples of results for each of the unidentifier tuples. - unidentifedResults :: Map ClientId (ItemSyncResponse a, ServerItem a) - unidentifedResults = M.map (uncurry processServerItemSync) unidentifedPairs - generatedResults <- generateIdentifiersFor genId unidentifedResults - -- Gather the items that had a server identifier already. - let clientIdentifiedSyncRequests :: Map i (ItemSyncRequest a) - clientIdentifiedSyncRequests = identifiedItemSyncRequests sr - -- Make 'ServerItem's for each of the items on the server side - serverIdentifiedItems :: Map i (ServerItem a) - serverIdentifiedItems = M.map ServerFull serverStoreItems - -- Match up client items with server items by their id. - thesePairs :: Map i (These (ServerItem a) (ItemSyncRequest a)) - thesePairs = unionTheseMaps serverIdentifiedItems clientIdentifiedSyncRequests - -- Make tuples of server 'ServerItem's and 'ItemSyncRequest's for each of the items with an id - requestPairs :: Map i (ServerItem a, ItemSyncRequest a) - requestPairs = M.map (fromThese ServerEmpty ItemSyncRequestPoll) thesePairs - -- Make tuples of results for each of the tuplus that had a server identifier. - identifiedResults :: Map i (ItemSyncResponse a, ServerItem a) - identifiedResults = M.map (uncurry processServerItemSync) requestPairs - -- Put together the results together - let allResults :: Map (Identifier i) (ItemSyncResponse a, ServerItem a) - allResults = - M.union - (M.mapKeys OnlyServer identifiedResults) - (M.mapKeys (uncurry BothServerAndClient) generatedResults) - pure $ produceSyncResults allResults - -identifiedItemSyncRequests :: Ord i => SyncRequest i a -> Map i (ItemSyncRequest a) -identifiedItemSyncRequests SyncRequest {..} = - M.unions - [ M.map ItemSyncRequestKnown syncRequestKnownItems - , M.map ItemSyncRequestKnownButChanged syncRequestKnownButChangedItems - , M.map ItemSyncRequestDeletedLocally syncRequestDeletedItems - ] - -generateIdentifiersFor :: - (Ord i, Monad m) - => m i - -> Map ClientId (ItemSyncResponse a, ServerItem a) - -> m (Map (i, ClientId) (ItemSyncResponse a, ServerItem a)) -generateIdentifiersFor genId unidentifedResults = - fmap M.fromList $ - forM (M.toList unidentifedResults) $ \(int, r) -> do - uuid <- genId - pure ((uuid, int), r) - -produceSyncResults :: - forall i a. Ord i - => Map (Identifier i) (ItemSyncResponse a, ServerItem a) - -> (SyncResponse i a, ServerStore i a) -produceSyncResults allResults - -- Produce a sync response - = - let resp :: SyncResponse i a - resp = - M.foldlWithKey - (\sr cid (isr, _) -> addToSyncResponse sr cid isr) - emptySyncResponse - allResults - -- Produce a new server store - newStore :: Map i (Timed a) - newStore = - M.mapMaybe - (\case - ServerEmpty -> Nothing - ServerFull t -> Just t) $ - M.map snd $ - M.mapKeys - (\case - OnlyServer i -> i - BothServerAndClient i _ -> i) - allResults - -- return them both. - in (resp, ServerStore newStore) - --- | Given an incomplete 'SyncResponse', an id, possibly a client ID too, and --- an 'ItemSyncResponse', produce a less incomplete 'SyncResponse'. -addToSyncResponse :: - Ord i => SyncResponse i a -> Identifier i -> ItemSyncResponse a -> SyncResponse i a -addToSyncResponse sr cid isr = - case cid of - BothServerAndClient i int -> - case isr of - ItemSyncResponseClientAdded st -> - sr {syncResponseClientAdded = M.insert int (i, st) $ syncResponseClientAdded sr} - _ -> error "should not happen" - OnlyServer i -> - case isr of - ItemSyncResponseInSyncEmpty -> sr - ItemSyncResponseInSyncFull -> sr - ItemSyncResponseClientAdded _ -> sr -- Should not happen. - ItemSyncResponseClientChanged st -> - sr {syncResponseClientChanged = M.insert i st $ syncResponseClientChanged sr} - ItemSyncResponseClientDeleted -> - sr {syncResponseClientDeleted = S.insert i $ syncResponseClientDeleted sr} - ItemSyncResponseServerAdded t -> - sr {syncResponseServerAdded = M.insert i t $ syncResponseServerAdded sr} - ItemSyncResponseServerChanged t -> - sr {syncResponseServerChanged = M.insert i t $ syncResponseServerChanged sr} - ItemSyncResponseServerDeleted -> - sr {syncResponseServerDeleted = S.insert i $ syncResponseServerDeleted sr} - ItemSyncResponseConflict a -> - sr {syncResponseConflicts = M.insert i a $ syncResponseConflicts sr} - ItemSyncResponseConflictClientDeleted a -> - sr - { syncResponseConflictsClientDeleted = - M.insert i a $ syncResponseConflictsClientDeleted sr - } - ItemSyncResponseConflictServerDeleted -> - sr - { syncResponseConflictsServerDeleted = - S.insert i $ syncResponseConflictsServerDeleted sr - } - -unionTheseMaps :: Ord k => Map k a -> Map k b -> Map k (These a b) -unionTheseMaps m1 m2 = M.unionWith go (M.map This m1) (M.map That m2) - where - go (This a) (That b) = These a b - go _ _ = error "should not happen." - -distinct :: Eq a => [a] -> Bool -distinct ls = nub ls == ls - --- Inlined because holy smokes, `these` has a _lot_ of dependencies. -data These a b - = This a - | That b - | These a b - deriving (Show, Eq, Generic) - -fromThese :: a -> b -> These a b -> (a, b) -fromThese a b t = - case t of - This a' -> (a', b) - That b' -> (a, b') - These a' b' -> (a', b') +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A way to synchronise a single item with safe merge conflicts. +-- +-- The setup is as follows: +-- +-- * A central server is set up to synchronise with +-- * Each client synchronises with the central server, but never with eachother +-- +-- +-- +-- = A client should operate as follows: +-- +-- The client starts with an 'initialClientStore'. +-- +-- * The client produces a 'SyncRequest' with 'makeSyncRequest'. +-- * The client sends that request to the central server and gets a 'SyncResponse'. +-- * The client then updates its local store with 'mergeSyncResponseIgnoreProblems'. +-- +-- +-- = The central server should operate as follows: +-- +-- The server starts with an 'initialServerStore'. +-- +-- * The server accepts a 'SyncRequest'. +-- * The server performs operations according to the functionality of 'processServerSync' or 'processServerSyncCustom'. +-- * The server respons with a 'SyncResponse'. +-- +-- +-- WARNING: +-- This whole approach can break down if a server resets its server times +-- or if a client syncs with two different servers using the same server times. +module Data.Mergeful.Collection + ( -- * Client side + ClientStore (..), + Timed (..), + ServerTime (..), + initialClientStore, + + -- ** Querying the client store + clientStoreSize, + clientStoreClientIdSet, + clientStoreUndeletedSyncIdSet, + clientStoreSyncIdSet, + clientStoreItems, + + -- ** Changing the client store + addItemToClientStore, + findFreeSpot, + markItemDeletedInClientStore, + changeItemInClientStore, + deleteItemFromClientStore, + + -- ** Maxing a sync request + SyncRequest (..), + initialSyncRequest, + makeSyncRequest, + + -- ** Merging the response + SyncResponse (..), + ClientAddition (..), + ItemMergeStrategy (..), + ChangeConflictResolution (..), + ClientDeletedConflictResolution (..), + ServerDeletedConflictResolution (..), + mergeFromServerStrategy, + mergeFromClientStrategy, + mergeUsingCRDTStrategy, + mergeSyncResponseFromServer, + mergeSyncResponseFromClient, + mergeSyncResponseUsingCRDT, + mergeSyncResponseUsingStrategy, + ClientSyncProcessor (..), + mergeSyncResponseCustom, + + -- *** Utility functions for implementing pure client-side merging + ClientId (..), + mergeAddedItems, + mergeSyncedButChangedItems, + mergeDeletedItems, + + -- *** Utility functions for implementing custom client-side merging + mergeSyncedButChangedConflicts, + mergeClientDeletedConflicts, + mergeServerDeletedConflicts, + + -- * Server side + + -- ** The store + ServerStore (..), + initialServerStore, + + -- ** Processing a sync request + processServerSync, + ServerSyncProcessor (..), + processServerSyncCustom, + emptySyncResponse, + initialServerTime, + incrementServerTime, + ) +where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.State +import Data.Aeson +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Mergeful.Item +import Data.Mergeful.Timed +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Validity +import Data.Validity.Containers () +import Data.Word +import GHC.Generics (Generic) + +-- | A Client-side identifier for items. +-- +-- These only need to be unique at the client. +newtype ClientId + = ClientId + { unClientId :: Word64 + } + deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey) + +instance Validity ClientId + +instance NFData ClientId + +data ClientStore ci si a + = ClientStore + { -- | These items are new locally but have not been synced to the server yet. + clientStoreAddedItems :: Map ci a, + -- | These items have been synced at their respective 'ServerTime's. + clientStoreSyncedItems :: Map si (Timed a), + -- | These items have been synced at their respective 'ServerTime's + -- but modified locally since then. + clientStoreSyncedButChangedItems :: Map si (Timed a), + -- | These items have been deleted locally after they were synced + -- but the server has not been notified of that yet. + clientStoreDeletedItems :: Map si ServerTime + } + deriving (Show, Eq, Generic) + +instance + (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => + Validity (ClientStore ci si a) + where + validate cs@ClientStore {..} = + mconcat + [ genericValidate cs, + declare "There are no duplicate IDs" + $ distinct + $ concat + [ M.keys clientStoreSyncedItems, + M.keys clientStoreSyncedButChangedItems, + M.keys clientStoreDeletedItems + ] + ] + +instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a) + +instance + (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) => + FromJSON (ClientStore ci si a) + where + parseJSON = + withObject "ClientStore" $ \o -> + ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty + <*> o .:? "changed" .!= M.empty + <*> o .:? "deleted" .!= M.empty + +instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where + toJSON ClientStore {..} = + object $ + catMaybes + [ jNull "added" clientStoreAddedItems, + jNull "synced" clientStoreSyncedItems, + jNull "changed" clientStoreSyncedButChangedItems, + jNull "deleted" clientStoreDeletedItems + ] + +-- | A client store to start with. +-- +-- This store contains no items. +initialClientStore :: ClientStore ci si a +initialClientStore = + ClientStore + { clientStoreAddedItems = M.empty, + clientStoreSyncedItems = M.empty, + clientStoreSyncedButChangedItems = M.empty, + clientStoreDeletedItems = M.empty + } + +-- | The number of items in a client store +-- +-- This does not count the deleted items, so that they really look deleted.. +clientStoreSize :: ClientStore ci si a -> Word +clientStoreSize ClientStore {..} = + fromIntegral $ + sum + [ M.size clientStoreAddedItems, + M.size clientStoreSyncedItems, + M.size clientStoreSyncedButChangedItems + ] + +-- | The set of client ids. +-- +-- These are only the client ids of the added items that have not been synced yet. +clientStoreClientIdSet :: ClientStore ci si a -> Set ci +clientStoreClientIdSet ClientStore {..} = M.keysSet clientStoreAddedItems + +-- | The set of server ids. +-- +-- This does not include the ids of items that have been marked as deleted. +clientStoreUndeletedSyncIdSet :: Ord si => ClientStore ci si a -> Set si +clientStoreUndeletedSyncIdSet ClientStore {..} = + S.unions [M.keysSet clientStoreSyncedItems, M.keysSet clientStoreSyncedButChangedItems] + +-- | The set of server ids. +-- +-- This includes the ids of items that have been marked as deleted. +clientStoreSyncIdSet :: Ord si => ClientStore ci si a -> Set si +clientStoreSyncIdSet ClientStore {..} = + S.unions + [ M.keysSet clientStoreSyncedItems, + M.keysSet clientStoreSyncedButChangedItems, + M.keysSet clientStoreDeletedItems + ] + +-- | The set of items in the client store +-- +-- This map does not include items that have been marked as deleted. +clientStoreItems :: (Ord ci, Ord si) => ClientStore ci si a -> Map (Either ci si) a +clientStoreItems ClientStore {..} = + M.unions + [ M.mapKeys Left clientStoreAddedItems, + M.mapKeys Right $ M.map timedValue clientStoreSyncedItems, + M.mapKeys Right $ M.map timedValue clientStoreSyncedButChangedItems + ] + +-- | Add an item to a client store as an added item. +-- +-- This will take care of the uniqueness constraint of the 'ci's in the map. +addItemToClientStore :: + (Ord ci, Enum ci, Bounded ci) => a -> ClientStore ci si a -> ClientStore ci si a +addItemToClientStore a cs = + let oldAddedItems = clientStoreAddedItems cs + newAddedItems = + let newKey = findFreeSpot oldAddedItems + in M.insert newKey a oldAddedItems + in cs {clientStoreAddedItems = newAddedItems} + +-- | Find a free client id to use +-- +-- You shouldn't need this function, 'addItemToClientStore' takes care of this. +-- +-- The values wrap around when reaching 'maxBound'. +findFreeSpot :: (Ord ci, Enum ci, Bounded ci) => Map ci a -> ci +findFreeSpot m = + if M.null m + then minBound + else + let (i, _) = M.findMax m + in go (next i) + where + go i = + if M.member i m + then go (next i) + else i + next ci + | ci == maxBound = minBound + | otherwise = succ ci + +-- | Mark an item deleted in a client store. +-- +-- This function will not delete the item, but mark it as deleted instead. +markItemDeletedInClientStore :: Ord si => si -> ClientStore ci si a -> ClientStore ci si a +markItemDeletedInClientStore u cs = + let oldSyncedItems = clientStoreSyncedItems cs + oldChangedItems = clientStoreSyncedButChangedItems cs + oldDeletedItems = clientStoreDeletedItems cs + mItem = M.lookup u oldSyncedItems <|> M.lookup u oldChangedItems + in case mItem of + Nothing -> cs + Just t -> + let newSyncedItems = M.delete u oldSyncedItems + newChangedItems = M.delete u oldChangedItems + newDeletedItems = M.insert u (timedTime t) oldDeletedItems + in cs + { clientStoreSyncedItems = newSyncedItems, + clientStoreSyncedButChangedItems = newChangedItems, + clientStoreDeletedItems = newDeletedItems + } + +-- | Replace the given item with a new value. +-- +-- This function will correctly mark the item as changed, if it exist. +-- +-- It will not add an item to the store with the given id, because the +-- server may not have been the origin of that id. +changeItemInClientStore :: Ord si => si -> a -> ClientStore ci si a -> ClientStore ci si a +changeItemInClientStore i a cs = + case M.lookup i (clientStoreSyncedItems cs) of + Just t -> + cs + { clientStoreSyncedItems = M.delete i (clientStoreSyncedItems cs), + clientStoreSyncedButChangedItems = + M.insert i (t {timedValue = a}) (clientStoreSyncedButChangedItems cs) + } + Nothing -> + case M.lookup i (clientStoreSyncedButChangedItems cs) of + Nothing -> cs + Just _ -> + cs + { clientStoreSyncedButChangedItems = + M.adjust (\t -> t {timedValue = a}) i (clientStoreSyncedButChangedItems cs) + } + +-- | Delete an unsynced item from a client store. +-- +-- This function will immediately delete the item, because it has never been synced. +deleteItemFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a +deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)} + +newtype ServerStore si a + = ServerStore + { -- | A map of items, named using an 'si', together with the 'ServerTime' at which + -- they were last synced. + serverStoreItems :: Map si (Timed a) + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +instance (Validity si, Show si, Ord si, Validity a) => Validity (ServerStore si a) + +instance (NFData si, NFData a) => NFData (ServerStore si a) + +-- | A server store to start with +-- +-- This store contains no items. +initialServerStore :: ServerStore si a +initialServerStore = ServerStore {serverStoreItems = M.empty} + +data SyncRequest ci si a + = SyncRequest + { -- | These items are new locally but have not been synced to the server yet. + syncRequestNewItems :: !(Map ci a), + -- | These items have been synced at their respective 'ServerTime's. + syncRequestKnownItems :: !(Map si ServerTime), + -- | These items have been synced at their respective 'ServerTime's + -- but modified locally since then. + syncRequestKnownButChangedItems :: !(Map si (Timed a)), + -- | These items have been deleted locally after they were synced + -- but the server has not been notified of that yet. + syncRequestDeletedItems :: !(Map si ServerTime) + } + deriving (Show, Eq, Generic) + +instance + (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => + Validity (SyncRequest ci si a) + where + validate sr@SyncRequest {..} = + mconcat + [ genericValidate sr, + declare "There are no duplicate IDs" + $ distinct + $ concat + [ M.keys syncRequestKnownItems, + M.keys syncRequestKnownButChangedItems, + M.keys syncRequestDeletedItems + ] + ] + +instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a) + +instance + (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) => + FromJSON (SyncRequest ci si a) + where + parseJSON = + withObject "SyncRequest" $ \o -> + SyncRequest <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty + <*> o .:? "changed" .!= M.empty + <*> o .:? "deleted" .!= M.empty + +instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncRequest ci si a) where + toJSON SyncRequest {..} = + object $ + catMaybes + [ jNull "added" syncRequestNewItems, + jNull "synced" syncRequestKnownItems, + jNull "changed" syncRequestKnownButChangedItems, + jNull "deleted" syncRequestDeletedItems + ] + +-- | An intial 'SyncRequest' to start with. +-- +-- It just asks the server to send over whatever it knows. +initialSyncRequest :: SyncRequest ci si a +initialSyncRequest = + SyncRequest + { syncRequestNewItems = M.empty, + syncRequestKnownItems = M.empty, + syncRequestKnownButChangedItems = M.empty, + syncRequestDeletedItems = M.empty + } + +data ClientAddition i + = ClientAddition + { clientAdditionId :: i, + clientAdditionServerTime :: ServerTime + } + deriving (Show, Eq, Generic) + +instance Validity i => Validity (ClientAddition i) + +instance NFData i => NFData (ClientAddition i) + +instance FromJSON i => FromJSON (ClientAddition i) where + parseJSON = withObject "ClientAddition" $ \o -> ClientAddition <$> o .: "id" <*> o .: "time" + +instance ToJSON i => ToJSON (ClientAddition i) where + toJSON ClientAddition {..} = object ["id" .= clientAdditionId, "time" .= clientAdditionServerTime] + +data SyncResponse ci si a + = SyncResponse + { -- | The client added these items and server has succesfully been made aware of that. + -- + -- The client needs to update their server times + syncResponseClientAdded :: !(Map ci (ClientAddition si)), + -- | The client changed these items and server has succesfully been made aware of that. + -- + -- The client needs to update their server times + syncResponseClientChanged :: !(Map si ServerTime), + -- | The client deleted these items and server has succesfully been made aware of that. + -- + -- The client can delete them from its deleted items + syncResponseClientDeleted :: !(Set si), + -- | These items have been added on the server side + -- + -- The client should add them too. + syncResponseServerAdded :: !(Map si (Timed a)), + -- | These items have been modified on the server side. + -- + -- The client should modify them too. + syncResponseServerChanged :: !(Map si (Timed a)), + -- | These items were deleted on the server side + -- + -- The client should delete them too + syncResponseServerDeleted :: !(Set si), + -- | These are conflicts where the server and the client both have an item, but it is different. + -- + -- The server kept its part of each, the client can either take whatever the server gave them + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflicts :: !(Map si (Timed a)), + -- | These are conflicts where the server has an item but the client does not. + -- + -- The server kept its item, the client can either take whatever the server gave them + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflictsClientDeleted :: !(Map si (Timed a)), + -- | These are conflicts where the server has no item but the client has a modified item. + -- + -- The server left its item deleted, the client can either delete its items too + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflictsServerDeleted :: !(Set si) + } + deriving (Show, Eq, Generic) + +instance + (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => + Validity (SyncResponse ci si a) + where + validate sr@SyncResponse {..} = + mconcat + [ genericValidate sr, + declare "There are no duplicate IDs" + $ distinct + $ concat + [ map (\(_, ClientAddition {..}) -> clientAdditionId) $ M.toList syncResponseClientAdded, + M.keys syncResponseClientChanged, + S.toList syncResponseClientDeleted, + M.keys syncResponseServerAdded, + M.keys syncResponseServerChanged, + S.toList syncResponseServerDeleted, + M.keys syncResponseConflicts, + M.keys syncResponseConflictsClientDeleted, + S.toList syncResponseConflictsServerDeleted + ] + ] + +instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a) + +instance + (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, FromJSON a) => + FromJSON (SyncResponse ci si a) + where + parseJSON = + withObject "SyncResponse" $ \o -> + SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty + <*> o .:? "client-deleted" .!= S.empty + <*> o .:? "server-added" .!= M.empty + <*> o .:? "server-changed" .!= M.empty + <*> o .:? "server-deleted" .!= S.empty + <*> o .:? "conflict" .!= M.empty + <*> o .:? "conflict-client-deleted" .!= M.empty + <*> o .:? "conflict-server-deleted" .!= S.empty + +instance + (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) => + ToJSON (SyncResponse ci si a) + where + toJSON SyncResponse {..} = + object $ + catMaybes + [ jNull "client-added" syncResponseClientAdded, + jNull "client-changed" syncResponseClientChanged, + jNull "client-deleted" syncResponseClientDeleted, + jNull "server-added" syncResponseServerAdded, + jNull "server-changed" syncResponseServerChanged, + jNull "server-deleted" syncResponseServerDeleted, + jNull "conflict" syncResponseConflicts, + jNull "conflict-client-deleted" syncResponseConflictsClientDeleted, + jNull "conflict-server-deleted" syncResponseConflictsServerDeleted + ] + +-- | A sync response to start with. +-- +-- It is entirely empty. +emptySyncResponse :: SyncResponse ci si a +emptySyncResponse = + SyncResponse + { syncResponseClientAdded = M.empty, + syncResponseClientChanged = M.empty, + syncResponseClientDeleted = S.empty, + syncResponseServerAdded = M.empty, + syncResponseServerChanged = M.empty, + syncResponseServerDeleted = S.empty, + syncResponseConflicts = M.empty, + syncResponseConflictsClientDeleted = M.empty, + syncResponseConflictsServerDeleted = S.empty + } + +jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value) +jNull n s = + if null s + then Nothing + else Just $ n .= s + +-- | Produce an 'SyncRequest' from a 'ClientStore'. +-- +-- Send this to the server for synchronisation. +makeSyncRequest :: ClientStore ci si a -> SyncRequest ci si a +makeSyncRequest ClientStore {..} = + SyncRequest + { syncRequestNewItems = clientStoreAddedItems, + syncRequestKnownItems = M.map timedTime clientStoreSyncedItems, + syncRequestKnownButChangedItems = clientStoreSyncedButChangedItems, + syncRequestDeletedItems = clientStoreDeletedItems + } + +-- | Merge a 'SyncResponse' into the current 'ClientStore' by taking whatever the server gave the client in case of conflict. +-- +-- Pro: Clients will converge on the same value. +-- +-- __Con: Conflicting updates will be lost.__ +mergeSyncResponseFromServer :: + (Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a +mergeSyncResponseFromServer = + mergeSyncResponseUsingStrategy mergeFromServerStrategy + +-- | Merge a 'SyncResponse' into the current 'ClientStore' by keeping whatever the client had in case of conflict. +-- +-- Pro: No data will be lost +-- +-- __Con: Clients will diverge when conflicts occur.__ +mergeSyncResponseFromClient :: + (Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a +mergeSyncResponseFromClient = mergeSyncResponseUsingStrategy mergeFromClientStrategy + +-- | Merge a 'SyncResponse' into the current 'ClientStore' by using the given GADT merging function in case of conflict +mergeSyncResponseUsingCRDT :: (Ord ci, Ord si) => (a -> a -> a) -> ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a +mergeSyncResponseUsingCRDT = mergeSyncResponseUsingStrategy . mergeUsingCRDTStrategy + +-- | Merge an 'SyncResponse' into the current 'ClientStore' with the given merge strategy. +-- +-- In order for clients to converge on the same collection correctly, this function must be: +-- +-- * Associative +-- * Idempotent +-- * The same on all clients +-- +-- This function ignores mismatches. +mergeSyncResponseUsingStrategy :: + (Ord ci, Ord si) => + ItemMergeStrategy a -> + ClientStore ci si a -> + SyncResponse ci si a -> + ClientStore ci si a +mergeSyncResponseUsingStrategy strat cs sr = + flip execState cs $ mergeSyncResponseCustom strat pureClientSyncProcessor sr + +pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a)) +pureClientSyncProcessor = + ClientSyncProcessor + { clientSyncProcessorQuerySyncedButChangedValues = \s -> + gets + ( \cs -> M.intersection (clientStoreSyncedButChangedItems cs) (M.fromSet (const ()) s) + ), + clientSyncProcessorSyncClientAdded = \m -> + modify + ( \cs -> + let (leftovers, added) = mergeAddedItems (clientStoreAddedItems cs) m + in cs {clientStoreAddedItems = leftovers, clientStoreSyncedItems = added `M.union` clientStoreSyncedItems cs} + ), + clientSyncProcessorSyncClientChanged = \m -> + modify + ( \cs -> + let (leftovers, changed) = mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) m + in cs {clientStoreSyncedButChangedItems = leftovers, clientStoreSyncedItems = changed `M.union` clientStoreSyncedItems cs} + ), + clientSyncProcessorSyncClientDeleted = \s -> + modify + ( \cs -> + let leftovers = mergeDeletedItems (clientStoreDeletedItems cs) s + in cs {clientStoreDeletedItems = leftovers} + ), + clientSyncProcessorSyncMergedConflict = \resolved -> + modify + ( \cs -> + let newSyncedButChanged = M.union resolved (clientStoreSyncedButChangedItems cs) + in cs {clientStoreSyncedButChangedItems = newSyncedButChanged, clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` newSyncedButChanged} + ), + clientSyncProcessorSyncServerAdded = \m -> + modify (\cs -> cs {clientStoreSyncedItems = m `M.union` clientStoreSyncedItems cs}), + clientSyncProcessorSyncServerChanged = \m -> + modify + ( \cs -> + let newSynced = m `M.union` clientStoreSyncedItems cs + in cs {clientStoreSyncedItems = newSynced, clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` newSynced} + ), + clientSyncProcessorSyncServerDeleted = \s -> + modify + ( \cs -> + let m = M.fromSet (const ()) s + in cs + { clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` m, + clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` m + } + ) + } + +-- | Merge the local added items with the ones that the server has acknowledged as added. +mergeAddedItems :: + forall ci si a. + (Ord ci, Ord si) => + Map ci a -> + Map ci (ClientAddition si) -> + (Map ci a, Map si (Timed a)) +mergeAddedItems local added = M.foldlWithKey go (M.empty, M.empty) local + where + go :: (Map ci a, Map si (Timed a)) -> ci -> a -> (Map ci a, Map si (Timed a)) + go (as, m) ci a = + case M.lookup ci added of + Nothing -> (M.insert ci a as, m) + Just ClientAddition {..} -> + ( as, + M.insert + clientAdditionId + (Timed {timedValue = a, timedTime = clientAdditionServerTime}) + m + ) + +-- | Merge the local synced but changed items with the ones that the server has acknowledged as changed. +mergeSyncedButChangedItems :: + forall i a. + Ord i => + Map i (Timed a) -> + Map i ServerTime -> + (Map i (Timed a), Map i (Timed a)) +mergeSyncedButChangedItems local changed = M.foldlWithKey go (M.empty, M.empty) local + where + go :: (Map i (Timed a), Map i (Timed a)) -> i -> Timed a -> (Map i (Timed a), Map i (Timed a)) + go (m1, m2) k t = + case M.lookup k changed of + Nothing -> (M.insert k t m1, m2) + Just st' -> (m1, M.insert k (t {timedTime = st'}) m2) + +-- | Merge the local deleted items with the ones that the server has acknowledged as deleted. +mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b +mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s + +data ClientSyncProcessor ci si a (m :: * -> *) + = ClientSyncProcessor + { -- | Get the synced values with keys in the given set + clientSyncProcessorQuerySyncedButChangedValues :: !(Set si -> m (Map si (Timed a))), + -- | Complete additions that were acknowledged by the server. + -- This involves saving the server id and the server time + clientSyncProcessorSyncClientAdded :: !(Map ci (ClientAddition si) -> m ()), + -- | Complete changes that were acknowledged by the server + -- This involves updating the server time + clientSyncProcessorSyncClientChanged :: !(Map si ServerTime -> m ()), + -- | Complete deletions that were acknowledged by the server + -- This means deleting these tombstoned items entirely + clientSyncProcessorSyncClientDeleted :: !(Set si -> m ()), + -- | Store the items that were in a conflict but the conflict was resolved correctly. + -- These items should be marked as changed. + clientSyncProcessorSyncMergedConflict :: !(Map si (Timed a) -> m ()), + clientSyncProcessorSyncServerAdded :: !(Map si (Timed a) -> m ()), + clientSyncProcessorSyncServerChanged :: !(Map si (Timed a) -> m ()), + clientSyncProcessorSyncServerDeleted :: !(Set si -> m ()) + } + deriving (Generic) + +mergeSyncResponseCustom :: (Ord si, Monad m) => ItemMergeStrategy a -> ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m () +mergeSyncResponseCustom ItemMergeStrategy {..} ClientSyncProcessor {..} SyncResponse {..} = do + -- Every client deleted conflict needs to be added, if the sync processor says so + let resolvedClientDeletedConflicts = mergeClientDeletedConflicts itemMergeStrategyMergeClientDeletedConflict syncResponseConflictsClientDeleted + -- Every change conflict, unless the client item is kept, needs to be updated + -- The unresolved conflicts don't need to be updated. + clientChangeConflicts <- clientSyncProcessorQuerySyncedButChangedValues $ M.keysSet syncResponseConflicts + let (_, mergedChangeConflicts, resolvedChangeConflicts) = mergeSyncedButChangedConflicts itemMergeStrategyMergeChangeConflict clientChangeConflicts syncResponseConflicts + -- Every served deleted conflict needs to be deleted, if the sync processor says so + clientServerDeletedConflicts <- clientSyncProcessorQuerySyncedButChangedValues syncResponseConflictsServerDeleted + let resolvedServerDeletedConflicts = mergeServerDeletedConflicts itemMergeStrategyMergeServerDeletedConflict clientServerDeletedConflicts + -- The order here matters. + clientSyncProcessorSyncServerAdded $ M.union syncResponseServerAdded resolvedClientDeletedConflicts + clientSyncProcessorSyncServerChanged $ M.union syncResponseServerChanged resolvedChangeConflicts + clientSyncProcessorSyncServerDeleted $ S.union syncResponseServerDeleted resolvedServerDeletedConflicts + clientSyncProcessorSyncMergedConflict mergedChangeConflicts + clientSyncProcessorSyncClientDeleted syncResponseClientDeleted + clientSyncProcessorSyncClientChanged syncResponseClientChanged + clientSyncProcessorSyncClientAdded syncResponseClientAdded + +-- | Resolve change conflicts +mergeSyncedButChangedConflicts :: + forall si a. + Ord si => + (a -> a -> ChangeConflictResolution a) -> + -- | The conflicting items on the client side + Map si (Timed a) -> + -- | The conflicting items on the server side + Map si (Timed a) -> + -- | Unresolved conflicts on the left, merged conflicts in the middle, resolved conflicts on the right + -- + -- * The unresolved conflicts should remain as-is + -- * The merged conflicts should be updated and marked as changed + -- * The resolved conflicts should be updated and marked as unchanged + (Map si (Timed a), Map si (Timed a), Map si (Timed a)) +mergeSyncedButChangedConflicts func clientItems = + M.foldlWithKey go (M.empty, M.empty, M.empty) + where + go :: + (Map si (Timed a), Map si (Timed a), Map si (Timed a)) -> + si -> + Timed a -> + (Map si (Timed a), Map si (Timed a), Map si (Timed a)) + go tup@(unresolved, merged, resolved) key s@(Timed si st) = case M.lookup key clientItems of + Nothing -> tup -- TODO not even sure what this would mean. Should not happen I guess. Just throw it away + Just c@(Timed ci _) -> case func ci si of + KeepLocal -> + (M.insert key c unresolved, merged, resolved) + Merged mi -> + (unresolved, M.insert key (Timed mi st) merged, M.insert key s resolved) + TakeRemote -> + (unresolved, merged, M.insert key s resolved) + +-- | Resolve client deleted conflicts +mergeClientDeletedConflicts :: + (a -> ClientDeletedConflictResolution) -> + -- | The conflicting items on the server side + Map si (Timed a) -> + -- | A map of items that need to be updated on the client. + Map si (Timed a) +mergeClientDeletedConflicts func = M.filter $ \(Timed si _) -> + case func si of + TakeRemoteChange -> True + StayDeleted -> False + +-- | Resolve server deleted conflicts +mergeServerDeletedConflicts :: + (a -> ServerDeletedConflictResolution) -> + -- | The conflicting items on the client side + Map si (Timed a) -> + -- | The result is a map of items that need to be deleted on the client. + Set si +mergeServerDeletedConflicts func m = M.keysSet $ flip M.filter m $ \(Timed si _) -> case func si of + KeepLocalChange -> False + Delete -> True + +data Identifier ci si + = OnlyServer si + | BothServerAndClient si ci + deriving (Show, Eq, Ord, Generic) + +instance (Validity ci, Validity si) => Validity (Identifier ci si) + +instance (NFData ci, NFData si) => NFData (Identifier ci si) + +data ServerSyncProcessor ci si a m + = ServerSyncProcessor + { -- | Read all items + serverSyncProcessorRead :: !(m (Map si (Timed a))), + -- | Add an item with 'initialServerTime' + serverSyncProcessorAddItem :: !(a -> m si), + -- | Update an item + serverSyncProcessorChangeItem :: !(si -> ServerTime -> a -> m ()), + -- | Delete an item + serverSyncProcessorDeleteItem :: !(si -> m ()) + } + deriving (Generic) + +-- | Process a server sync +-- +-- === __Implementation Details__ +-- +-- There are four cases for the items in the sync request +-- +-- - Added (A) +-- - Synced (S) +-- - Changed (C) +-- - Deleted (D) +-- +-- Each of them present options and may require action on the sever side: +-- +-- * Added: +-- +-- * Client Added (CA) (This is the only case where a new identifier needs to be generated.) +-- +-- * Synced: +-- +-- * Server Changed (SC) (Nothing) +-- * Server Deleted (SD) (Nothing) +-- +-- * Changed: +-- +-- * Client Changed (CC) (Update value and increment server time) +-- * Change Conflict (CConf) (Nothing) +-- * Server Deleted Conflict (SDC) (Nothing) +-- +-- * Deleted: +-- +-- * Client Deleted (CD) (Delete the item) +-- * Client Deleted Conflict (CDC) (Nothing) +-- +-- * Extra: +-- +-- * Server Added (SA) (Nothing) +-- +-- For more detailed comments of the nine cases, see the source of 'processServerItemSync' in the "Data.Mergeful.Item". +processServerSyncCustom :: + forall ci si a m. + ( Ord si, + Monad m + ) => + -- | Your server sync processor + ServerSyncProcessor ci si a m -> + SyncRequest ci si a -> + m (SyncResponse ci si a) +processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do + serverItems <- serverSyncProcessorRead + -- A: CA (generate a new identifier) + syncResponseClientAdded <- forM syncRequestNewItems $ \a -> do + si <- serverSyncProcessorAddItem a + pure $ ClientAddition {clientAdditionId = si, clientAdditionServerTime = initialServerTime} + -- C: + let decideOnSynced tup@(sc, sd) (si, ct) = + case M.lookup si serverItems of + -- SD: The server must have deleted it. + Nothing -> (sc, S.insert si sd) + Just t@(Timed _ st) -> + if ct >= st + then tup -- In sync + else (M.insert si t sc, sd) -- SC: The server has changed it because its server time is newer + let (syncResponseServerChanged, syncResponseServerDeleted) = foldl decideOnSynced (M.empty, S.empty) (M.toList syncRequestKnownItems) + -- S: + let decideOnChanged (cc, cConf, sdc) (si, Timed clientItem ct) = do + case M.lookup si serverItems of + -- SDC + Nothing -> pure (cc, cConf, S.insert si sdc) + Just serverTimed@(Timed _ st) -> + if ct >= st + then do + -- CC + let st' = incrementServerTime st + -- Update the server item + serverSyncProcessorChangeItem si st' clientItem + pure (M.insert si st' cc, cConf, sdc) + else do + -- CConf + pure (cc, M.insert si serverTimed cConf, sdc) + (syncResponseClientChanged, syncResponseConflicts, syncResponseConflictsServerDeleted) <- foldM decideOnChanged (M.empty, M.empty, S.empty) (M.toList syncRequestKnownButChangedItems) + --- D: + let decideOnDeleted (cd, cdc) (si, ct) = do + case M.lookup si serverItems of + Nothing -> do + -- CD: It was already deleted on the server side, Just pretend that the client made that happen. + pure (S.insert si cd, cdc) + Just serverTimed@(Timed _ st) -> + if ct >= st + then do + -- CD + -- Delete the item + serverSyncProcessorDeleteItem si + pure (S.insert si cd, cdc) + else do + -- CDC + pure (cd, M.insert si serverTimed cdc) + (syncResponseClientDeleted, syncResponseConflictsClientDeleted) <- foldM decideOnDeleted (S.empty, M.empty) (M.toList syncRequestDeletedItems) + -- Extra: for all items that are in the server but not in the sync request, we need to say they are server added. + let syncResponseServerAdded = serverItems `M.difference` M.unions [() <$ syncRequestKnownItems, () <$ syncRequestKnownButChangedItems, () <$ syncRequestDeletedItems] + pure SyncResponse {..} + +-- | Serve an 'SyncRequest' using the current 'ServerStore', producing an 'SyncResponse' and a new 'ServerStore'. +processServerSync :: + forall ci si a m. + ( Ord si, + Monad m + ) => + -- | The action that is guaranteed to generate unique identifiers + m si -> + ServerStore si a -> + SyncRequest ci si a -> + m (SyncResponse ci si a, ServerStore si a) +processServerSync genId ss sr = runStateT (processServerSyncCustom (pureServerSyncProcessor genId) sr) ss + +-- | A potentially pure sync processor +pureServerSyncProcessor :: + (Ord si, Monad m) => + -- | The action that is guaranteed to generate unique identifiers + m si -> + ServerSyncProcessor ci si a (StateT (ServerStore si a) m) +pureServerSyncProcessor genId = ServerSyncProcessor {..} + where + serverSyncProcessorRead = gets serverStoreItems + serverSyncProcessorAddItem a = do + i <- lift genId + modify (\(ServerStore m) -> ServerStore (M.insert i (Timed a initialServerTime) m)) + pure i + serverSyncProcessorChangeItem si st a = + modify + ( \(ServerStore m) -> + let m' = M.adjust (const (Timed a st)) si m + in ServerStore m' + ) + serverSyncProcessorDeleteItem si = + modify + ( \(ServerStore m) -> + let m' = M.delete si m + in ServerStore m' + ) + +distinct :: Eq a => [a] -> Bool +distinct ls = nub ls == ls diff --git a/src/Data/Mergeful/Item.hs b/src/Data/Mergeful/Item.hs --- a/src/Data/Mergeful/Item.hs +++ b/src/Data/Mergeful/Item.hs @@ -39,50 +39,63 @@ -- This whole approach can break down if a server resets its server times -- or if a client syncs with two different servers using the same server times. module Data.Mergeful.Item - ( initialClientItem - , initialItemSyncRequest - , makeItemSyncRequest - , mergeItemSyncResponseRaw - , ItemMergeResult(..) - , mergeItemSyncResponseIgnoreProblems - , mergeIgnoringProblems - , mergeFromServer - , ItemMergeStrategy(..) - , mergeUsingStrategy - -- * Server side - , initialServerItem - , processServerItemSync - -- * Types, for reference - , ClientItem(..) - , ItemSyncRequest(..) - , ItemSyncResponse(..) - , ServerItem(..) - ) where + ( initialClientItem, + initialItemSyncRequest, + makeItemSyncRequest, + mergeItemSyncResponseFromServer, + mergeItemSyncResponseFromClient, + mergeItemSyncResponseUsingCRDT, + mergeItemSyncResponseUsingStrategy, + mergeFromServer, + mergeFromServerStrategy, + mergeFromClient, + mergeFromClientStrategy, + mergeUsingCRDT, + mergeUsingCRDTStrategy, + ItemMergeStrategy (..), + ChangeConflictResolution (..), + ClientDeletedConflictResolution (..), + ServerDeletedConflictResolution (..), + mergeUsingStrategy, + mergeItemSyncResponseRaw, + ItemMergeResult (..), -import GHC.Generics (Generic) + -- * Server side + initialServerItem, + processServerItemSync, -import Data.Aeson as JSON -import Data.Validity + -- * Types, for reference + ClientItem (..), + ItemSyncRequest (..), + ItemSyncResponse (..), + ServerItem (..), + ) +where import Control.Applicative - +import Control.DeepSeq +import Data.Aeson as JSON import Data.Mergeful.Timed +import Data.Validity +import GHC.Generics (Generic) data ClientItem a - -- | There is no item on the client side - = ClientEmpty - -- | There is is an item but the server is not aware of it yet. - | ClientAdded !a - -- | There is is an item and it has been synced with the server. - | ClientItemSynced !(Timed a) - -- | There is is an item and it has been synced with the server, but it has since been modified. - | ClientItemSyncedButChanged !(Timed a) - -- | There was an item, and it has been deleted locally, but the server has not been made aware of this. - | ClientDeleted !ServerTime + = -- | There is no item on the client side + ClientEmpty + | -- | There is is an item but the server is not aware of it yet. + ClientAdded !a + | -- | There is is an item and it has been synced with the server. + ClientItemSynced !(Timed a) + | -- | There is is an item and it has been synced with the server, but it has since been modified. + ClientItemSyncedButChanged !(Timed a) + | -- | There was an item, and it has been deleted locally, but the server has not been made aware of this. + ClientDeleted !ServerTime deriving (Show, Eq, Generic) instance Validity a => Validity (ClientItem a) +instance NFData a => NFData (ClientItem a) + instance FromJSON a => FromJSON (ClientItem a) where parseJSON = withObject "ClientItem" $ \o -> do @@ -98,14 +111,14 @@ instance ToJSON a => ToJSON (ClientItem a) where toJSON ci = object $ - case ci of - ClientEmpty -> ["type" .= ("empty" :: String)] - ClientAdded a -> ["type" .= ("added" :: String), "value" .= a] - ClientItemSynced Timed {..} -> - ["type" .= ("synced" :: String), "value" .= timedValue, "time" .= timedTime] - ClientItemSyncedButChanged Timed {..} -> - ["type" .= ("changed" :: String), "value" .= timedValue, "time" .= timedTime] - ClientDeleted t -> ["type" .= ("deleted" :: String), "time" .= t] + case ci of + ClientEmpty -> ["type" .= ("empty" :: String)] + ClientAdded a -> ["type" .= ("added" :: String), "value" .= a] + ClientItemSynced Timed {..} -> + ["type" .= ("synced" :: String), "value" .= timedValue, "time" .= timedTime] + ClientItemSyncedButChanged Timed {..} -> + ["type" .= ("changed" :: String), "value" .= timedValue, "time" .= timedTime] + ClientDeleted t -> ["type" .= ("deleted" :: String), "time" .= t] -- | A client item to start with. -- @@ -114,14 +127,16 @@ initialClientItem = ClientEmpty data ServerItem a - -- | There is no item on the server side - = ServerEmpty - -- | There is an item on the server side, and it was last synced at the given 'ServerTime'. - | ServerFull !(Timed a) + = -- | There is no item on the server side + ServerEmpty + | -- | There is an item on the server side, and it was last synced at the given 'ServerTime'. + ServerFull !(Timed a) deriving (Show, Eq, Generic) instance Validity a => Validity (ServerItem a) +instance NFData a => NFData (ServerItem a) + instance FromJSON a => FromJSON (ServerItem a) where parseJSON = withObject "ServerItem" $ \o -> @@ -130,9 +145,9 @@ instance ToJSON a => ToJSON (ServerItem a) where toJSON si = object $ - case si of - ServerEmpty -> [] - ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime] + case si of + ServerEmpty -> [] + ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime] -- | A server item to start with. -- @@ -141,22 +156,24 @@ initialServerItem = ServerEmpty data ItemSyncRequest a - -- | There is no item locally - = ItemSyncRequestPoll - -- | There is an item locally that has not been synced to the server yet. - | ItemSyncRequestNew !a - -- | There is an item locally that was synced at the given 'ServerTime' - | ItemSyncRequestKnown !ServerTime - -- | There is an item locally that was synced at the given 'ServerTime' - -- but it has been changed since then. - | ItemSyncRequestKnownButChanged !(Timed a) - -- | There was an item locally that has been deleted but the - -- deletion wasn't synced to the server yet. - | ItemSyncRequestDeletedLocally !ServerTime + = -- | There is no item locally + ItemSyncRequestPoll + | -- | There is an item locally that has not been synced to the server yet. + ItemSyncRequestNew !a + | -- | There is an item locally that was synced at the given 'ServerTime' + ItemSyncRequestKnown !ServerTime + | -- | There is an item locally that was synced at the given 'ServerTime' + -- but it has been changed since then. + ItemSyncRequestKnownButChanged !(Timed a) + | -- | There was an item locally that has been deleted but the + -- deletion wasn't synced to the server yet. + ItemSyncRequestDeletedLocally !ServerTime deriving (Show, Eq, Generic) instance Validity a => Validity (ItemSyncRequest a) +instance NFData a => NFData (ItemSyncRequest a) + instance FromJSON a => FromJSON (ItemSyncRequest a) where parseJSON = withObject "ItemSyncRequest" $ \o -> do @@ -172,15 +189,15 @@ instance ToJSON a => ToJSON (ItemSyncRequest a) where toJSON ci = object $ - let o n rest = ("type" .= (n :: String)) : rest - oe n = o n [] - in case ci of - ItemSyncRequestPoll -> oe "empty" - ItemSyncRequestNew a -> o "added" ["value" .= a] - ItemSyncRequestKnown t -> o "synced" ["time" .= t] - ItemSyncRequestKnownButChanged Timed {..} -> - o "changed" ["value" .= timedValue, "time" .= timedTime] - ItemSyncRequestDeletedLocally t -> o "deleted" ["time" .= t] + let o n rest = ("type" .= (n :: String)) : rest + oe n = o n [] + in case ci of + ItemSyncRequestPoll -> oe "empty" + ItemSyncRequestNew a -> o "added" ["value" .= a] + ItemSyncRequestKnown t -> o "synced" ["time" .= t] + ItemSyncRequestKnownButChanged Timed {..} -> + o "changed" ["value" .= timedValue, "time" .= timedTime] + ItemSyncRequestDeletedLocally t -> o "deleted" ["time" .= t] -- | An intial 'ItemSyncRequest' to start with. -- @@ -189,60 +206,59 @@ initialItemSyncRequest = ItemSyncRequestPoll data ItemSyncResponse a - -- | The client and server are fully in sync, and both empty - -- - -- Nothing needs to be done at the client side. - = ItemSyncResponseInSyncEmpty - -- | The client and server are fully in sync. - -- - -- Nothing needs to be done at the client side. - | ItemSyncResponseInSyncFull - -- | The client added an item and server has succesfully been made aware of that. - -- - -- The client needs to update its server time - | ItemSyncResponseClientAdded !ServerTime - -- | The client changed an item and server has succesfully been made aware of that. - -- - -- The client needs to update its server time - | ItemSyncResponseClientChanged !ServerTime - -- | The client deleted an item and server has succesfully been made aware of that. - -- - -- The client can delete it from its deleted items - | ItemSyncResponseClientDeleted - -- | This item has been added on the server side - -- - -- The client should add it too. - | ItemSyncResponseServerAdded !(Timed a) - -- | This item has been modified on the server side. - -- - -- The client should modify it too. - | ItemSyncResponseServerChanged !(Timed a) - -- | The item was deleted on the server side - -- - -- The client should delete it too. - | ItemSyncResponseServerDeleted - -- | A conflict occurred. - -- - -- The server and the client both have an item, but it is different. - -- The server kept its part, the client can either take whatever the server gave them - -- or deal with the conflict somehow, and then try to re-sync. - | ItemSyncResponseConflict !(Timed a) -- ^ The item at the server side - -- | A conflict occurred. - -- - -- The server has an item but the client does not. - -- The server kept its part, the client can either take whatever the server gave them - -- or deal with the conflict somehow, and then try to re-sync. - | ItemSyncResponseConflictClientDeleted !(Timed a) -- ^ The item at the server side - -- | A conflict occurred. - -- - -- The client has a (modified) item but the server does not have any item. - -- The server left its item deleted, the client can either delete its item too - -- or deal with the conflict somehow, and then try to re-sync. + = -- | The client and server are fully in sync, and both empty + -- + -- Nothing needs to be done at the client side. + ItemSyncResponseInSyncEmpty + | -- | The client and server are fully in sync. + -- + -- Nothing needs to be done at the client side. + ItemSyncResponseInSyncFull + | -- | The client added an item and server has succesfully been made aware of that. + -- + -- The client needs to update its server time + ItemSyncResponseClientAdded !ServerTime + | -- | The client changed an item and server has succesfully been made aware of that. + -- + -- The client needs to update its server time + ItemSyncResponseClientChanged !ServerTime + | -- | The client deleted an item and server has succesfully been made aware of that. + -- + -- The client can delete it from its deleted items + ItemSyncResponseClientDeleted + | -- | This item has been added on the server side + -- + -- The client should add it too. + ItemSyncResponseServerAdded !(Timed a) + | -- | This item has been modified on the server side. + -- + -- The client should modify it too. + ItemSyncResponseServerChanged !(Timed a) + | -- | The item was deleted on the server side + -- + -- The client should delete it too. + ItemSyncResponseServerDeleted + | -- | The item at the server side + -- | A conflict occurred. + -- + -- The server has an item but the client does not. + -- The server kept its part, the client can either take whatever the server gave them + -- or deal with the conflict somehow, and then try to re-sync. + ItemSyncResponseConflict !(Timed a) + | -- | The item at the server side + -- | A conflict occurred. + -- + -- The client has a (modified) item but the server does not have any item. + -- The server left its item deleted, the client can either delete its item too + -- or deal with the conflict somehow, and then try to re-sync. + ItemSyncResponseConflictClientDeleted !(Timed a) | ItemSyncResponseConflictServerDeleted deriving (Show, Eq, Generic) instance Validity a => Validity (ItemSyncResponse a) +instance NFData a => NFData (ItemSyncResponse a) + instance FromJSON a => FromJSON (ItemSyncResponse a) where parseJSON = withObject "ItemSyncResponse" $ \o -> do @@ -265,22 +281,22 @@ instance ToJSON a => ToJSON (ItemSyncResponse a) where toJSON isr = object $ - let o s rest = ("type" .= (s :: String)) : rest - oe s = o s [] - in case isr of - ItemSyncResponseInSyncEmpty -> oe "in-sync-empty" - ItemSyncResponseInSyncFull -> oe "in-sync-full" - ItemSyncResponseClientAdded t -> o "client-added" ["time" .= t] - ItemSyncResponseClientChanged t -> o "client-changed" ["time" .= t] - ItemSyncResponseClientDeleted -> oe "client-deleted" - ItemSyncResponseServerAdded Timed {..} -> - o "server-added" ["value" .= timedValue, "time" .= timedTime] - ItemSyncResponseServerChanged Timed {..} -> - o "server-changed" ["value" .= timedValue, "time" .= timedTime] - ItemSyncResponseServerDeleted -> oe "server-deleted" - ItemSyncResponseConflict a -> o "conflict" ["value" .= a] - ItemSyncResponseConflictClientDeleted a -> o "conflict-client-deleted" ["value" .= a] - ItemSyncResponseConflictServerDeleted -> oe "conflict-server-deleted" + let o s rest = ("type" .= (s :: String)) : rest + oe s = o s [] + in case isr of + ItemSyncResponseInSyncEmpty -> oe "in-sync-empty" + ItemSyncResponseInSyncFull -> oe "in-sync-full" + ItemSyncResponseClientAdded t -> o "client-added" ["time" .= t] + ItemSyncResponseClientChanged t -> o "client-changed" ["time" .= t] + ItemSyncResponseClientDeleted -> oe "client-deleted" + ItemSyncResponseServerAdded Timed {..} -> + o "server-added" ["value" .= timedValue, "time" .= timedTime] + ItemSyncResponseServerChanged Timed {..} -> + o "server-changed" ["value" .= timedValue, "time" .= timedTime] + ItemSyncResponseServerDeleted -> oe "server-deleted" + ItemSyncResponseConflict a -> o "conflict" ["value" .= a] + ItemSyncResponseConflictClientDeleted a -> o "conflict-client-deleted" ["value" .= a] + ItemSyncResponseConflictServerDeleted -> oe "conflict-server-deleted" -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. -- @@ -295,20 +311,24 @@ ClientDeleted st -> ItemSyncRequestDeletedLocally st data ItemMergeResult a - -- | The merger went succesfully, no conflicts or desyncs - = MergeSuccess !(ClientItem a) - -- | There was a merge conflict. The server and client had different, conflicting versions. - | MergeConflict !a !(Timed a) -- ^ The item at the server side - -- | There was a merge conflict. The client had deleted the item while the server had modified it. - | MergeConflictClientDeleted !(Timed a) -- ^ The item at the server side - -- | There was a merge conflict. The server had deleted the item while the client had modified it. - | MergeConflictServerDeleted !a -- ^ The item at the client side - -- | The server responded with a response that did not make sense given the client's request. + = -- | The merger went succesfully, no conflicts or desyncs + MergeSuccess !(ClientItem a) + | -- | The item at the server side + -- | There was a merge conflict. The client had deleted the item while the server had modified it. + MergeConflict !a !(Timed a) + | -- | The item at the server side + -- | There was a merge conflict. The server had deleted the item while the client had modified it. + MergeConflictClientDeleted !(Timed a) + | -- | The item at the client side + -- | The server responded with a response that did not make sense given the client's request. + MergeConflictServerDeleted !a | MergeMismatch deriving (Show, Eq, Generic) instance Validity a => Validity (ItemMergeResult a) +instance NFData a => NFData (ItemMergeResult a) + -- | Merge an 'ItemSyncResponse' into the current 'ClientItem'. -- -- This function will not make any decisions about what to do with @@ -346,48 +366,48 @@ ItemSyncResponseConflictClientDeleted si -> MergeConflictClientDeleted si _ -> MergeMismatch --- | Merge an 'ItemSyncResponse' into the current 'ClientItem'. --- --- This function ignores any problems that may occur. --- In the case of a conclict, it will just not update the client item. --- The next sync request will then produce a conflict again. --- --- > mergeItemSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeItemSyncResponseRaw cs -mergeItemSyncResponseIgnoreProblems :: ClientItem a -> ItemSyncResponse a -> ClientItem a -mergeItemSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeItemSyncResponseRaw cs +mergeItemSyncResponseUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemSyncResponse a -> ClientItem a +mergeItemSyncResponseUsingStrategy strat ci sr = mergeUsingStrategy strat ci $ mergeItemSyncResponseRaw ci sr +mergeItemSyncResponseFromServer :: ClientItem a -> ItemSyncResponse a -> ClientItem a +mergeItemSyncResponseFromServer = mergeItemSyncResponseUsingStrategy mergeFromServerStrategy + +mergeItemSyncResponseFromClient :: ClientItem a -> ItemSyncResponse a -> ClientItem a +mergeItemSyncResponseFromClient = mergeItemSyncResponseUsingStrategy mergeFromClientStrategy + +mergeItemSyncResponseUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemSyncResponse a -> ClientItem a +mergeItemSyncResponseUsingCRDT = mergeItemSyncResponseUsingStrategy . mergeUsingCRDTStrategy + -- | A strategy to merge conflicts for item synchronisation -data ItemMergeStrategy a = - ItemMergeStrategy - { itemMergeStrategyMergeChangeConflict :: a -> Timed a -> Timed a - -- ^ How to merge modification conflicts - , itemMergeStrategyMergeClientDeletedConflict :: Timed a -> Maybe (Timed a) - -- ^ How to merge conflicts where the client deleted an item that the server modified - , itemMergeStrategyMergeServerDeletedConflict :: a -> Maybe a - -- ^ How to merge conflicts where the server deleted an item that the client modified - } +data ItemMergeStrategy a + = ItemMergeStrategy + { -- | How to merge modification conflicts + -- + -- The first argument is the client item and the second argument is the server item. + itemMergeStrategyMergeChangeConflict :: a -> a -> ChangeConflictResolution a, + -- | How to merge conflicts where the client deleted an item that the server modified + itemMergeStrategyMergeClientDeletedConflict :: a -> ClientDeletedConflictResolution, + -- | How to merge conflicts where the server deleted an item that the client modified + itemMergeStrategyMergeServerDeletedConflict :: a -> ServerDeletedConflictResolution + } deriving (Generic) --- | Ignore any merge problems in a 'ItemMergeResult'. --- --- This function just returns the original 'ClientItem' if anything other than 'MergeSuccess' occurs. --- --- This function ignores any problems that may occur. --- In the case of a conclict, it will just not update the client item. --- The next sync request will then produce a conflict again. --- --- Pro: does not lose data --- --- __Con: Clients will diverge when a conflict occurs__ -mergeIgnoringProblems :: ClientItem a -> ItemMergeResult a -> ClientItem a -mergeIgnoringProblems cs mr = - case mr of - MergeSuccess cs' -> cs' - MergeConflict _ _ -> cs - MergeConflictServerDeleted _ -> cs - MergeConflictClientDeleted _ -> cs - MergeMismatch -> cs +data ChangeConflictResolution a + = KeepLocal + | TakeRemote + | Merged a + deriving (Show, Eq, Generic) +data ClientDeletedConflictResolution + = TakeRemoteChange + | StayDeleted + deriving (Show, Eq, Generic) + +data ServerDeletedConflictResolution + = KeepLocalChange + | Delete + deriving (Show, Eq, Generic) + -- | Resolve an 'ItemMergeResult' using a given merge strategy. -- -- This function ignores 'MergeMismatch' and will just return the original 'ClientItem' in that case. @@ -398,20 +418,30 @@ -- * Idempotent -- * The same on all clients mergeUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemMergeResult a -> ClientItem a -mergeUsingStrategy ItemMergeStrategy {..} cs mr = +mergeUsingStrategy ItemMergeStrategy {..} ci mr = case mr of - MergeSuccess cs' -> cs' - MergeConflict a1 a2 -> ClientItemSynced $ itemMergeStrategyMergeChangeConflict a1 a2 - MergeConflictClientDeleted sa -> - case itemMergeStrategyMergeClientDeletedConflict sa of - Nothing -> ClientEmpty - Just t -> ClientItemSynced t - MergeConflictServerDeleted ca -> - case itemMergeStrategyMergeServerDeletedConflict ca of - Nothing -> ClientEmpty - Just a -> ClientAdded a - MergeMismatch -> cs + MergeSuccess ci' -> ci' + MergeConflict a1 ri -> mergeChangeConflict itemMergeStrategyMergeChangeConflict ci a1 ri + MergeConflictClientDeleted ri -> mergeClientDeletedConflict itemMergeStrategyMergeClientDeletedConflict ci ri + MergeConflictServerDeleted ca -> mergeServerDeletedConflict itemMergeStrategyMergeServerDeletedConflict ci ca + MergeMismatch -> ci +mergeChangeConflict :: (a -> a -> ChangeConflictResolution a) -> ClientItem a -> a -> Timed a -> ClientItem a +mergeChangeConflict func ci a1 ri@(Timed a2 st) = case func a1 a2 of + KeepLocal -> ci + TakeRemote -> ClientItemSynced ri + Merged ma -> ClientItemSynced $ Timed ma st + +mergeClientDeletedConflict :: (a -> ClientDeletedConflictResolution) -> ClientItem a -> Timed a -> ClientItem a +mergeClientDeletedConflict func ci ri@(Timed sa _) = case func sa of + TakeRemoteChange -> ClientItemSynced ri + StayDeleted -> ci -- We can't just use 'ClientEmpty' here because otherwise the 'mergeUsingStrategy' wouldn't be idempotent anymore. + +mergeServerDeletedConflict :: (a -> ServerDeletedConflictResolution) -> ClientItem a -> a -> ClientItem a +mergeServerDeletedConflict func ci ca = case func ca of + KeepLocalChange -> ci -- We can't just use 'ClientAdded ca' here because otherwise the 'mergeUsingStrategy' wouldn't be idempotent anymore. + Delete -> ClientEmpty + -- | Resolve an 'ItemMergeResult' by taking whatever the server gave the client. -- -- Pro: Clients will converge on the same value. @@ -419,13 +449,55 @@ -- __Con: Conflicting updates will be lost.__ mergeFromServer :: ClientItem a -> ItemMergeResult a -> ClientItem a mergeFromServer = - mergeUsingStrategy - ItemMergeStrategy - { itemMergeStrategyMergeChangeConflict = \_ serverItem -> serverItem - , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem - , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing - } + mergeUsingStrategy mergeFromServerStrategy +-- | A merge strategy that takes whatever the server gave the client. +-- +-- Pro: Clients will converge on the same value. +-- +-- __Con: Conflicting updates will be lost.__ +mergeFromServerStrategy :: ItemMergeStrategy a +mergeFromServerStrategy = + ItemMergeStrategy + { itemMergeStrategyMergeChangeConflict = \_ _ -> TakeRemote, + itemMergeStrategyMergeClientDeletedConflict = \_ -> TakeRemoteChange, + itemMergeStrategyMergeServerDeletedConflict = \_ -> Delete + } + +-- | Resolve an 'ItemMergeResult' by keeping whatever the client had. +-- +-- Pro: does not lose data +-- +-- __Con: Clients will diverge when a conflict occurs__ +mergeFromClient :: ClientItem a -> ItemMergeResult a -> ClientItem a +mergeFromClient = mergeUsingStrategy mergeFromClientStrategy + +-- | A merge strategy that keeps whatever the client had. +-- +-- Pro: does not lose data +-- +-- __Con: Clients will diverge when a conflict occurs__ +mergeFromClientStrategy :: ItemMergeStrategy a +mergeFromClientStrategy = + ItemMergeStrategy + { itemMergeStrategyMergeChangeConflict = \_ _ -> KeepLocal, + itemMergeStrategyMergeClientDeletedConflict = \_ -> StayDeleted, + itemMergeStrategyMergeServerDeletedConflict = \_ -> KeepLocalChange + } + +mergeUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemMergeResult a -> ClientItem a +mergeUsingCRDT = mergeUsingStrategy . mergeUsingCRDTStrategy + +-- | A merge strategy that uses a CRDT merging function to merge items. +-- +-- In case of other-than-change conflicts, this will be the same as the 'mergeFromServerStrategy' strategy. +-- If this is not what you want, create your own 'ItemMergeStrategy' manually. +mergeUsingCRDTStrategy :: (a -> a -> a) -> ItemMergeStrategy a +mergeUsingCRDTStrategy merge = + mergeFromServerStrategy + { itemMergeStrategyMergeChangeConflict = \a1 a2 -> Merged (merge a1 a2) + } + -- | Serve an 'ItemSyncRequest' using the current 'ServerItem', producing an 'ItemSyncResponse' and a new 'ServerItem'. processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a) processServerItemSync store sr = @@ -436,79 +508,83 @@ ItemSyncRequestPoll -> (ItemSyncResponseInSyncEmpty, store) ItemSyncRequestNew ci -> (ItemSyncResponseClientAdded t, ServerFull $ Timed {timedValue = ci, timedTime = t}) - ItemSyncRequestKnown _ - -- This indicates that the server synced with another client and was told to - -- delete its item. - -- - -- Given that the client indicates that it did not change anything locally, - -- the server will just instruct the client to delete its item too. - -- No conflict here. - -> (ItemSyncResponseServerDeleted, store) - ItemSyncRequestKnownButChanged _ - -- This indicates that the server synced with another client and was told to - -- delete its item. - -- - -- Given that the client indicates that it *did* change its item locally, - -- there is a conflict. - -> (ItemSyncResponseConflictServerDeleted, store) - ItemSyncRequestDeletedLocally _ - -- This means that the server synced with another client, - -- was instructed to delete its item by that client, - -- and is now being told to delete its item again. - -- - -- That's fine, it will just remain deleted. - -- No conflict here - -> (ItemSyncResponseClientDeleted, store) + ItemSyncRequestKnown _ -> + -- This indicates that the server synced with another client and was told to + -- delete its item. + -- + -- Given that the client indicates that it did not change anything locally, + -- the server will just instruct the client to delete its item too. + -- No conflict here. + (ItemSyncResponseServerDeleted, store) + ItemSyncRequestKnownButChanged _ -> + -- This indicates that the server synced with another client and was told to + -- delete its item. + -- + -- Given that the client indicates that it *did* change its item locally, + -- there is a conflict. + (ItemSyncResponseConflictServerDeleted, store) + ItemSyncRequestDeletedLocally _ -> + -- This means that the server synced with another client, + -- was instructed to delete its item by that client, + -- and is now being told to delete its item again. + -- + -- That's fine, it will just remain deleted. + -- No conflict here + (ItemSyncResponseClientDeleted, store) ServerFull t@(Timed si st) -> let st' = incrementServerTime st in case sr of - ItemSyncRequestPoll + ItemSyncRequestPoll -> -- The client is empty but the server is not. -- This means that the server has synced with another client before, -- so we can just send the item to the client. - -> (ItemSyncResponseServerAdded (Timed {timedValue = si, timedTime = st}), store) - ItemSyncRequestNew _ + (ItemSyncResponseServerAdded (Timed {timedValue = si, timedTime = st}), store) + ItemSyncRequestNew _ -> -- The client has a newly added item, so it thought it was empty before that, -- but the server has already synced with another client before. -- This indicates a conflict. -- The server is always right, so the item at the server will remain unmodified. -- The client will receive the conflict. - -> (ItemSyncResponseConflict t, store) + (ItemSyncResponseConflict t, store) ItemSyncRequestKnown ct -> if ct >= st - -- The client time is equal to the server time. + then-- The client time is equal to the server time. -- The client indicates that the item was not modified at their side. -- This means that the items are in sync. -- (Unless the server somehow modified the item but not its server time, -- which would beconsidered a bug.) - then (ItemSyncResponseInSyncFull, store) - -- The client time is less than the server time + (ItemSyncResponseInSyncFull, store) + else-- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item was not modified at their side, -- we can just send it back to the client to have them update their version. -- No conflict here. - else ( ItemSyncResponseServerChanged (Timed {timedValue = si, timedTime = st}) - , store) + + ( ItemSyncResponseServerChanged (Timed {timedValue = si, timedTime = st}), + store + ) ItemSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} -> if ct >= st - -- The client time is equal to the server time. + then-- The client time is equal to the server time. -- The client indicates that the item *was* modified at their side. -- This means that the server needs to be updated. - then ( ItemSyncResponseClientChanged st' - , ServerFull (Timed {timedValue = ci, timedTime = st'})) - -- The client time is less than the server time + + ( ItemSyncResponseClientChanged st', + ServerFull (Timed {timedValue = ci, timedTime = st'}) + ) + else-- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item *was* modified at their side, -- there is a conflict. - else (ItemSyncResponseConflict t, store) + (ItemSyncResponseConflict t, store) ItemSyncRequestDeletedLocally ct -> if ct >= st - -- The client time is equal to the server time. + then-- The client time is equal to the server time. -- The client indicates that the item was deleted on their side. -- This means that the server item needs to be deleted as well. - then (ItemSyncResponseClientDeleted, ServerEmpty) - -- The client time is less than the server time + (ItemSyncResponseClientDeleted, ServerEmpty) + else-- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item was deleted at their side, -- there is a conflict. - else (ItemSyncResponseConflictClientDeleted t, store) + (ItemSyncResponseConflictClientDeleted t, store) diff --git a/src/Data/Mergeful/Timed.hs b/src/Data/Mergeful/Timed.hs --- a/src/Data/Mergeful/Timed.hs +++ b/src/Data/Mergeful/Timed.hs @@ -1,23 +1,24 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Dealing with server times. -- -- __If you are importing this module, you are probably doing something wrong.__ module Data.Mergeful.Timed - ( ServerTime - , initialServerTime - , incrementServerTime - , Timed(..) - ) where - -import GHC.Generics (Generic) + ( ServerTime (..), + initialServerTime, + incrementServerTime, + Timed (..), + ) +where +import Control.DeepSeq import Data.Aeson as JSON import Data.Validity import Data.Word +import GHC.Generics (Generic) -- | A "time", as "measured" by the server. -- @@ -25,31 +26,41 @@ -- distinction should not matter for your usage of this library. -- -- In any case, a client should not be changing this value. -newtype ServerTime = - ServerTime - { unServerTime :: Word64 - } +-- +-- We use a 'Word64' instead of a natural. +-- This will go wrong after 2^64 versions, but since that +-- will not happen in practice, we will not worry about it. +-- You would have to sync millions of modifications every second +-- until long after the sun consumes the earth for this to be a problem. +newtype ServerTime + = ServerTime + { unServerTime :: Word64 + } deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) instance Validity ServerTime +instance NFData ServerTime + -- | A server time to start with. initialServerTime :: ServerTime initialServerTime = ServerTime 0 --- | Increment a server time, this will only start repeating after at least @2^64 - 1@ values, so you're probably fine. +-- | Increment a server time. incrementServerTime :: ServerTime -> ServerTime incrementServerTime (ServerTime w) = ServerTime (succ w) -- | A value along with a server time. -data Timed a = - Timed - { timedValue :: !a - , timedTime :: !ServerTime - } +data Timed a + = Timed + { timedValue :: !a, + timedTime :: !ServerTime + } deriving (Show, Eq, Generic) instance Validity a => Validity (Timed a) + +instance NFData a => NFData (Timed a) instance FromJSON a => FromJSON (Timed a) where parseJSON = withObject "Timed" $ \o -> Timed <$> o .: "value" <*> o .: "time" diff --git a/src/Data/Mergeful/Value.hs b/src/Data/Mergeful/Value.hs --- a/src/Data/Mergeful/Value.hs +++ b/src/Data/Mergeful/Value.hs @@ -38,31 +38,33 @@ -- This whole approach can break down if a server resets its server times -- or if a client syncs with two different servers using the same server times. module Data.Mergeful.Value - ( initialClientValue - , makeValueSyncRequest - , mergeValueSyncResponseRaw - , ValueMergeResult(..) - , mergeValueSyncResponseIgnoreProblems - , mergeIgnoringProblems - , mergeFromServer - , mergeUsingFunction + ( initialClientValue, + makeValueSyncRequest, + mergeValueSyncResponseRaw, + ValueMergeResult (..), + mergeValueSyncResponseIgnoreProblems, + mergeIgnoringProblems, + mergeFromServer, + mergeUsingFunction, + -- * Server side - , initialServerValue - , processServerValueSync - -- * Types, for reference - , ChangedFlag(..) - , ClientValue(..) - , ValueSyncRequest(..) - , ValueSyncResponse(..) - , ServerValue(..) - ) where + initialServerValue, + processServerValueSync, -import GHC.Generics (Generic) + -- * Types, for reference + ChangedFlag (..), + ClientValue (..), + ValueSyncRequest (..), + ValueSyncResponse (..), + ServerValue (..), + ) +where +import Control.DeepSeq import Data.Aeson as JSON -import Data.Validity - import Data.Mergeful.Timed +import Data.Validity +import GHC.Generics (Generic) data ChangedFlag = Changed @@ -71,6 +73,8 @@ instance Validity ChangedFlag +instance NFData ChangedFlag + -- | The client side value. -- -- The only differences between `a` and 'ClientValue a' are that @@ -78,31 +82,36 @@ -- the server, and whether the item has been modified at the client -- -- There cannot be an unsynced 'ClientValue'. -data ClientValue a = - ClientValue !(Timed a) !ChangedFlag +data ClientValue a + = ClientValue !(Timed a) !ChangedFlag deriving (Show, Eq, Generic) instance Validity a => Validity (ClientValue a) +instance NFData a => NFData (ClientValue a) + instance FromJSON a => FromJSON (ClientValue a) where parseJSON = withObject "ClientValue" $ \o -> - ClientValue <$> (Timed <$> o .: "value" <*> o .: "time") <*> - ((\b -> - if b - then Changed - else NotChanged) <$> - o .: "changed") + ClientValue <$> (Timed <$> o .: "value" <*> o .: "time") + <*> ( ( \b -> + if b + then Changed + else NotChanged + ) + <$> o .: "changed" + ) instance ToJSON a => ToJSON (ClientValue a) where toJSON (ClientValue Timed {..} cf) = object - [ "value" .= timedValue - , "time" .= timedTime - , "changed" .= - (case cf of - Changed -> True - NotChanged -> False) + [ "value" .= timedValue, + "time" .= timedTime, + "changed" + .= ( case cf of + Changed -> True + NotChanged -> False + ) ] -- | Produce a client value based on an initial synchronisation request @@ -113,12 +122,14 @@ -- -- The only difference between 'a' and 'ServerValue a' is that 'ServerValue a' also -- remembers the last time this value was changed during synchronisation. -newtype ServerValue a = - ServerValue (Timed a) +newtype ServerValue a + = ServerValue (Timed a) deriving (Show, Eq, Generic) instance Validity a => Validity (ServerValue a) +instance NFData a => NFData (ServerValue a) + instance FromJSON a => FromJSON (ServerValue a) where parseJSON = withObject "ServerValue" $ \o -> ServerValue <$> (Timed <$> o .: "value" <*> o .: "time") @@ -133,15 +144,17 @@ initialServerValue a = ServerValue $ Timed {timedValue = a, timedTime = initialServerTime} data ValueSyncRequest a - -- | There is an item locally that was synced at the given 'ServerTime' - = ValueSyncRequestKnown !ServerTime - -- | There is an item locally that was synced at the given 'ServerTime' - -- but it has been changed since then. - | ValueSyncRequestKnownButChanged !(Timed a) + = -- | There is an item locally that was synced at the given 'ServerTime' + ValueSyncRequestKnown !ServerTime + | -- | There is an item locally that was synced at the given 'ServerTime' + -- but it has been changed since then. + ValueSyncRequestKnownButChanged !(Timed a) deriving (Show, Eq, Generic) instance Validity a => Validity (ValueSyncRequest a) +instance NFData a => NFData (ValueSyncRequest a) + instance FromJSON a => FromJSON (ValueSyncRequest a) where parseJSON = withObject "ValueSyncRequest" $ \o -> do @@ -154,35 +167,33 @@ instance ToJSON a => ToJSON (ValueSyncRequest a) where toJSON ci = object $ - let o n rest = ("type" .= (n :: String)) : rest - in case ci of - ValueSyncRequestKnown t -> o "synced" ["time" .= t] - ValueSyncRequestKnownButChanged Timed {..} -> - o "changed" ["value" .= timedValue, "time" .= timedTime] + let o n rest = ("type" .= (n :: String)) : rest + in case ci of + ValueSyncRequestKnown t -> o "synced" ["time" .= t] + ValueSyncRequestKnownButChanged Timed {..} -> + o "changed" ["value" .= timedValue, "time" .= timedTime] data ValueSyncResponse a - -- | The client and server are fully in sync. - -- - -- Nothing needs to be done at the client side. - = ValueSyncResponseInSync - -- | The client changed the value and server has succesfully been made aware of that. - -- - -- The client needs to update its server time - | ValueSyncResponseClientChanged !ServerTime - -- | This value has been changed on the server side. - -- - -- The client should change it too. - | ValueSyncResponseServerChanged !(Timed a) - -- | A conflict occurred. - -- - -- The server and the client both changed the value in a conflicting manner. - -- The server kept its part, the client can either take whatever the server gave them - -- or deal with the conflict somehow, and then try to re-sync. - | ValueSyncResponseConflict !(Timed a) -- ^ The item at the server side + = -- | The client and server are fully in sync. + -- + -- Nothing needs to be done at the client side. + ValueSyncResponseInSync + | -- | The client changed the value and server has succesfully been made aware of that. + -- + -- The client needs to update its server time + ValueSyncResponseClientChanged !ServerTime + | -- | This value has been changed on the server side. + -- + -- The client should change it too. + ValueSyncResponseServerChanged !(Timed a) + | -- | The item at the server side + ValueSyncResponseConflict !(Timed a) deriving (Show, Eq, Generic) instance Validity a => Validity (ValueSyncResponse a) +instance NFData a => NFData (ValueSyncResponse a) + instance FromJSON a => FromJSON (ValueSyncResponse a) where parseJSON = withObject "ValueSyncResponse" $ \o -> do @@ -198,14 +209,14 @@ instance ToJSON a => ToJSON (ValueSyncResponse a) where toJSON isr = object $ - let o s rest = ("type" .= (s :: String)) : rest - oe s = o s [] - in case isr of - ValueSyncResponseInSync -> oe "in-sync" - ValueSyncResponseClientChanged t -> o "client-changed" ["time" .= t] - ValueSyncResponseServerChanged Timed {..} -> - o "server-changed" ["value" .= timedValue, "time" .= timedTime] - ValueSyncResponseConflict a -> o "conflict" ["value" .= a] + let o s rest = ("type" .= (s :: String)) : rest + oe s = o s [] + in case isr of + ValueSyncResponseInSync -> oe "in-sync" + ValueSyncResponseClientChanged t -> o "client-changed" ["time" .= t] + ValueSyncResponseServerChanged Timed {..} -> + o "server-changed" ["value" .= timedValue, "time" .= timedTime] + ValueSyncResponseConflict a -> o "conflict" ["value" .= a] -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. -- @@ -217,18 +228,20 @@ Changed -> ValueSyncRequestKnownButChanged t data ValueMergeResult a - -- | The merger went succesfully, no conflicts or desyncs - = MergeSuccess !(ClientValue a) - -- | There was a merge conflict. The server and client had different, conflicting versions. - | MergeConflict !a !(Timed a) -- ^ The item at the server side - | MergeMismatch - -- ^ The server responded with a response that did not make sense given the client's request. - -- - -- This should not happen in practice. + = -- | The merger went succesfully, no conflicts or desyncs + MergeSuccess !(ClientValue a) + | -- | The item at the server side + MergeConflict !a !(Timed a) + | -- | The server responded with a response that did not make sense given the client's request. + -- + -- This should not happen in practice. + MergeMismatch deriving (Show, Eq, Generic) instance Validity a => Validity (ValueMergeResult a) +instance NFData a => NFData (ValueMergeResult a) + -- | Merge an 'ValueSyncResponse' into the current 'ClientValue'. -- -- This function will not make any decisions about what to do with @@ -287,7 +300,7 @@ -- * Idempotent -- * The same on all clients mergeUsingFunction :: - (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a + (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a mergeUsingFunction func cs mr = case mr of MergeSuccess cs' -> cs' @@ -304,33 +317,35 @@ -- | Serve an 'ValueSyncRequest' using the current 'ServerValue', producing an 'ValueSyncResponse' and a new 'ServerValue'. processServerValueSync :: - ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a) + ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a) processServerValueSync sv@(ServerValue t@(Timed _ st)) sr = case sr of ValueSyncRequestKnown ct -> if ct >= st - -- The client time is equal to the server time. - -- The client indicates that the item was not modified at their side. - -- This means that the items are in sync. - -- (Unless the server somehow modified the item but not its server time, - -- which would beconsidered a bug.) - then (ValueSyncResponseInSync, sv) - -- The client time is less than the server time - -- That means that the server has synced with another client in the meantime. - -- Since the client indicates that the item was not modified at their side, - -- we can just send it back to the client to have them update their version. - -- No conflict here. - else (ValueSyncResponseServerChanged t, sv) + then-- The client time is equal to the server time. + -- The client indicates that the item was not modified at their side. + -- This means that the items are in sync. + -- (Unless the server somehow modified the item but not its server time, + -- which would beconsidered a bug.) + (ValueSyncResponseInSync, sv) + else-- The client time is less than the server time + -- That means that the server has synced with another client in the meantime. + -- Since the client indicates that the item was not modified at their side, + -- we can just send it back to the client to have them update their version. + -- No conflict here. + (ValueSyncResponseServerChanged t, sv) ValueSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} -> if ct >= st - -- The client time is equal to the server time. - -- The client indicates that the item *was* modified at their side. - -- This means that the server needs to be updated. - then let st' = incrementServerTime st - in ( ValueSyncResponseClientChanged st' - , ServerValue (Timed {timedValue = ci, timedTime = st'})) - -- The client time is less than the server time - -- That means that the server has synced with another client in the meantime. - -- Since the client indicates that the item *was* modified at their side, - -- there is a conflict. - else (ValueSyncResponseConflict t, sv) + then-- The client time is equal to the server time. + -- The client indicates that the item *was* modified at their side. + -- This means that the server needs to be updated. + + let st' = incrementServerTime st + in ( ValueSyncResponseClientChanged st', + ServerValue (Timed {timedValue = ci, timedTime = st'}) + ) + else-- The client time is less than the server time + -- That means that the server has synced with another client in the meantime. + -- Since the client indicates that the item *was* modified at their side, + -- there is a conflict. + (ValueSyncResponseConflict t, sv)