diff --git a/mergeless.cabal b/mergeless.cabal --- 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 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 --- 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.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 @@ , "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 @@ 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,26 +321,86 @@ 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 { centralValue :: !a @@ -307,6 +423,8 @@ 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 @@ -- | 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 @@ -> 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 ::