{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Mergeful.Collection
(
ClientStore (..),
Timed (..),
ServerTime (..),
initialClientStore,
clientStoreSize,
clientStoreClientIdSet,
clientStoreUndeletedSyncIdSet,
clientStoreSyncIdSet,
clientStoreItems,
addItemToClientStore,
findFreeSpot,
markItemDeletedInClientStore,
changeItemInClientStore,
deleteItemFromClientStore,
SyncRequest (..),
initialSyncRequest,
makeSyncRequest,
SyncResponse (..),
ClientAddition (..),
ItemMergeStrategy (..),
ChangeConflictResolution (..),
ClientDeletedConflictResolution (..),
ServerDeletedConflictResolution (..),
mergeFromServerStrategy,
mergeFromClientStrategy,
mergeUsingCRDTStrategy,
mergeSyncResponseFromServer,
mergeSyncResponseFromClient,
mergeSyncResponseUsingCRDT,
mergeSyncResponseUsingStrategy,
ClientSyncProcessor (..),
mergeSyncResponseCustom,
ClientId (..),
mergeAddedItems,
mergeSyncedButChangedItems,
mergeDeletedItems,
mergeSyncedButChangedConflicts,
mergeClientDeletedConflicts,
mergeServerDeletedConflicts,
ServerStore (..),
initialServerStore,
processServerSync,
ServerSyncProcessor (..),
processServerSyncCustom,
emptySyncResponse,
initialServerTime,
incrementServerTime,
)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.State
import Data.Aeson
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Mergeful.Item
import Data.Mergeful.Timed
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Validity
import Data.Validity.Containers ()
import Data.Word
import GHC.Generics (Generic)
newtype ClientId
= ClientId
{ unClientId :: Word64
}
deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)
instance Validity ClientId
instance NFData ClientId
data ClientStore ci si a
= ClientStore
{
clientStoreAddedItems :: Map ci a,
clientStoreSyncedItems :: Map si (Timed a),
clientStoreSyncedButChangedItems :: Map si (Timed a),
clientStoreDeletedItems :: Map si ServerTime
}
deriving (Show, Eq, Generic)
instance
(Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>
Validity (ClientStore ci si a)
where
validate cs@ClientStore {..} =
mconcat
[ genericValidate cs,
declare "There are no duplicate IDs"
$ distinct
$ concat
[ M.keys clientStoreSyncedItems,
M.keys clientStoreSyncedButChangedItems,
M.keys clientStoreDeletedItems
]
]
instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a)
instance
(Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>
FromJSON (ClientStore ci si a)
where
parseJSON =
withObject "ClientStore" $ \o ->
ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty
<*> o .:? "changed" .!= M.empty
<*> o .:? "deleted" .!= M.empty
instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where
toJSON ClientStore {..} =
object $
catMaybes
[ jNull "added" clientStoreAddedItems,
jNull "synced" clientStoreSyncedItems,
jNull "changed" clientStoreSyncedButChangedItems,
jNull "deleted" clientStoreDeletedItems
]
initialClientStore :: ClientStore ci si a
initialClientStore =
ClientStore
{ clientStoreAddedItems = M.empty,
clientStoreSyncedItems = M.empty,
clientStoreSyncedButChangedItems = M.empty,
clientStoreDeletedItems = M.empty
}
clientStoreSize :: ClientStore ci si a -> Word
clientStoreSize ClientStore {..} =
fromIntegral $
sum
[ M.size clientStoreAddedItems,
M.size clientStoreSyncedItems,
M.size clientStoreSyncedButChangedItems
]
clientStoreClientIdSet :: ClientStore ci si a -> Set ci
clientStoreClientIdSet ClientStore {..} = M.keysSet clientStoreAddedItems
clientStoreUndeletedSyncIdSet :: Ord si => ClientStore ci si a -> Set si
clientStoreUndeletedSyncIdSet ClientStore {..} =
S.unions [M.keysSet clientStoreSyncedItems, M.keysSet clientStoreSyncedButChangedItems]
clientStoreSyncIdSet :: Ord si => ClientStore ci si a -> Set si
clientStoreSyncIdSet ClientStore {..} =
S.unions
[ M.keysSet clientStoreSyncedItems,
M.keysSet clientStoreSyncedButChangedItems,
M.keysSet clientStoreDeletedItems
]
clientStoreItems :: (Ord ci, Ord si) => ClientStore ci si a -> Map (Either ci si) a
clientStoreItems ClientStore {..} =
M.unions
[ M.mapKeys Left clientStoreAddedItems,
M.mapKeys Right $ M.map timedValue clientStoreSyncedItems,
M.mapKeys Right $ M.map timedValue clientStoreSyncedButChangedItems
]
addItemToClientStore ::
(Ord ci, Enum ci, Bounded ci) => a -> ClientStore ci si a -> ClientStore ci si a
addItemToClientStore a cs =
let oldAddedItems = clientStoreAddedItems cs
newAddedItems =
let newKey = findFreeSpot oldAddedItems
in M.insert newKey a oldAddedItems
in cs {clientStoreAddedItems = newAddedItems}
findFreeSpot :: (Ord ci, Enum ci, Bounded ci) => Map ci a -> ci
findFreeSpot m =
if M.null m
then minBound
else
let (i, _) = M.findMax m
in go (next i)
where
go i =
if M.member i m
then go (next i)
else i
next ci
| ci == maxBound = minBound
| otherwise = succ ci
markItemDeletedInClientStore :: Ord si => si -> ClientStore ci si a -> ClientStore ci si a
markItemDeletedInClientStore u cs =
let oldSyncedItems = clientStoreSyncedItems cs
oldChangedItems = clientStoreSyncedButChangedItems cs
oldDeletedItems = clientStoreDeletedItems cs
mItem = M.lookup u oldSyncedItems <|> M.lookup u oldChangedItems
in case mItem of
Nothing -> cs
Just t ->
let newSyncedItems = M.delete u oldSyncedItems
newChangedItems = M.delete u oldChangedItems
newDeletedItems = M.insert u (timedTime t) oldDeletedItems
in cs
{ clientStoreSyncedItems = newSyncedItems,
clientStoreSyncedButChangedItems = newChangedItems,
clientStoreDeletedItems = newDeletedItems
}
changeItemInClientStore :: Ord si => si -> a -> ClientStore ci si a -> ClientStore ci si a
changeItemInClientStore i a cs =
case M.lookup i (clientStoreSyncedItems cs) of
Just t ->
cs
{ clientStoreSyncedItems = M.delete i (clientStoreSyncedItems cs),
clientStoreSyncedButChangedItems =
M.insert i (t {timedValue = a}) (clientStoreSyncedButChangedItems cs)
}
Nothing ->
case M.lookup i (clientStoreSyncedButChangedItems cs) of
Nothing -> cs
Just _ ->
cs
{ clientStoreSyncedButChangedItems =
M.adjust (\t -> t {timedValue = a}) i (clientStoreSyncedButChangedItems cs)
}
deleteItemFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a
deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)}
newtype ServerStore si a
= ServerStore
{
serverStoreItems :: Map si (Timed a)
}
deriving (Show, Eq, Generic, FromJSON, ToJSON)
instance (Validity si, Show si, Ord si, Validity a) => Validity (ServerStore si a)
instance (NFData si, NFData a) => NFData (ServerStore si a)
initialServerStore :: ServerStore si a
initialServerStore = ServerStore {serverStoreItems = M.empty}
data SyncRequest ci si a
= SyncRequest
{
syncRequestNewItems :: !(Map ci a),
syncRequestKnownItems :: !(Map si ServerTime),
syncRequestKnownButChangedItems :: !(Map si (Timed a)),
syncRequestDeletedItems :: !(Map si ServerTime)
}
deriving (Show, Eq, Generic)
instance
(Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>
Validity (SyncRequest ci si a)
where
validate sr@SyncRequest {..} =
mconcat
[ genericValidate sr,
declare "There are no duplicate IDs"
$ distinct
$ concat
[ M.keys syncRequestKnownItems,
M.keys syncRequestKnownButChangedItems,
M.keys syncRequestDeletedItems
]
]
instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a)
instance
(Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>
FromJSON (SyncRequest ci si a)
where
parseJSON =
withObject "SyncRequest" $ \o ->
SyncRequest <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty
<*> o .:? "changed" .!= M.empty
<*> o .:? "deleted" .!= M.empty
instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncRequest ci si a) where
toJSON SyncRequest {..} =
object $
catMaybes
[ jNull "added" syncRequestNewItems,
jNull "synced" syncRequestKnownItems,
jNull "changed" syncRequestKnownButChangedItems,
jNull "deleted" syncRequestDeletedItems
]
initialSyncRequest :: SyncRequest ci si a
initialSyncRequest =
SyncRequest
{ syncRequestNewItems = M.empty,
syncRequestKnownItems = M.empty,
syncRequestKnownButChangedItems = M.empty,
syncRequestDeletedItems = M.empty
}
data ClientAddition i
= ClientAddition
{ clientAdditionId :: i,
clientAdditionServerTime :: ServerTime
}
deriving (Show, Eq, Generic)
instance Validity i => Validity (ClientAddition i)
instance NFData i => NFData (ClientAddition i)
instance FromJSON i => FromJSON (ClientAddition i) where
parseJSON = withObject "ClientAddition" $ \o -> ClientAddition <$> o .: "id" <*> o .: "time"
instance ToJSON i => ToJSON (ClientAddition i) where
toJSON ClientAddition {..} = object ["id" .= clientAdditionId, "time" .= clientAdditionServerTime]
data SyncResponse ci si a
= SyncResponse
{
syncResponseClientAdded :: !(Map ci (ClientAddition si)),
syncResponseClientChanged :: !(Map si ServerTime),
syncResponseClientDeleted :: !(Set si),
syncResponseServerAdded :: !(Map si (Timed a)),
syncResponseServerChanged :: !(Map si (Timed a)),
syncResponseServerDeleted :: !(Set si),
syncResponseConflicts :: !(Map si (Timed a)),
syncResponseConflictsClientDeleted :: !(Map si (Timed a)),
syncResponseConflictsServerDeleted :: !(Set si)
}
deriving (Show, Eq, Generic)
instance
(Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) =>
Validity (SyncResponse ci si a)
where
validate sr@SyncResponse {..} =
mconcat
[ genericValidate sr,
declare "There are no duplicate IDs"
$ distinct
$ concat
[ map (\(_, ClientAddition {..}) -> clientAdditionId) $ M.toList syncResponseClientAdded,
M.keys syncResponseClientChanged,
S.toList syncResponseClientDeleted,
M.keys syncResponseServerAdded,
M.keys syncResponseServerChanged,
S.toList syncResponseServerDeleted,
M.keys syncResponseConflicts,
M.keys syncResponseConflictsClientDeleted,
S.toList syncResponseConflictsServerDeleted
]
]
instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a)
instance
(Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, FromJSON a) =>
FromJSON (SyncResponse ci si a)
where
parseJSON =
withObject "SyncResponse" $ \o ->
SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty
<*> o .:? "client-deleted" .!= S.empty
<*> o .:? "server-added" .!= M.empty
<*> o .:? "server-changed" .!= M.empty
<*> o .:? "server-deleted" .!= S.empty
<*> o .:? "conflict" .!= M.empty
<*> o .:? "conflict-client-deleted" .!= M.empty
<*> o .:? "conflict-server-deleted" .!= S.empty
instance
(ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) =>
ToJSON (SyncResponse ci si a)
where
toJSON SyncResponse {..} =
object $
catMaybes
[ jNull "client-added" syncResponseClientAdded,
jNull "client-changed" syncResponseClientChanged,
jNull "client-deleted" syncResponseClientDeleted,
jNull "server-added" syncResponseServerAdded,
jNull "server-changed" syncResponseServerChanged,
jNull "server-deleted" syncResponseServerDeleted,
jNull "conflict" syncResponseConflicts,
jNull "conflict-client-deleted" syncResponseConflictsClientDeleted,
jNull "conflict-server-deleted" syncResponseConflictsServerDeleted
]
emptySyncResponse :: SyncResponse ci si a
emptySyncResponse =
SyncResponse
{ syncResponseClientAdded = M.empty,
syncResponseClientChanged = M.empty,
syncResponseClientDeleted = S.empty,
syncResponseServerAdded = M.empty,
syncResponseServerChanged = M.empty,
syncResponseServerDeleted = S.empty,
syncResponseConflicts = M.empty,
syncResponseConflictsClientDeleted = M.empty,
syncResponseConflictsServerDeleted = S.empty
}
jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value)
jNull n s =
if null s
then Nothing
else Just $ n .= s
makeSyncRequest :: ClientStore ci si a -> SyncRequest ci si a
makeSyncRequest ClientStore {..} =
SyncRequest
{ syncRequestNewItems = clientStoreAddedItems,
syncRequestKnownItems = M.map timedTime clientStoreSyncedItems,
syncRequestKnownButChangedItems = clientStoreSyncedButChangedItems,
syncRequestDeletedItems = clientStoreDeletedItems
}
mergeSyncResponseFromServer ::
(Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a
mergeSyncResponseFromServer =
mergeSyncResponseUsingStrategy mergeFromServerStrategy
mergeSyncResponseFromClient ::
(Ord ci, Ord si) => ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a
mergeSyncResponseFromClient = mergeSyncResponseUsingStrategy mergeFromClientStrategy
mergeSyncResponseUsingCRDT :: (Ord ci, Ord si) => (a -> a -> a) -> ClientStore ci si a -> SyncResponse ci si a -> ClientStore ci si a
mergeSyncResponseUsingCRDT = mergeSyncResponseUsingStrategy . mergeUsingCRDTStrategy
mergeSyncResponseUsingStrategy ::
(Ord ci, Ord si) =>
ItemMergeStrategy a ->
ClientStore ci si a ->
SyncResponse ci si a ->
ClientStore ci si a
mergeSyncResponseUsingStrategy strat cs sr =
flip execState cs $ mergeSyncResponseCustom strat pureClientSyncProcessor sr
pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a))
pureClientSyncProcessor =
ClientSyncProcessor
{ clientSyncProcessorQuerySyncedButChangedValues = \s ->
gets
( \cs -> M.intersection (clientStoreSyncedButChangedItems cs) (M.fromSet (const ()) s)
),
clientSyncProcessorSyncClientAdded = \m ->
modify
( \cs ->
let (leftovers, added) = mergeAddedItems (clientStoreAddedItems cs) m
in cs {clientStoreAddedItems = leftovers, clientStoreSyncedItems = added `M.union` clientStoreSyncedItems cs}
),
clientSyncProcessorSyncClientChanged = \m ->
modify
( \cs ->
let (leftovers, changed) = mergeSyncedButChangedItems (clientStoreSyncedButChangedItems cs) m
in cs {clientStoreSyncedButChangedItems = leftovers, clientStoreSyncedItems = changed `M.union` clientStoreSyncedItems cs}
),
clientSyncProcessorSyncClientDeleted = \s ->
modify
( \cs ->
let leftovers = mergeDeletedItems (clientStoreDeletedItems cs) s
in cs {clientStoreDeletedItems = leftovers}
),
clientSyncProcessorSyncMergedConflict = \resolved ->
modify
( \cs ->
let newSyncedButChanged = M.union resolved (clientStoreSyncedButChangedItems cs)
in cs {clientStoreSyncedButChangedItems = newSyncedButChanged, clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` newSyncedButChanged}
),
clientSyncProcessorSyncServerAdded = \m ->
modify (\cs -> cs {clientStoreSyncedItems = m `M.union` clientStoreSyncedItems cs}),
clientSyncProcessorSyncServerChanged = \m ->
modify
( \cs ->
let newSynced = m `M.union` clientStoreSyncedItems cs
in cs {clientStoreSyncedItems = newSynced, clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` newSynced}
),
clientSyncProcessorSyncServerDeleted = \s ->
modify
( \cs ->
let m = M.fromSet (const ()) s
in cs
{ clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` m,
clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` m
}
)
}
mergeAddedItems ::
forall ci si a.
(Ord ci, Ord si) =>
Map ci a ->
Map ci (ClientAddition si) ->
(Map ci a, Map si (Timed a))
mergeAddedItems local added = M.foldlWithKey go (M.empty, M.empty) local
where
go :: (Map ci a, Map si (Timed a)) -> ci -> a -> (Map ci a, Map si (Timed a))
go (as, m) ci a =
case M.lookup ci added of
Nothing -> (M.insert ci a as, m)
Just ClientAddition {..} ->
( as,
M.insert
clientAdditionId
(Timed {timedValue = a, timedTime = clientAdditionServerTime})
m
)
mergeSyncedButChangedItems ::
forall i a.
Ord i =>
Map i (Timed a) ->
Map i ServerTime ->
(Map i (Timed a), Map i (Timed a))
mergeSyncedButChangedItems local changed = M.foldlWithKey go (M.empty, M.empty) local
where
go :: (Map i (Timed a), Map i (Timed a)) -> i -> Timed a -> (Map i (Timed a), Map i (Timed a))
go (m1, m2) k t =
case M.lookup k changed of
Nothing -> (M.insert k t m1, m2)
Just st' -> (m1, M.insert k (t {timedTime = st'}) m2)
mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b
mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s
data ClientSyncProcessor ci si a (m :: * -> *)
= ClientSyncProcessor
{
clientSyncProcessorQuerySyncedButChangedValues :: !(Set si -> m (Map si (Timed a))),
clientSyncProcessorSyncClientAdded :: !(Map ci (ClientAddition si) -> m ()),
clientSyncProcessorSyncClientChanged :: !(Map si ServerTime -> m ()),
clientSyncProcessorSyncClientDeleted :: !(Set si -> m ()),
clientSyncProcessorSyncMergedConflict :: !(Map si (Timed a) -> m ()),
clientSyncProcessorSyncServerAdded :: !(Map si (Timed a) -> m ()),
clientSyncProcessorSyncServerChanged :: !(Map si (Timed a) -> m ()),
clientSyncProcessorSyncServerDeleted :: !(Set si -> m ())
}
deriving (Generic)
mergeSyncResponseCustom :: (Ord si, Monad m) => ItemMergeStrategy a -> ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()
mergeSyncResponseCustom ItemMergeStrategy {..} ClientSyncProcessor {..} SyncResponse {..} = do
let resolvedClientDeletedConflicts = mergeClientDeletedConflicts itemMergeStrategyMergeClientDeletedConflict syncResponseConflictsClientDeleted
clientChangeConflicts <- clientSyncProcessorQuerySyncedButChangedValues $ M.keysSet syncResponseConflicts
let (_, mergedChangeConflicts, resolvedChangeConflicts) = mergeSyncedButChangedConflicts itemMergeStrategyMergeChangeConflict clientChangeConflicts syncResponseConflicts
clientServerDeletedConflicts <- clientSyncProcessorQuerySyncedButChangedValues syncResponseConflictsServerDeleted
let resolvedServerDeletedConflicts = mergeServerDeletedConflicts itemMergeStrategyMergeServerDeletedConflict clientServerDeletedConflicts
clientSyncProcessorSyncServerAdded $ M.union syncResponseServerAdded resolvedClientDeletedConflicts
clientSyncProcessorSyncServerChanged $ M.union syncResponseServerChanged resolvedChangeConflicts
clientSyncProcessorSyncServerDeleted $ S.union syncResponseServerDeleted resolvedServerDeletedConflicts
clientSyncProcessorSyncMergedConflict mergedChangeConflicts
clientSyncProcessorSyncClientDeleted syncResponseClientDeleted
clientSyncProcessorSyncClientChanged syncResponseClientChanged
clientSyncProcessorSyncClientAdded syncResponseClientAdded
mergeSyncedButChangedConflicts ::
forall si a.
Ord si =>
(a -> a -> ChangeConflictResolution a) ->
Map si (Timed a) ->
Map si (Timed a) ->
(Map si (Timed a), Map si (Timed a), Map si (Timed a))
mergeSyncedButChangedConflicts func clientItems =
M.foldlWithKey go (M.empty, M.empty, M.empty)
where
go ::
(Map si (Timed a), Map si (Timed a), Map si (Timed a)) ->
si ->
Timed a ->
(Map si (Timed a), Map si (Timed a), Map si (Timed a))
go tup@(unresolved, merged, resolved) key s@(Timed si st) = case M.lookup key clientItems of
Nothing -> tup
Just c@(Timed ci _) -> case func ci si of
KeepLocal ->
(M.insert key c unresolved, merged, resolved)
Merged mi ->
(unresolved, M.insert key (Timed mi st) merged, M.insert key s resolved)
TakeRemote ->
(unresolved, merged, M.insert key s resolved)
mergeClientDeletedConflicts ::
(a -> ClientDeletedConflictResolution) ->
Map si (Timed a) ->
Map si (Timed a)
mergeClientDeletedConflicts func = M.filter $ \(Timed si _) ->
case func si of
TakeRemoteChange -> True
StayDeleted -> False
mergeServerDeletedConflicts ::
(a -> ServerDeletedConflictResolution) ->
Map si (Timed a) ->
Set si
mergeServerDeletedConflicts func m = M.keysSet $ flip M.filter m $ \(Timed si _) -> case func si of
KeepLocalChange -> False
Delete -> True
data Identifier ci si
= OnlyServer si
| BothServerAndClient si ci
deriving (Show, Eq, Ord, Generic)
instance (Validity ci, Validity si) => Validity (Identifier ci si)
instance (NFData ci, NFData si) => NFData (Identifier ci si)
data ServerSyncProcessor ci si a m
= ServerSyncProcessor
{
serverSyncProcessorRead :: !(m (Map si (Timed a))),
serverSyncProcessorAddItem :: !(a -> m si),
serverSyncProcessorChangeItem :: !(si -> ServerTime -> a -> m ()),
serverSyncProcessorDeleteItem :: !(si -> m ())
}
deriving (Generic)
processServerSyncCustom ::
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
serverItems <- serverSyncProcessorRead
syncResponseClientAdded <- forM syncRequestNewItems $ \a -> do
si <- serverSyncProcessorAddItem a
pure $ ClientAddition {clientAdditionId = si, clientAdditionServerTime = initialServerTime}
let decideOnSynced tup@(sc, sd) (si, ct) =
case M.lookup si serverItems of
Nothing -> (sc, S.insert si sd)
Just t@(Timed _ st) ->
if ct >= st
then tup
else (M.insert si t sc, sd)
let (syncResponseServerChanged, syncResponseServerDeleted) = foldl decideOnSynced (M.empty, S.empty) (M.toList syncRequestKnownItems)
let decideOnChanged (cc, cConf, sdc) (si, Timed clientItem ct) = do
case M.lookup si serverItems of
Nothing -> pure (cc, cConf, S.insert si sdc)
Just serverTimed@(Timed _ st) ->
if ct >= st
then do
let st' = incrementServerTime st
serverSyncProcessorChangeItem si st' clientItem
pure (M.insert si st' cc, cConf, sdc)
else do
pure (cc, M.insert si serverTimed cConf, sdc)
(syncResponseClientChanged, syncResponseConflicts, syncResponseConflictsServerDeleted) <- foldM decideOnChanged (M.empty, M.empty, S.empty) (M.toList syncRequestKnownButChangedItems)
let decideOnDeleted (cd, cdc) (si, ct) = do
case M.lookup si serverItems of
Nothing -> do
pure (S.insert si cd, cdc)
Just serverTimed@(Timed _ st) ->
if ct >= st
then do
serverSyncProcessorDeleteItem si
pure (S.insert si cd, cdc)
else do
pure (cd, M.insert si serverTimed cdc)
(syncResponseClientDeleted, syncResponseConflictsClientDeleted) <- foldM decideOnDeleted (S.empty, M.empty) (M.toList syncRequestDeletedItems)
let syncResponseServerAdded = serverItems `M.difference` M.unions [() <$ syncRequestKnownItems, () <$ syncRequestKnownButChangedItems, () <$ syncRequestDeletedItems]
pure SyncResponse {..}
processServerSync ::
forall ci si a m.
( Ord si,
Monad m
) =>
m si ->
ServerStore si a ->
SyncRequest ci si a ->
m (SyncResponse ci si a, ServerStore si a)
processServerSync genId ss sr = runStateT (processServerSyncCustom (pureServerSyncProcessor genId) sr) ss
pureServerSyncProcessor ::
(Ord si, Monad m) =>
m si ->
ServerSyncProcessor ci si a (StateT (ServerStore si a) m)
pureServerSyncProcessor genId = ServerSyncProcessor {..}
where
serverSyncProcessorRead = gets serverStoreItems
serverSyncProcessorAddItem a = do
i <- lift genId
modify (\(ServerStore m) -> ServerStore (M.insert i (Timed a initialServerTime) m))
pure i
serverSyncProcessorChangeItem si st a =
modify
( \(ServerStore m) ->
let m' = M.adjust (const (Timed a st)) si m
in ServerStore m'
)
serverSyncProcessorDeleteItem si =
modify
( \(ServerStore m) ->
let m' = M.delete si m
in ServerStore m'
)
distinct :: Eq a => [a] -> Bool
distinct ls = nub ls == ls