summaryrefslogtreecommitdiff
path: root/src/Data/Mergeless.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Mergeless.hs')
-rw-r--r--src/Data/Mergeless.hs401
1 files changed, 401 insertions, 0 deletions
diff --git a/src/Data/Mergeless.hs b/src/Data/Mergeless.hs
new file mode 100644
index 0000000..62c3dae
--- /dev/null
+++ b/src/Data/Mergeless.hs
@@ -0,0 +1,401 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | A way to synchronise items without merge conflicts.
+--
+-- This concept has a few requirements:
+--
+-- * Items must be immutable.
+-- * Items must allow for a centrally unique identifier.
+-- * Identifiers for items must be generatable in such a way that they are certainly unique.
+--
+-- Should mutation be a requirement, then it can be build such that it entails deleting the old version and creating a new version that is the modification of the old version.
+--
+--
+-- There are a few obvious candidates for identifiers:
+--
+-- * incremental identifiers
+-- * universally unique identifiers (recommended).
+--
+--
+--
+-- The typical setup is as follows:
+--
+-- * A central server is set up to synchronise with
+-- * Each client synchronises with the central server, but never with eachother
+--
+--
+-- A central server should operate as follows:
+--
+-- * The server accepts a 'SyncRequest'.
+-- * The server performs operations according to the functionality of 'processSync'.
+-- * The server respons with a 'SyncResponse'.
+--
+--
+-- A client should operate as follows:
+--
+-- * The client produces a 'SyncRequest' with 'makeSyncRequest'.
+-- * 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(..)
+ , Synced(..)
+ , SyncRequest(..)
+ , makeSyncRequest
+ , SyncResponse(..)
+ , mergeSyncResponse
+ , CentralStore(..)
+ , CentralItem(..)
+ , processSync
+ , processSyncWith
+ ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.State.Strict
+import Data.Aeson
+import Data.List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import qualified Data.Set as S
+import Data.Set (Set)
+import Data.Time
+import Data.Validity
+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
+
+-- | A local item of type @a@ that has been added but not synchronised yet
+data Added a = Added
+ { addedValue :: !a
+ , addedCreated :: !UTCTime
+ } deriving (Show, Eq, Ord, Generic)
+
+instance Validity a => Validity (Added a)
+
+instance FromJSON a => FromJSON (Added a) where
+ parseJSON =
+ withObject "Added" $ \o -> Added <$> o .: "value" <*> o .: "added"
+
+instance ToJSON a => ToJSON (Added a) where
+ toJSON Added {..} = object ["value" .= addedValue, "added" .= addedCreated]
+
+-- | A local item of type @a@ with an identifier of type @a@ that has been synchronised
+data Synced i a = Synced
+ { syncedUuid :: i
+ , syncedValue :: !a
+ , syncedCreated :: !UTCTime
+ , syncedSynced :: !UTCTime
+ } deriving (Show, Eq, Ord, Generic)
+
+instance (Validity i, Validity a) => Validity (Synced i a)
+
+instance (FromJSON i, FromJSON a) => FromJSON (Synced i a) where
+ parseJSON =
+ withObject "Synced" $ \o ->
+ Synced <$> o .: "id" <*> o .: "value" <*> o .: "created" <*>
+ o .: "synced"
+
+instance (ToJSON i, ToJSON a) => ToJSON (Synced i a) where
+ toJSON Synced {..} =
+ object
+ [ "id" .= syncedUuid
+ , "value" .= syncedValue
+ , "created" .= syncedCreated
+ , "synced" .= syncedSynced
+ ]
+
+-- | A synchronisation request for items with identifiers of type @i@ and values of type @a@
+data SyncRequest i a = SyncRequest
+ { syncRequestAddedItems :: !(Set (Added a))
+ , syncRequestSyncedItems :: !(Set i)
+ , syncRequestUndeletedItems :: !(Set i)
+ } deriving (Show, Eq, Ord, Generic)
+
+instance (Validity i, Validity a, Ord i, Ord a) =>
+ Validity (SyncRequest i a) where
+ validate SyncRequest {..} =
+ mconcat
+ [ annotate syncRequestAddedItems "syncRequestAddedItems"
+ , annotate syncRequestSyncedItems "syncRequestSyncedItems"
+ , annotate syncRequestUndeletedItems "syncRequestUndeletedItems"
+ , declare "the sync request items have distinct ids" $
+ distinct $
+ S.toList syncRequestSyncedItems ++
+ S.toList syncRequestUndeletedItems
+ ]
+
+instance (FromJSON i, FromJSON a, Ord i, Ord a) =>
+ FromJSON (SyncRequest i a) where
+ parseJSON =
+ withObject "SyncRequest" $ \o ->
+ SyncRequest <$> o .: "unsynced" <*> o .: "synced" <*>
+ o .: "undeleted"
+
+instance (ToJSON i, ToJSON a) => ToJSON (SyncRequest i a) where
+ toJSON SyncRequest {..} =
+ object
+ [ "unsynced" .= syncRequestAddedItems
+ , "synced" .= syncRequestSyncedItems
+ , "undeleted" .= syncRequestUndeletedItems
+ ]
+
+-- | A synchronisation response for items with identifiers of type @i@ and values of type @a@
+data SyncResponse i a = SyncResponse
+ { syncResponseAddedItems :: !(Set (Synced i a))
+ , syncResponseNewRemoteItems :: !(Set (Synced i a))
+ , syncResponseItemsToBeDeletedLocally :: !(Set i)
+ } deriving (Show, Eq, Ord, Generic)
+
+instance (Validity i, Validity a, Ord i, Ord a) =>
+ Validity (SyncResponse i a) where
+ validate SyncResponse {..} =
+ mconcat
+ [ annotate syncResponseAddedItems "syncResponseAddedItems"
+ , annotate syncResponseNewRemoteItems "syncResponseNewRemoteItems"
+ , annotate
+ syncResponseItemsToBeDeletedLocally
+ "syncResponseItemsToBeDeletedLocally"
+ , declare "the sync response items have distinct uuids" $
+ distinct $
+ map
+ syncedUuid
+ (S.toList syncResponseAddedItems ++
+ S.toList syncResponseNewRemoteItems) ++
+ S.toList syncResponseItemsToBeDeletedLocally
+ ]
+
+instance (FromJSON i, FromJSON a, Ord i, Ord a) =>
+ FromJSON (SyncResponse i a) where
+ parseJSON =
+ withObject "SyncResponse" $ \o ->
+ SyncResponse <$> o .: "added" <*> o .: "new" <*> o .: "deleted"
+
+instance (ToJSON i, ToJSON a) => ToJSON (SyncResponse i a) where
+ toJSON SyncResponse {..} =
+ object
+ [ "added" .= syncResponseAddedItems
+ , "new" .= syncResponseNewRemoteItems
+ , "deleted" .= syncResponseItemsToBeDeletedLocally
+ ]
+
+-- | Produce a synchronisation request for a client-side store.
+--
+-- This request can then be sent to a central store for synchronisation.
+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
+ }
+
+-- | Merge a synchronisation response back into a client-side store.
+mergeSyncResponse ::
+ (Ord i, Ord a) => Store i a -> SyncResponse i a -> Store i a
+mergeSyncResponse s SyncResponse {..} =
+ let withNewOwnItems =
+ flip mapSetMaybe (storeItems s) $ \si ->
+ case si of
+ UnsyncedItem Added {..} ->
+ case find
+ (\Synced {..} ->
+ syncedCreated == addedCreated &&
+ syncedValue == addedValue)
+ syncResponseAddedItems of
+ Nothing -> Just si -- If it wasn't added (for whatever reason), just leave it as unsynced
+ Just ii -> Just $ SyncedItem ii -- If it was added, then it becomes synced
+ SyncedItem ii ->
+ case find
+ (== syncedUuid ii)
+ syncResponseItemsToBeDeletedLocally of
+ 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
+ }
+
+-- | An item in a central store with a value of type @a@
+data CentralItem a = CentralItem
+ { centralValue :: !a
+ , centralSynced :: !UTCTime
+ , centralCreated :: !UTCTime
+ } deriving (Show, Eq, Ord, Generic)
+
+instance Validity a => Validity (CentralItem a)
+
+instance FromJSON a => FromJSON (CentralItem a)
+
+instance ToJSON a => ToJSON (CentralItem a)
+
+-- | A central store of items with identifiers of type @i@ and values of type @a@
+newtype CentralStore i a = CentralStore
+ { centralStoreItems :: Map i (CentralItem a)
+ } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+instance (Validity i, Validity a, Ord i, Ord a) =>
+ Validity (CentralStore i a)
+
+-- | Process a server-side synchronisation request using @getCurrentTime@
+processSync ::
+ (Ord i, Ord a, MonadIO m)
+ => m i
+ -> CentralStore i a
+ -> SyncRequest i a
+ -> m (SyncResponse i a, CentralStore i a)
+processSync genId cs sr = do
+ now <- liftIO getCurrentTime
+ processSyncWith genId now cs sr
+
+-- | 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.
+processSyncWith ::
+ forall i a m. (Ord i, Ord a, Monad m)
+ => m i
+ -> UTCTime
+ -> 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
+ }
+ 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)
+ pure $
+ S.fromList $
+ flip map (M.toList syncedValues) $ \(u, CentralItem {..}) ->
+ Synced
+ { syncedUuid = u
+ , syncedValue = centralValue
+ , syncedCreated = centralCreated
+ , syncedSynced = centralSynced
+ }
+ 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
+ ins
+ uuid
+ CentralItem
+ { centralValue = addedValue
+ , centralCreated = addedCreated
+ , centralSynced = now
+ }
+ pure
+ Synced
+ { syncedUuid = uuid
+ , syncedCreated = addedCreated
+ , syncedSynced = now
+ , syncedValue = addedValue
+ }
+ ins :: i -> CentralItem a -> StateT (CentralStore i a) m ()
+ ins i val = modC $ M.insert i val
+ modC ::
+ (Map i (CentralItem a) -> Map i (CentralItem a))
+ -> StateT (CentralStore i a) m ()
+ modC func = modify (\(CentralStore m) -> CentralStore $ func m)
+
+mapSetMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
+mapSetMaybe func = S.map fromJust . S.filter isJust . S.map func
+
+distinct :: Ord a => [a] -> Bool
+distinct ls = sort ls == S.toAscList (S.fromList ls)