summaryrefslogtreecommitdiff
path: root/src/Data/Mergeless/Collection.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Mergeless/Collection.hs')
-rw-r--r--src/Data/Mergeless/Collection.hs479
1 files changed, 243 insertions, 236 deletions
diff --git a/src/Data/Mergeless/Collection.hs b/src/Data/Mergeless/Collection.hs
index 7937eaf..69c4d00 100644
--- a/src/Data/Mergeless/Collection.hs
+++ b/src/Data/Mergeless/Collection.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -11,9 +12,10 @@
--
-- * 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.
+-- * Items must allow for a client-side unique identifier.
+-- * Identifiers for items must be generated 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.
+-- Should mutation be a requirement, then there is another library: 'mergeful' for exactly this purpose.
--
--
-- There are a few obvious candidates for identifiers:
@@ -42,113 +44,125 @@
-- * 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
+ ( ClientStore (..),
+ SyncRequest (..),
+ SyncResponse (..),
+
-- * Client-side Synchronisation
- , makeSyncRequest
- , mergeSyncResponse
- , addRemotelyAddedItems
- , addAddedItems
- , deleteItemsToBeDeletedLocally
- , deleteLocalUndeletedItems
+
+ -- ** General
+ ClientSyncProcessor (..),
+ mergeSyncResponseCustom,
+
+ -- ** Pure
+ emptyClientStore,
+ ClientId (..),
+ storeSize,
+ addItemToClientStore,
+ deleteUnsyncedFromClientStore,
+ deleteSyncedFromClientStore,
+ emptySyncRequest,
+ makeSyncRequest,
+ mergeSyncResponse,
+ pureClientSyncProcessor,
+
-- * Server-side Synchronisation
- -- ** General synchronisation
- , ServerSyncProcessor(..)
- , processServerSyncCustom
- -- ** Synchronisation with a simple central store
- , ServerStore(..)
- , emptyServerStore
- , processServerSync
- ) where
-import GHC.Generics (Generic)
+ -- ** General synchronisation
+ ServerSyncProcessor (..),
+ processServerSyncCustom,
-import Data.Validity
-import Data.Validity.Containers ()
+ -- ** Synchronisation with a simple central store
+ ServerStore (..),
+ emptyServerStore,
+ emptySyncResponse,
+ processServerSync,
+ )
+where
+import Control.DeepSeq
+import Control.Monad.State.Strict
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.Validity
+import Data.Validity.Containers ()
import Data.Word
-
-import Control.DeepSeq
-import Control.Monad.State.Strict
+import GHC.Generics (Generic)
{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}
--- | A Client-side identifier for items.
+-- | A Client-side identifier for items for use with pure client stores
--
-- These only need to be unique at the client.
-newtype ClientId =
- ClientId
- { unClientId :: Word64
- }
+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)
- }
+-- | A client-side store of items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@
+data ClientStore ci si a
+ = ClientStore
+ { clientStoreAdded :: !(Map ci a),
+ clientStoreSynced :: !(Map si a),
+ clientStoreDeleted :: !(Set si)
+ }
deriving (Show, Eq, Ord, Generic)
-instance (NFData i, NFData a) => NFData (ClientStore i a)
+instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a)
-instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ClientStore i a) where
+instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (ClientStore ci si a) where
validate cs@ClientStore {..} =
mconcat
- [ genericValidate cs
- , declare "the store items have distinct ids" $
- distinct $ M.keys clientStoreSynced ++ S.toList clientStoreDeleted
+ [ 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
+instance (Ord ci, FromJSON ci, FromJSONKey ci, Ord si, FromJSON si, FromJSONKey si, FromJSON a) => FromJSON (ClientStore ci si a) where
parseJSON =
withObject "ClientStore" $ \o ->
- ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty <*>
- o .:? "deleted" .!= S.empty
+ 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
+instance (Ord ci, ToJSON ci, ToJSONKey ci, Ord si, ToJSON si, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where
toJSON ClientStore {..} =
object
["added" .= clientStoreAdded, "synced" .= clientStoreSynced, "deleted" .= clientStoreDeleted]
--- | The store with no items.
-emptyClientStore :: ClientStore i a
+-- | The client store with no items.
+emptyClientStore :: ClientStore ci si a
emptyClientStore =
ClientStore
- {clientStoreAdded = M.empty, clientStoreSynced = M.empty, clientStoreDeleted = S.empty}
+ { 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 ci si a -> Int
storeSize ClientStore {..} = M.size clientStoreAdded + M.size clientStoreSynced
-clientStoreIds :: Ord i => ClientStore i a -> Set i
+clientStoreIds :: Ord si => ClientStore ci si a -> Set si
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
+-- This will take care of the uniqueness constraint of the 'ci's in the map.
+--
+-- The values wrap around when reaching 'maxBound'.
+addItemToClientStore :: (Enum ci, Bounded ci, Ord ci) => a -> ClientStore ci si a -> ClientStore ci si a
addItemToClientStore a cs =
let oldAddedItems = clientStoreAdded cs
newAddedItems =
@@ -159,276 +173,269 @@ addItemToClientStore a cs =
-- | Find a free client id to use
--
-- You shouldn't need this function, 'addItemToClientStore' takes care of this.
-findFreeSpot :: Map ClientId a -> ClientId
+--
+-- 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 ClientId 0
- else let (i, _) = M.findMax m
- in go (next i)
+ 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 (ClientId w)
- | w == maxBound = ClientId 0
- | otherwise = ClientId $ succ w
+ next ci
+ | ci == maxBound = minBound
+ | otherwise = succ ci
-deleteUnsyncedFromClientStore :: (Ord i, Ord a) => ClientId -> ClientStore i a -> ClientStore i a
+deleteUnsyncedFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a
deleteUnsyncedFromClientStore cid cs = cs {clientStoreAdded = M.delete cid $ clientStoreAdded cs}
-deleteSyncedFromClientStore :: (Ord i, Ord a) => i -> ClientStore i a -> ClientStore i a
+deleteSyncedFromClientStore :: Ord si => si -> ClientStore ci si a -> ClientStore ci si 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
+ { 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)
- }
+-- | A synchronisation request for items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@
+data SyncRequest ci si a
+ = SyncRequest
+ { syncRequestAdded :: !(Map ci a),
+ syncRequestSynced :: !(Set si),
+ syncRequestDeleted :: !(Set si)
+ }
deriving (Show, Eq, Ord, Generic)
-instance (NFData i, NFData a) => NFData (SyncRequest i a)
+instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a)
-instance (Validity i, Validity a, Ord i, Ord a) => Validity (SyncRequest i a) where
+instance (Validity ci, Validity si, Validity a, Ord ci, Ord si, Show ci) => Validity (SyncRequest ci si a) where
validate sr@SyncRequest {..} =
mconcat
- [ genericValidate sr
- , declare "the sync request items have distinct ids" $
- distinct $ S.toList syncRequestSynced ++ S.toList syncRequestDeleted
+ [ 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
+instance (FromJSON ci, FromJSON si, FromJSON a, FromJSONKey ci, Ord ci, Ord si, Ord a) => FromJSON (SyncRequest ci si a) where
parseJSON =
withObject "SyncRequest" $ \o ->
- SyncRequest <$> o .: "added" <*> o .: "synced" <*> o .: "undeleted"
+ SyncRequest <$> o .: "added" <*> o .: "synced" <*> o .: "deleted"
-instance (ToJSON i, ToJSON a) => ToJSON (SyncRequest i a) where
+instance (ToJSON ci, ToJSON si, ToJSON a, ToJSONKey ci) => ToJSON (SyncRequest ci si a) where
toJSON SyncRequest {..} =
object
- [ "added" .= syncRequestAdded
- , "synced" .= syncRequestSynced
- , "undeleted" .= syncRequestDeleted
+ [ "added" .= syncRequestAdded,
+ "synced" .= syncRequestSynced,
+ "deleted" .= syncRequestDeleted
]
+emptySyncRequest :: SyncRequest ci si a
+emptySyncRequest =
+ SyncRequest
+ { syncRequestAdded = M.empty,
+ syncRequestSynced = S.empty,
+ syncRequestDeleted = S.empty
+ }
+
-- | 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 ci si a -> SyncRequest ci si a
makeSyncRequest ClientStore {..} =
SyncRequest
- { syncRequestAdded = clientStoreAdded
- , syncRequestSynced = M.keysSet clientStoreSynced
- , syncRequestDeleted = clientStoreDeleted
+ { 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)
- }
+data SyncResponse ci si a
+ = SyncResponse
+ { syncResponseClientAdded :: !(Map ci si),
+ syncResponseClientDeleted :: !(Set si),
+ syncResponseServerAdded :: !(Map si a),
+ syncResponseServerDeleted :: !(Set si)
+ }
deriving (Show, Eq, Ord, Generic)
-instance (NFData i, NFData a) => NFData (SyncResponse i a)
+instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a)
-instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (SyncResponse i a) where
+instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (SyncResponse ci si 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
- ]
+ [ 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
+instance (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, Ord a, FromJSON a) => FromJSON (SyncResponse ci si a) where
parseJSON =
withObject "SyncResponse" $ \o ->
- SyncResponse <$> o .: "client-added" <*> o .: "client-deleted" <*> o .: "server-added" <*>
- o .: "server-deleted"
+ 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
+instance (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncResponse ci si a) where
toJSON SyncResponse {..} =
object
- [ "client-added" .= syncResponseClientAdded
- , "client-deleted" .= syncResponseClientDeleted
- , "server-added" .= syncResponseServerAdded
- , "server-deleted" .= syncResponseServerDeleted
+ [ "client-added" .= syncResponseClientAdded,
+ "client-deleted" .= syncResponseClientDeleted,
+ "server-added" .= syncResponseServerAdded,
+ "server-deleted" .= syncResponseServerDeleted
]
-emptySyncResponse :: SyncResponse i ia
+emptySyncResponse :: SyncResponse ci si a
emptySyncResponse =
SyncResponse
- { syncResponseClientAdded = M.empty
- , syncResponseClientDeleted = S.empty
- , syncResponseServerAdded = M.empty
- , syncResponseServerDeleted = S.empty
+ { 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}
+ forall ci si a.
+ (Ord ci, Ord si) =>
+ ClientStore ci si a ->
+ SyncResponse ci si a ->
+ ClientStore ci si a
+mergeSyncResponse s sr =
+ flip execState s $
+ mergeSyncResponseCustom
+ pureClientSyncProcessor
+ sr
+
+pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a))
+pureClientSyncProcessor =
+ ClientSyncProcessor
+ { clientSyncProcessorSyncServerAdded = \m -> modify $ \cs ->
+ cs {clientStoreSynced = M.union (clientStoreSynced cs) (m `diffSet` clientStoreIds cs)},
+ clientSyncProcessorSyncClientAdded = \addedItems -> modify $ \cs ->
+ let oldAdded = clientStoreAdded cs
+ oldSynced = clientStoreSynced cs
+ go :: (Map ci a, Map si a) -> ci -> si -> (Map ci a, Map si 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},
+ clientSyncProcessorSyncServerDeleted = \toBeDeletedLocally -> modify $ \cs ->
+ cs {clientStoreSynced = clientStoreSynced cs `diffSet` toBeDeletedLocally},
+ clientSyncProcessorSyncClientDeleted = \cd -> modify $ \cs ->
+ cs {clientStoreDeleted = clientStoreDeleted cs `S.difference` cd}
+ }
+
+data ClientSyncProcessor ci si a m
+ = ClientSyncProcessor
+ { clientSyncProcessorSyncServerAdded :: Map si a -> m (),
+ clientSyncProcessorSyncClientAdded :: Map ci si -> m (),
+ clientSyncProcessorSyncServerDeleted :: Set si -> m (),
+ clientSyncProcessorSyncClientDeleted :: Set si -> m ()
+ }
+ deriving (Generic)
+
+mergeSyncResponseCustom :: Monad m => ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()
+mergeSyncResponseCustom ClientSyncProcessor {..} SyncResponse {..} = do
+ -- The order here matters!
+ clientSyncProcessorSyncServerAdded syncResponseServerAdded
+ clientSyncProcessorSyncServerDeleted syncResponseServerDeleted
+ clientSyncProcessorSyncClientDeleted syncResponseClientDeleted
+ clientSyncProcessorSyncClientAdded syncResponseClientAdded
-- | 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.
- }
+data ServerSyncProcessor ci si a m
+ = ServerSyncProcessor
+ { serverSyncProcessorRead :: m (Map si a),
+ serverSyncProcessorAddItems :: Map ci a -> m (Map ci si),
+ serverSyncProcessorDeleteItems :: Set si -> m (Set si)
+ }
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)
+ forall ci si a m.
+ (Ord si, Monad m) =>
+ ServerSyncProcessor ci si a m ->
+ SyncRequest ci si a ->
+ m (SyncResponse ci si 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
+ serverItems <- serverSyncProcessorRead
+ let syncResponseServerAdded = serverItems `M.difference` toMap (syncRequestSynced `S.union` syncRequestDeleted)
+ let syncResponseServerDeleted = syncRequestSynced `S.difference` M.keysSet serverItems
+ syncResponseClientDeleted <- serverSyncProcessorDeleteItems syncRequestDeleted
+ syncResponseClientAdded <- serverSyncProcessorAddItems syncRequestAdded
+ pure SyncResponse {..}
-- | A central store of items with identifiers of type @i@ and values of type @a@
-newtype ServerStore i a =
- ServerStore
- { serverStoreItems :: Map i a
- }
+newtype ServerStore si a
+ = ServerStore
+ { serverStoreItems :: Map si a
+ }
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
-instance (NFData i, NFData a) => NFData (ServerStore i a)
+instance (NFData si, NFData a) => NFData (ServerStore si a)
-instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ServerStore i a)
+instance (Validity si, Validity a, Show si, Show a, Ord si) => Validity (ServerStore si a)
-- | An empty central store to start with
-emptyServerStore :: ServerStore i a
+emptyServerStore :: ServerStore si a
emptyServerStore = ServerStore {serverStoreItems = M.empty}
--- | Process a server-side synchronisation request using @getCurrentTime@
+-- | Process a server-side synchronisation request using a server id generator
--
-- 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)
+ forall m ci si a.
+ (Ord si, Monad m) =>
+ m si ->
+ ServerStore si a ->
+ SyncRequest ci si a ->
+ m (SyncResponse ci si a, ServerStore si a)
processServerSync genUuid cs sr =
flip runStateT cs $
- processServerSyncCustom
- ServerSyncProcessor
- { serverSyncProcessorDeleteMany = deleteMany
- , serverSyncProcessorQueryNoLongerSynced = queryNoLongerSynced
- , serverSyncProcessorQueryNewRemote = queryNewRemote
- , serverSyncProcessorInsertMany = insertMany
- }
- sr
+ processServerSyncCustom
+ ServerSyncProcessor
+ { serverSyncProcessorRead = gets serverStoreItems,
+ serverSyncProcessorDeleteItems = deleteMany,
+ serverSyncProcessorAddItems = insertMany
+ }
+ sr
where
- deleteMany :: Set i -> StateT (ServerStore i a) m (Set i)
+ deleteMany :: Set si -> StateT (ServerStore si a) m (Set si)
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 :: Map ci a -> StateT (ServerStore si a) m (Map ci si)
insertMany =
traverse $ \a -> do
u <- lift genUuid
ins u a
pure u
- ins :: i -> a -> StateT (ServerStore i a) m ()
+ ins :: si -> a -> StateT (ServerStore si a) m ()
ins i val = modC $ M.insert i val
- modC :: (Map i a -> Map i a) -> StateT (ServerStore i a) m ()
+ modC :: (Map si a -> Map si a) -> StateT (ServerStore si a) m ()
modC func = modify (\(ServerStore m) -> ServerStore $ func m)
-diffSet :: Ord i => Map i a -> Set i -> Map i a
+diffSet :: Ord si => Map si a -> Set si -> Map si a
diffSet m s = m `M.difference` toMap s
-toMap :: Set i -> Map i ()
+toMap :: Set si -> Map si ()
toMap = M.fromSet (const ())
distinct :: Ord a => [a] -> Bool