version 0.1.0.00.1.0.0

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 ::