mergeful (empty) → 0.0.0.0

raw patch · 9 files changed

+1694/−0 lines, 9 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, mtl, text, time, validity, validity-containers, validity-time

Files

ChangeLog.md +3/−0
LICENSE +21/−0
README.md +1/−0
Setup.hs +3/−0
mergeful.cabal +48/−0
src/Data/Mergeful.hs +707/−0
src/Data/Mergeful/Item.hs +515/−0
src/Data/Mergeful/Timed.hs +59/−0
src/Data/Mergeful/Value.hs +337/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for mergeful++## Unreleased changes

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,1 @@+# mergeful

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ mergeful.cabal view

@@ -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 <https://github.com/NorfairKing/mergeful#readme>+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

+ src/Data/Mergeful.hs view

@@ -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')

+ src/Data/Mergeful/Item.hs view

@@ -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)

+ src/Data/Mergeful/Timed.hs view

@@ -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]

+ src/Data/Mergeful/Value.hs view

@@ -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)