mergeless 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+599/−505 lines, 5 filesdep +deepseqdep −timedep −validity-timePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependencies removed: time, validity-time

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• mergeless.cabal +9/−7
• src/Data/Mergeless.hs +3/−498
• src/Data/Mergeless/Collection.hs +435/−0
• src/Data/Mergeless/Item.hs +148/−0

@@ -1,3 +1,7 @@ # Changelog for mergeless  ## Unreleased changes++## [0.2.0.0] - 2020-02-12++* Got rid of the UTCTimes. The client should take care of that.

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 749159cfb0e485429b445319f97126579e191fed759cadc0903f884e813159a7+-- hash: 7b7549a7b1a7d5ca5767941adb11f773af2e6727a37c8fdceb9367c0147b4d91  name:           mergeless-version:        0.1.0.0+version:        0.2.0.0 description:    Please see the README on GitHub at <https://github.com/NorfairKing/mergeless#readme> homepage:       https://github.com/NorfairKing/mergeless#readme bug-reports:    https://github.com/NorfairKing/mergeless/issues@@ -14,10 +16,9 @@ copyright:      Copyright: (c) 2018 Tom Sydney Kerckhove license:        MIT build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:-    ChangeLog.md     README.md+    ChangeLog.md  source-repository head   type: git@@ -26,6 +27,8 @@ library   exposed-modules:       Data.Mergeless+      Data.Mergeless.Collection+      Data.Mergeless.Item   other-modules:       Paths_mergeless   hs-source-dirs:@@ -34,9 +37,8 @@       aeson     , base >=4.7 && <5     , containers+    , deepseq     , mtl-    , time     , validity     , validity-containers-    , validity-time   default-language: Haskell2010

@@ -1,500 +1,5 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | A way to synchronise items without merge conflicts.------ This concept has a few requirements:------ * Items must be immutable.--- * Items must allow for a centrally unique identifier.--- * Identifiers for items must be generatable in such a way that they are certainly unique.------ Should mutation be a requirement, then it can be build such that it entails deleting the old version and creating a new version that is the modification of the old version.--------- There are a few obvious candidates for identifiers:------ * incremental identifiers--- * universally unique identifiers (recommended).------------ The typical 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 central server should operate as follows:------ * The server accepts a 'SyncRequest'.--- * The server performs operations according to the functionality of 'processSync'.--- * The server respons with a 'SyncResponse'.--------- A client should operate as follows:------ * 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 'mergeSyncResponse'. module Data.Mergeless-    ( Added(..)-    , Synced(..)-    , StoreItem(..)-    , Store(..)-    , emptyStore-    , storeSize-    , addItemToStore-    , deleteUnsynced-    , deleteSynced-    , SyncRequest(..)-    , SyncResponse(..)-    -- * Client-side Synchronisation-    , makeSyncRequest-    , mergeSyncResponse-    -- * Server-side Synchronisation-    -- ** General synchronisation-    , SyncProcessor(..)-    , processSyncCustom-    -- ** Synchronisation with a simple central store-    , CentralStore(..)-    , CentralItem(..)-    , processSyncWith-    , processSync-    ) where--import Control.Applicative-import Control.Monad.IO.Class-import Control.Monad.State.Strict-import Data.Aeson-import Data.List-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Set as S-import Data.Set (Set)-import Data.Time-import Data.Validity-import Data.Validity.Containers ()-import Data.Validity.Time ()-import GHC.Generics (Generic)--{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}---- | A local item of type @a@ that has been added but not synchronised yet-data Added a = Added-    { addedValue :: !a-    , addedCreated :: !UTCTime-    } deriving (Show, Eq, Ord, Generic)--instance Validity a => Validity (Added a)--instance FromJSON a => FromJSON (Added a) where-    parseJSON =-        withObject "Added" $ \o -> Added <$> o .: "value" <*> o .: "added"--instance ToJSON a => ToJSON (Added a) where-    toJSON Added {..} = object ["value" .= addedValue, "added" .= addedCreated]---- | A local item of type @a@ with an identifier of type @a@ that has been synchronised-data Synced i a = Synced-    { syncedUuid :: i-    , syncedValue :: !a-    , syncedCreated :: !UTCTime-    , syncedSynced :: !UTCTime-    } deriving (Show, Eq, Ord, Generic)--instance (Validity i, Validity a) => Validity (Synced i a)--instance (FromJSON i, FromJSON a) => FromJSON (Synced i a) where-    parseJSON =-        withObject "Synced" $ \o ->-            Synced <$> o .: "id" <*> o .: "value" <*> o .: "created" <*>-            o .: "synced"--instance (ToJSON i, ToJSON a) => ToJSON (Synced i a) where-    toJSON Synced {..} =-        object-            [ "id" .= syncedUuid-            , "value" .= syncedValue-            , "created" .= syncedCreated-            , "synced" .= syncedSynced-            ]---- | A store item with an Id of type @i@ and a value of type @a@-data StoreItem i a-    = UnsyncedItem !(Added a) -- ^ A local item that has not been synchronised to the central store yet-    | SyncedItem !(Synced i a) -- ^ A local item that has been synchronised to the central store already-    | UndeletedItem !i -- ^ An item that has been synchronised to the central store, was subsequently deleted locally but this deletion has not been synchronised to the central store yet.-    deriving (Show, Eq, Ord, Generic)--instance (Validity i, Validity a) => Validity (StoreItem i a)--instance (FromJSON i, FromJSON a) => FromJSON (StoreItem i a) where-    parseJSON v =-        (SyncedItem <$> parseJSON v) <|> (UnsyncedItem <$> parseJSON v) <|>-        (UndeletedItem <$> parseJSON v)--instance (ToJSON i, ToJSON a) => ToJSON (StoreItem i a) where-    toJSON (UnsyncedItem a) = toJSON a-    toJSON (SyncedItem a) = toJSON a-    toJSON (UndeletedItem a) = toJSON a---- | A client-side store of items with Id's of type @i@ and values of type @a@-newtype Store i a = Store-    { storeItems :: Set (StoreItem i a)-    } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)--instance (Validity i, Validity a, Ord i, Ord a) => Validity (Store i a) where-    validate Store {..} =-        mconcat-            [ annotate storeItems "storeItems"-            , declare "the store items have distinct uuids" $-              distinct $-              flip mapMaybe (S.toList storeItems) $ \case-                  UnsyncedItem _ -> Nothing-                  SyncedItem Synced {..} -> Just syncedUuid-                  UndeletedItem u -> Just u-            ]---- | The store with no items.-emptyStore :: Store i a-emptyStore = Store S.empty---- | The number of items in a store-storeSize :: Store i a -> Int-storeSize (Store s) =-    S.size $-    S.filter-        (\si ->-             case si of-                 UndeletedItem _ -> False-                 _ -> True)-        s---- | Add a new (unsynced) item to the store-addItemToStore :: (Ord i, Ord a) => Added a -> Store i a -> Store i a-addItemToStore a (Store s) = Store $ S.insert (UnsyncedItem a) s--deleteUnsynced :: (Ord i, Ord a) => Added a -> Store i a -> Store i a-deleteUnsynced a (Store s) =-    Store $-    flip mapSetMaybe s $ \si ->-        case si of-            UnsyncedItem i ->-                if i == a-                    then Nothing-                    else Just si-            SyncedItem _ -> Just si-            UndeletedItem _ -> Just si--deleteSynced :: (Ord i, Ord a) => Synced i a -> Store i a -> Store i a-deleteSynced a (Store s) =-    Store $-    flip mapSetMaybe s $ \si ->-        case si of-            UnsyncedItem _ -> Just si-            SyncedItem i ->-                if i == a-                    then Just $ UndeletedItem $ syncedUuid i-                    else Just si-            UndeletedItem _ -> Just si---- | A synchronisation request for items with identifiers of type @i@ and values of type @a@-data SyncRequest i a = SyncRequest-    { syncRequestAddedItems :: !(Set (Added a))-    , syncRequestSyncedItems :: !(Set i)-    , syncRequestUndeletedItems :: !(Set i)-    } deriving (Show, Eq, Ord, Generic)--instance (Validity i, Validity a, Ord i, Ord a) =>-         Validity (SyncRequest i a) where-    validate SyncRequest {..} =-        mconcat-            [ annotate syncRequestAddedItems "syncRequestAddedItems"-            , annotate syncRequestSyncedItems "syncRequestSyncedItems"-            , annotate syncRequestUndeletedItems "syncRequestUndeletedItems"-            , declare "the sync request items have distinct ids" $-              distinct $-              S.toList syncRequestSyncedItems ++-              S.toList syncRequestUndeletedItems-            ]--instance (FromJSON i, FromJSON a, Ord i, Ord a) =>-         FromJSON (SyncRequest i a) where-    parseJSON =-        withObject "SyncRequest" $ \o ->-            SyncRequest <$> o .: "unsynced" <*> o .: "synced" <*>-            o .: "undeleted"--instance (ToJSON i, ToJSON a) => ToJSON (SyncRequest i a) where-    toJSON SyncRequest {..} =-        object-            [ "unsynced" .= syncRequestAddedItems-            , "synced" .= syncRequestSyncedItems-            , "undeleted" .= syncRequestUndeletedItems-            ]---- | A synchronisation response for items with identifiers of type @i@ and values of type @a@-data SyncResponse i a = SyncResponse-    { syncResponseAddedItems :: !(Set (Synced i a))-    , syncResponseNewRemoteItems :: !(Set (Synced i a))-    , syncResponseItemsToBeDeletedLocally :: !(Set i)-    } deriving (Show, Eq, Ord, Generic)--instance (Validity i, Validity a, Ord i, Ord a) =>-         Validity (SyncResponse i a) where-    validate SyncResponse {..} =-        mconcat-            [ annotate syncResponseAddedItems "syncResponseAddedItems"-            , annotate syncResponseNewRemoteItems "syncResponseNewRemoteItems"-            , annotate-                  syncResponseItemsToBeDeletedLocally-                  "syncResponseItemsToBeDeletedLocally"-            , declare "the sync response items have distinct uuids" $-              distinct $-              map-                  syncedUuid-                  (S.toList syncResponseAddedItems ++-                   S.toList syncResponseNewRemoteItems) ++-              S.toList syncResponseItemsToBeDeletedLocally-            ]--instance (FromJSON i, FromJSON a, Ord i, Ord a) =>-         FromJSON (SyncResponse i a) where-    parseJSON =-        withObject "SyncResponse" $ \o ->-            SyncResponse <$> o .: "added" <*> o .: "new" <*> o .: "deleted"--instance (ToJSON i, ToJSON a) => ToJSON (SyncResponse i a) where-    toJSON SyncResponse {..} =-        object-            [ "added" .= syncResponseAddedItems-            , "new" .= syncResponseNewRemoteItems-            , "deleted" .= syncResponseItemsToBeDeletedLocally-            ]---- | Produce a synchronisation request for a client-side store.------ This request can then be sent to a central store for synchronisation.-makeSyncRequest :: (Ord i, Ord a) => Store i a -> SyncRequest i a-makeSyncRequest Store {..} =-    SyncRequest-        { syncRequestAddedItems =-              flip mapSetMaybe storeItems $ \case-                  UnsyncedItem a -> Just a-                  _ -> Nothing-        , syncRequestSyncedItems =-              flip mapSetMaybe storeItems $ \case-                  SyncedItem i -> Just $ syncedUuid i-                  _ -> Nothing-        , syncRequestUndeletedItems =-              flip mapSetMaybe storeItems $ \case-                  UndeletedItem uuid -> Just uuid-                  _ -> Nothing-        }---- | Merge a synchronisation response back into a client-side store.-mergeSyncResponse ::-       (Ord i, Ord a) => Store i a -> SyncResponse i a -> Store i a-mergeSyncResponse s SyncResponse {..} =-    let withNewOwnItems =-            flip mapSetMaybe (storeItems s) $ \si ->-                case si of-                    UnsyncedItem Added {..} ->-                        case find-                                 (\Synced {..} ->-                                      syncedCreated == addedCreated &&-                                      syncedValue == addedValue)-                                 syncResponseAddedItems of-                            Nothing -> Just si -- If it wasn't added (for whatever reason), just leave it as unsynced-                            Just ii -> Just $ SyncedItem ii -- If it was added, then it becomes synced-                    SyncedItem ii ->-                        case find-                                 (== syncedUuid ii)-                                 syncResponseItemsToBeDeletedLocally of-                            Nothing -> Just si -- If it wasn't deleted, don't delete it.-                            Just _ -> Nothing -- If it was deleted, delete it here.-                    UndeletedItem _ -> Nothing -- Delete all locally deleted items after sync-     in Store-            { storeItems =-                  S.fromList .-                  nubBy-                      (\i1 i2 ->-                           case (i1, i2) of-                               (UnsyncedItem _, _) -> False-                               (_, UnsyncedItem _) -> False-                               (SyncedItem s1, SyncedItem s2) ->-                                   syncedUuid s1 == syncedUuid s2-                               (SyncedItem s1, UndeletedItem u2) ->-                                   syncedUuid s1 == u2-                               (UndeletedItem u1, SyncedItem s2) ->-                                   u1 == syncedUuid s2-                               (UndeletedItem u1, UndeletedItem u2) -> u1 == u2) .-                  S.toList $-                  S.map SyncedItem syncResponseNewRemoteItems `S.union`-                  withNewOwnItems-            }---- | A record of the basic operations that are necessary to build a synchronisation processor.-data SyncProcessor i a m = SyncProcessor-    { syncProcessorDeleteMany :: Set i -> m () -- ^ Delete the items with an identifier in the given set.-    , syncProcessorQuerySynced :: Set i -> m (Set i) -- ^ Query the identifiers of the items that are in store, of the given set.-    , syncProcessorQueryNewRemote :: Set i -> m (Set (Synced i a)) -- ^ Query the items that are in store, but not in the given set.-    , syncProcessorInsertMany :: Set (Synced i a) -> m () -- ^ Insert a set of items into the stor.-    } deriving (Generic)---- | Process a server-side synchronisation request using a custom synchronisation processor------ WARNING: The identifier generation function must produce newly unique identifiers such that each new item gets a unique identifier.------ You can use this function with deterministically-random identifiers or incrementing identifiers.-processSyncCustom ::-       forall i a m. (Ord i, Ord a, Monad m)-    => m i-    -> UTCTime-    -> SyncProcessor i a m-    -> SyncRequest i a-    -> m (SyncResponse i a)-processSyncCustom genUuid now SyncProcessor {..} SyncRequest {..} = do-    deleteUndeleted-        -- First we delete the items that were deleted locally but not yet remotely.-        -- Then we find the items that have been deleted remotely but not locally-    deletedRemotely <- syncItemsToBeDeletedLocally-        -- Then we find the items that have appeared remotely but aren't known locally-    newRemoteItems <- syncNewRemoteItems-        -- Then we add the items that should be added.-    newLocalItems <- syncAddedItems-    pure-        SyncResponse-            { syncResponseNewRemoteItems = newRemoteItems-            , syncResponseAddedItems = newLocalItems-            , syncResponseItemsToBeDeletedLocally = deletedRemotely-            }-  where-    deleteUndeleted :: m ()-    deleteUndeleted = syncProcessorDeleteMany syncRequestUndeletedItems-    syncItemsToBeDeletedLocally :: m (Set i)-    syncItemsToBeDeletedLocally = do-        foundItems <- syncProcessorQuerySynced syncRequestSyncedItems-        pure $ syncRequestSyncedItems `S.difference` foundItems-    syncNewRemoteItems :: m (Set (Synced i a))-    syncNewRemoteItems = syncProcessorQueryNewRemote syncRequestSyncedItems-    syncAddedItems :: m (Set (Synced i a))-    syncAddedItems = do-        is <--            fmap S.fromList $-            forM (S.toList syncRequestAddedItems) $ \Added {..} -> do-                uuid <- genUuid-                pure-                    Synced-                        { syncedUuid = uuid-                        , syncedCreated = addedCreated-                        , syncedSynced = now-                        , syncedValue = addedValue-                        }-        syncProcessorInsertMany is-        pure is---- | An item in a central store with a value of type @a@-data CentralItem a = CentralItem-    { centralValue :: !a-    , centralSynced :: !UTCTime-    , centralCreated :: !UTCTime-    } deriving (Show, Eq, Ord, Generic)--instance Validity a => Validity (CentralItem a)--instance FromJSON a => FromJSON (CentralItem a)--instance ToJSON a => ToJSON (CentralItem a)---- | A central store of items with identifiers of type @i@ and values of type @a@-newtype CentralStore i a = CentralStore-    { centralStoreItems :: Map i (CentralItem a)-    } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)--instance (Validity i, Validity a, Ord i, Ord a) =>-         Validity (CentralStore i a)---- | Process a server-side synchronisation request using @getCurrentTime@------ see 'processSyncCustom'-processSync ::-       (Ord i, Ord a, MonadIO m)-    => m i-    -> CentralStore i a-    -> SyncRequest i a-    -> m (SyncResponse i a, CentralStore i a)-processSync genId cs sr = do-    now <- liftIO getCurrentTime-    processSyncWith genId now cs sr---- | Process a server-side synchronisation request using a time of syncing, and an identifier generation function.------ see 'processSyncCustom'-processSyncWith ::-       forall i a m. (Ord i, Ord a, Monad m)-    => m i-    -> UTCTime-    -> CentralStore i a-    -> SyncRequest i a-    -> m (SyncResponse i a, CentralStore i a)-processSyncWith genUuid now cs sr =-    flip runStateT cs $-    processSyncCustom-        (lift genUuid)-        now-        SyncProcessor-            { syncProcessorDeleteMany = deleteMany-            , syncProcessorQuerySynced = querySynced-            , syncProcessorQueryNewRemote = queryNewRemote-            , syncProcessorInsertMany = insertMany-            }-        sr-  where-    deleteMany :: Set i -> StateT (CentralStore i a) m ()-    deleteMany s = modC (`M.withoutKeys` s)-    querySynced :: Set i -> StateT (CentralStore i a) m (Set i)-    querySynced s = M.keysSet <$> query (`M.restrictKeys` s)-    queryNewRemote :: Set i -> StateT (CentralStore i a) m (Set (Synced i a))-    queryNewRemote s = do-        m <- query (`M.withoutKeys` s)-        pure $-            S.fromList $-            flip map (M.toList m) $ \(i, CentralItem {..}) ->-                Synced-                    { syncedUuid = i-                    , syncedCreated = centralCreated-                    , syncedSynced = centralSynced-                    , syncedValue = centralValue-                    }-    query :: (Map i (CentralItem a) -> b) -> StateT (CentralStore i a) m b-    query func = gets $ func . centralStoreItems-    insertMany :: Set (Synced i a) -> StateT (CentralStore i a) m ()-    insertMany s =-        forM_ (S.toList s) $ \Synced {..} ->-            ins-                syncedUuid-                CentralItem-                    { centralValue = syncedValue-                    , centralCreated = syncedCreated-                    , centralSynced = syncedSynced-                    }-    ins :: i -> CentralItem a -> StateT (CentralStore i a) m ()-    ins i val = modC $ M.insert i val-    modC ::-           (Map i (CentralItem a) -> Map i (CentralItem a))-        -> StateT (CentralStore i a) m ()-    modC func = modify (\(CentralStore m) -> CentralStore $ func m)--mapSetMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b-mapSetMaybe func = S.map fromJust . S.filter isJust . S.map func+  ( module Data.Mergeless.Collection+  ) where -distinct :: Ord a => [a] -> Bool-distinct ls = sort ls == S.toAscList (S.fromList ls)+import Data.Mergeless.Collection

@@ -0,0 +1,435 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A way to synchronise items without merge conflicts.+--+-- This concept has a few requirements:+--+-- * Items must be immutable.+-- * Items must allow for a centrally unique identifier.+-- * Identifiers for items must be generatable in such a way that they are certainly unique.+--+-- Should mutation be a requirement, then it can be build such that it entails deleting the old version and creating a new version that is the modification of the old version.+--+--+-- There are a few obvious candidates for identifiers:+--+-- * incremental identifiers+-- * universally unique identifiers (recommended).+--+--+--+-- The typical 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 central server should operate as follows:+--+-- * The server accepts a 'SyncRequest'.+-- * The server performs operations according to the functionality of 'processServerSync'.+-- * The server respons with a 'SyncResponse'.+--+--+-- A client should operate as follows:+--+-- * 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 'mergeSyncResponse'.+module Data.Mergeless.Collection+  ( ClientId(..)+  , ClientStore(..)+  , emptyClientStore+  , storeSize+  , addItemToClientStore+  , deleteUnsyncedFromClientStore+  , deleteSyncedFromClientStore+  , SyncRequest(..)+  , SyncResponse(..)+  , emptySyncResponse+    -- * Client-side Synchronisation+  , makeSyncRequest+  , mergeSyncResponse+  , addRemotelyAddedItems+  , addAddedItems+  , deleteItemsToBeDeletedLocally+  , deleteLocalUndeletedItems+    -- * Server-side Synchronisation+    -- ** General synchronisation+  , ServerSyncProcessor(..)+  , processServerSyncCustom+    -- ** Synchronisation with a simple central store+  , ServerStore(..)+  , emptyServerStore+  , processServerSync+  ) where++import GHC.Generics (Generic)++import Data.Validity+import Data.Validity.Containers ()++import Data.Aeson+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Set (Set)+import Data.Word++import Control.DeepSeq+import Control.Monad.State.Strict++{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}++-- | 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++-- | A client-side store of items with Id's of type @i@ and values of type @a@+data ClientStore i a =+  ClientStore+    { clientStoreAdded :: !(Map ClientId a)+    , clientStoreSynced :: !(Map i a)+    , clientStoreDeleted :: !(Set i)+    }+  deriving (Show, Eq, Ord, Generic)++instance (NFData i, NFData a) => NFData (ClientStore i a)++instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ClientStore i a) where+  validate cs@ClientStore {..} =+    mconcat+      [ genericValidate cs+      , declare "the store items have distinct ids" $+        distinct $ M.keys clientStoreSynced ++ S.toList clientStoreDeleted+      ]++instance (Ord i, FromJSON i, FromJSONKey i, FromJSON a) => FromJSON (ClientStore i a) where+  parseJSON =+    withObject "ClientStore" $ \o ->+      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty <*>+      o .:? "deleted" .!= S.empty++instance (Ord i, ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (ClientStore i a) where+  toJSON ClientStore {..} =+    object+      ["added" .= clientStoreAdded, "synced" .= clientStoreSynced, "deleted" .= clientStoreDeleted]++-- | The store with no items.+emptyClientStore :: ClientStore i a+emptyClientStore =+  ClientStore+    {clientStoreAdded = M.empty, clientStoreSynced = M.empty, clientStoreDeleted = S.empty}++-- | The number of items in a store+--+-- This does not count the deleted items, so that those really look deleted.+storeSize :: ClientStore i a -> Int+storeSize ClientStore {..} = M.size clientStoreAdded + M.size clientStoreSynced++clientStoreIds :: Ord i => ClientStore i a -> Set i+clientStoreIds ClientStore {..} = M.keysSet clientStoreSynced `S.union` clientStoreDeleted++-- | 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 :: (Ord i, Ord a) => a -> ClientStore i a -> ClientStore i a+addItemToClientStore a cs =+  let oldAddedItems = clientStoreAdded cs+      newAddedItems =+        let newKey = findFreeSpot oldAddedItems+         in M.insert newKey a oldAddedItems+   in cs {clientStoreAdded = newAddedItems}++-- | Find a free client id to use+--+-- You shouldn't need this function, 'addItemToClientStore' takes care of this.+findFreeSpot :: Map ClientId a -> ClientId+findFreeSpot m =+  if M.null m+    then ClientId 0+    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 (ClientId w)+      | w == maxBound = ClientId 0+      | otherwise = ClientId $ succ w++deleteUnsyncedFromClientStore :: (Ord i, Ord a) => ClientId -> ClientStore i a -> ClientStore i a+deleteUnsyncedFromClientStore cid cs = cs {clientStoreAdded = M.delete cid $ clientStoreAdded cs}++deleteSyncedFromClientStore :: (Ord i, Ord a) => i -> ClientStore i a -> ClientStore i a+deleteSyncedFromClientStore i cs =+  let syncedBefore = clientStoreSynced cs+   in case M.lookup i syncedBefore of+        Nothing -> cs+        Just _ ->+          cs+            { clientStoreSynced = M.delete i syncedBefore+            , clientStoreDeleted = S.insert i $ clientStoreDeleted cs+            }++-- | A synchronisation request for items with identifiers of type @i@ and values of type @a@+data SyncRequest i a =+  SyncRequest+    { syncRequestAdded :: !(Map ClientId a)+    , syncRequestSynced :: !(Set i)+    , syncRequestDeleted :: !(Set i)+    }+  deriving (Show, Eq, Ord, Generic)++instance (NFData i, NFData a) => NFData (SyncRequest i a)++instance (Validity i, Validity a, Ord i, Ord a) => Validity (SyncRequest i a) where+  validate sr@SyncRequest {..} =+    mconcat+      [ genericValidate sr+      , declare "the sync request items have distinct ids" $+        distinct $ S.toList syncRequestSynced ++ S.toList syncRequestDeleted+      ]++instance (FromJSON i, FromJSON a, Ord i, Ord a) => FromJSON (SyncRequest i a) where+  parseJSON =+    withObject "SyncRequest" $ \o ->+      SyncRequest <$> o .: "added" <*> o .: "synced" <*> o .: "undeleted"++instance (ToJSON i, ToJSON a) => ToJSON (SyncRequest i a) where+  toJSON SyncRequest {..} =+    object+      [ "added" .= syncRequestAdded+      , "synced" .= syncRequestSynced+      , "undeleted" .= syncRequestDeleted+      ]++-- | Produce a synchronisation request for a client-side store.+--+-- This request can then be sent to a central store for synchronisation.+makeSyncRequest :: (Ord i, Ord a) => ClientStore i a -> SyncRequest i a+makeSyncRequest ClientStore {..} =+  SyncRequest+    { syncRequestAdded = clientStoreAdded+    , syncRequestSynced = M.keysSet clientStoreSynced+    , syncRequestDeleted = clientStoreDeleted+    }++-- | A synchronisation response for items with identifiers of type @i@ and values of type @a@+data SyncResponse i a =+  SyncResponse+    { syncResponseClientAdded :: !(Map ClientId i)+    , syncResponseClientDeleted :: !(Set i)+    , syncResponseServerAdded :: !(Map i a)+    , syncResponseServerDeleted :: !(Set i)+    }+  deriving (Show, Eq, Ord, Generic)++instance (NFData i, NFData a) => NFData (SyncResponse i a)++instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (SyncResponse i a) where+  validate sr@SyncResponse {..} =+    mconcat+      [ genericValidate sr+      , declare "the sync response items have distinct uuids" $+        distinct $+        concat+          [ M.elems syncResponseClientAdded+          , S.toList syncResponseClientDeleted+          , M.keys syncResponseServerAdded+          , S.toList syncResponseServerDeleted+          ]+      ]++instance (Ord i, FromJSON i, FromJSONKey i, Ord a, FromJSON a) => FromJSON (SyncResponse i a) where+  parseJSON =+    withObject "SyncResponse" $ \o ->+      SyncResponse <$> o .: "client-added" <*> o .: "client-deleted" <*> o .: "server-added" <*>+      o .: "server-deleted"++instance (ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (SyncResponse i a) where+  toJSON SyncResponse {..} =+    object+      [ "client-added" .= syncResponseClientAdded+      , "client-deleted" .= syncResponseClientDeleted+      , "server-added" .= syncResponseServerAdded+      , "server-deleted" .= syncResponseServerDeleted+      ]++emptySyncResponse :: SyncResponse i ia+emptySyncResponse =+  SyncResponse+    { syncResponseClientAdded = M.empty+    , syncResponseClientDeleted = S.empty+    , syncResponseServerAdded = M.empty+    , syncResponseServerDeleted = S.empty+    }++-- | Merge a synchronisation response back into a client-side store.+mergeSyncResponse ::+     forall i a. (Ord i, Ord a)+  => ClientStore i a+  -> SyncResponse i a+  -> ClientStore i a+mergeSyncResponse s SyncResponse {..} =+  addRemotelyAddedItems syncResponseServerAdded .+  addAddedItems syncResponseClientAdded .+  deleteItemsToBeDeletedLocally syncResponseServerDeleted .+  deleteLocalUndeletedItems syncResponseClientDeleted $+  s++addRemotelyAddedItems :: (Ord i, Ord a) => Map i a -> ClientStore i a -> ClientStore i a+addRemotelyAddedItems m cs =+  cs {clientStoreSynced = M.union (clientStoreSynced cs) (m `diffSet` clientStoreIds cs)}++addAddedItems ::+     forall i a. (Ord i, Ord a)+  => Map ClientId i+  -> ClientStore i a+  -> ClientStore i a+addAddedItems addedItems cs =+  let oldAdded = clientStoreAdded cs+      oldSynced = clientStoreSynced cs+      go :: (Map ClientId a, Map i a) -> ClientId -> i -> (Map ClientId a, Map i a)+      go (added, synced) cid i =+        case M.lookup cid added of+          Nothing -> (added, synced)+          Just a -> (M.delete cid added, M.insert i a synced)+      (newAdded, newSynced) = M.foldlWithKey go (oldAdded, oldSynced) addedItems+   in cs {clientStoreAdded = newAdded, clientStoreSynced = newSynced}++deleteItemsToBeDeletedLocally :: (Ord i, Ord a) => Set i -> ClientStore i a -> ClientStore i a+deleteItemsToBeDeletedLocally toBeDeletedLocally cs =+  cs {clientStoreSynced = clientStoreSynced cs `diffSet` toBeDeletedLocally}++deleteLocalUndeletedItems :: (Ord i, Ord a) => Set i -> ClientStore i a -> ClientStore i a+deleteLocalUndeletedItems cd cs = cs {clientStoreDeleted = clientStoreDeleted cs `S.difference` cd}++-- | A record of the basic operations that are necessary to build a synchronisation processor.+data ServerSyncProcessor i a m =+  ServerSyncProcessor+    { serverSyncProcessorDeleteMany :: Set i -> m (Set i)+      -- ^ Delete the items with an identifier in the given set, return the set that was indeed deleted or did not exist.+      -- In particular, return the identifiers of the items that the client should forget about.+    , serverSyncProcessorQueryNoLongerSynced :: Set i -> m (Set i) -- ^ Query the identifiers of the items that are in the given set but not in the store.+    , serverSyncProcessorQueryNewRemote :: Set i -> m (Map i a) -- ^ Query the items that are in store, but not in the given set.+    , serverSyncProcessorInsertMany :: Map ClientId a -> m (Map ClientId i) -- ^ Insert a set of items into the store.+    }+  deriving (Generic)++-- | Process a server-side synchronisation request using a custom synchronisation processor+--+-- WARNING: The identifier generation function must produce newly unique identifiers such that each new item gets a unique identifier.+--+-- You can use this function with deterministically-random identifiers or incrementing identifiers.+processServerSyncCustom ::+     forall i a m. (Ord i, Ord a, Monad m)+  => ServerSyncProcessor i a m+  -> SyncRequest i a+  -> m (SyncResponse i a)+processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do+  deletedFromClient <- deleteUndeleted+        -- First we delete the items that were deleted locally but not yet remotely.+        -- Then we find the items that have been deleted remotely but not locally+  deletedRemotely <- syncItemsToBeDeletedLocally+        -- Then we find the items that have appeared remotely but aren't known locally+  newRemoteItems <- syncNewRemoteItems+        -- Then we add the items that should be added.+  newLocalItems <- syncAddedItems+  pure+    SyncResponse+      { syncResponseClientAdded = newLocalItems+      , syncResponseClientDeleted = deletedFromClient+      , syncResponseServerAdded = newRemoteItems+      , syncResponseServerDeleted = deletedRemotely+      }+  where+    deleteUndeleted :: m (Set i)+    deleteUndeleted = serverSyncProcessorDeleteMany syncRequestDeleted+    syncItemsToBeDeletedLocally :: m (Set i)+    syncItemsToBeDeletedLocally = serverSyncProcessorQueryNoLongerSynced syncRequestSynced+    syncNewRemoteItems :: m (Map i a)+    syncNewRemoteItems = serverSyncProcessorQueryNewRemote syncRequestSynced+    syncAddedItems :: m (Map ClientId i)+    syncAddedItems = serverSyncProcessorInsertMany syncRequestAdded++-- | A central store of items with identifiers of type @i@ and values of type @a@+newtype ServerStore i a =+  ServerStore+    { serverStoreItems :: Map i a+    }+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)++instance (NFData i, NFData a) => NFData (ServerStore i a)++instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ServerStore i a)++-- | An empty central store to start with+emptyServerStore :: ServerStore i a+emptyServerStore = ServerStore {serverStoreItems = M.empty}++-- | Process a server-side synchronisation request using @getCurrentTime@+--+-- see 'processSyncCustom'+processServerSync ::+     forall m i a. (Ord i, Ord a, Monad m)+  => m i+  -> ServerStore i a+  -> SyncRequest i a+  -> m (SyncResponse i a, ServerStore i a)+processServerSync genUuid cs sr =+  flip runStateT cs $+  processServerSyncCustom+    ServerSyncProcessor+      { serverSyncProcessorDeleteMany = deleteMany+      , serverSyncProcessorQueryNoLongerSynced = queryNoLongerSynced+      , serverSyncProcessorQueryNewRemote = queryNewRemote+      , serverSyncProcessorInsertMany = insertMany+      }+    sr+  where+    deleteMany :: Set i -> StateT (ServerStore i a) m (Set i)+    deleteMany s = do+      modC (`diffSet` s)+      pure s+    queryNoLongerSynced :: Set i -> StateT (ServerStore i a) m (Set i)+    queryNoLongerSynced s = query ((s `S.difference`) . M.keysSet)+    queryNewRemote :: Set i -> StateT (ServerStore i a) m (Map i a)+    queryNewRemote s = query (`diffSet` s)+    query :: (Map i a -> b) -> StateT (ServerStore i a) m b+    query func = gets $ func . serverStoreItems+    insertMany :: Map ClientId a -> StateT (ServerStore i a) m (Map ClientId i)+    insertMany =+      traverse $ \a -> do+        u <- lift genUuid+        ins u a+        pure u+    ins :: i -> a -> StateT (ServerStore i a) m ()+    ins i val = modC $ M.insert i val+    modC :: (Map i a -> Map i a) -> StateT (ServerStore i a) m ()+    modC func = modify (\(ServerStore m) -> ServerStore $ func m)++diffSet :: Ord i => Map i a -> Set i -> Map i a+diffSet m s = m `M.difference` toMap s++toMap :: Set i -> Map i ()+toMap = M.fromSet (const ())++distinct :: Ord a => [a] -> Bool+distinct ls = sort ls == S.toAscList (S.fromList ls)

@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Mergeless.Item where++import Control.DeepSeq+import Data.Aeson+import Data.Validity+import Data.Validity.Containers ()+import GHC.Generics (Generic)++{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}++data ClientItem a+  = ClientEmpty+  | ClientAdded !a+  | ClientSynced !a+  | ClientDeleted+  deriving (Show, Eq, Ord, Generic)++instance Validity a => Validity (ClientItem a)++instance NFData a => NFData (ClientItem a)++instance FromJSON a => FromJSON (ClientItem a)++instance ToJSON a => ToJSON (ClientItem a)++-- | A synchronisation request for items with identifiers of type @i@ and values of type @a@+data ItemSyncRequest a+  = ItemSyncRequestPoll+  | ItemSyncRequestNew a+  | ItemSyncRequestKnown+  | ItemSyncRequestDeleted+  deriving (Show, Eq, Ord, Generic)++instance Validity a => Validity (ItemSyncRequest a)++instance NFData a => NFData (ItemSyncRequest a)++instance FromJSON a => FromJSON (ItemSyncRequest a)++instance ToJSON a => ToJSON (ItemSyncRequest a)++makeItemSyncRequest :: ClientItem a -> ItemSyncRequest a+makeItemSyncRequest ci =+  case ci of+    ClientEmpty -> ItemSyncRequestPoll+    ClientAdded a -> ItemSyncRequestNew a+    ClientSynced _ -> ItemSyncRequestKnown+    ClientDeleted -> ItemSyncRequestDeleted++-- | A synchronisation response for items with identifiers of type @i@ and values of type @a@+data ItemSyncResponse a+  = ItemSyncResponseInSyncEmpty+  | ItemSyncResponseInSyncFull+  | ItemSyncResponseClientAdded+  | ItemSyncResponseClientDeleted+  | ItemSyncResponseServerAdded !a+  | ItemSyncResponseServerDeleted+  deriving (Show, Eq, Ord, Generic)++instance Validity a => Validity (ItemSyncResponse a)++instance NFData a => NFData (ItemSyncResponse a)++instance FromJSON a => FromJSON (ItemSyncResponse a)++instance ToJSON a => ToJSON (ItemSyncResponse a)++-- | Merge a synchronisation response back into a client-side store.+mergeItemSyncResponse :: ClientItem a -> ItemSyncResponse a -> ClientItem a+mergeItemSyncResponse ci sr =+  let mismatch = ci+   in case ci of+        ClientEmpty ->+          case sr of+            ItemSyncResponseInSyncEmpty -> ClientEmpty+            ItemSyncResponseServerAdded s -> ClientSynced s+            _ -> mismatch+        ClientAdded a ->+          case sr of+            ItemSyncResponseClientAdded -> ClientSynced a+            ItemSyncResponseServerAdded s -> ClientSynced s+            -- For completeness sake.+            -- This can only happen if two clients make the item at the same time.+            -- In practice, with named items in a collection, this will never happen.+            _ -> mismatch+        ClientSynced _ ->+          case sr of+            ItemSyncResponseInSyncFull -> ci -- No change+            ItemSyncResponseServerDeleted -> ClientEmpty+            _ -> mismatch+        ClientDeleted ->+          case sr of+            ItemSyncResponseClientDeleted -> ClientEmpty+            _ -> mismatch++-- | An item in a central store with a value of type @a@+data ServerItem a+  = ServerItemEmpty+  | ServerItemFull !a+  deriving (Show, Eq, Ord, Generic)++instance Validity a => Validity (ServerItem a)++instance NFData a => NFData (ServerItem a)++instance FromJSON a => FromJSON (ServerItem a)++instance ToJSON a => ToJSON (ServerItem a)++processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a)+processServerItemSync si sr =+  case si of+    ServerItemEmpty ->+      case sr of+        ItemSyncRequestPoll+          -- Both the client and the server think the item is empty, fine.+         -> (ItemSyncResponseInSyncEmpty, si)+        ItemSyncRequestNew a+          -- The client has a new item and the server has space for it, add it.+         -> (ItemSyncResponseClientAdded, ServerItemFull a)+        ItemSyncRequestKnown+          -- The client has an item that the server doesn't, so the server must have+          -- deleted it when another client asked to do that.+          -- Leave it deleted.+         -> (ItemSyncResponseServerDeleted, si)+        ItemSyncRequestDeleted+          -- The server has deleted an item but the current client hasn't been made aware of that+          -- AND this server also deleted that item in the meantime.+          -- Just leave it deleted.+         -> (ItemSyncResponseClientDeleted, si)+    ServerItemFull s ->+      case sr of+        ItemSyncRequestPoll+          -- The server has an item that the client doesn't, send it to the client.+         -> (ItemSyncResponseServerAdded s, si)+        ItemSyncRequestNew _+          -- The client wants to add an item that the server already has.+          -- That means that another client has added that same item in the meantime.+          -- This wouldn't happen if the items were named.+          -- In this case, for completeness sake,+         -> (ItemSyncResponseServerAdded s, si)+        ItemSyncRequestKnown -> (ItemSyncResponseInSyncFull, si)+        ItemSyncRequestDeleted -> (ItemSyncResponseClientDeleted, ServerItemEmpty)