{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Mergeless.Collection
( ClientId(..)
, ClientStore(..)
, emptyClientStore
, storeSize
, addItemToClientStore
, deleteUnsyncedFromClientStore
, deleteSyncedFromClientStore
, SyncRequest(..)
, SyncResponse(..)
, emptySyncResponse
, makeSyncRequest
, mergeSyncResponse
, addRemotelyAddedItems
, addAddedItems
, deleteItemsToBeDeletedLocally
, deleteLocalUndeletedItems
, ServerSyncProcessor(..)
, processServerSyncCustom
, 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) #-}
newtype ClientId =
ClientId
{ unClientId :: Word64
}
deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)
instance Validity ClientId
instance NFData ClientId
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]
emptyClientStore :: ClientStore i a
emptyClientStore =
ClientStore
{clientStoreAdded = M.empty, clientStoreSynced = M.empty, clientStoreDeleted = S.empty}
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
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}
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
}
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
]
makeSyncRequest :: (Ord i, Ord a) => ClientStore i a -> SyncRequest i a
makeSyncRequest ClientStore {..} =
SyncRequest
{ syncRequestAdded = clientStoreAdded
, syncRequestSynced = M.keysSet clientStoreSynced
, syncRequestDeleted = clientStoreDeleted
}
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
}
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}
data ServerSyncProcessor i a m =
ServerSyncProcessor
{ serverSyncProcessorDeleteMany :: Set i -> m (Set i)
, serverSyncProcessorQueryNoLongerSynced :: Set i -> m (Set i)
, serverSyncProcessorQueryNewRemote :: Set i -> m (Map i a)
, serverSyncProcessorInsertMany :: Map ClientId a -> m (Map ClientId i)
}
deriving (Generic)
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
deletedRemotely <- syncItemsToBeDeletedLocally
newRemoteItems <- syncNewRemoteItems
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
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)
emptyServerStore :: ServerStore i a
emptyServerStore = ServerStore {serverStoreItems = M.empty}
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)