mergeful 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+1450/−1123 lines, 7 filesdep +deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• mergeful.cabal +6/−4
• src/Data/Mergeful.hs +3/−2
• src/Data/Mergeful/Collection.hs +964/−755
• src/Data/Mergeful/Item.hs +315/−239
• src/Data/Mergeful/Timed.hs +29/−18
• src/Data/Mergeful/Value.hs +120/−105

@@ -2,6 +2,19 @@  ## [Unreleased] +## [0.2.0.0] - 2020-05-21++## Added++* processServerSyncCustom and related+* mergeSyncResponseCustom and related++### Changed++* Another parameter: the client id so that you can use an sql id as the client id.+  This likely means that none of your code that works with mergeful-0.1 will compile anymore+  but it is easy to fix by adding the right parameter.+ ## [0.1.0.0] - 2019-09-23  ### Changed

@@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 165daa0156c2d4d4295cd5dbfa2b75914c44985aca486dca68525510afa932ce+-- hash: 5c04518a45f3748d42c829e645b69f607f23450b79fa96bcd6c567976b0465b7  name:           mergeful-version:        0.1.0.0+version:        0.2.0.0 description:    Please see the README on GitHub at <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+copyright:      Copyright: (c) 2019-2020 Tom Sydney Kerckhove license:        MIT license-file:   LICENSE build-type:     Simple@@ -36,10 +36,12 @@       Paths_mergeful   hs-source-dirs:       src+  ghc-options: -Wall -fwarn-redundant-constraints   build-depends:       aeson     , base >=4.7 && <5     , containers+    , deepseq     , mtl     , text     , time

@@ -1,5 +1,6 @@ module Data.Mergeful-  ( module Data.Mergeful.Collection-  ) where+  ( module Data.Mergeful.Collection,+  )+where  import Data.Mergeful.Collection

@@ -1,757 +1,966 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | A way to synchronise a single item with safe merge conflicts.------ The setup is as follows:------ * A central server is set up to synchronise with--- * Each client synchronises with the central server, but never with eachother------------ = A client should operate as follows:------ The client starts with an 'initialClientStore'.------ * The client produces a 'SyncRequest' with 'makeSyncRequest'.--- * The client sends that request to the central server and gets a 'SyncResponse'.--- * The client then updates its local store with 'mergeSyncResponseIgnoreProblems'.--------- = The central server should operate as follows:------ The server starts with an 'initialServerStore'.------ * The server accepts a 'SyncRequest'.--- * The server performs operations according to the functionality of 'processServerSync'.--- * The server respons with a 'SyncResponse'.--------- WARNING:--- This whole approach can break down if a server resets its server times--- or if a client syncs with two different servers using the same server times.-module Data.Mergeful.Collection-  ( initialClientStore-  , clientStoreSize-  , clientStoreClientIdSet-  , clientStoreUndeletedSyncIdSet-  , clientStoreSyncIdSet-  , clientStoreItems-  , addItemToClientStore-  , markItemDeletedInClientStore-  , changeItemInClientStore-  , deleteItemFromClientStore-  , initialSyncRequest-  , makeSyncRequest-  , mergeSyncResponseIgnoreProblems-  , mergeSyncResponseFromServer-  -- * Custom merging-  , ItemMergeStrategy(..)-  , mergeSyncResponseUsingStrategy-  -- * Server side-  , initialServerStore-  , processServerSync-  -- * Types, for reference-  , ClientStore(..)-  , SyncRequest(..)-  , SyncResponse(..)-  , emptySyncResponse-  , ServerStore(..)-  , ClientId(..)-  -- * Utility functions for implementing client-side merging-  , mergeAddedItems-  , mergeSyncedButChangedItems-  , mergeDeletedItems-  -- * Utility functions for implementing server-side responding-  , addToSyncResponse-  ) where--import GHC.Generics (Generic)--import Data.Aeson-import Data.List-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as S-import Data.Text (Text)-import Data.Validity-import Data.Validity.Containers ()-import Data.Word--import Control.Applicative-import Control.Monad--import Data.Mergeful.Item-import Data.Mergeful.Timed---- | A Client-side identifier for items.------ These only need to be unique at the client.-newtype ClientId =-  ClientId-    { unClientId :: Word64-    }-  deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)--instance Validity ClientId--data ClientStore i a =-  ClientStore-    { clientStoreAddedItems :: Map ClientId a-      -- ^ These items are new locally but have not been synced to the server yet.-    , clientStoreSyncedItems :: Map i (Timed a)-      -- ^ These items have been synced at their respective 'ServerTime's.-    , clientStoreSyncedButChangedItems :: Map i (Timed a)-      -- ^ These items have been synced at their respective 'ServerTime's-      -- but modified locally since then.-    , clientStoreDeletedItems :: Map i ServerTime-      -- ^ These items have been deleted locally after they were synced-      -- but the server has not been notified of that yet.-    }-  deriving (Show, Eq, Generic)--instance (Validity i, Show i, Ord i, Validity a) => Validity (ClientStore i a) where-  validate cs@ClientStore {..} =-    mconcat-      [ genericValidate cs-      , declare "There are no duplicate IDs" $-        distinct $-        concat-          [ M.keys clientStoreSyncedItems-          , M.keys clientStoreSyncedButChangedItems-          , M.keys clientStoreDeletedItems-          ]-      ]--instance (Ord i, FromJSONKey i, FromJSON a) => FromJSON (ClientStore i a) where-  parseJSON =-    withObject "ClientStore" $ \o ->-      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty <*>-      o .:? "changed" .!= M.empty <*>-      o .:? "deleted" .!= M.empty--instance (ToJSONKey i, ToJSON a) => ToJSON (ClientStore i a) where-  toJSON ClientStore {..} =-    object $-    catMaybes-      [ jNull "added" clientStoreAddedItems-      , jNull "synced" clientStoreSyncedItems-      , jNull "changed" clientStoreSyncedButChangedItems-      , jNull "deleted" clientStoreDeletedItems-      ]---- | A client store to start with.------ This store contains no items.-initialClientStore :: ClientStore i a-initialClientStore =-  ClientStore-    { clientStoreAddedItems = M.empty-    , clientStoreSyncedItems = M.empty-    , clientStoreSyncedButChangedItems = M.empty-    , clientStoreDeletedItems = M.empty-    }---- | The number of items in a client store------ This does not count the deleted items, so that they really look deleted..-clientStoreSize :: ClientStore i a -> Word-clientStoreSize ClientStore {..} =-  fromIntegral $-  sum-    [ M.size clientStoreAddedItems-    , M.size clientStoreSyncedItems-    , M.size clientStoreSyncedButChangedItems-    ]---- | The set of client ids.------ These are only the client ids of the added items that have not been synced yet.-clientStoreClientIdSet :: ClientStore i a -> Set ClientId-clientStoreClientIdSet ClientStore {..} = M.keysSet clientStoreAddedItems---- | The set of server ids.------ This does not include the ids of items that have been marked as deleted.-clientStoreUndeletedSyncIdSet :: Ord i => ClientStore i a -> Set i-clientStoreUndeletedSyncIdSet ClientStore {..} =-  S.unions [M.keysSet clientStoreSyncedItems, M.keysSet clientStoreSyncedButChangedItems]---- | The set of server ids.------ This includes the ids of items that have been marked as deleted.-clientStoreSyncIdSet :: Ord i => ClientStore i a -> Set i-clientStoreSyncIdSet ClientStore {..} =-  S.unions-    [ M.keysSet clientStoreSyncedItems-    , M.keysSet clientStoreSyncedButChangedItems-    , M.keysSet clientStoreDeletedItems-    ]---- | The set of items in the client store------ This map does not include items that have been marked as deleted.-clientStoreItems :: Ord i => ClientStore i a -> Map (Either ClientId i) a-clientStoreItems ClientStore {..} =-  M.unions-    [ M.mapKeys Left clientStoreAddedItems-    , M.mapKeys Right $ M.map timedValue clientStoreSyncedItems-    , M.mapKeys Right $ M.map timedValue clientStoreSyncedButChangedItems-    ]---- | Add an item to a client store as an added item.------ This will take care of the uniqueness constraint of the 'ClientId's in the map.-addItemToClientStore :: a -> ClientStore i a -> ClientStore i a-addItemToClientStore a cs =-  let oldAddedItems = clientStoreAddedItems cs-      newAddedItems =-        let newKey =-              ClientId $-              if M.null oldAddedItems-                then 0-                else let (ClientId k, _) = M.findMax oldAddedItems-                      in succ k-         in M.insert newKey a oldAddedItems-   in cs {clientStoreAddedItems = newAddedItems}---- | Mark an item deleted in a client store.------ This function will not delete the item, but mark it as deleted instead.-markItemDeletedInClientStore :: Ord i => i -> ClientStore i a -> ClientStore i a-markItemDeletedInClientStore u cs =-  let oldSyncedItems = clientStoreSyncedItems cs-      oldChangedItems = clientStoreSyncedButChangedItems cs-      oldDeletedItems = clientStoreDeletedItems cs-      mItem = M.lookup u oldSyncedItems <|> M.lookup u oldChangedItems-   in case mItem of-        Nothing -> cs-        Just t ->-          let newSyncedItems = M.delete u oldSyncedItems-              newChangedItems = M.delete u oldChangedItems-              newDeletedItems = M.insert u (timedTime t) oldDeletedItems-           in cs-                { clientStoreSyncedItems = newSyncedItems-                , clientStoreSyncedButChangedItems = newChangedItems-                , clientStoreDeletedItems = newDeletedItems-                }---- | Replace the given item with a new value.------ This function will correctly mark the item as changed, if it exist.------ It will not add an item to the store with the given id, because the--- server may not have been the origin of that id.-changeItemInClientStore :: Ord i => i -> a -> ClientStore i a -> ClientStore i a-changeItemInClientStore i a cs =-  case M.lookup i (clientStoreSyncedItems cs) of-    Just t ->-      cs-        { clientStoreSyncedItems = M.delete i (clientStoreSyncedItems cs)-        , clientStoreSyncedButChangedItems =-            M.insert i (t {timedValue = a}) (clientStoreSyncedButChangedItems cs)-        }-    Nothing ->-      case M.lookup i (clientStoreSyncedButChangedItems cs) of-        Nothing -> cs-        Just _ ->-          cs-            { clientStoreSyncedButChangedItems =-                M.adjust (\t -> t {timedValue = a}) i (clientStoreSyncedButChangedItems cs)-            }---- | Delete an unsynced item from a client store.------ This function will immediately delete the item, because it has never been synced.-deleteItemFromClientStore :: ClientId -> ClientStore i a -> ClientStore i a-deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)}--newtype ServerStore i a =-  ServerStore-    { serverStoreItems :: Map i (Timed a)-      -- ^ A map of items, named using an 'i', together with the 'ServerTime' at which-      -- they were last synced.-    }-  deriving (Show, Eq, Generic, FromJSON, ToJSON)--instance (Validity i, Show i, Ord i, Validity a) => Validity (ServerStore i a)---- | A server store to start with------ This store contains no items.-initialServerStore :: ServerStore i a-initialServerStore = ServerStore {serverStoreItems = M.empty}--data SyncRequest i a =-  SyncRequest-    { syncRequestNewItems :: Map ClientId a-      -- ^ These items are new locally but have not been synced to the server yet.-    , syncRequestKnownItems :: Map i ServerTime-      -- ^ These items have been synced at their respective 'ServerTime's.-    , syncRequestKnownButChangedItems :: Map i (Timed a)-      -- ^ These items have been synced at their respective 'ServerTime's-      -- but modified locally since then.-    , syncRequestDeletedItems :: Map i ServerTime-      -- ^ These items have been deleted locally after they were synced-      -- but the server has not been notified of that yet.-    }-  deriving (Show, Eq, Generic)--instance (Validity i, Show i, Ord i, Validity a) => Validity (SyncRequest i a) where-  validate sr@SyncRequest {..} =-    mconcat-      [ genericValidate sr-      , declare "There are no duplicate IDs" $-        distinct $-        concat-          [ M.keys syncRequestKnownItems-          , M.keys syncRequestKnownButChangedItems-          , M.keys syncRequestDeletedItems-          ]-      ]--instance (Ord i, FromJSONKey i, FromJSON a) => FromJSON (SyncRequest i a) where-  parseJSON =-    withObject "SyncRequest" $ \o ->-      SyncRequest <$> o .:? "new" .!= M.empty <*> o .:? "synced" .!= M.empty <*>-      o .:? "changed" .!= M.empty <*>-      o .:? "deleted" .!= M.empty--instance (ToJSONKey i, ToJSON a) => ToJSON (SyncRequest i a) where-  toJSON SyncRequest {..} =-    object $-    catMaybes-      [ jNull "new" syncRequestNewItems-      , jNull "synced" syncRequestKnownItems-      , jNull "changed" syncRequestKnownButChangedItems-      , jNull "deleted" syncRequestDeletedItems-      ]---- | An intial 'SyncRequest' to start with.------ It just asks the server to send over whatever it knows.-initialSyncRequest :: SyncRequest i a-initialSyncRequest =-  SyncRequest-    { syncRequestNewItems = M.empty-    , syncRequestKnownItems = M.empty-    , syncRequestKnownButChangedItems = M.empty-    , syncRequestDeletedItems = M.empty-    }--data SyncResponse i a =-  SyncResponse-    { syncResponseClientAdded :: Map ClientId (i, ServerTime)-      -- ^ The client added these items and server has succesfully been made aware of that.-      ---      -- The client needs to update their server times-    , syncResponseClientChanged :: Map i ServerTime-      -- ^ The client changed these items and server has succesfully been made aware of that.-      ---      -- The client needs to update their server times-    , syncResponseClientDeleted :: Set i-      -- ^ The client deleted these items and server has succesfully been made aware of that.-      ---      -- The client can delete them from its deleted items-    , syncResponseServerAdded :: Map i (Timed a)-      -- ^ These items have been added on the server side-      ---      -- The client should add them too.-    , syncResponseServerChanged :: Map i (Timed a)-      -- ^ These items have been modified on the server side.-      ---      -- The client should modify them too.-    , syncResponseServerDeleted :: Set i-      -- ^ These items were deleted on the server side-      ---      -- The client should delete them too-    , syncResponseConflicts :: Map i (Timed a)-      -- ^ These are conflicts where the server and the client both have an item, but it is different.-      ---      -- The server kept its part of each, the client can either take whatever the server gave them-      -- or deal with the conflicts somehow, and then try to re-sync.-    , syncResponseConflictsClientDeleted :: Map i (Timed a)-      -- ^ These are conflicts where the server has an item but the client does not.-      ---      -- The server kept its item, the client can either take whatever the server gave them-      -- or deal with the conflicts somehow, and then try to re-sync.-    , syncResponseConflictsServerDeleted :: Set i-      -- ^ These are conflicts where the server has no item but the client has a modified item.-      ---      -- The server left its item deleted, the client can either delete its items too-      -- or deal with the conflicts somehow, and then try to re-sync.-    }-  deriving (Show, Eq, Generic)--instance (Validity i, Show i, Ord i, Validity a) => Validity (SyncResponse i a) where-  validate sr@SyncResponse {..} =-    mconcat-      [ genericValidate sr-      , declare "There are no duplicate IDs" $-        distinct $-        concat-          [ map (\(_, (i, _)) -> i) $ M.toList syncResponseClientAdded-          , M.keys syncResponseClientChanged-          , S.toList syncResponseClientDeleted-          , M.keys syncResponseServerAdded-          , M.keys syncResponseServerChanged-          , S.toList syncResponseServerDeleted-          , M.keys syncResponseConflicts-          , M.keys syncResponseConflictsClientDeleted-          , S.toList syncResponseConflictsServerDeleted-          ]-      ]--instance (Ord i, FromJSON i, FromJSONKey i, FromJSON a) => FromJSON (SyncResponse i a) where-  parseJSON =-    withObject "SyncResponse" $ \o ->-      SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty <*>-      o .:? "client-deleted" .!= S.empty <*>-      o .:? "server-added" .!= M.empty <*>-      o .:? "server-changed" .!= M.empty <*>-      o .:? "server-deleted" .!= S.empty <*>-      o .:? "conflict" .!= M.empty <*>-      o .:? "conflict-client-deleted" .!= M.empty <*>-      o .:? "conflict-server-deleted" .!= S.empty--instance (ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (SyncResponse i a) where-  toJSON SyncResponse {..} =-    object $-    catMaybes-      [ jNull "client-added" syncResponseClientAdded-      , jNull "client-changed" syncResponseClientChanged-      , jNull "client-deleted" syncResponseClientDeleted-      , jNull "server-added" syncResponseServerAdded-      , jNull "server-changed" syncResponseServerChanged-      , jNull "server-deleted" syncResponseServerDeleted-      , jNull "conflict" syncResponseConflicts-      , jNull "conflict-client-deleted" syncResponseConflictsClientDeleted-      , jNull "conflict-server-deleted" syncResponseConflictsServerDeleted-      ]--emptySyncResponse :: SyncResponse i a-emptySyncResponse =-  SyncResponse-    { syncResponseClientAdded = M.empty-    , syncResponseClientChanged = M.empty-    , syncResponseClientDeleted = S.empty-    , syncResponseServerAdded = M.empty-    , syncResponseServerChanged = M.empty-    , syncResponseServerDeleted = S.empty-    , syncResponseConflicts = M.empty-    , syncResponseConflictsClientDeleted = M.empty-    , syncResponseConflictsServerDeleted = S.empty-    }--jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value)-jNull n s =-  if null s-    then Nothing-    else Just $ n .= s---- | Produce an 'SyncRequest' from a 'ClientStore'.------ Send this to the server for synchronisation.-makeSyncRequest :: ClientStore i a -> SyncRequest i a-makeSyncRequest ClientStore {..} =-  SyncRequest-    { syncRequestNewItems = clientStoreAddedItems-    , syncRequestKnownItems = M.map timedTime clientStoreSyncedItems-    , syncRequestKnownButChangedItems = clientStoreSyncedButChangedItems-    , syncRequestDeletedItems = clientStoreDeletedItems-    }---- | Merge an 'SyncResponse' into the current 'ClientStore'.------ This function ignores any problems that may occur.--- In the case of a conclict, it will just not update the client item.--- The next sync request will then produce a conflict again.------ Pro: No data will be lost------ __Con: Clients will diverge when conflicts occur.__-mergeSyncResponseIgnoreProblems :: Ord i => ClientStore i a -> SyncResponse i a -> ClientStore i a-mergeSyncResponseIgnoreProblems cs SyncResponse {..} =-  let (addedItemsLeftovers, newSyncedItems) =-        mergeAddedItems (clientStoreAddedItems cs) syncResponseClientAdded-      (syncedButNotChangedLeftovers, newModifiedItems) =-        mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) syncResponseClientChanged-      deletedItemsLeftovers =-        mergeDeletedItems (clientStoreDeletedItems cs) syncResponseClientDeleted-      synced =-        M.unions-          [ newSyncedItems-          , syncResponseServerAdded-          , syncResponseServerChanged-          , newModifiedItems-          , clientStoreSyncedItems cs-          ]-   in ClientStore-        { clientStoreAddedItems = addedItemsLeftovers-        , clientStoreSyncedButChangedItems = syncedButNotChangedLeftovers `M.difference` synced-        , clientStoreDeletedItems = deletedItemsLeftovers `M.difference` synced-        , clientStoreSyncedItems =-            synced `M.difference` M.fromSet (const ()) syncResponseServerDeleted-        }---- | Merge an 'SyncResponse' into the current 'ClientStore' with the given merge strategy.------ In order for clients to converge on the same collection correctly, this function must be:------ * Associative--- * Idempotent--- * The same on all clients------ This function ignores mismatches.-mergeSyncResponseUsingStrategy ::-     Ord i => ItemMergeStrategy a -> ClientStore i a -> SyncResponse i a -> ClientStore i a-mergeSyncResponseUsingStrategy ItemMergeStrategy {..} cs SyncResponse {..} =-  let (addedItemsLeftovers, newSyncedItems) =-        mergeAddedItems (clientStoreAddedItems cs) syncResponseClientAdded-      (syncedButNotChangedLeftovers, newModifiedItems) =-        mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) syncResponseClientChanged-      deletedItemsLeftovers =-        mergeDeletedItems (clientStoreDeletedItems cs) syncResponseClientDeleted-      synced =-        M.unions-          [ newSyncedItems-          , syncResponseServerAdded-          , syncResponseServerChanged-          -- Merge the synced but changed (the only ones that could have caused a conflict)-          -- with the ones that the response indicated were a conflict.-          , M.intersectionWith-              itemMergeStrategyMergeChangeConflict-              (M.map timedValue $ clientStoreSyncedButChangedItems cs)-              syncResponseConflicts-          -- Of the items that the server changed but the client deleted,-          -- keep the ones that the strategy wants to keep.-          , M.mapMaybe id $-            M.intersectionWith-              (\_ t -> itemMergeStrategyMergeClientDeletedConflict t)-              (clientStoreDeletedItems cs)-              syncResponseConflictsClientDeleted-          , newModifiedItems-          , clientStoreSyncedItems cs-          ]-      -- | The synced but changed items that were not acknowledged as changed,-      -- minus the ones that the strategy decided to delete.-      newSyncedButChangedItems =-        syncedButNotChangedLeftovers `M.difference`-        M.fromSet (const ()) syncResponseConflictsServerDeleted-   in ClientStore-        { clientStoreAddedItems = addedItemsLeftovers-        , clientStoreSyncedButChangedItems = newSyncedButChangedItems `M.difference` synced-        , clientStoreDeletedItems = deletedItemsLeftovers `M.difference` synced-        , clientStoreSyncedItems =-            synced `M.difference` M.fromSet (const ()) syncResponseServerDeleted-        }---- | Merge an 'SyncResponse' into the current 'ClientStore' by taking whatever the server gave the client.------ Pro: Clients will converge on the same value.------ __Con: Conflicting updates will be lost.__-mergeSyncResponseFromServer :: Ord i => ClientStore i a -> SyncResponse i a -> ClientStore i a-mergeSyncResponseFromServer =-  mergeSyncResponseUsingStrategy-    ItemMergeStrategy-      { itemMergeStrategyMergeChangeConflict = \_ serverItem -> serverItem-      , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem-      , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing-      }---- | Merge the local added items with the ones that the server has acknowledged as added.-mergeAddedItems ::-     forall i a. Ord i-  => Map ClientId a-  -> Map ClientId (i, ServerTime)-  -> (Map ClientId a, Map i (Timed a))-mergeAddedItems local added = M.foldlWithKey go (M.empty, M.empty) local-  where-    go :: (Map ClientId a, Map i (Timed a)) -> ClientId -> a -> (Map ClientId a, Map i (Timed a))-    go (as, m) i a =-      case M.lookup i added of-        Nothing -> (M.insert i a as, m)-        Just (k, st) -> (as, M.insert k (Timed {timedValue = a, timedTime = st}) m)---- | Merge the local synced but changed items with the ones that the server has acknowledged as changed.-mergeSyncedButChangedItems ::-     forall i a. Ord i-  => Map i (Timed a)-  -> Map i ServerTime-  -> (Map i (Timed a), Map i (Timed a))-mergeSyncedButChangedItems local changed = M.foldlWithKey go (M.empty, M.empty) local-  where-    go :: (Map i (Timed a), Map i (Timed a)) -> i -> Timed a -> (Map i (Timed a), Map i (Timed a))-    go (m1, m2) k t =-      case M.lookup k changed of-        Nothing -> (M.insert k t m1, m2)-        Just st' -> (m1, M.insert k (t {timedTime = st'}) m2)---- | Merge the local deleted items with the ones that the server has acknowledged as deleted.-mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b-mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s--data Identifier i-  = OnlyServer i-  | BothServerAndClient i ClientId-  deriving (Show, Eq, Ord, Generic)--instance Validity i => Validity (Identifier i)---- | Serve an 'SyncRequest' using the current 'ServerStore', producing an 'SyncResponse' and a new 'ServerStore'.-processServerSync ::-     forall i a m. (Ord i, Monad m)-  => m i -- ^ The action that is guaranteed to generate unique identifiers-  -> ServerStore i a-  -> SyncRequest i a-  -> m (SyncResponse i a, ServerStore i a)-processServerSync genId ServerStore {..} sr@SyncRequest {..}-      -- Make tuples of requests for all of the items that only had a client identifier.- = do-  let unidentifedPairs :: Map ClientId (ServerItem a, ItemSyncRequest a)-      unidentifedPairs = M.map (\a -> (ServerEmpty, ItemSyncRequestNew a)) syncRequestNewItems-      -- Make tuples of results for each of the unidentifier tuples.-      unidentifedResults :: Map ClientId (ItemSyncResponse a, ServerItem a)-      unidentifedResults = M.map (uncurry processServerItemSync) unidentifedPairs-  generatedResults <- generateIdentifiersFor genId unidentifedResults-      -- Gather the items that had a server identifier already.-  let clientIdentifiedSyncRequests :: Map i (ItemSyncRequest a)-      clientIdentifiedSyncRequests = identifiedItemSyncRequests sr-      -- Make 'ServerItem's for each of the items on the server side-      serverIdentifiedItems :: Map i (ServerItem a)-      serverIdentifiedItems = M.map ServerFull serverStoreItems-      -- Match up client items with server items by their id.-      thesePairs :: Map i (These (ServerItem a) (ItemSyncRequest a))-      thesePairs = unionTheseMaps serverIdentifiedItems clientIdentifiedSyncRequests-      -- Make tuples of server 'ServerItem's and 'ItemSyncRequest's for each of the items with an id-      requestPairs :: Map i (ServerItem a, ItemSyncRequest a)-      requestPairs = M.map (fromThese ServerEmpty ItemSyncRequestPoll) thesePairs-      -- Make tuples of results for each of the tuplus that had a server identifier.-      identifiedResults :: Map i (ItemSyncResponse a, ServerItem a)-      identifiedResults = M.map (uncurry processServerItemSync) requestPairs-      -- Put together the results together-  let allResults :: Map (Identifier i) (ItemSyncResponse a, ServerItem a)-      allResults =-        M.union-          (M.mapKeys OnlyServer identifiedResults)-          (M.mapKeys (uncurry BothServerAndClient) generatedResults)-  pure $ produceSyncResults allResults--identifiedItemSyncRequests :: Ord i => SyncRequest i a -> Map i (ItemSyncRequest a)-identifiedItemSyncRequests SyncRequest {..} =-  M.unions-    [ M.map ItemSyncRequestKnown syncRequestKnownItems-    , M.map ItemSyncRequestKnownButChanged syncRequestKnownButChangedItems-    , M.map ItemSyncRequestDeletedLocally syncRequestDeletedItems-    ]--generateIdentifiersFor ::-     (Ord i, Monad m)-  => m i-  -> Map ClientId (ItemSyncResponse a, ServerItem a)-  -> m (Map (i, ClientId) (ItemSyncResponse a, ServerItem a))-generateIdentifiersFor genId unidentifedResults =-  fmap M.fromList $-  forM (M.toList unidentifedResults) $ \(int, r) -> do-    uuid <- genId-    pure ((uuid, int), r)--produceSyncResults ::-     forall i a. Ord i-  => Map (Identifier i) (ItemSyncResponse a, ServerItem a)-  -> (SyncResponse i a, ServerStore i a)-produceSyncResults allResults-      -- Produce a sync response- =-  let resp :: SyncResponse i a-      resp =-        M.foldlWithKey-          (\sr cid (isr, _) -> addToSyncResponse sr cid isr)-          emptySyncResponse-          allResults-      -- Produce a new server store-      newStore :: Map i (Timed a)-      newStore =-        M.mapMaybe-          (\case-             ServerEmpty -> Nothing-             ServerFull t -> Just t) $-        M.map snd $-        M.mapKeys-          (\case-             OnlyServer i -> i-             BothServerAndClient i _ -> i)-          allResults-      -- return them both.-   in (resp, ServerStore newStore)---- | Given an incomplete 'SyncResponse', an id, possibly a client ID too, and--- an 'ItemSyncResponse', produce a less incomplete 'SyncResponse'.-addToSyncResponse ::-     Ord i => SyncResponse i a -> Identifier i -> ItemSyncResponse a -> SyncResponse i a-addToSyncResponse sr cid isr =-  case cid of-    BothServerAndClient i int ->-      case isr of-        ItemSyncResponseClientAdded st ->-          sr {syncResponseClientAdded = M.insert int (i, st) $ syncResponseClientAdded sr}-        _ -> error "should not happen"-    OnlyServer i ->-      case isr of-        ItemSyncResponseInSyncEmpty -> sr-        ItemSyncResponseInSyncFull -> sr-        ItemSyncResponseClientAdded _ -> sr -- Should not happen.-        ItemSyncResponseClientChanged st ->-          sr {syncResponseClientChanged = M.insert i st $ syncResponseClientChanged sr}-        ItemSyncResponseClientDeleted ->-          sr {syncResponseClientDeleted = S.insert i $ syncResponseClientDeleted sr}-        ItemSyncResponseServerAdded t ->-          sr {syncResponseServerAdded = M.insert i t $ syncResponseServerAdded sr}-        ItemSyncResponseServerChanged t ->-          sr {syncResponseServerChanged = M.insert i t $ syncResponseServerChanged sr}-        ItemSyncResponseServerDeleted ->-          sr {syncResponseServerDeleted = S.insert i $ syncResponseServerDeleted sr}-        ItemSyncResponseConflict a ->-          sr {syncResponseConflicts = M.insert i a $ syncResponseConflicts sr}-        ItemSyncResponseConflictClientDeleted a ->-          sr-            { syncResponseConflictsClientDeleted =-                M.insert i a $ syncResponseConflictsClientDeleted sr-            }-        ItemSyncResponseConflictServerDeleted ->-          sr-            { syncResponseConflictsServerDeleted =-                S.insert i $ syncResponseConflictsServerDeleted sr-            }--unionTheseMaps :: Ord k => Map k a -> Map k b -> Map k (These a b)-unionTheseMaps m1 m2 = M.unionWith go (M.map This m1) (M.map That m2)-  where-    go (This a) (That b) = These a b-    go _ _ = error "should not happen."--distinct :: Eq a => [a] -> Bool-distinct ls = nub ls == ls---- Inlined because holy smokes, `these` has a _lot_ of dependencies.-data These a b-  = This a-  | That b-  | These a b-  deriving (Show, Eq, Generic)--fromThese :: a -> b -> These a b -> (a, b)-fromThese a b t =-  case t of-    This a' -> (a', b)-    That b' -> (a, b')-    These a' b' -> (a', b')+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A way to synchronise a single item with safe merge conflicts.+--+-- The setup is as follows:+--+-- * A central server is set up to synchronise with+-- * Each client synchronises with the central server, but never with eachother+--+--+--+-- = A client should operate as follows:+--+-- The client starts with an 'initialClientStore'.+--+-- * The client produces a 'SyncRequest' with 'makeSyncRequest'.+-- * The client sends that request to the central server and gets a 'SyncResponse'.+-- * The client then updates its local store with 'mergeSyncResponseIgnoreProblems'.+--+--+-- = The central server should operate as follows:+--+-- The server starts with an 'initialServerStore'.+--+-- * The server accepts a 'SyncRequest'.+-- * The server performs operations according to the functionality of 'processServerSync' or 'processServerSyncCustom'.+-- * The server respons with a 'SyncResponse'.+--+--+-- WARNING:+-- This whole approach can break down if a server resets its server times+-- or if a client syncs with two different servers using the same server times.+module Data.Mergeful.Collection+  ( -- * Client side+    ClientStore (..),+    Timed (..),+    ServerTime (..),+    initialClientStore,++    -- ** Querying the client store+    clientStoreSize,+    clientStoreClientIdSet,+    clientStoreUndeletedSyncIdSet,+    clientStoreSyncIdSet,+    clientStoreItems,++    -- ** Changing the client store+    addItemToClientStore,+    findFreeSpot,+    markItemDeletedInClientStore,+    changeItemInClientStore,+    deleteItemFromClientStore,++    -- ** Maxing a sync request+    SyncRequest (..),+    initialSyncRequest,+    makeSyncRequest,++    -- ** Merging the response+    SyncResponse (..),+    ClientAddition (..),+    ItemMergeStrategy (..),+    ChangeConflictResolution (..),+    ClientDeletedConflictResolution (..),+    ServerDeletedConflictResolution (..),+    mergeFromServerStrategy,+    mergeFromClientStrategy,+    mergeUsingCRDTStrategy,+    mergeSyncResponseFromServer,+    mergeSyncResponseFromClient,+    mergeSyncResponseUsingCRDT,+    mergeSyncResponseUsingStrategy,+    ClientSyncProcessor (..),+    mergeSyncResponseCustom,++    -- *** Utility functions for implementing pure client-side merging+    ClientId (..),+    mergeAddedItems,+    mergeSyncedButChangedItems,+    mergeDeletedItems,++    -- *** Utility functions for implementing custom client-side merging+    mergeSyncedButChangedConflicts,+    mergeClientDeletedConflicts,+    mergeServerDeletedConflicts,++    -- * Server side++    -- ** The store+    ServerStore (..),+    initialServerStore,++    -- ** Processing a sync request+    processServerSync,+    ServerSyncProcessor (..),+    processServerSyncCustom,+    emptySyncResponse,+    initialServerTime,+    incrementServerTime,+  )+where++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Monad.State+import Data.Aeson+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Mergeful.Item+import Data.Mergeful.Timed+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import Data.Validity+import Data.Validity.Containers ()+import Data.Word+import GHC.Generics (Generic)++-- | A Client-side identifier for items.+--+-- These only need to be unique at the client.+newtype ClientId+  = ClientId+      { unClientId :: Word64+      }+  deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)++instance Validity ClientId++instance NFData ClientId++data ClientStore ci si a+  = ClientStore+      { -- | These items are new locally but have not been synced to the server yet.+        clientStoreAddedItems :: Map ci a,+        -- | These items have been synced at their respective 'ServerTime's.+        clientStoreSyncedItems :: Map si (Timed a),+        -- | These items have been synced at their respective 'ServerTime's+        -- but modified locally since then.+        clientStoreSyncedButChangedItems :: Map si (Timed a),+        -- | These items have been deleted locally after they were synced+        -- but the server has not been notified of that yet.+        clientStoreDeletedItems :: Map si ServerTime+      }+  deriving (Show, Eq, Generic)++instance+  (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>+  Validity (ClientStore ci si a)+  where+  validate cs@ClientStore {..} =+    mconcat+      [ genericValidate cs,+        declare "There are no duplicate IDs"+          $ distinct+          $ concat+            [ M.keys clientStoreSyncedItems,+              M.keys clientStoreSyncedButChangedItems,+              M.keys clientStoreDeletedItems+            ]+      ]++instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a)++instance+  (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>+  FromJSON (ClientStore ci si a)+  where+  parseJSON =+    withObject "ClientStore" $ \o ->+      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty+        <*> o .:? "changed" .!= M.empty+        <*> o .:? "deleted" .!= M.empty++instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where+  toJSON ClientStore {..} =+    object $+      catMaybes+        [ jNull "added" clientStoreAddedItems,+          jNull "synced" clientStoreSyncedItems,+          jNull "changed" clientStoreSyncedButChangedItems,+          jNull "deleted" clientStoreDeletedItems+        ]++-- | A client store to start with.+--+-- This store contains no items.+initialClientStore :: ClientStore ci si a+initialClientStore =+  ClientStore+    { clientStoreAddedItems = M.empty,+      clientStoreSyncedItems = M.empty,+      clientStoreSyncedButChangedItems = M.empty,+      clientStoreDeletedItems = M.empty+    }++-- | The number of items in a client store+--+-- This does not count the deleted items, so that they really look deleted..+clientStoreSize :: ClientStore ci si a -> Word+clientStoreSize ClientStore {..} =+  fromIntegral $+    sum+      [ M.size clientStoreAddedItems,+        M.size clientStoreSyncedItems,+        M.size clientStoreSyncedButChangedItems+      ]++-- | The set of client ids.+--+-- These are only the client ids of the added items that have not been synced yet.+clientStoreClientIdSet :: ClientStore ci si a -> Set ci+clientStoreClientIdSet ClientStore {..} = M.keysSet clientStoreAddedItems++-- | The set of server ids.+--+-- This does not include the ids of items that have been marked as deleted.+clientStoreUndeletedSyncIdSet :: Ord si => ClientStore ci si a -> Set si+clientStoreUndeletedSyncIdSet ClientStore {..} =+  S.unions [M.keysSet clientStoreSyncedItems, M.keysSet clientStoreSyncedButChangedItems]++-- | The set of server ids.+--+-- This includes the ids of items that have been marked as deleted.+clientStoreSyncIdSet :: Ord si => ClientStore ci si a -> Set si+clientStoreSyncIdSet ClientStore {..} =+  S.unions+    [ M.keysSet clientStoreSyncedItems,+      M.keysSet clientStoreSyncedButChangedItems,+      M.keysSet clientStoreDeletedItems+    ]++-- | The set of items in the client store+--+-- This map does not include items that have been marked as deleted.+clientStoreItems :: (Ord ci, Ord si) => ClientStore ci si a -> Map (Either ci si) a+clientStoreItems ClientStore {..} =+  M.unions+    [ M.mapKeys Left clientStoreAddedItems,+      M.mapKeys Right $ M.map timedValue clientStoreSyncedItems,+      M.mapKeys Right $ M.map timedValue clientStoreSyncedButChangedItems+    ]++-- | Add an item to a client store as an added item.+--+-- This will take care of the uniqueness constraint of the 'ci's in the map.+addItemToClientStore ::+  (Ord ci, Enum ci, Bounded ci) => a -> ClientStore ci si a -> ClientStore ci si a+addItemToClientStore a cs =+  let oldAddedItems = clientStoreAddedItems cs+      newAddedItems =+        let newKey = findFreeSpot oldAddedItems+         in M.insert newKey a oldAddedItems+   in cs {clientStoreAddedItems = newAddedItems}++-- | Find a free client id to use+--+-- You shouldn't need this function, 'addItemToClientStore' takes care of this.+--+-- The values wrap around when reaching 'maxBound'.+findFreeSpot :: (Ord ci, Enum ci, Bounded ci) => Map ci a -> ci+findFreeSpot m =+  if M.null m+    then minBound+    else+      let (i, _) = M.findMax m+       in go (next i)+  where+    go i =+      if M.member i m+        then go (next i)+        else i+    next ci+      | ci == maxBound = minBound+      | otherwise = succ ci++-- | Mark an item deleted in a client store.+--+-- This function will not delete the item, but mark it as deleted instead.+markItemDeletedInClientStore :: Ord si => si -> ClientStore ci si a -> ClientStore ci si a+markItemDeletedInClientStore u cs =+  let oldSyncedItems = clientStoreSyncedItems cs+      oldChangedItems = clientStoreSyncedButChangedItems cs+      oldDeletedItems = clientStoreDeletedItems cs+      mItem = M.lookup u oldSyncedItems <|> M.lookup u oldChangedItems+   in case mItem of+        Nothing -> cs+        Just t ->+          let newSyncedItems = M.delete u oldSyncedItems+              newChangedItems = M.delete u oldChangedItems+              newDeletedItems = M.insert u (timedTime t) oldDeletedItems+           in cs+                { clientStoreSyncedItems = newSyncedItems,+                  clientStoreSyncedButChangedItems = newChangedItems,+                  clientStoreDeletedItems = newDeletedItems+                }++-- | Replace the given item with a new value.+--+-- This function will correctly mark the item as changed, if it exist.+--+-- It will not add an item to the store with the given id, because the+-- server may not have been the origin of that id.+changeItemInClientStore :: Ord si => si -> a -> ClientStore ci si a -> ClientStore ci si a+changeItemInClientStore i a cs =+  case M.lookup i (clientStoreSyncedItems cs) of+    Just t ->+      cs+        { clientStoreSyncedItems = M.delete i (clientStoreSyncedItems cs),+          clientStoreSyncedButChangedItems =+            M.insert i (t {timedValue = a}) (clientStoreSyncedButChangedItems cs)+        }+    Nothing ->+      case M.lookup i (clientStoreSyncedButChangedItems cs) of+        Nothing -> cs+        Just _ ->+          cs+            { clientStoreSyncedButChangedItems =+                M.adjust (\t -> t {timedValue = a}) i (clientStoreSyncedButChangedItems cs)+            }++-- | Delete an unsynced item from a client store.+--+-- This function will immediately delete the item, because it has never been synced.+deleteItemFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a+deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)}++newtype ServerStore si a+  = ServerStore+      { -- | A map of items, named using an 'si', together with the 'ServerTime' at which+        -- they were last synced.+        serverStoreItems :: Map si (Timed a)+      }+  deriving (Show, Eq, Generic, FromJSON, ToJSON)++instance (Validity si, Show si, Ord si, Validity a) => Validity (ServerStore si a)++instance (NFData si, NFData a) => NFData (ServerStore si a)++-- | A server store to start with+--+-- This store contains no items.+initialServerStore :: ServerStore si a+initialServerStore = ServerStore {serverStoreItems = M.empty}++data SyncRequest ci si a+  = SyncRequest+      { -- | These items are new locally but have not been synced to the server yet.+        syncRequestNewItems :: !(Map ci a),+        -- | These items have been synced at their respective 'ServerTime's.+        syncRequestKnownItems :: !(Map si ServerTime),+        -- | These items have been synced at their respective 'ServerTime's+        -- but modified locally since then.+        syncRequestKnownButChangedItems :: !(Map si (Timed a)),+        -- | These items have been deleted locally after they were synced+        -- but the server has not been notified of that yet.+        syncRequestDeletedItems :: !(Map si ServerTime)+      }+  deriving (Show, Eq, Generic)++instance+  (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>+  Validity (SyncRequest ci si a)+  where+  validate sr@SyncRequest {..} =+    mconcat+      [ genericValidate sr,+        declare "There are no duplicate IDs"+          $ distinct+          $ concat+            [ M.keys syncRequestKnownItems,+              M.keys syncRequestKnownButChangedItems,+              M.keys syncRequestDeletedItems+            ]+      ]++instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a)++instance+  (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>+  FromJSON (SyncRequest ci si a)+  where+  parseJSON =+    withObject "SyncRequest" $ \o ->+      SyncRequest <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty+        <*> o .:? "changed" .!= M.empty+        <*> o .:? "deleted" .!= M.empty++instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncRequest ci si a) where+  toJSON SyncRequest {..} =+    object $+      catMaybes+        [ jNull "added" syncRequestNewItems,+          jNull "synced" syncRequestKnownItems,+          jNull "changed" syncRequestKnownButChangedItems,+          jNull "deleted" syncRequestDeletedItems+        ]++-- | An intial 'SyncRequest' to start with.+--+-- It just asks the server to send over whatever it knows.+initialSyncRequest :: SyncRequest ci si a+initialSyncRequest =+  SyncRequest+    { syncRequestNewItems = M.empty,+      syncRequestKnownItems = M.empty,+      syncRequestKnownButChangedItems = M.empty,+      syncRequestDeletedItems = M.empty+    }++data ClientAddition i+  = ClientAddition+      { clientAdditionId :: i,+        clientAdditionServerTime :: ServerTime+      }+  deriving (Show, Eq, Generic)++instance Validity i => Validity (ClientAddition i)++instance NFData i => NFData (ClientAddition i)++instance FromJSON i => FromJSON (ClientAddition i) where+  parseJSON = withObject "ClientAddition" $ \o -> ClientAddition <$> o .: "id" <*> o .: "time"++instance ToJSON i => ToJSON (ClientAddition i) where+  toJSON ClientAddition {..} = object ["id" .= clientAdditionId, "time" .= clientAdditionServerTime]++data SyncResponse ci si a+  = SyncResponse+      { -- | The client added these items and server has succesfully been made aware of that.+        --+        -- The client needs to update their server times+        syncResponseClientAdded :: !(Map ci (ClientAddition si)),+        -- | The client changed these items and server has succesfully been made aware of that.+        --+        -- The client needs to update their server times+        syncResponseClientChanged :: !(Map si ServerTime),+        -- | The client deleted these items and server has succesfully been made aware of that.+        --+        -- The client can delete them from its deleted items+        syncResponseClientDeleted :: !(Set si),+        -- | These items have been added on the server side+        --+        -- The client should add them too.+        syncResponseServerAdded :: !(Map si (Timed a)),+        -- | These items have been modified on the server side.+        --+        -- The client should modify them too.+        syncResponseServerChanged :: !(Map si (Timed a)),+        -- | These items were deleted on the server side+        --+        -- The client should delete them too+        syncResponseServerDeleted :: !(Set si),+        -- | These are conflicts where the server and the client both have an item, but it is different.+        --+        -- The server kept its part of each, the client can either take whatever the server gave them+        -- or deal with the conflicts somehow, and then try to re-sync.+        syncResponseConflicts :: !(Map si (Timed a)),+        -- | These are conflicts where the server has an item but the client does not.+        --+        -- The server kept its item, the client can either take whatever the server gave them+        -- or deal with the conflicts somehow, and then try to re-sync.+        syncResponseConflictsClientDeleted :: !(Map si (Timed a)),+        -- | These are conflicts where the server has no item but the client has a modified item.+        --+        -- The server left its item deleted, the client can either delete its items too+        -- or deal with the conflicts somehow, and then try to re-sync.+        syncResponseConflictsServerDeleted :: !(Set si)+      }+  deriving (Show, Eq, Generic)++instance+  (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>+  Validity (SyncResponse ci si a)+  where+  validate sr@SyncResponse {..} =+    mconcat+      [ genericValidate sr,+        declare "There are no duplicate IDs"+          $ distinct+          $ concat+            [ map (\(_, ClientAddition {..}) -> clientAdditionId) $ M.toList syncResponseClientAdded,+              M.keys syncResponseClientChanged,+              S.toList syncResponseClientDeleted,+              M.keys syncResponseServerAdded,+              M.keys syncResponseServerChanged,+              S.toList syncResponseServerDeleted,+              M.keys syncResponseConflicts,+              M.keys syncResponseConflictsClientDeleted,+              S.toList syncResponseConflictsServerDeleted+            ]+      ]++instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a)++instance+  (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>+  FromJSON (SyncResponse ci si a)+  where+  parseJSON =+    withObject "SyncResponse" $ \o ->+      SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty+        <*> o .:? "client-deleted" .!= S.empty+        <*> o .:? "server-added" .!= M.empty+        <*> o .:? "server-changed" .!= M.empty+        <*> o .:? "server-deleted" .!= S.empty+        <*> o .:? "conflict" .!= M.empty+        <*> o .:? "conflict-client-deleted" .!= M.empty+        <*> o .:? "conflict-server-deleted" .!= S.empty++instance+  (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) =>+  ToJSON (SyncResponse ci si a)+  where+  toJSON SyncResponse {..} =+    object $+      catMaybes+        [ jNull "client-added" syncResponseClientAdded,+          jNull "client-changed" syncResponseClientChanged,+          jNull "client-deleted" syncResponseClientDeleted,+          jNull "server-added" syncResponseServerAdded,+          jNull "server-changed" syncResponseServerChanged,+          jNull "server-deleted" syncResponseServerDeleted,+          jNull "conflict" syncResponseConflicts,+          jNull "conflict-client-deleted" syncResponseConflictsClientDeleted,+          jNull "conflict-server-deleted" syncResponseConflictsServerDeleted+        ]++-- | A sync response to start with.+--+-- It is entirely empty.+emptySyncResponse :: SyncResponse ci si a+emptySyncResponse =+  SyncResponse+    { syncResponseClientAdded = M.empty,+      syncResponseClientChanged = M.empty,+      syncResponseClientDeleted = S.empty,+      syncResponseServerAdded = M.empty,+      syncResponseServerChanged = M.empty,+      syncResponseServerDeleted = S.empty,+      syncResponseConflicts = M.empty,+      syncResponseConflictsClientDeleted = M.empty,+      syncResponseConflictsServerDeleted = S.empty+    }++jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value)+jNull n s =+  if null s+    then Nothing+    else Just $ n .= s++-- | Produce an 'SyncRequest' from a 'ClientStore'.+--+-- Send this to the server for synchronisation.+makeSyncRequest :: ClientStore ci si a -> SyncRequest ci si a+makeSyncRequest ClientStore {..} =+  SyncRequest+    { syncRequestNewItems = clientStoreAddedItems,+      syncRequestKnownItems = M.map timedTime clientStoreSyncedItems,+      syncRequestKnownButChangedItems = clientStoreSyncedButChangedItems,+      syncRequestDeletedItems = clientStoreDeletedItems+    }++-- | Merge a 'SyncResponse' into the current 'ClientStore' by taking whatever the server gave the client in case of conflict.+--+-- Pro: Clients will converge on the same value.+--+-- __Con: Conflicting updates will be lost.__+mergeSyncResponseFromServer ::+  (Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a+mergeSyncResponseFromServer =+  mergeSyncResponseUsingStrategy mergeFromServerStrategy++-- | Merge a 'SyncResponse' into the current 'ClientStore' by keeping whatever the client had in case of conflict.+--+-- Pro: No data will be lost+--+-- __Con: Clients will diverge when conflicts occur.__+mergeSyncResponseFromClient ::+  (Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a+mergeSyncResponseFromClient = mergeSyncResponseUsingStrategy mergeFromClientStrategy++-- | Merge a 'SyncResponse' into the current 'ClientStore' by using the given GADT merging function in case of conflict+mergeSyncResponseUsingCRDT :: (Ord ci, Ord si) => (a -> a -> a) -> ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a+mergeSyncResponseUsingCRDT = mergeSyncResponseUsingStrategy . mergeUsingCRDTStrategy++-- | Merge an 'SyncResponse' into the current 'ClientStore' with the given merge strategy.+--+-- In order for clients to converge on the same collection correctly, this function must be:+--+-- * Associative+-- * Idempotent+-- * The same on all clients+--+-- This function ignores mismatches.+mergeSyncResponseUsingStrategy ::+  (Ord ci, Ord si) =>+  ItemMergeStrategy a ->+  ClientStore ci si a ->+  SyncResponse ci si a ->+  ClientStore ci si a+mergeSyncResponseUsingStrategy strat cs sr =+  flip execState cs $ mergeSyncResponseCustom strat pureClientSyncProcessor sr++pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a))+pureClientSyncProcessor =+  ClientSyncProcessor+    { clientSyncProcessorQuerySyncedButChangedValues = \s ->+        gets+          ( \cs -> M.intersection (clientStoreSyncedButChangedItems cs) (M.fromSet (const ()) s)+          ),+      clientSyncProcessorSyncClientAdded = \m ->+        modify+          ( \cs ->+              let (leftovers, added) = mergeAddedItems (clientStoreAddedItems cs) m+               in cs {clientStoreAddedItems = leftovers, clientStoreSyncedItems = added `M.union` clientStoreSyncedItems cs}+          ),+      clientSyncProcessorSyncClientChanged = \m ->+        modify+          ( \cs ->+              let (leftovers, changed) = mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) m+               in cs {clientStoreSyncedButChangedItems = leftovers, clientStoreSyncedItems = changed `M.union` clientStoreSyncedItems cs}+          ),+      clientSyncProcessorSyncClientDeleted = \s ->+        modify+          ( \cs ->+              let leftovers = mergeDeletedItems (clientStoreDeletedItems cs) s+               in cs {clientStoreDeletedItems = leftovers}+          ),+      clientSyncProcessorSyncMergedConflict = \resolved ->+        modify+          ( \cs ->+              let newSyncedButChanged = M.union resolved (clientStoreSyncedButChangedItems cs)+               in cs {clientStoreSyncedButChangedItems = newSyncedButChanged, clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` newSyncedButChanged}+          ),+      clientSyncProcessorSyncServerAdded = \m ->+        modify (\cs -> cs {clientStoreSyncedItems = m `M.union` clientStoreSyncedItems cs}),+      clientSyncProcessorSyncServerChanged = \m ->+        modify+          ( \cs ->+              let newSynced = m `M.union` clientStoreSyncedItems cs+               in cs {clientStoreSyncedItems = newSynced, clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` newSynced}+          ),+      clientSyncProcessorSyncServerDeleted = \s ->+        modify+          ( \cs ->+              let m = M.fromSet (const ()) s+               in cs+                    { clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` m,+                      clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` m+                    }+          )+    }++-- | Merge the local added items with the ones that the server has acknowledged as added.+mergeAddedItems ::+  forall ci si a.+  (Ord ci, Ord si) =>+  Map ci a ->+  Map ci (ClientAddition si) ->+  (Map ci a, Map si (Timed a))+mergeAddedItems local added = M.foldlWithKey go (M.empty, M.empty) local+  where+    go :: (Map ci a, Map si (Timed a)) -> ci -> a -> (Map ci a, Map si (Timed a))+    go (as, m) ci a =+      case M.lookup ci added of+        Nothing -> (M.insert ci a as, m)+        Just ClientAddition {..} ->+          ( as,+            M.insert+              clientAdditionId+              (Timed {timedValue = a, timedTime = clientAdditionServerTime})+              m+          )++-- | Merge the local synced but changed items with the ones that the server has acknowledged as changed.+mergeSyncedButChangedItems ::+  forall i a.+  Ord i =>+  Map i (Timed a) ->+  Map i ServerTime ->+  (Map i (Timed a), Map i (Timed a))+mergeSyncedButChangedItems local changed = M.foldlWithKey go (M.empty, M.empty) local+  where+    go :: (Map i (Timed a), Map i (Timed a)) -> i -> Timed a -> (Map i (Timed a), Map i (Timed a))+    go (m1, m2) k t =+      case M.lookup k changed of+        Nothing -> (M.insert k t m1, m2)+        Just st' -> (m1, M.insert k (t {timedTime = st'}) m2)++-- | Merge the local deleted items with the ones that the server has acknowledged as deleted.+mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b+mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s++data ClientSyncProcessor ci si a (m :: * -> *)+  = ClientSyncProcessor+      { -- | Get the synced values with keys in the given set+        clientSyncProcessorQuerySyncedButChangedValues :: !(Set si -> m (Map si (Timed a))),+        -- | Complete additions that were acknowledged by the server.+        -- This involves saving the server id and the server time+        clientSyncProcessorSyncClientAdded :: !(Map ci (ClientAddition si) -> m ()),+        -- | Complete changes that were acknowledged by the server+        -- This involves updating the server time+        clientSyncProcessorSyncClientChanged :: !(Map si ServerTime -> m ()),+        -- | Complete deletions that were acknowledged by the server+        -- This means deleting these tombstoned items entirely+        clientSyncProcessorSyncClientDeleted :: !(Set si -> m ()),+        -- | Store the items that were in a conflict but the conflict was resolved correctly.+        -- These items should be marked as changed.+        clientSyncProcessorSyncMergedConflict :: !(Map si (Timed a) -> m ()),+        clientSyncProcessorSyncServerAdded :: !(Map si (Timed a) -> m ()),+        clientSyncProcessorSyncServerChanged :: !(Map si (Timed a) -> m ()),+        clientSyncProcessorSyncServerDeleted :: !(Set si -> m ())+      }+  deriving (Generic)++mergeSyncResponseCustom :: (Ord si, Monad m) => ItemMergeStrategy a -> ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()+mergeSyncResponseCustom ItemMergeStrategy {..} ClientSyncProcessor {..} SyncResponse {..} = do+  -- Every client deleted conflict needs to be added, if the sync processor says so+  let resolvedClientDeletedConflicts = mergeClientDeletedConflicts itemMergeStrategyMergeClientDeletedConflict syncResponseConflictsClientDeleted+  -- Every change conflict, unless the client item is kept, needs to be updated+  -- The unresolved conflicts don't need to be updated.+  clientChangeConflicts <- clientSyncProcessorQuerySyncedButChangedValues $ M.keysSet syncResponseConflicts+  let (_, mergedChangeConflicts, resolvedChangeConflicts) = mergeSyncedButChangedConflicts itemMergeStrategyMergeChangeConflict clientChangeConflicts syncResponseConflicts+  -- Every served deleted conflict needs to be deleted, if the sync processor says so+  clientServerDeletedConflicts <- clientSyncProcessorQuerySyncedButChangedValues syncResponseConflictsServerDeleted+  let resolvedServerDeletedConflicts = mergeServerDeletedConflicts itemMergeStrategyMergeServerDeletedConflict clientServerDeletedConflicts+  -- The order here matters.+  clientSyncProcessorSyncServerAdded $ M.union syncResponseServerAdded resolvedClientDeletedConflicts+  clientSyncProcessorSyncServerChanged $ M.union syncResponseServerChanged resolvedChangeConflicts+  clientSyncProcessorSyncServerDeleted $ S.union syncResponseServerDeleted resolvedServerDeletedConflicts+  clientSyncProcessorSyncMergedConflict mergedChangeConflicts+  clientSyncProcessorSyncClientDeleted syncResponseClientDeleted+  clientSyncProcessorSyncClientChanged syncResponseClientChanged+  clientSyncProcessorSyncClientAdded syncResponseClientAdded++-- | Resolve change conflicts+mergeSyncedButChangedConflicts ::+  forall si a.+  Ord si =>+  (a -> a -> ChangeConflictResolution a) ->+  -- | The conflicting items on the client side+  Map si (Timed a) ->+  -- | The conflicting items on the server side+  Map si (Timed a) ->+  -- | Unresolved conflicts on the left, merged conflicts in the middle, resolved conflicts on the right+  --+  -- * The unresolved conflicts should remain as-is+  -- * The merged conflicts should be updated and marked as changed+  -- * The resolved conflicts should be updated and marked as unchanged+  (Map si (Timed a), Map si (Timed a), Map si (Timed a))+mergeSyncedButChangedConflicts func clientItems =+  M.foldlWithKey go (M.empty, M.empty, M.empty)+  where+    go ::+      (Map si (Timed a), Map si (Timed a), Map si (Timed a)) ->+      si ->+      Timed a ->+      (Map si (Timed a), Map si (Timed a), Map si (Timed a))+    go tup@(unresolved, merged, resolved) key s@(Timed si st) = case M.lookup key clientItems of+      Nothing -> tup -- TODO not even sure what this would mean. Should not happen I guess. Just throw it away+      Just c@(Timed ci _) -> case func ci si of+        KeepLocal ->+          (M.insert key c unresolved, merged, resolved)+        Merged mi ->+          (unresolved, M.insert key (Timed mi st) merged, M.insert key s resolved)+        TakeRemote ->+          (unresolved, merged, M.insert key s resolved)++-- | Resolve client deleted conflicts+mergeClientDeletedConflicts ::+  (a -> ClientDeletedConflictResolution) ->+  -- | The conflicting items on the server side+  Map si (Timed a) ->+  -- | A map of items that need to be updated on the client.+  Map si (Timed a)+mergeClientDeletedConflicts func = M.filter $ \(Timed si _) ->+  case func si of+    TakeRemoteChange -> True+    StayDeleted -> False++-- | Resolve server deleted conflicts+mergeServerDeletedConflicts ::+  (a -> ServerDeletedConflictResolution) ->+  -- | The conflicting items on the client side+  Map si (Timed a) ->+  -- | The result is a map of items that need to be deleted on the client.+  Set si+mergeServerDeletedConflicts func m = M.keysSet $ flip M.filter m $ \(Timed si _) -> case func si of+  KeepLocalChange -> False+  Delete -> True++data Identifier ci si+  = OnlyServer si+  | BothServerAndClient si ci+  deriving (Show, Eq, Ord, Generic)++instance (Validity ci, Validity si) => Validity (Identifier ci si)++instance (NFData ci, NFData si) => NFData (Identifier ci si)++data ServerSyncProcessor ci si a m+  = ServerSyncProcessor+      { -- | Read all items+        serverSyncProcessorRead :: !(m (Map si (Timed a))),+        -- | Add an item with 'initialServerTime'+        serverSyncProcessorAddItem :: !(a -> m si),+        -- | Update an item+        serverSyncProcessorChangeItem :: !(si -> ServerTime -> a -> m ()),+        -- | Delete an item+        serverSyncProcessorDeleteItem :: !(si -> m ())+      }+  deriving (Generic)++-- | Process a server sync+--+-- === __Implementation Details__+--+-- There are four cases for the items in the sync request+--+-- - Added (A)+-- - Synced (S)+-- - Changed (C)+-- - Deleted (D)+--+-- Each of them present options and may require action on the sever side:+--+-- * Added:+--+--     * Client Added (CA) (This is the only case where a new identifier needs to be generated.)+--+-- * Synced:+--+--     * Server Changed (SC) (Nothing)+--     * Server Deleted (SD) (Nothing)+--+-- * Changed:+--+--     * Client Changed (CC) (Update value and increment server time)+--     * Change Conflict (CConf) (Nothing)+--     * Server Deleted Conflict (SDC) (Nothing)+--+-- * Deleted:+--+--     * Client Deleted (CD) (Delete the item)+--     * Client Deleted Conflict (CDC) (Nothing)+--+-- * Extra:+--+--     * Server Added (SA) (Nothing)+--+-- For more detailed comments of the nine cases, see the source of 'processServerItemSync' in the "Data.Mergeful.Item".+processServerSyncCustom ::+  forall ci si a m.+  ( Ord si,+    Monad m+  ) =>+  -- | Your server sync processor+  ServerSyncProcessor ci si a m ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a)+processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do+  serverItems <- serverSyncProcessorRead+  -- A: CA (generate a new identifier)+  syncResponseClientAdded <- forM syncRequestNewItems $ \a -> do+    si <- serverSyncProcessorAddItem a+    pure $ ClientAddition {clientAdditionId = si, clientAdditionServerTime = initialServerTime}+  -- C:+  let decideOnSynced tup@(sc, sd) (si, ct) =+        case M.lookup si serverItems of+          -- SD: The server must have deleted it.+          Nothing -> (sc, S.insert si sd)+          Just t@(Timed _ st) ->+            if ct >= st+              then tup -- In sync+              else (M.insert si t sc, sd) -- SC: The server has changed it because its server time is newer+  let (syncResponseServerChanged, syncResponseServerDeleted) = foldl decideOnSynced (M.empty, S.empty) (M.toList syncRequestKnownItems)+  -- S:+  let decideOnChanged (cc, cConf, sdc) (si, Timed clientItem ct) = do+        case M.lookup si serverItems of+          -- SDC+          Nothing -> pure (cc, cConf, S.insert si sdc)+          Just serverTimed@(Timed _ st) ->+            if ct >= st+              then do+                -- CC+                let st' = incrementServerTime st+                -- Update the server item+                serverSyncProcessorChangeItem si st' clientItem+                pure (M.insert si st' cc, cConf, sdc)+              else do+                -- CConf+                pure (cc, M.insert si serverTimed cConf, sdc)+  (syncResponseClientChanged, syncResponseConflicts, syncResponseConflictsServerDeleted) <- foldM decideOnChanged (M.empty, M.empty, S.empty) (M.toList syncRequestKnownButChangedItems)+  --- D:+  let decideOnDeleted (cd, cdc) (si, ct) = do+        case M.lookup si serverItems of+          Nothing -> do+            -- CD: It was already deleted on the server side, Just pretend that the client made that happen.+            pure (S.insert si cd, cdc)+          Just serverTimed@(Timed _ st) ->+            if ct >= st+              then do+                -- CD+                -- Delete the item+                serverSyncProcessorDeleteItem si+                pure (S.insert si cd, cdc)+              else do+                -- CDC+                pure (cd, M.insert si serverTimed cdc)+  (syncResponseClientDeleted, syncResponseConflictsClientDeleted) <- foldM decideOnDeleted (S.empty, M.empty) (M.toList syncRequestDeletedItems)+  -- Extra: for all items that are in the server but not in the sync request, we need to say they are server added.+  let syncResponseServerAdded = serverItems `M.difference` M.unions [() <$ syncRequestKnownItems, () <$ syncRequestKnownButChangedItems, () <$ syncRequestDeletedItems]+  pure SyncResponse {..}++-- | Serve an 'SyncRequest' using the current 'ServerStore', producing an 'SyncResponse' and a new 'ServerStore'.+processServerSync ::+  forall ci si a m.+  ( Ord si,+    Monad m+  ) =>+  -- | The action that is guaranteed to generate unique identifiers+  m si ->+  ServerStore si a ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a, ServerStore si a)+processServerSync genId ss sr = runStateT (processServerSyncCustom (pureServerSyncProcessor genId) sr) ss++-- | A potentially pure sync processor+pureServerSyncProcessor ::+  (Ord si, Monad m) =>+  -- | The action that is guaranteed to generate unique identifiers+  m si ->+  ServerSyncProcessor ci si a (StateT (ServerStore si a) m)+pureServerSyncProcessor genId = ServerSyncProcessor {..}+  where+    serverSyncProcessorRead = gets serverStoreItems+    serverSyncProcessorAddItem a = do+      i <- lift genId+      modify (\(ServerStore m) -> ServerStore (M.insert i (Timed a initialServerTime) m))+      pure i+    serverSyncProcessorChangeItem si st a =+      modify+        ( \(ServerStore m) ->+            let m' = M.adjust (const (Timed a st)) si m+             in ServerStore m'+        )+    serverSyncProcessorDeleteItem si =+      modify+        ( \(ServerStore m) ->+            let m' = M.delete si m+             in ServerStore m'+        )++distinct :: Eq a => [a] -> Bool+distinct ls = nub ls == ls

@@ -39,50 +39,63 @@ -- This whole approach can break down if a server resets its server times -- or if a client syncs with two different servers using the same server times. module Data.Mergeful.Item-  ( initialClientItem-  , initialItemSyncRequest-  , makeItemSyncRequest-  , mergeItemSyncResponseRaw-  , ItemMergeResult(..)-  , mergeItemSyncResponseIgnoreProblems-  , mergeIgnoringProblems-  , mergeFromServer-  , ItemMergeStrategy(..)-  , mergeUsingStrategy-    -- * Server side-  , initialServerItem-  , processServerItemSync-    -- * Types, for reference-  , ClientItem(..)-  , ItemSyncRequest(..)-  , ItemSyncResponse(..)-  , ServerItem(..)-  ) where+  ( initialClientItem,+    initialItemSyncRequest,+    makeItemSyncRequest,+    mergeItemSyncResponseFromServer,+    mergeItemSyncResponseFromClient,+    mergeItemSyncResponseUsingCRDT,+    mergeItemSyncResponseUsingStrategy,+    mergeFromServer,+    mergeFromServerStrategy,+    mergeFromClient,+    mergeFromClientStrategy,+    mergeUsingCRDT,+    mergeUsingCRDTStrategy,+    ItemMergeStrategy (..),+    ChangeConflictResolution (..),+    ClientDeletedConflictResolution (..),+    ServerDeletedConflictResolution (..),+    mergeUsingStrategy,+    mergeItemSyncResponseRaw,+    ItemMergeResult (..), -import GHC.Generics (Generic)+    -- * Server side+    initialServerItem,+    processServerItemSync, -import Data.Aeson as JSON-import Data.Validity+    -- * Types, for reference+    ClientItem (..),+    ItemSyncRequest (..),+    ItemSyncResponse (..),+    ServerItem (..),+  )+where  import Control.Applicative-+import Control.DeepSeq+import Data.Aeson as JSON import Data.Mergeful.Timed+import Data.Validity+import GHC.Generics (Generic)  data ClientItem a-  -- | There is no item on the client side-  = ClientEmpty-  -- | There is is an item but the server is not aware of it yet.-  | ClientAdded !a-  -- | There is is an item and it has been synced with the server.-  | ClientItemSynced !(Timed a)-  -- | There is is an item and it has been synced with the server, but it has since been modified.-  | ClientItemSyncedButChanged !(Timed a)-  -- | There was an item, and it has been deleted locally, but the server has not been made aware of this.-  | ClientDeleted !ServerTime+  = -- | There is no item on the client side+    ClientEmpty+  | -- | There is is an item but the server is not aware of it yet.+    ClientAdded !a+  | -- | There is is an item and it has been synced with the server.+    ClientItemSynced !(Timed a)+  | -- | There is is an item and it has been synced with the server, but it has since been modified.+    ClientItemSyncedButChanged !(Timed a)+  | -- | There was an item, and it has been deleted locally, but the server has not been made aware of this.+    ClientDeleted !ServerTime   deriving (Show, Eq, Generic)  instance Validity a => Validity (ClientItem a) +instance NFData a => NFData (ClientItem a)+ instance FromJSON a => FromJSON (ClientItem a) where   parseJSON =     withObject "ClientItem" $ \o -> do@@ -98,14 +111,14 @@ instance ToJSON a => ToJSON (ClientItem a) where   toJSON ci =     object $-    case ci of-      ClientEmpty -> ["type" .= ("empty" :: String)]-      ClientAdded a -> ["type" .= ("added" :: String), "value" .= a]-      ClientItemSynced Timed {..} ->-        ["type" .= ("synced" :: String), "value" .= timedValue, "time" .= timedTime]-      ClientItemSyncedButChanged Timed {..} ->-        ["type" .= ("changed" :: String), "value" .= timedValue, "time" .= timedTime]-      ClientDeleted t -> ["type" .= ("deleted" :: String), "time" .= t]+      case ci of+        ClientEmpty -> ["type" .= ("empty" :: String)]+        ClientAdded a -> ["type" .= ("added" :: String), "value" .= a]+        ClientItemSynced Timed {..} ->+          ["type" .= ("synced" :: String), "value" .= timedValue, "time" .= timedTime]+        ClientItemSyncedButChanged Timed {..} ->+          ["type" .= ("changed" :: String), "value" .= timedValue, "time" .= timedTime]+        ClientDeleted t -> ["type" .= ("deleted" :: String), "time" .= t]  -- | A client item to start with. --@@ -114,14 +127,16 @@ initialClientItem = ClientEmpty  data ServerItem a-  -- | There is no item on the server side-  = ServerEmpty-  -- | There is an item on the server side, and it was last synced at the given 'ServerTime'.-  | ServerFull !(Timed a)+  = -- | There is no item on the server side+    ServerEmpty+  | -- | There is an item on the server side, and it was last synced at the given 'ServerTime'.+    ServerFull !(Timed a)   deriving (Show, Eq, Generic)  instance Validity a => Validity (ServerItem a) +instance NFData a => NFData (ServerItem a)+ instance FromJSON a => FromJSON (ServerItem a) where   parseJSON =     withObject "ServerItem" $ \o ->@@ -130,9 +145,9 @@ instance ToJSON a => ToJSON (ServerItem a) where   toJSON si =     object $-    case si of-      ServerEmpty -> []-      ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime]+      case si of+        ServerEmpty -> []+        ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime]  -- | A server item to start with. --@@ -141,22 +156,24 @@ initialServerItem = ServerEmpty  data ItemSyncRequest a-  -- | There is no item locally-  = ItemSyncRequestPoll-  -- | There is an item locally that has not been synced to the server yet.-  | ItemSyncRequestNew !a-  -- | There is an item locally that was synced at the given 'ServerTime'-  | ItemSyncRequestKnown !ServerTime-  -- | There is an item locally that was synced at the given 'ServerTime'-  -- but it has been changed since then.-  | ItemSyncRequestKnownButChanged !(Timed a)-  -- | There was an item locally that has been deleted but the-  -- deletion wasn't synced to the server yet.-  | ItemSyncRequestDeletedLocally !ServerTime+  = -- | There is no item locally+    ItemSyncRequestPoll+  | -- | There is an item locally that has not been synced to the server yet.+    ItemSyncRequestNew !a+  | -- | There is an item locally that was synced at the given 'ServerTime'+    ItemSyncRequestKnown !ServerTime+  | -- | There is an item locally that was synced at the given 'ServerTime'+    -- but it has been changed since then.+    ItemSyncRequestKnownButChanged !(Timed a)+  | -- | There was an item locally that has been deleted but the+    -- deletion wasn't synced to the server yet.+    ItemSyncRequestDeletedLocally !ServerTime   deriving (Show, Eq, Generic)  instance Validity a => Validity (ItemSyncRequest a) +instance NFData a => NFData (ItemSyncRequest a)+ instance FromJSON a => FromJSON (ItemSyncRequest a) where   parseJSON =     withObject "ItemSyncRequest" $ \o -> do@@ -172,15 +189,15 @@ instance ToJSON a => ToJSON (ItemSyncRequest a) where   toJSON ci =     object $-    let o n rest = ("type" .= (n :: String)) : rest-        oe n = o n []-     in case ci of-          ItemSyncRequestPoll -> oe "empty"-          ItemSyncRequestNew a -> o "added" ["value" .= a]-          ItemSyncRequestKnown t -> o "synced" ["time" .= t]-          ItemSyncRequestKnownButChanged Timed {..} ->-            o "changed" ["value" .= timedValue, "time" .= timedTime]-          ItemSyncRequestDeletedLocally t -> o "deleted" ["time" .= t]+      let o n rest = ("type" .= (n :: String)) : rest+          oe n = o n []+       in case ci of+            ItemSyncRequestPoll -> oe "empty"+            ItemSyncRequestNew a -> o "added" ["value" .= a]+            ItemSyncRequestKnown t -> o "synced" ["time" .= t]+            ItemSyncRequestKnownButChanged Timed {..} ->+              o "changed" ["value" .= timedValue, "time" .= timedTime]+            ItemSyncRequestDeletedLocally t -> o "deleted" ["time" .= t]  -- | An intial 'ItemSyncRequest' to start with. --@@ -189,60 +206,59 @@ initialItemSyncRequest = ItemSyncRequestPoll  data ItemSyncResponse a-  -- | The client and server are fully in sync, and both empty-  ---  -- Nothing needs to be done at the client side.-  = ItemSyncResponseInSyncEmpty-  -- | The client and server are fully in sync.-  ---  -- Nothing needs to be done at the client side.-  | ItemSyncResponseInSyncFull-  -- | The client added an item and server has succesfully been made aware of that.-  ---  -- The client needs to update its server time-  | ItemSyncResponseClientAdded !ServerTime-  -- | The client changed an item and server has succesfully been made aware of that.-  ---  -- The client needs to update its server time-  | ItemSyncResponseClientChanged !ServerTime-  -- | The client deleted an item and server has succesfully been made aware of that.-  ---  -- The client can delete it from its deleted items-  | ItemSyncResponseClientDeleted-  -- | This item has been added on the server side-  ---  -- The client should add it too.-  | ItemSyncResponseServerAdded !(Timed a)-  -- | This item has been modified on the server side.-  ---  -- The client should modify it too.-  | ItemSyncResponseServerChanged !(Timed a)-  -- | The item was deleted on the server side-  ---  -- The client should delete it too.-  | ItemSyncResponseServerDeleted-  -- | A conflict occurred.-  ---  -- The server and the client both have an item, but it is different.-  -- The server kept its part, the client can either take whatever the server gave them-  -- or deal with the conflict somehow, and then try to re-sync.-  | ItemSyncResponseConflict !(Timed a) -- ^ The item at the server side-  -- | A conflict occurred.-  ---  -- The server has an item but the client does not.-  -- The server kept its part, the client can either take whatever the server gave them-  -- or deal with the conflict somehow, and then try to re-sync.-  | ItemSyncResponseConflictClientDeleted !(Timed a) -- ^ The item at the server side-  -- | A conflict occurred.-  ---  -- The client has a (modified) item but the server does not have any item.-  -- The server left its item deleted, the client can either delete its item too-  -- or deal with the conflict somehow, and then try to re-sync.+  = -- | The client and server are fully in sync, and both empty+    --+    -- Nothing needs to be done at the client side.+    ItemSyncResponseInSyncEmpty+  | -- | The client and server are fully in sync.+    --+    -- Nothing needs to be done at the client side.+    ItemSyncResponseInSyncFull+  | -- | The client added an item and server has succesfully been made aware of that.+    --+    -- The client needs to update its server time+    ItemSyncResponseClientAdded !ServerTime+  | -- | The client changed an item and server has succesfully been made aware of that.+    --+    -- The client needs to update its server time+    ItemSyncResponseClientChanged !ServerTime+  | -- | The client deleted an item and server has succesfully been made aware of that.+    --+    -- The client can delete it from its deleted items+    ItemSyncResponseClientDeleted+  | -- | This item has been added on the server side+    --+    -- The client should add it too.+    ItemSyncResponseServerAdded !(Timed a)+  | -- | This item has been modified on the server side.+    --+    -- The client should modify it too.+    ItemSyncResponseServerChanged !(Timed a)+  | -- | The item was deleted on the server side+    --+    -- The client should delete it too.+    ItemSyncResponseServerDeleted+  | -- | The item at the server side+    -- | A conflict occurred.+    --+    -- The server has an item but the client does not.+    -- The server kept its part, the client can either take whatever the server gave them+    -- or deal with the conflict somehow, and then try to re-sync.+    ItemSyncResponseConflict !(Timed a)+  | -- | The item at the server side+    -- | A conflict occurred.+    --+    -- The client has a (modified) item but the server does not have any item.+    -- The server left its item deleted, the client can either delete its item too+    -- or deal with the conflict somehow, and then try to re-sync.+    ItemSyncResponseConflictClientDeleted !(Timed a)   | ItemSyncResponseConflictServerDeleted   deriving (Show, Eq, Generic)  instance Validity a => Validity (ItemSyncResponse a) +instance NFData a => NFData (ItemSyncResponse a)+ instance FromJSON a => FromJSON (ItemSyncResponse a) where   parseJSON =     withObject "ItemSyncResponse" $ \o -> do@@ -265,22 +281,22 @@ instance ToJSON a => ToJSON (ItemSyncResponse a) where   toJSON isr =     object $-    let o s rest = ("type" .= (s :: String)) : rest-        oe s = o s []-     in case isr of-          ItemSyncResponseInSyncEmpty -> oe "in-sync-empty"-          ItemSyncResponseInSyncFull -> oe "in-sync-full"-          ItemSyncResponseClientAdded t -> o "client-added" ["time" .= t]-          ItemSyncResponseClientChanged t -> o "client-changed" ["time" .= t]-          ItemSyncResponseClientDeleted -> oe "client-deleted"-          ItemSyncResponseServerAdded Timed {..} ->-            o "server-added" ["value" .= timedValue, "time" .= timedTime]-          ItemSyncResponseServerChanged Timed {..} ->-            o "server-changed" ["value" .= timedValue, "time" .= timedTime]-          ItemSyncResponseServerDeleted -> oe "server-deleted"-          ItemSyncResponseConflict a -> o "conflict" ["value" .= a]-          ItemSyncResponseConflictClientDeleted a -> o "conflict-client-deleted" ["value" .= a]-          ItemSyncResponseConflictServerDeleted -> oe "conflict-server-deleted"+      let o s rest = ("type" .= (s :: String)) : rest+          oe s = o s []+       in case isr of+            ItemSyncResponseInSyncEmpty -> oe "in-sync-empty"+            ItemSyncResponseInSyncFull -> oe "in-sync-full"+            ItemSyncResponseClientAdded t -> o "client-added" ["time" .= t]+            ItemSyncResponseClientChanged t -> o "client-changed" ["time" .= t]+            ItemSyncResponseClientDeleted -> oe "client-deleted"+            ItemSyncResponseServerAdded Timed {..} ->+              o "server-added" ["value" .= timedValue, "time" .= timedTime]+            ItemSyncResponseServerChanged Timed {..} ->+              o "server-changed" ["value" .= timedValue, "time" .= timedTime]+            ItemSyncResponseServerDeleted -> oe "server-deleted"+            ItemSyncResponseConflict a -> o "conflict" ["value" .= a]+            ItemSyncResponseConflictClientDeleted a -> o "conflict-client-deleted" ["value" .= a]+            ItemSyncResponseConflictServerDeleted -> oe "conflict-server-deleted"  -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. --@@ -295,20 +311,24 @@     ClientDeleted st -> ItemSyncRequestDeletedLocally st  data ItemMergeResult a-  -- | The merger went succesfully, no conflicts or desyncs-  = MergeSuccess !(ClientItem a)-  -- | There was a merge conflict. The server and client had different, conflicting versions.-  | MergeConflict !a !(Timed a) -- ^ The item at the server side-  -- | There was a merge conflict. The client had deleted the item while the server had modified it.-  | MergeConflictClientDeleted !(Timed a) -- ^ The item at the server side-  -- | There was a merge conflict. The server had deleted the item while the client had modified it.-  | MergeConflictServerDeleted !a -- ^ The item at the client side-  -- | The server responded with a response that did not make sense given the client's request.+  = -- | The merger went succesfully, no conflicts or desyncs+    MergeSuccess !(ClientItem a)+  | -- | The item at the server side+    -- | There was a merge conflict. The client had deleted the item while the server had modified it.+    MergeConflict !a !(Timed a)+  | -- | The item at the server side+    -- | There was a merge conflict. The server had deleted the item while the client had modified it.+    MergeConflictClientDeleted !(Timed a)+  | -- | The item at the client side+    -- | The server responded with a response that did not make sense given the client's request.+    MergeConflictServerDeleted !a   | MergeMismatch   deriving (Show, Eq, Generic)  instance Validity a => Validity (ItemMergeResult a) +instance NFData a => NFData (ItemMergeResult a)+ -- | Merge an 'ItemSyncResponse' into the current 'ClientItem'. -- -- This function will not make any decisions about what to do with@@ -346,48 +366,48 @@         ItemSyncResponseConflictClientDeleted si -> MergeConflictClientDeleted si         _ -> MergeMismatch --- | Merge an 'ItemSyncResponse' into the current 'ClientItem'.------ This function ignores any problems that may occur.--- In the case of a conclict, it will just not update the client item.--- The next sync request will then produce a conflict again.------ > mergeItemSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeItemSyncResponseRaw cs-mergeItemSyncResponseIgnoreProblems :: ClientItem a -> ItemSyncResponse a -> ClientItem a-mergeItemSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeItemSyncResponseRaw cs+mergeItemSyncResponseUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemSyncResponse a -> ClientItem a+mergeItemSyncResponseUsingStrategy strat ci sr = mergeUsingStrategy strat ci $ mergeItemSyncResponseRaw ci sr +mergeItemSyncResponseFromServer :: ClientItem a -> ItemSyncResponse a -> ClientItem a+mergeItemSyncResponseFromServer = mergeItemSyncResponseUsingStrategy mergeFromServerStrategy++mergeItemSyncResponseFromClient :: ClientItem a -> ItemSyncResponse a -> ClientItem a+mergeItemSyncResponseFromClient = mergeItemSyncResponseUsingStrategy mergeFromClientStrategy++mergeItemSyncResponseUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemSyncResponse a -> ClientItem a+mergeItemSyncResponseUsingCRDT = mergeItemSyncResponseUsingStrategy . mergeUsingCRDTStrategy+ -- | A strategy to merge conflicts for item synchronisation-data ItemMergeStrategy a =-  ItemMergeStrategy-    { itemMergeStrategyMergeChangeConflict :: a -> Timed a -> Timed a-      -- ^ How to merge modification conflicts-    , itemMergeStrategyMergeClientDeletedConflict :: Timed a -> Maybe (Timed a)-      -- ^ How to merge conflicts where the client deleted an item that the server modified-    , itemMergeStrategyMergeServerDeletedConflict :: a -> Maybe a-      -- ^ How to merge conflicts where the server deleted an item that the client modified-    }+data ItemMergeStrategy a+  = ItemMergeStrategy+      { -- | How to merge modification conflicts+        --+        -- The first argument is the client item and the second argument is the server item.+        itemMergeStrategyMergeChangeConflict :: a -> a -> ChangeConflictResolution a,+        -- | How to merge conflicts where the client deleted an item that the server modified+        itemMergeStrategyMergeClientDeletedConflict :: a -> ClientDeletedConflictResolution,+        -- | How to merge conflicts where the server deleted an item that the client modified+        itemMergeStrategyMergeServerDeletedConflict :: a -> ServerDeletedConflictResolution+      }   deriving (Generic) --- | Ignore any merge problems in a 'ItemMergeResult'.------ This function just returns the original 'ClientItem' if anything other than 'MergeSuccess' occurs.------ This function ignores any problems that may occur.--- In the case of a conclict, it will just not update the client item.--- The next sync request will then produce a conflict again.------ Pro: does not lose data------ __Con: Clients will diverge when a conflict occurs__-mergeIgnoringProblems :: ClientItem a -> ItemMergeResult a -> ClientItem a-mergeIgnoringProblems cs mr =-  case mr of-    MergeSuccess cs' -> cs'-    MergeConflict _ _ -> cs-    MergeConflictServerDeleted _ -> cs-    MergeConflictClientDeleted _ -> cs-    MergeMismatch -> cs+data ChangeConflictResolution a+  = KeepLocal+  | TakeRemote+  | Merged a+  deriving (Show, Eq, Generic) +data ClientDeletedConflictResolution+  = TakeRemoteChange+  | StayDeleted+  deriving (Show, Eq, Generic)++data ServerDeletedConflictResolution+  = KeepLocalChange+  | Delete+  deriving (Show, Eq, Generic)+ -- | Resolve an 'ItemMergeResult' using a given merge strategy. -- -- This function ignores 'MergeMismatch' and will just return the original 'ClientItem' in that case.@@ -398,20 +418,30 @@ -- * Idempotent -- * The same on all clients mergeUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemMergeResult a -> ClientItem a-mergeUsingStrategy ItemMergeStrategy {..} cs mr =+mergeUsingStrategy ItemMergeStrategy {..} ci mr =   case mr of-    MergeSuccess cs' -> cs'-    MergeConflict a1 a2 -> ClientItemSynced $ itemMergeStrategyMergeChangeConflict a1 a2-    MergeConflictClientDeleted sa ->-      case itemMergeStrategyMergeClientDeletedConflict sa of-        Nothing -> ClientEmpty-        Just t -> ClientItemSynced t-    MergeConflictServerDeleted ca ->-      case itemMergeStrategyMergeServerDeletedConflict ca of-        Nothing -> ClientEmpty-        Just a -> ClientAdded a-    MergeMismatch -> cs+    MergeSuccess ci' -> ci'+    MergeConflict a1 ri -> mergeChangeConflict itemMergeStrategyMergeChangeConflict ci a1 ri+    MergeConflictClientDeleted ri -> mergeClientDeletedConflict itemMergeStrategyMergeClientDeletedConflict ci ri+    MergeConflictServerDeleted ca -> mergeServerDeletedConflict itemMergeStrategyMergeServerDeletedConflict ci ca+    MergeMismatch -> ci +mergeChangeConflict :: (a -> a -> ChangeConflictResolution a) -> ClientItem a -> a -> Timed a -> ClientItem a+mergeChangeConflict func ci a1 ri@(Timed a2 st) = case func a1 a2 of+  KeepLocal -> ci+  TakeRemote -> ClientItemSynced ri+  Merged ma -> ClientItemSynced $ Timed ma st++mergeClientDeletedConflict :: (a -> ClientDeletedConflictResolution) -> ClientItem a -> Timed a -> ClientItem a+mergeClientDeletedConflict func ci ri@(Timed sa _) = case func sa of+  TakeRemoteChange -> ClientItemSynced ri+  StayDeleted -> ci -- We can't just use 'ClientEmpty' here because otherwise the 'mergeUsingStrategy' wouldn't be idempotent anymore.++mergeServerDeletedConflict :: (a -> ServerDeletedConflictResolution) -> ClientItem a -> a -> ClientItem a+mergeServerDeletedConflict func ci ca = case func ca of+  KeepLocalChange -> ci -- We can't just use 'ClientAdded ca' here because otherwise the 'mergeUsingStrategy' wouldn't be idempotent anymore.+  Delete -> ClientEmpty+ -- | Resolve an 'ItemMergeResult' by taking whatever the server gave the client. -- -- Pro: Clients will converge on the same value.@@ -419,13 +449,55 @@ -- __Con: Conflicting updates will be lost.__ mergeFromServer :: ClientItem a -> ItemMergeResult a -> ClientItem a mergeFromServer =-  mergeUsingStrategy-    ItemMergeStrategy-      { itemMergeStrategyMergeChangeConflict = \_ serverItem -> serverItem-      , itemMergeStrategyMergeClientDeletedConflict = \serverItem -> Just serverItem-      , itemMergeStrategyMergeServerDeletedConflict = \_ -> Nothing-      }+  mergeUsingStrategy mergeFromServerStrategy +-- | A merge strategy that takes whatever the server gave the client.+--+-- Pro: Clients will converge on the same value.+--+-- __Con: Conflicting updates will be lost.__+mergeFromServerStrategy :: ItemMergeStrategy a+mergeFromServerStrategy =+  ItemMergeStrategy+    { itemMergeStrategyMergeChangeConflict = \_ _ -> TakeRemote,+      itemMergeStrategyMergeClientDeletedConflict = \_ -> TakeRemoteChange,+      itemMergeStrategyMergeServerDeletedConflict = \_ -> Delete+    }++-- | Resolve an 'ItemMergeResult' by keeping whatever the client had.+--+-- Pro: does not lose data+--+-- __Con: Clients will diverge when a conflict occurs__+mergeFromClient :: ClientItem a -> ItemMergeResult a -> ClientItem a+mergeFromClient = mergeUsingStrategy mergeFromClientStrategy++-- | A merge strategy that keeps whatever the client had.+--+-- Pro: does not lose data+--+-- __Con: Clients will diverge when a conflict occurs__+mergeFromClientStrategy :: ItemMergeStrategy a+mergeFromClientStrategy =+  ItemMergeStrategy+    { itemMergeStrategyMergeChangeConflict = \_ _ -> KeepLocal,+      itemMergeStrategyMergeClientDeletedConflict = \_ -> StayDeleted,+      itemMergeStrategyMergeServerDeletedConflict = \_ -> KeepLocalChange+    }++mergeUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemMergeResult a -> ClientItem a+mergeUsingCRDT = mergeUsingStrategy . mergeUsingCRDTStrategy++-- | A merge strategy that uses a CRDT merging function to merge items.+--+-- In case of other-than-change conflicts, this will be the same as the 'mergeFromServerStrategy' strategy.+-- If this is not what you want, create your own 'ItemMergeStrategy' manually.+mergeUsingCRDTStrategy :: (a -> a -> a) -> ItemMergeStrategy a+mergeUsingCRDTStrategy merge =+  mergeFromServerStrategy+    { itemMergeStrategyMergeChangeConflict = \a1 a2 -> Merged (merge a1 a2)+    }+ -- | Serve an 'ItemSyncRequest' using the current 'ServerItem', producing an 'ItemSyncResponse' and a new 'ServerItem'. processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a) processServerItemSync store sr =@@ -436,79 +508,83 @@             ItemSyncRequestPoll -> (ItemSyncResponseInSyncEmpty, store)             ItemSyncRequestNew ci ->               (ItemSyncResponseClientAdded t, ServerFull $ Timed {timedValue = ci, timedTime = t})-            ItemSyncRequestKnown _-             -- This indicates that the server synced with another client and was told to-             -- delete its item.-             ---             -- Given that the client indicates that it did not change anything locally,-             -- the server will just instruct the client to delete its item too.-             -- No conflict here.-             -> (ItemSyncResponseServerDeleted, store)-            ItemSyncRequestKnownButChanged _-             -- This indicates that the server synced with another client and was told to-             -- delete its item.-             ---             -- Given that the client indicates that it *did* change its item locally,-             -- there is a conflict.-             -> (ItemSyncResponseConflictServerDeleted, store)-            ItemSyncRequestDeletedLocally _-             -- This means that the server synced with another client,-             -- was instructed to delete its item by that client,-             -- and is now being told to delete its item again.-             ---             -- That's fine, it will just remain deleted.-             -- No conflict here-             -> (ItemSyncResponseClientDeleted, store)+            ItemSyncRequestKnown _ ->+              -- This indicates that the server synced with another client and was told to+              -- delete its item.+              --+              -- Given that the client indicates that it did not change anything locally,+              -- the server will just instruct the client to delete its item too.+              -- No conflict here.+              (ItemSyncResponseServerDeleted, store)+            ItemSyncRequestKnownButChanged _ ->+              -- This indicates that the server synced with another client and was told to+              -- delete its item.+              --+              -- Given that the client indicates that it *did* change its item locally,+              -- there is a conflict.+              (ItemSyncResponseConflictServerDeleted, store)+            ItemSyncRequestDeletedLocally _ ->+              -- This means that the server synced with another client,+              -- was instructed to delete its item by that client,+              -- and is now being told to delete its item again.+              --+              -- That's fine, it will just remain deleted.+              -- No conflict here+              (ItemSyncResponseClientDeleted, store)     ServerFull t@(Timed si st) ->       let st' = incrementServerTime st        in case sr of-            ItemSyncRequestPoll+            ItemSyncRequestPoll ->               -- The client is empty but the server is not.               -- This means that the server has synced with another client before,               -- so we can just send the item to the client.-             -> (ItemSyncResponseServerAdded (Timed {timedValue = si, timedTime = st}), store)-            ItemSyncRequestNew _+              (ItemSyncResponseServerAdded (Timed {timedValue = si, timedTime = st}), store)+            ItemSyncRequestNew _ ->               -- The client has a newly added item, so it thought it was empty before that,               -- but the server has already synced with another client before.               -- This indicates a conflict.               -- The server is always right, so the item at the server will remain unmodified.               -- The client will receive the conflict.-             -> (ItemSyncResponseConflict t, store)+              (ItemSyncResponseConflict t, store)             ItemSyncRequestKnown ct ->               if ct >= st-                -- The client time is equal to the server time.+                then-- The client time is equal to the server time.                 -- The client indicates that the item was not modified at their side.                 -- This means that the items are in sync.                 -- (Unless the server somehow modified the item but not its server time,                 -- which would beconsidered a bug.)-                then (ItemSyncResponseInSyncFull, store)-                -- The client time is less than the server time+                  (ItemSyncResponseInSyncFull, store)+                else-- The client time is less than the server time                 -- That means that the server has synced with another client in the meantime.                 -- Since the client indicates that the item was not modified at their side,                 -- we can just send it back to the client to have them update their version.                 -- No conflict here.-                else ( ItemSyncResponseServerChanged (Timed {timedValue = si, timedTime = st})-                     , store)++                  ( ItemSyncResponseServerChanged (Timed {timedValue = si, timedTime = st}),+                    store+                  )             ItemSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} ->               if ct >= st-                -- The client time is equal to the server time.+                then-- The client time is equal to the server time.                 -- The client indicates that the item *was* modified at their side.                 -- This means that the server needs to be updated.-                then ( ItemSyncResponseClientChanged st'-                     , ServerFull (Timed {timedValue = ci, timedTime = st'}))-                -- The client time is less than the server time++                  ( ItemSyncResponseClientChanged st',+                    ServerFull (Timed {timedValue = ci, timedTime = st'})+                  )+                else-- The client time is less than the server time                 -- That means that the server has synced with another client in the meantime.                 -- Since the client indicates that the item *was* modified at their side,                 -- there is a conflict.-                else (ItemSyncResponseConflict t, store)+                  (ItemSyncResponseConflict t, store)             ItemSyncRequestDeletedLocally ct ->               if ct >= st-                -- The client time is equal to the server time.+                then-- The client time is equal to the server time.                 -- The client indicates that the item was deleted on their side.                 -- This means that the server item needs to be deleted as well.-                then (ItemSyncResponseClientDeleted, ServerEmpty)-                -- The client time is less than the server time+                  (ItemSyncResponseClientDeleted, ServerEmpty)+                else-- The client time is less than the server time                 -- That means that the server has synced with another client in the meantime.                 -- Since the client indicates that the item was deleted at their side,                 -- there is a conflict.-                else (ItemSyncResponseConflictClientDeleted t, store)+                  (ItemSyncResponseConflictClientDeleted t, store)

@@ -1,23 +1,24 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  -- | Dealing with server times. -- -- __If you are importing this module, you are probably doing something wrong.__ module Data.Mergeful.Timed-  ( ServerTime-  , initialServerTime-  , incrementServerTime-  , Timed(..)-  ) where--import GHC.Generics (Generic)+  ( ServerTime (..),+    initialServerTime,+    incrementServerTime,+    Timed (..),+  )+where +import Control.DeepSeq import Data.Aeson as JSON import Data.Validity import Data.Word+import GHC.Generics (Generic)  -- | A "time", as "measured" by the server. --@@ -25,31 +26,41 @@ -- distinction should not matter for your usage of this library. -- -- In any case, a client should not be changing this value.-newtype ServerTime =-  ServerTime-    { unServerTime :: Word64-    }+--+-- We use a 'Word64' instead of a natural.+-- This will go wrong after 2^64 versions, but since that+-- will not happen in practice, we will not worry about it.+-- You would have to sync millions of modifications every second+-- until long after the sun consumes the earth for this to be a problem.+newtype ServerTime+  = ServerTime+      { unServerTime :: Word64+      }   deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)  instance Validity ServerTime +instance NFData ServerTime+ -- | A server time to start with. initialServerTime :: ServerTime initialServerTime = ServerTime 0 --- | Increment a server time, this will only start repeating after at least @2^64 - 1@ values, so you're probably fine.+-- | Increment a server time. incrementServerTime :: ServerTime -> ServerTime incrementServerTime (ServerTime w) = ServerTime (succ w)  -- | A value along with a server time.-data Timed a =-  Timed-    { timedValue :: !a-    , timedTime :: !ServerTime-    }+data Timed a+  = Timed+      { timedValue :: !a,+        timedTime :: !ServerTime+      }   deriving (Show, Eq, Generic)  instance Validity a => Validity (Timed a)++instance NFData a => NFData (Timed a)  instance FromJSON a => FromJSON (Timed a) where   parseJSON = withObject "Timed" $ \o -> Timed <$> o .: "value" <*> o .: "time"

@@ -38,31 +38,33 @@ -- This whole approach can break down if a server resets its server times -- or if a client syncs with two different servers using the same server times. module Data.Mergeful.Value-  ( initialClientValue-  , makeValueSyncRequest-  , mergeValueSyncResponseRaw-  , ValueMergeResult(..)-  , mergeValueSyncResponseIgnoreProblems-  , mergeIgnoringProblems-  , mergeFromServer-  , mergeUsingFunction+  ( initialClientValue,+    makeValueSyncRequest,+    mergeValueSyncResponseRaw,+    ValueMergeResult (..),+    mergeValueSyncResponseIgnoreProblems,+    mergeIgnoringProblems,+    mergeFromServer,+    mergeUsingFunction,+     -- * Server side-  , initialServerValue-  , processServerValueSync-    -- * Types, for reference-  , ChangedFlag(..)-  , ClientValue(..)-  , ValueSyncRequest(..)-  , ValueSyncResponse(..)-  , ServerValue(..)-  ) where+    initialServerValue,+    processServerValueSync, -import GHC.Generics (Generic)+    -- * Types, for reference+    ChangedFlag (..),+    ClientValue (..),+    ValueSyncRequest (..),+    ValueSyncResponse (..),+    ServerValue (..),+  )+where +import Control.DeepSeq import Data.Aeson as JSON-import Data.Validity- import Data.Mergeful.Timed+import Data.Validity+import GHC.Generics (Generic)  data ChangedFlag   = Changed@@ -71,6 +73,8 @@  instance Validity ChangedFlag +instance NFData ChangedFlag+ -- | The client side value. -- -- The only differences between `a` and 'ClientValue a' are that@@ -78,31 +82,36 @@ -- the server, and whether the item has been modified at the client -- -- There cannot be an unsynced 'ClientValue'.-data ClientValue a =-  ClientValue !(Timed a) !ChangedFlag+data ClientValue a+  = ClientValue !(Timed a) !ChangedFlag   deriving (Show, Eq, Generic)  instance Validity a => Validity (ClientValue a) +instance NFData a => NFData (ClientValue a)+ instance FromJSON a => FromJSON (ClientValue a) where   parseJSON =     withObject "ClientValue" $ \o ->-      ClientValue <$> (Timed <$> o .: "value" <*> o .: "time") <*>-      ((\b ->-          if b-            then Changed-            else NotChanged) <$>-       o .: "changed")+      ClientValue <$> (Timed <$> o .: "value" <*> o .: "time")+        <*> ( ( \b ->+                  if b+                    then Changed+                    else NotChanged+              )+                <$> o .: "changed"+            )  instance ToJSON a => ToJSON (ClientValue a) where   toJSON (ClientValue Timed {..} cf) =     object-      [ "value" .= timedValue-      , "time" .= timedTime-      , "changed" .=-        (case cf of-           Changed -> True-           NotChanged -> False)+      [ "value" .= timedValue,+        "time" .= timedTime,+        "changed"+          .= ( case cf of+                 Changed -> True+                 NotChanged -> False+             )       ]  -- | Produce a client value based on an initial synchronisation request@@ -113,12 +122,14 @@ -- -- The only difference between 'a' and 'ServerValue a' is that 'ServerValue a' also -- remembers the last time this value was changed during synchronisation.-newtype ServerValue a =-  ServerValue (Timed a)+newtype ServerValue a+  = ServerValue (Timed a)   deriving (Show, Eq, Generic)  instance Validity a => Validity (ServerValue a) +instance NFData a => NFData (ServerValue a)+ instance FromJSON a => FromJSON (ServerValue a) where   parseJSON =     withObject "ServerValue" $ \o -> ServerValue <$> (Timed <$> o .: "value" <*> o .: "time")@@ -133,15 +144,17 @@ initialServerValue a = ServerValue $ Timed {timedValue = a, timedTime = initialServerTime}  data ValueSyncRequest a-  -- | There is an item locally that was synced at the given 'ServerTime'-  = ValueSyncRequestKnown !ServerTime-  -- | There is an item locally that was synced at the given 'ServerTime'-  -- but it has been changed since then.-  | ValueSyncRequestKnownButChanged !(Timed a)+  = -- | There is an item locally that was synced at the given 'ServerTime'+    ValueSyncRequestKnown !ServerTime+  | -- | There is an item locally that was synced at the given 'ServerTime'+    -- but it has been changed since then.+    ValueSyncRequestKnownButChanged !(Timed a)   deriving (Show, Eq, Generic)  instance Validity a => Validity (ValueSyncRequest a) +instance NFData a => NFData (ValueSyncRequest a)+ instance FromJSON a => FromJSON (ValueSyncRequest a) where   parseJSON =     withObject "ValueSyncRequest" $ \o -> do@@ -154,35 +167,33 @@ instance ToJSON a => ToJSON (ValueSyncRequest a) where   toJSON ci =     object $-    let o n rest = ("type" .= (n :: String)) : rest-     in case ci of-          ValueSyncRequestKnown t -> o "synced" ["time" .= t]-          ValueSyncRequestKnownButChanged Timed {..} ->-            o "changed" ["value" .= timedValue, "time" .= timedTime]+      let o n rest = ("type" .= (n :: String)) : rest+       in case ci of+            ValueSyncRequestKnown t -> o "synced" ["time" .= t]+            ValueSyncRequestKnownButChanged Timed {..} ->+              o "changed" ["value" .= timedValue, "time" .= timedTime]  data ValueSyncResponse a-  -- | The client and server are fully in sync.-  ---  -- Nothing needs to be done at the client side.-  = ValueSyncResponseInSync-  -- | The client changed the value and server has succesfully been made aware of that.-  ---  -- The client needs to update its server time-  | ValueSyncResponseClientChanged !ServerTime-  -- | This value has been changed on the server side.-  ---  -- The client should change it too.-  | ValueSyncResponseServerChanged !(Timed a)-  -- | A conflict occurred.-  ---  -- The server and the client both changed the value in a conflicting manner.-  -- The server kept its part, the client can either take whatever the server gave them-  -- or deal with the conflict somehow, and then try to re-sync.-  | ValueSyncResponseConflict !(Timed a) -- ^ The item at the server side+  = -- | The client and server are fully in sync.+    --+    -- Nothing needs to be done at the client side.+    ValueSyncResponseInSync+  | -- | The client changed the value and server has succesfully been made aware of that.+    --+    -- The client needs to update its server time+    ValueSyncResponseClientChanged !ServerTime+  | -- | This value has been changed on the server side.+    --+    -- The client should change it too.+    ValueSyncResponseServerChanged !(Timed a)+  | -- | The item at the server side+    ValueSyncResponseConflict !(Timed a)   deriving (Show, Eq, Generic)  instance Validity a => Validity (ValueSyncResponse a) +instance NFData a => NFData (ValueSyncResponse a)+ instance FromJSON a => FromJSON (ValueSyncResponse a) where   parseJSON =     withObject "ValueSyncResponse" $ \o -> do@@ -198,14 +209,14 @@ instance ToJSON a => ToJSON (ValueSyncResponse a) where   toJSON isr =     object $-    let o s rest = ("type" .= (s :: String)) : rest-        oe s = o s []-     in case isr of-          ValueSyncResponseInSync -> oe "in-sync"-          ValueSyncResponseClientChanged t -> o "client-changed" ["time" .= t]-          ValueSyncResponseServerChanged Timed {..} ->-            o "server-changed" ["value" .= timedValue, "time" .= timedTime]-          ValueSyncResponseConflict a -> o "conflict" ["value" .= a]+      let o s rest = ("type" .= (s :: String)) : rest+          oe s = o s []+       in case isr of+            ValueSyncResponseInSync -> oe "in-sync"+            ValueSyncResponseClientChanged t -> o "client-changed" ["time" .= t]+            ValueSyncResponseServerChanged Timed {..} ->+              o "server-changed" ["value" .= timedValue, "time" .= timedTime]+            ValueSyncResponseConflict a -> o "conflict" ["value" .= a]  -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. --@@ -217,18 +228,20 @@     Changed -> ValueSyncRequestKnownButChanged t  data ValueMergeResult a-  -- | The merger went succesfully, no conflicts or desyncs-  = MergeSuccess !(ClientValue a)-  -- | There was a merge conflict. The server and client had different, conflicting versions.-  | MergeConflict !a !(Timed a) -- ^ The item at the server side-  | MergeMismatch-  -- ^ The server responded with a response that did not make sense given the client's request.-  ---  -- This should not happen in practice.+  = -- | The merger went succesfully, no conflicts or desyncs+    MergeSuccess !(ClientValue a)+  | -- | The item at the server side+    MergeConflict !a !(Timed a)+  | -- | The server responded with a response that did not make sense given the client's request.+    --+    -- This should not happen in practice.+    MergeMismatch   deriving (Show, Eq, Generic)  instance Validity a => Validity (ValueMergeResult a) +instance NFData a => NFData (ValueMergeResult a)+ -- | Merge an 'ValueSyncResponse' into the current 'ClientValue'. -- -- This function will not make any decisions about what to do with@@ -287,7 +300,7 @@ -- * Idempotent -- * The same on all clients mergeUsingFunction ::-     (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a+  (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a mergeUsingFunction func cs mr =   case mr of     MergeSuccess cs' -> cs'@@ -304,33 +317,35 @@  -- | Serve an 'ValueSyncRequest' using the current 'ServerValue', producing an 'ValueSyncResponse' and a new 'ServerValue'. processServerValueSync ::-     ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a)+  ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a) processServerValueSync sv@(ServerValue t@(Timed _ st)) sr =   case sr of     ValueSyncRequestKnown ct ->       if ct >= st-                -- The client time is equal to the server time.-                -- The client indicates that the item was not modified at their side.-                -- This means that the items are in sync.-                -- (Unless the server somehow modified the item but not its server time,-                -- which would beconsidered a bug.)-        then (ValueSyncResponseInSync, sv)-                -- The client time is less than the server time-                -- That means that the server has synced with another client in the meantime.-                -- Since the client indicates that the item was not modified at their side,-                -- we can just send it back to the client to have them update their version.-                -- No conflict here.-        else (ValueSyncResponseServerChanged t, sv)+        then-- The client time is equal to the server time.+        -- The client indicates that the item was not modified at their side.+        -- This means that the items are in sync.+        -- (Unless the server somehow modified the item but not its server time,+        -- which would beconsidered a bug.)+          (ValueSyncResponseInSync, sv)+        else-- The client time is less than the server time+        -- That means that the server has synced with another client in the meantime.+        -- Since the client indicates that the item was not modified at their side,+        -- we can just send it back to the client to have them update their version.+        -- No conflict here.+          (ValueSyncResponseServerChanged t, sv)     ValueSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} ->       if ct >= st-                -- The client time is equal to the server time.-                -- The client indicates that the item *was* modified at their side.-                -- This means that the server needs to be updated.-        then let st' = incrementServerTime st-              in ( ValueSyncResponseClientChanged st'-                 , ServerValue (Timed {timedValue = ci, timedTime = st'}))-                -- The client time is less than the server time-                -- That means that the server has synced with another client in the meantime.-                -- Since the client indicates that the item *was* modified at their side,-                -- there is a conflict.-        else (ValueSyncResponseConflict t, sv)+        then-- The client time is equal to the server time.+        -- The client indicates that the item *was* modified at their side.+        -- This means that the server needs to be updated.++          let st' = incrementServerTime st+           in ( ValueSyncResponseClientChanged st',+                ServerValue (Timed {timedValue = ci, timedTime = st'})+              )+        else-- The client time is less than the server time+        -- That means that the server has synced with another client in the meantime.+        -- Since the client indicates that the item *was* modified at their side,+        -- there is a conflict.+          (ValueSyncResponseConflict t, sv)