diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/mergeless.cabal b/mergeless.cabal --- a/mergeless.cabal +++ b/mergeless.cabal @@ -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 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 diff --git a/src/Data/Mergeless.hs b/src/Data/Mergeless.hs --- a/src/Data/Mergeless.hs +++ b/src/Data/Mergeless.hs @@ -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 diff --git a/src/Data/Mergeless/Collection.hs b/src/Data/Mergeless/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeless/Collection.hs @@ -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) diff --git a/src/Data/Mergeless/Item.hs b/src/Data/Mergeless/Item.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mergeless/Item.hs @@ -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)