summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNorfair <>2018-07-08 11:57:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-07-08 11:57:00 (GMT)
commitee2f4f2c04f835a5ca0d21ebe4cfa63abae1291e (patch)
treedc4b1c263c359642187c185861903e9ea64b36f8
parent550e009eab9410b199a94779583195d4fb3c97b4 (diff)
version 0.1.0.00.1.0.0
-rw-r--r--mergeless.cabal4
-rw-r--r--src/Data/Mergeless.hs343
2 files changed, 223 insertions, 124 deletions
diff --git a/mergeless.cabal b/mergeless.cabal
index 81f54b7..2a630c3 100644
--- a/mergeless.cabal
+++ b/mergeless.cabal
@@ -2,10 +2,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 1d48986631abbde319b213203864f3a03d2b7033281b04b021493365844a0eb8
+-- hash: 749159cfb0e485429b445319f97126579e191fed759cadc0903f884e813159a7
name: mergeless
-version: 0.0.0.0
+version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/NorfairKing/mergeless#readme>
homepage: https://github.com/NorfairKing/mergeless#readme
bug-reports: https://github.com/NorfairKing/mergeless/issues
diff --git a/src/Data/Mergeless.hs b/src/Data/Mergeless.hs
index 62c3dae..53f6763 100644
--- a/src/Data/Mergeless.hs
+++ b/src/Data/Mergeless.hs
@@ -43,18 +43,29 @@
-- * 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
- ( Store(..)
- , StoreItem(..)
- , Added(..)
+ ( Added(..)
, Synced(..)
+ , StoreItem(..)
+ , Store(..)
+ , emptyStore
+ , storeSize
+ , addItemToStore
+ , deleteUnsynced
+ , deleteSynced
, SyncRequest(..)
- , makeSyncRequest
, SyncResponse(..)
+ -- * Client-side Synchronisation
+ , makeSyncRequest
, mergeSyncResponse
+ -- * Server-side Synchronisation
+ -- ** General synchronisation
+ , SyncProcessor(..)
+ , processSyncCustom
+ -- ** Synchronisation with a simple central store
, CentralStore(..)
, CentralItem(..)
- , processSync
, processSyncWith
+ , processSync
) where
import Control.Applicative
@@ -73,41 +84,7 @@ import Data.Validity.Containers ()
import Data.Validity.Time ()
import GHC.Generics (Generic)
--- | 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
- ]
-
--- | 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
+{-# 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
@@ -149,6 +126,85 @@ instance (ToJSON i, ToJSON a) => ToJSON (Synced i a) where
, "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))
@@ -229,19 +285,19 @@ instance (ToJSON i, ToJSON a) => ToJSON (SyncResponse i a) where
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
- }
+ { 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 ::
@@ -265,25 +321,85 @@ mergeSyncResponse s SyncResponse {..} =
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
- }
+ 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
@@ -307,6 +423,8 @@ 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
@@ -319,9 +437,7 @@ processSync genId cs sr = do
-- | Process a server-side synchronisation request using a time of syncing, and an identifier generation function.
--
--- 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.
+-- see 'processSyncCustom'
processSyncWith ::
forall i a m. (Ord i, Ord a, Monad m)
=> m i
@@ -329,64 +445,47 @@ processSyncWith ::
-> CentralStore i a
-> SyncRequest i a
-> m (SyncResponse i a, CentralStore i a)
-processSyncWith genUuid now cs SyncRequest {..} =
- flip runStateT cs $ 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
+processSyncWith genUuid now cs sr =
+ flip runStateT cs $
+ processSyncCustom
+ (lift genUuid)
+ now
+ SyncProcessor
+ { syncProcessorDeleteMany = deleteMany
+ , syncProcessorQuerySynced = querySynced
+ , syncProcessorQueryNewRemote = queryNewRemote
+ , syncProcessorInsertMany = insertMany
}
+ sr
where
- deleteUndeleted :: StateT (CentralStore i a) m ()
- deleteUndeleted = deleteMany syncRequestUndeletedItems
deleteMany :: Set i -> StateT (CentralStore i a) m ()
deleteMany s = modC (`M.withoutKeys` s)
- syncItemsToBeDeletedLocally :: StateT (CentralStore i a) m (Set i)
- syncItemsToBeDeletedLocally = do
- foundItems <- query (`M.restrictKeys` syncRequestSyncedItems)
- pure $ syncRequestSyncedItems `S.difference` M.keysSet foundItems
- syncNewRemoteItems :: StateT (CentralStore i a) m (Set (Synced i a))
- syncNewRemoteItems = do
- syncedValues <- query (`M.withoutKeys` syncRequestSyncedItems)
+ 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 syncedValues) $ \(u, CentralItem {..}) ->
+ flip map (M.toList m) $ \(i, CentralItem {..}) ->
Synced
- { syncedUuid = u
- , syncedValue = centralValue
- , syncedCreated = centralCreated
- , syncedSynced = centralSynced
- }
+ { 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
- syncAddedItems :: StateT (CentralStore i a) m (Set (Synced i a))
- syncAddedItems =
- fmap S.fromList $
- forM (S.toList syncRequestAddedItems) $ \Added {..} -> do
- uuid <- lift genUuid
+ insertMany :: Set (Synced i a) -> StateT (CentralStore i a) m ()
+ insertMany s =
+ forM_ (S.toList s) $ \Synced {..} ->
ins
- uuid
+ syncedUuid
CentralItem
- { centralValue = addedValue
- , centralCreated = addedCreated
- , centralSynced = now
- }
- pure
- Synced
- { syncedUuid = uuid
- , syncedCreated = addedCreated
- , syncedSynced = now
- , syncedValue = addedValue
- }
+ { centralValue = syncedValue
+ , centralCreated = syncedCreated
+ , centralSynced = syncedSynced
+ }
ins :: i -> CentralItem a -> StateT (CentralStore i a) m ()
ins i val = modC $ M.insert i val
modC ::