mergeless 0.0.0.0 → 0.1.0.0

raw patch · 2 files changed

+223/−124 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• mergeless.cabal +2/−2
• src/Data/Mergeless.hs +221/−122

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

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