diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for mergeful + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018-2019 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# mergeful diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/mergeful.cabal b/mergeful.cabal new file mode 100644 --- /dev/null +++ b/mergeful.cabal @@ -0,0 +1,48 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1779bd15e9a78b9227b2f291e7c301be723b2ae4bb160e6f540c68cf51852fac + +name: mergeful +version: 0.0.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 +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/NorfairKing/mergeful + +library + exposed-modules: + Data.Mergeful + Data.Mergeful.Item + Data.Mergeful.Timed + Data.Mergeful.Value + other-modules: + Paths_mergeful + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , containers + , mtl + , text + , time + , validity + , validity-containers + , validity-time + default-language: Haskell2010 diff --git a/src/Data/Mergeful.hs b/src/Data/Mergeful.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeful.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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 + ( initialClientStore + , 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, 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 + } + +-- | 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 u a cs = + case M.lookup u (clientStoreSyncedItems cs) of + Just _ -> + cs + { clientStoreSyncedItems = M.delete u (clientStoreSyncedItems cs) + , clientStoreSyncedButChangedItems = + M.adjust (\t -> t {timedValue = a}) u (clientStoreSyncedButChangedItems cs) + } + Nothing -> + case M.lookup u (clientStoreSyncedButChangedItems cs) of + Nothing -> cs + Just _ -> + cs + { clientStoreSyncedButChangedItems = + M.adjust (\t -> t {timedValue = a}) u (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, 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, 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, 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 + (\si -> + case si of + ServerEmpty -> Nothing + ServerFull t -> Just t) $ + M.map snd $ + M.mapKeys + (\cid -> + case cid of + 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') diff --git a/src/Data/Mergeful/Item.hs b/src/Data/Mergeful/Item.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeful/Item.hs @@ -0,0 +1,515 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A way to synchronise an item with safe merge conflicts. +-- +-- The item is "zero or one" value. +-- One could say that @Item a = Maybe a@ but there are so such types here. +-- This methaphor just serves as explanation +-- +-- +-- 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 clients starts with an 'initialClientItem'. +-- +-- * The client produces a 'ItemSyncRequest' with 'makeItemSyncRequest'. +-- * The client sends that request to the central server and gets a 'ItemSyncResponse'. +-- * The client then updates its local store with 'mergeItemSyncResponseRaw' or 'mergeItemSyncResponseIgnoreProblems'. +-- +-- +-- = The central server should operate as follows: +-- +-- The server starts with an 'initialServerItem'. +-- +-- * The server accepts a 'ItemSyncRequest'. +-- * The server performs operations according to the functionality of 'processServerItemSync'. +-- * The server respons with a 'ItemSyncResponse'. +-- +-- +-- +-- 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.Item + ( initialClientItem + , initialItemSyncRequest + , makeItemSyncRequest + , mergeItemSyncResponseRaw + , ItemMergeResult(..) + , mergeItemSyncResponseIgnoreProblems + , mergeIgnoringProblems + , mergeFromServer + , ItemMergeStrategy(..) + , mergeUsingStrategy + -- * Server side + , initialServerItem + , processServerItemSync + -- * Types, for reference + , ClientItem(..) + , ItemSyncRequest(..) + , ItemSyncResponse(..) + , ServerItem(..) + ) where + +import GHC.Generics (Generic) + +import Data.Aeson as JSON +import Data.Validity + +import Control.Applicative + +import Data.Mergeful.Timed + +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 + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ClientItem a) + +instance FromJSON a => FromJSON (ClientItem a) where + parseJSON = + withObject "ClientItem" $ \o -> do + typ <- o .: "type" + case typ :: String of + "empty" -> pure ClientEmpty + "added" -> ClientAdded <$> o .: "value" + "synced" -> ClientItemSynced <$> (Timed <$> o .: "value" <*> o .: "time") + "changed" -> ClientItemSyncedButChanged <$> (Timed <$> o .: "value" <*> o .: "time") + "deleted" -> ClientDeleted <$> o .: "time" + _ -> fail "unknown item type" + +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] + +-- | A client item to start with. +-- +-- It contains no value. +initialClientItem :: ClientItem a +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) + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ServerItem a) + +instance FromJSON a => FromJSON (ServerItem a) where + parseJSON = + withObject "ServerItem" $ \o -> + ServerFull <$> (Timed <$> o .: "value" <*> o .: "time") <|> pure ServerEmpty + +instance ToJSON a => ToJSON (ServerItem a) where + toJSON si = + object $ + case si of + ServerEmpty -> [] + ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime] + +-- | A server item to start with. +-- +-- It contains no value. +initialServerItem :: ServerItem a +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 + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ItemSyncRequest a) + +instance FromJSON a => FromJSON (ItemSyncRequest a) where + parseJSON = + withObject "ItemSyncRequest" $ \o -> do + typ <- o .: "type" + case typ :: String of + "empty" -> pure ItemSyncRequestPoll + "added" -> ItemSyncRequestNew <$> o .: "value" + "synced" -> ItemSyncRequestKnown <$> o .: "time" + "changed" -> ItemSyncRequestKnownButChanged <$> (Timed <$> o .: "value" <*> o .: "time") + "deleted" -> ItemSyncRequestDeletedLocally <$> o .: "time" + _ -> fail "unknown item type" + +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] + +-- | An intial 'ItemSyncRequest' to start with. +-- +-- It just asks the server to send over whatever it knows. +initialItemSyncRequest :: ItemSyncRequest a +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. + | ItemSyncResponseConflictServerDeleted + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ItemSyncResponse a) + +instance FromJSON a => FromJSON (ItemSyncResponse a) where + parseJSON = + withObject "ItemSyncResponse" $ \o -> do + typ <- o .: "type" + case typ :: String of + "in-sync-empty" -> pure ItemSyncResponseInSyncEmpty + "in-sync-full" -> pure ItemSyncResponseInSyncFull + "client-added" -> ItemSyncResponseClientAdded <$> o .: "time" + "client-changed" -> ItemSyncResponseClientChanged <$> o .: "time" + "client-deleted" -> pure ItemSyncResponseClientDeleted + "server-added" -> ItemSyncResponseServerAdded <$> (Timed <$> o .: "value" <*> o .: "time") + "server-changed" -> + ItemSyncResponseServerChanged <$> (Timed <$> o .: "value" <*> o .: "time") + "server-deleted" -> pure ItemSyncResponseServerDeleted + "conflict" -> ItemSyncResponseConflict <$> o .: "value" + "conflict-client-deleted" -> ItemSyncResponseConflictClientDeleted <$> o .: "value" + "conflict-server-deleted" -> pure ItemSyncResponseConflictServerDeleted + _ -> fail "unknown type" + +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" + +-- | Produce an 'ItemSyncRequest' from a 'ClientItem'. +-- +-- Send this to the server for synchronisation. +makeItemSyncRequest :: ClientItem a -> ItemSyncRequest a +makeItemSyncRequest cs = + case cs of + ClientEmpty -> ItemSyncRequestPoll + ClientAdded i -> ItemSyncRequestNew i + ClientItemSynced t -> ItemSyncRequestKnown (timedTime t) + ClientItemSyncedButChanged t -> ItemSyncRequestKnownButChanged t + 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. + | MergeMismatch + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ItemMergeResult a) + +-- | Merge an 'ItemSyncResponse' into the current 'ClientItem'. +-- +-- This function will not make any decisions about what to do with +-- conflicts or mismatches between the request and the response. +-- It only produces a 'ItemMergeResult' so you can decide what to do with it. +mergeItemSyncResponseRaw :: ClientItem a -> ItemSyncResponse a -> ItemMergeResult a +mergeItemSyncResponseRaw cs sr = + case cs of + ClientEmpty -> + case sr of + ItemSyncResponseInSyncEmpty -> MergeSuccess cs + ItemSyncResponseServerAdded t -> MergeSuccess $ ClientItemSynced t + _ -> MergeMismatch + ClientAdded ci -> + case sr of + ItemSyncResponseClientAdded st -> + MergeSuccess $ ClientItemSynced $ Timed {timedValue = ci, timedTime = st} + ItemSyncResponseConflict si -> MergeConflict ci si + _ -> MergeMismatch + ClientItemSynced t -> + case sr of + ItemSyncResponseInSyncFull -> MergeSuccess $ ClientItemSynced t + ItemSyncResponseServerChanged st -> MergeSuccess $ ClientItemSynced st + ItemSyncResponseServerDeleted -> MergeSuccess ClientEmpty + _ -> MergeMismatch + ClientItemSyncedButChanged ct -> + case sr of + ItemSyncResponseClientChanged st -> MergeSuccess $ ClientItemSynced $ ct {timedTime = st} + ItemSyncResponseConflict si -> MergeConflict (timedValue ct) si + ItemSyncResponseConflictServerDeleted -> MergeConflictServerDeleted (timedValue ct) + _ -> MergeMismatch + ClientDeleted _ -> + case sr of + ItemSyncResponseClientDeleted -> MergeSuccess ClientEmpty + 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 + +-- | 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 + } + 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 + +-- | Resolve an 'ItemMergeResult' using a given merge strategy. +-- +-- This function ignores 'MergeMismatch' and will just return the original 'ClientItem' in that case. +-- +-- In order for clients to converge on the same item correctly, this function must be: +-- +-- * Associative +-- * Idempotent +-- * The same on all clients +mergeUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemMergeResult a -> ClientItem a +mergeUsingStrategy ItemMergeStrategy {..} cs 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 + +-- | Resolve an 'ItemMergeResult' by taking whatever the server gave the client. +-- +-- Pro: Clients will converge on the same value. +-- +-- __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 + } + +-- | 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 = + case store of + ServerEmpty -> + let t = initialServerTime + in case sr of + 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) + ServerFull t@(Timed si st) -> + let st' = incrementServerTime st + in case sr of + 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 _ + -- 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) + ItemSyncRequestKnown 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 (ItemSyncResponseInSyncFull, store) + -- 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) + ItemSyncRequestKnownButChanged (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 ( ItemSyncResponseClientChanged st' + , ServerFull (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 (ItemSyncResponseConflict t, store) + ItemSyncRequestDeletedLocally ct -> + if ct >= st + -- 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 + -- 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) diff --git a/src/Data/Mergeful/Timed.hs b/src/Data/Mergeful/Timed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeful/Timed.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 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) + +import Data.Aeson as JSON +import Data.Validity +import Data.Word + +-- | A "time", as "measured" by the server. +-- +-- This is closer to a version number than an actual timestamp, but that +-- 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 + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) + +instance Validity 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. +incrementServerTime :: ServerTime -> ServerTime +incrementServerTime (ServerTime w) = ServerTime (succ w) + +-- | A value along with a server time. +data Timed a = + Timed + { timedValue :: !a + , timedTime :: !ServerTime + } + deriving (Show, Eq, Generic) + +instance Validity a => Validity (Timed a) + +instance FromJSON a => FromJSON (Timed a) where + parseJSON = withObject "Timed" $ \o -> Timed <$> o .: "value" <*> o .: "time" + +instance ToJSON a => ToJSON (Timed a) where + toJSON Timed {..} = object ["value" .= timedValue, "time" .= timedTime] diff --git a/src/Data/Mergeful/Value.hs b/src/Data/Mergeful/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeful/Value.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A way to synchronise a single value 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: +-- +-- == For the first sychronisation +-- +-- The client should ask the server for the current server value. +-- The server should send over a 'Timed' vaule, and the client should create its 'ClientValue' with 'initialClientValue'. +-- +-- == For any following synchronisation: +-- +-- * The client produces a 'ValueSyncRequest' with 'makeValueSyncRequest'. +-- * The client sends that request to the central server and gets a 'ValueSyncResponse'. +-- * The client then updates its local store with 'mergeValueSyncResponseRaw' or 'mergeValueSyncResponseIgnoreProblems'. +-- +-- +-- = The central server should operate as follows: +-- +-- * The server should create an initial 'ServerValue' using 'initialServerValue'. +-- * The server accepts a 'ValueSyncRequest'. +-- * The server performs operations according to the functionality of 'processServerValueSync'. +-- * The server respons with a 'ValueSyncResponse'. +-- +-- +-- 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.Value + ( initialClientValue + , makeValueSyncRequest + , mergeValueSyncResponseRaw + , ValueMergeResult(..) + , mergeValueSyncResponseIgnoreProblems + , mergeIgnoringProblems + , mergeFromServer + , mergeUsingFunction + -- * Server side + , initialServerValue + , processServerValueSync + -- * Types, for reference + , ChangedFlag(..) + , ClientValue(..) + , ValueSyncRequest(..) + , ValueSyncResponse(..) + , ServerValue(..) + ) where + +import GHC.Generics (Generic) + +import Data.Aeson as JSON +import Data.Validity + +import Data.Mergeful.Timed + +data ChangedFlag + = Changed + | NotChanged + deriving (Show, Eq, Generic) + +instance Validity ChangedFlag + +-- | The client side value. +-- +-- The only differences between `a` and 'ClientValue a' are that +-- 'ClientValue a' also remembers the last synchronisation time from +-- 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 + deriving (Show, Eq, Generic) + +instance Validity a => Validity (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") + +instance ToJSON a => ToJSON (ClientValue a) where + toJSON (ClientValue Timed {..} cf) = + object + [ "value" .= timedValue + , "time" .= timedTime + , "changed" .= + (case cf of + Changed -> True + NotChanged -> False) + ] + +-- | Produce a client value based on an initial synchronisation request +initialClientValue :: Timed a -> ClientValue a +initialClientValue t = ClientValue t NotChanged + +-- | The server-side value. +-- +-- The only difference between 'a' and 'ServerValue a' is that 'ServerValue a' also +-- remembers the last time this value was changed during synchronisation. +data ServerValue a = + ServerValue !(Timed a) + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ServerValue a) + +instance FromJSON a => FromJSON (ServerValue a) where + parseJSON = + withObject "ServerValue" $ \o -> ServerValue <$> (Timed <$> o .: "value" <*> o .: "time") + +instance ToJSON a => ToJSON (ServerValue a) where + toJSON (ServerValue Timed {..}) = object ["value" .= timedValue, "time" .= timedTime] + +-- | Initialise a server value. +-- +-- Note that the server has to start with a value, the value 'a' cannot be omitted. +initialServerValue :: a -> ServerValue a +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) + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ValueSyncRequest a) + +instance FromJSON a => FromJSON (ValueSyncRequest a) where + parseJSON = + withObject "ValueSyncRequest" $ \o -> do + typ <- o .: "type" + case typ :: String of + "synced" -> ValueSyncRequestKnown <$> o .: "time" + "changed" -> ValueSyncRequestKnownButChanged <$> (Timed <$> o .: "value" <*> o .: "time") + _ -> fail "unknown item type" + +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] + +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 + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ValueSyncResponse a) + +instance FromJSON a => FromJSON (ValueSyncResponse a) where + parseJSON = + withObject "ValueSyncResponse" $ \o -> do + typ <- o .: "type" + case typ :: String of + "in-sync" -> pure ValueSyncResponseInSync + "client-changed" -> ValueSyncResponseClientChanged <$> o .: "time" + "server-changed" -> + ValueSyncResponseServerChanged <$> (Timed <$> o .: "value" <*> o .: "time") + "conflict" -> ValueSyncResponseConflict <$> o .: "value" + _ -> fail "unknown type" + +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] + +-- | Produce an 'ItemSyncRequest' from a 'ClientItem'. +-- +-- Send this to the server for synchronisation. +makeValueSyncRequest :: ClientValue a -> ValueSyncRequest a +makeValueSyncRequest (ClientValue t cf) = + case cf of + NotChanged -> ValueSyncRequestKnown (timedTime t) + 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. + deriving (Show, Eq, Generic) + +instance Validity a => Validity (ValueMergeResult a) + +-- | Merge an 'ValueSyncResponse' into the current 'ClientValue'. +-- +-- This function will not make any decisions about what to do with +-- conflicts or mismatches between the request and the response. +-- It only produces a 'ValueMergeResult' so you can decide what to do with it. +mergeValueSyncResponseRaw :: ClientValue a -> ValueSyncResponse a -> ValueMergeResult a +mergeValueSyncResponseRaw cv@(ClientValue ct cf) sr = + case cf of + NotChanged -> + case sr of + ValueSyncResponseInSync -> MergeSuccess cv + ValueSyncResponseServerChanged st -> MergeSuccess $ ClientValue st NotChanged + _ -> MergeMismatch + Changed -> + case sr of + ValueSyncResponseClientChanged st -> + MergeSuccess $ ClientValue (ct {timedTime = st}) NotChanged + ValueSyncResponseConflict si -> MergeConflict (timedValue ct) si + _ -> MergeMismatch + +-- | Resolve a 'ValueSyncResponse' into the current 'ClientValue'. +-- +-- 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. +-- +-- > mergeValueSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeValueSyncResponseRaw cs +mergeValueSyncResponseIgnoreProblems :: ClientValue a -> ValueSyncResponse a -> ClientValue a +mergeValueSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeValueSyncResponseRaw cs + +-- | Ignore any merge problems in a 'ValueMergeResult'. +-- +-- This function just returns the original 'ClientValue' 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 :: ClientValue a -> ValueMergeResult a -> ClientValue a +mergeIgnoringProblems cs mr = + case mr of + MergeSuccess cs' -> cs' + MergeConflict _ _ -> cs + MergeMismatch -> cs + +-- | Resolve a 'ValueMergeResult' using a given merge strategy. +-- +-- This function ignores 'MergeMismatch' and will just return the original 'ClientValue' in that case. +-- +-- In order for clients to converge on the same value correctly, this function must be: +-- +-- * Associative +-- * Idempotent +-- * The same on all clients +mergeUsingFunction :: + (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a +mergeUsingFunction func cs mr = + case mr of + MergeSuccess cs' -> cs' + MergeConflict a1 a2 -> ClientValue (func a1 a2) NotChanged + MergeMismatch -> cs + +-- | Resolve a 'ValueMergeResult' by taking whatever the server gave the client. +-- +-- Pro: Clients will converge on the same value. +-- +-- __Con: Conflicting updates will be lost.__ +mergeFromServer :: ClientValue a -> ValueMergeResult a -> ClientValue a +mergeFromServer = mergeUsingFunction (\_ serverItem -> serverItem) + +-- | Serve an 'ValueSyncRequest' using the current 'ServerValue', producing an 'ValueSyncResponse' and a new 'ServerValue'. +processServerValueSync :: + 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) + 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)