diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ # Changelog -## [Unreleased] +## [0.3.0.0] - 2022-06-19 + +### Added + +* `autodocodec` support + +### Changed + +* Fixed a bug in which the `ValueSyncResponse` serialised conflicting values to JSON strangely. +* Fixed a bug in which the `ItemSyncResponseConflict` and `ItemSyncResponseConflict` serialised conflicting values to JSON strangely. ## [0.2.0.0] - 2020-05-21 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018-2019 Tom Sydney Kerckhove +Copyright (c) 2018-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,1 +0,0 @@ -# mergeful diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/mergeful.cabal b/mergeful.cabal --- a/mergeful.cabal +++ b/mergeful.cabal @@ -1,24 +1,23 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack -- --- hash: 5c04518a45f3748d42c829e645b69f607f23450b79fa96bcd6c567976b0465b7 +-- hash: 257049459827bc46485c454fe83f602efd9c34332aceaeb318f90a161c06082a name: mergeful -version: 0.2.0.0 +version: 0.3.0.0 description: Please see the README on GitHub at homepage: https://github.com/NorfairKing/mergeful#readme bug-reports: https://github.com/NorfairKing/mergeful/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2019-2020 Tom Sydney Kerckhove +copyright: Copyright: (c) 2018-2022 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple extra-source-files: - README.md CHANGELOG.md source-repository head @@ -39,6 +38,7 @@ ghc-options: -Wall -fwarn-redundant-constraints build-depends: aeson + , autodocodec , base >=4.7 && <5 , containers , deepseq diff --git a/src/Data/Mergeful/Collection.hs b/src/Data/Mergeful/Collection.hs --- a/src/Data/Mergeful/Collection.hs +++ b/src/Data/Mergeful/Collection.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -58,7 +59,7 @@ changeItemInClientStore, deleteItemFromClientStore, - -- ** Maxing a sync request + -- ** Making a sync request SyncRequest (..), initialSyncRequest, makeSyncRequest, @@ -107,20 +108,20 @@ ) where +import Autodocodec import Control.Applicative import Control.DeepSeq import Control.Monad import Control.Monad.State -import Data.Aeson +import Data.Aeson (FromJSON, FromJSONKey (..), ToJSON, ToJSONKey (..)) +import Data.Kind import Data.List import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe import Data.Mergeful.Item import Data.Mergeful.Timed import Data.Set (Set) import qualified Data.Set as S -import Data.Text (Text) import Data.Validity import Data.Validity.Containers () import Data.Word @@ -129,31 +130,35 @@ -- | A Client-side identifier for items. -- -- These only need to be unique at the client. -newtype ClientId - = ClientId - { unClientId :: Word64 - } - deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey) +newtype ClientId = ClientId + { unClientId :: Word64 + } + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Enum, Bounded, ToJSONKey, FromJSONKey) + deriving (FromJSON, ToJSON) via (Autodocodec ClientId) instance Validity ClientId instance NFData ClientId -data ClientStore ci si a - = ClientStore - { -- | These items are new locally but have not been synced to the server yet. - clientStoreAddedItems :: Map ci a, - -- | These items have been synced at their respective 'ServerTime's. - clientStoreSyncedItems :: Map si (Timed a), - -- | These items have been synced at their respective 'ServerTime's - -- but modified locally since then. - clientStoreSyncedButChangedItems :: Map si (Timed a), - -- | These items have been deleted locally after they were synced - -- but the server has not been notified of that yet. - clientStoreDeletedItems :: Map si ServerTime - } - deriving (Show, Eq, Generic) +instance HasCodec ClientId where + codec = dimapCodec ClientId unClientId codec "ClientId" +data ClientStore ci si a = ClientStore + { -- | These items are new locally but have not been synced to the server yet. + clientStoreAddedItems :: !(Map ci a), + -- | These items have been synced at their respective 'ServerTime's. + clientStoreSyncedItems :: !(Map si (Timed a)), + -- | These items have been synced at their respective 'ServerTime's + -- but modified locally since then. + clientStoreSyncedButChangedItems :: !(Map si (Timed a)), + -- | These items have been deleted locally after they were synced + -- but the server has not been notified of that yet. + clientStoreDeletedItems :: !(Map si ServerTime) + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ClientStore ci si a)) + instance (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => Validity (ClientStore ci si a) @@ -161,36 +166,36 @@ validate cs@ClientStore {..} = mconcat [ genericValidate cs, - declare "There are no duplicate IDs" - $ distinct - $ concat - [ M.keys clientStoreSyncedItems, - M.keys clientStoreSyncedButChangedItems, - M.keys clientStoreDeletedItems - ] + declare "There are no duplicate IDs" $ + distinct $ + concat + [ M.keys clientStoreSyncedItems, + M.keys clientStoreSyncedButChangedItems, + M.keys clientStoreDeletedItems + ] ] instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a) instance - (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) => - FromJSON (ClientStore ci si a) + ( Ord ci, + FromJSONKey ci, + ToJSONKey ci, + Ord si, + FromJSONKey si, + ToJSONKey si, + Eq a, + HasCodec a + ) => + HasCodec (ClientStore ci si a) where - parseJSON = - withObject "ClientStore" $ \o -> - ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty - <*> o .:? "changed" .!= M.empty - <*> o .:? "deleted" .!= M.empty - -instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where - toJSON ClientStore {..} = - object $ - catMaybes - [ jNull "added" clientStoreAddedItems, - jNull "synced" clientStoreSyncedItems, - jNull "changed" clientStoreSyncedButChangedItems, - jNull "deleted" clientStoreDeletedItems - ] + codec = + object "ClientStore" $ + ClientStore + <$> optionalFieldWithOmittedDefault "added" M.empty "added items" .= clientStoreAddedItems + <*> optionalFieldWithOmittedDefault "synced" M.empty "synced items" .= clientStoreSyncedItems + <*> optionalFieldWithOmittedDefault "changed" M.empty "changed items" .= clientStoreSyncedButChangedItems + <*> optionalFieldWithOmittedDefault "deleted" M.empty "deleted items" .= clientStoreDeletedItems -- | A client store to start with. -- @@ -335,38 +340,48 @@ deleteItemFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a deleteItemFromClientStore i cs = cs {clientStoreAddedItems = M.delete i (clientStoreAddedItems cs)} -newtype ServerStore si a - = ServerStore - { -- | A map of items, named using an 'si', together with the 'ServerTime' at which - -- they were last synced. - serverStoreItems :: Map si (Timed a) - } - deriving (Show, Eq, Generic, FromJSON, ToJSON) +newtype ServerStore si a = ServerStore + { -- | A map of items, named using an 'si', together with the 'ServerTime' at which + -- they were last synced. + serverStoreItems :: Map si (Timed a) + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ServerStore si a)) instance (Validity si, Show si, Ord si, Validity a) => Validity (ServerStore si a) instance (NFData si, NFData a) => NFData (ServerStore si a) +instance + ( Ord si, + FromJSONKey si, + ToJSONKey si, + HasCodec a + ) => + HasCodec (ServerStore si a) + where + codec = dimapCodec ServerStore serverStoreItems codec + -- | A server store to start with -- -- This store contains no items. initialServerStore :: ServerStore si a initialServerStore = ServerStore {serverStoreItems = M.empty} -data SyncRequest ci si a - = SyncRequest - { -- | These items are new locally but have not been synced to the server yet. - syncRequestNewItems :: !(Map ci a), - -- | These items have been synced at their respective 'ServerTime's. - syncRequestKnownItems :: !(Map si ServerTime), - -- | These items have been synced at their respective 'ServerTime's - -- but modified locally since then. - syncRequestKnownButChangedItems :: !(Map si (Timed a)), - -- | These items have been deleted locally after they were synced - -- but the server has not been notified of that yet. - syncRequestDeletedItems :: !(Map si ServerTime) - } - deriving (Show, Eq, Generic) +data SyncRequest ci si a = SyncRequest + { -- | These items are new locally but have not been synced to the server yet. + syncRequestNewItems :: !(Map ci a), + -- | These items have been synced at their respective 'ServerTime's. + syncRequestKnownItems :: !(Map si ServerTime), + -- | These items have been synced at their respective 'ServerTime's + -- but modified locally since then. + syncRequestKnownButChangedItems :: !(Map si (Timed a)), + -- | These items have been deleted locally after they were synced + -- but the server has not been notified of that yet. + syncRequestDeletedItems :: !(Map si ServerTime) + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (SyncRequest ci si a)) instance (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => @@ -375,36 +390,36 @@ validate sr@SyncRequest {..} = mconcat [ genericValidate sr, - declare "There are no duplicate IDs" - $ distinct - $ concat - [ M.keys syncRequestKnownItems, - M.keys syncRequestKnownButChangedItems, - M.keys syncRequestDeletedItems - ] + declare "There are no duplicate IDs" $ + distinct $ + concat + [ M.keys syncRequestKnownItems, + M.keys syncRequestKnownButChangedItems, + M.keys syncRequestDeletedItems + ] ] instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a) instance - (Ord ci, Ord si, FromJSONKey ci, FromJSONKey si, FromJSON a) => - FromJSON (SyncRequest ci si a) + ( Ord ci, + FromJSONKey ci, + ToJSONKey ci, + Ord si, + FromJSONKey si, + ToJSONKey si, + Eq a, + HasCodec a + ) => + HasCodec (SyncRequest ci si a) where - parseJSON = - withObject "SyncRequest" $ \o -> - SyncRequest <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty - <*> o .:? "changed" .!= M.empty - <*> o .:? "deleted" .!= M.empty - -instance (ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncRequest ci si a) where - toJSON SyncRequest {..} = - object $ - catMaybes - [ jNull "added" syncRequestNewItems, - jNull "synced" syncRequestKnownItems, - jNull "changed" syncRequestKnownButChangedItems, - jNull "deleted" syncRequestDeletedItems - ] + codec = + object "SyncRequest" $ + SyncRequest + <$> optionalFieldWithOmittedDefault "added" M.empty "new items" .= syncRequestNewItems + <*> optionalFieldWithOmittedDefault "synced" M.empty "known items" .= syncRequestKnownItems + <*> optionalFieldWithOmittedDefault "changed" M.empty "known but changed items" .= syncRequestKnownButChangedItems + <*> optionalFieldWithOmittedDefault "deleted" M.empty "deleted items" .= syncRequestDeletedItems -- | An intial 'SyncRequest' to start with. -- @@ -418,66 +433,67 @@ syncRequestDeletedItems = M.empty } -data ClientAddition i - = ClientAddition - { clientAdditionId :: i, - clientAdditionServerTime :: ServerTime - } - deriving (Show, Eq, Generic) +data ClientAddition i = ClientAddition + { clientAdditionId :: !i, + clientAdditionServerTime :: !ServerTime + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ClientAddition i)) instance Validity i => Validity (ClientAddition i) instance NFData i => NFData (ClientAddition i) -instance FromJSON i => FromJSON (ClientAddition i) where - parseJSON = withObject "ClientAddition" $ \o -> ClientAddition <$> o .: "id" <*> o .: "time" - -instance ToJSON i => ToJSON (ClientAddition i) where - toJSON ClientAddition {..} = object ["id" .= clientAdditionId, "time" .= clientAdditionServerTime] +instance HasCodec i => HasCodec (ClientAddition i) where + codec = + object "ClientAddition" $ + ClientAddition + <$> requiredField "id" "client-side identifier" .= clientAdditionId + <*> requiredField "time" "server-side time" .= clientAdditionServerTime -data SyncResponse ci si a - = SyncResponse - { -- | The client added these items and server has succesfully been made aware of that. - -- - -- The client needs to update their server times - syncResponseClientAdded :: !(Map ci (ClientAddition si)), - -- | The client changed these items and server has succesfully been made aware of that. - -- - -- The client needs to update their server times - syncResponseClientChanged :: !(Map si ServerTime), - -- | The client deleted these items and server has succesfully been made aware of that. - -- - -- The client can delete them from its deleted items - syncResponseClientDeleted :: !(Set si), - -- | These items have been added on the server side - -- - -- The client should add them too. - syncResponseServerAdded :: !(Map si (Timed a)), - -- | These items have been modified on the server side. - -- - -- The client should modify them too. - syncResponseServerChanged :: !(Map si (Timed a)), - -- | These items were deleted on the server side - -- - -- The client should delete them too - syncResponseServerDeleted :: !(Set si), - -- | These are conflicts where the server and the client both have an item, but it is different. - -- - -- The server kept its part of each, the client can either take whatever the server gave them - -- or deal with the conflicts somehow, and then try to re-sync. - syncResponseConflicts :: !(Map si (Timed a)), - -- | These are conflicts where the server has an item but the client does not. - -- - -- The server kept its item, the client can either take whatever the server gave them - -- or deal with the conflicts somehow, and then try to re-sync. - syncResponseConflictsClientDeleted :: !(Map si (Timed a)), - -- | These are conflicts where the server has no item but the client has a modified item. - -- - -- The server left its item deleted, the client can either delete its items too - -- or deal with the conflicts somehow, and then try to re-sync. - syncResponseConflictsServerDeleted :: !(Set si) - } - deriving (Show, Eq, Generic) +data SyncResponse ci si a = SyncResponse + { -- | The client added these items and server has succesfully been made aware of that. + -- + -- The client needs to update their server times + syncResponseClientAdded :: !(Map ci (ClientAddition si)), + -- | The client changed these items and server has succesfully been made aware of that. + -- + -- The client needs to update their server times + syncResponseClientChanged :: !(Map si ServerTime), + -- | The client deleted these items and server has succesfully been made aware of that. + -- + -- The client can delete them from its deleted items + syncResponseClientDeleted :: !(Set si), + -- | These items have been added on the server side + -- + -- The client should add them too. + syncResponseServerAdded :: !(Map si (Timed a)), + -- | These items have been modified on the server side. + -- + -- The client should modify them too. + syncResponseServerChanged :: !(Map si (Timed a)), + -- | These items were deleted on the server side + -- + -- The client should delete them too + syncResponseServerDeleted :: !(Set si), + -- | These are conflicts where the server and the client both have an item, but it is different. + -- + -- The server kept its part of each, the client can either take whatever the server gave them + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflicts :: !(Map si (Timed a)), + -- | These are conflicts where the server has an item but the client does not. + -- + -- The server kept its item, the client can either take whatever the server gave them + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflictsClientDeleted :: !(Map si (Timed a)), + -- | These are conflicts where the server has no item but the client has a modified item. + -- + -- The server left its item deleted, the client can either delete its items too + -- or deal with the conflicts somehow, and then try to re-sync. + syncResponseConflictsServerDeleted :: !(Set si) + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (SyncResponse ci si a)) instance (Validity ci, Validity si, Show ci, Show si, Ord ci, Ord si, Validity a) => @@ -486,55 +502,49 @@ validate sr@SyncResponse {..} = mconcat [ genericValidate sr, - declare "There are no duplicate IDs" - $ distinct - $ concat - [ map (\(_, ClientAddition {..}) -> clientAdditionId) $ M.toList syncResponseClientAdded, - M.keys syncResponseClientChanged, - S.toList syncResponseClientDeleted, - M.keys syncResponseServerAdded, - M.keys syncResponseServerChanged, - S.toList syncResponseServerDeleted, - M.keys syncResponseConflicts, - M.keys syncResponseConflictsClientDeleted, - S.toList syncResponseConflictsServerDeleted - ] + declare "There are no duplicate IDs" $ + distinct $ + concat + [ map (\(_, ClientAddition {..}) -> clientAdditionId) $ M.toList syncResponseClientAdded, + M.keys syncResponseClientChanged, + S.toList syncResponseClientDeleted, + M.keys syncResponseServerAdded, + M.keys syncResponseServerChanged, + S.toList syncResponseServerDeleted, + M.keys syncResponseConflicts, + M.keys syncResponseConflictsClientDeleted, + S.toList syncResponseConflictsServerDeleted + ] ] instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a) instance - (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, FromJSON a) => - FromJSON (SyncResponse ci si a) - where - parseJSON = - withObject "SyncResponse" $ \o -> - SyncResponse <$> o .:? "client-added" .!= M.empty <*> o .:? "client-changed" .!= M.empty - <*> o .:? "client-deleted" .!= S.empty - <*> o .:? "server-added" .!= M.empty - <*> o .:? "server-changed" .!= M.empty - <*> o .:? "server-deleted" .!= S.empty - <*> o .:? "conflict" .!= M.empty - <*> o .:? "conflict-client-deleted" .!= M.empty - <*> o .:? "conflict-server-deleted" .!= S.empty - -instance - (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) => - ToJSON (SyncResponse ci si a) + ( Ord ci, + FromJSONKey ci, + ToJSONKey ci, + HasCodec ci, + Ord si, + FromJSONKey si, + ToJSONKey si, + HasCodec si, + Eq a, + HasCodec a + ) => + HasCodec (SyncResponse ci si a) where - toJSON SyncResponse {..} = - object $ - catMaybes - [ jNull "client-added" syncResponseClientAdded, - jNull "client-changed" syncResponseClientChanged, - jNull "client-deleted" syncResponseClientDeleted, - jNull "server-added" syncResponseServerAdded, - jNull "server-changed" syncResponseServerChanged, - jNull "server-deleted" syncResponseServerDeleted, - jNull "conflict" syncResponseConflicts, - jNull "conflict-client-deleted" syncResponseConflictsClientDeleted, - jNull "conflict-server-deleted" syncResponseConflictsServerDeleted - ] + codec = + object "SyncResponse" $ + SyncResponse + <$> optionalFieldWithOmittedDefault "client-added" M.empty "items added by the client" .= syncResponseClientAdded + <*> optionalFieldWithOmittedDefault "client-changed" M.empty "items changed by the client" .= syncResponseClientChanged + <*> optionalFieldWithOmittedDefault "client-deleted" S.empty "items deleted by the client" .= syncResponseClientDeleted + <*> optionalFieldWithOmittedDefault "server-added" M.empty "items added by the server" .= syncResponseServerAdded + <*> optionalFieldWithOmittedDefault "server-changed" M.empty "items changed by the server" .= syncResponseServerChanged + <*> optionalFieldWithOmittedDefault "server-deleted" S.empty "items deleted by the server" .= syncResponseServerDeleted + <*> optionalFieldWithOmittedDefault "conflict" M.empty "items that were changed simultaneously" .= syncResponseConflicts + <*> optionalFieldWithOmittedDefault "conflict-client-deleted" M.empty "items that the server changed while the client deleted it" .= syncResponseConflictsClientDeleted + <*> optionalFieldWithOmittedDefault "conflict-server-deleted" S.empty "items that the client changed while the server deleted it" .= syncResponseConflictsServerDeleted -- | A sync response to start with. -- @@ -553,12 +563,6 @@ syncResponseConflictsServerDeleted = S.empty } -jNull :: (Foldable f, ToJSON (f b)) => Text -> f b -> Maybe (Text, Value) -jNull n s = - if null s - then Nothing - else Just $ n .= s - -- | Produce an 'SyncRequest' from a 'ClientStore'. -- -- Send this to the server for synchronisation. @@ -637,12 +641,32 @@ let leftovers = mergeDeletedItems (clientStoreDeletedItems cs) s in cs {clientStoreDeletedItems = leftovers} ), - clientSyncProcessorSyncMergedConflict = \resolved -> + clientSyncProcessorSyncChangeConflictKeepLocal = \_ -> pure (), + clientSyncProcessorSyncChangeConflictMerged = \resolved -> modify ( \cs -> let newSyncedButChanged = M.union resolved (clientStoreSyncedButChangedItems cs) in cs {clientStoreSyncedButChangedItems = newSyncedButChanged, clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` newSyncedButChanged} ), + clientSyncProcessorSyncChangeConflictTakeRemote = \m -> + modify + ( \cs -> + let newSynced = m `M.union` clientStoreSyncedItems cs + in cs {clientStoreSyncedItems = newSynced, clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` newSynced} + ), + clientSyncProcessorSyncClientDeletedConflictTakeRemoteChanged = \m -> + modify (\cs -> cs {clientStoreSyncedItems = m `M.union` clientStoreSyncedItems cs}), + clientSyncProcessorSyncClientDeletedConflictStayDeleted = \_ -> pure (), + clientSyncProcessorSyncServerDeletedConflictKeepLocalChange = \_ -> pure (), + clientSyncProcessorSyncServerDeletedConflictDelete = \s -> + modify + ( \cs -> + let m = M.fromSet (const ()) s + in cs + { clientStoreSyncedItems = clientStoreSyncedItems cs `M.difference` m, + clientStoreSyncedButChangedItems = clientStoreSyncedButChangedItems cs `M.difference` m + } + ), clientSyncProcessorSyncServerAdded = \m -> modify (\cs -> cs {clientStoreSyncedItems = m `M.union` clientStoreSyncedItems cs}), clientSyncProcessorSyncServerChanged = \m -> @@ -702,44 +726,113 @@ mergeDeletedItems :: Ord i => Map i b -> Set i -> Map i b mergeDeletedItems m s = m `M.difference` M.fromSet (const ()) s -data ClientSyncProcessor ci si a (m :: * -> *) - = ClientSyncProcessor - { -- | Get the synced values with keys in the given set - clientSyncProcessorQuerySyncedButChangedValues :: !(Set si -> m (Map si (Timed a))), - -- | Complete additions that were acknowledged by the server. - -- This involves saving the server id and the server time - clientSyncProcessorSyncClientAdded :: !(Map ci (ClientAddition si) -> m ()), - -- | Complete changes that were acknowledged by the server - -- This involves updating the server time - clientSyncProcessorSyncClientChanged :: !(Map si ServerTime -> m ()), - -- | Complete deletions that were acknowledged by the server - -- This means deleting these tombstoned items entirely - clientSyncProcessorSyncClientDeleted :: !(Set si -> m ()), - -- | Store the items that were in a conflict but the conflict was resolved correctly. - -- These items should be marked as changed. - clientSyncProcessorSyncMergedConflict :: !(Map si (Timed a) -> m ()), - clientSyncProcessorSyncServerAdded :: !(Map si (Timed a) -> m ()), - clientSyncProcessorSyncServerChanged :: !(Map si (Timed a) -> m ()), - clientSyncProcessorSyncServerDeleted :: !(Set si -> m ()) - } +-- | A processor for dealing with @SyncResponse@s on the client side. +-- +-- It has to deal with each of the 13 cases: +-- +-- - server +-- +-- - added +-- - changed +-- - deleted +-- +-- - client +-- +-- - added +-- - changed +-- - deleted +-- +-- - client-deleted conflict +-- +-- - take remote +-- - delete +-- +-- - server-deleted conflict +-- +-- - delete +-- - keep local +-- +-- - change conflict +-- +-- - take remote +-- - merge +-- - keep local +-- +-- It is a lot of work to implement one of these, so make sure to have a look at the mergeful companion packages to see if maybe there is already one for your application domain. +data ClientSyncProcessor ci si a (m :: Type -> Type) = ClientSyncProcessor + { -- | Get the synced values with keys in the given set + clientSyncProcessorQuerySyncedButChangedValues :: !(Set si -> m (Map si (Timed a))), + -- | Complete additions that were acknowledged by the server. + -- + -- This involves saving the server id and the server time + clientSyncProcessorSyncClientAdded :: !(Map ci (ClientAddition si) -> m ()), + -- | Complete changes that were acknowledged by the server + -- + -- This involves updating the server time + clientSyncProcessorSyncClientChanged :: !(Map si ServerTime -> m ()), + -- | Complete deletions that were acknowledged by the server + -- + -- This means deleting these tombstoned items entirely + clientSyncProcessorSyncClientDeleted :: !(Set si -> m ()), + -- | Re-create the items that need to be created locally as a result of a 'client deleted' conflict that has been merged by taking the remote value. + -- + -- You can likely implement this in the same way as @clientSyncProcessorSyncServerAdded@. + clientSyncProcessorSyncClientDeletedConflictTakeRemoteChanged :: !(Map si (Timed a) -> m ()), + -- | Leave the items deleted that need to be left deleted as a result of a 'client deleted' conflict that has been merged by leaving it deleted. + -- + -- You likely don't have to do anything with these, as they are the way that has been decided they should be, but you may want to log them or so. + clientSyncProcessorSyncClientDeletedConflictStayDeleted :: !(Map si (Timed a) -> m ()), + -- | Leave the items undeleted that need to be left deleted as a result of a 'server deleted' conflict that has been merged by leaving it undeleted. + -- + -- You likely don't have to do anything with these, as they are the way that has been decided they should be, but you may want to log them or so. + clientSyncProcessorSyncServerDeletedConflictKeepLocalChange :: !(Set si -> m ()), + -- | Delete the items that need to be deleted locally as a result of a 'server deleted' conflict that has been merged by deleting the local value. + -- + -- You can likely implement this in the same way as @clientSyncProcessorSyncServerDeleted@. + clientSyncProcessorSyncServerDeletedConflictDelete :: !(Set si -> m ()), + -- | Deal with the items for which no conflict was resolved. + -- + -- You likely don't have to do anything with these, as they are the way that has been decided they should be, but you may want to log them or so. + clientSyncProcessorSyncChangeConflictKeepLocal :: !(Map si (Timed a) -> m ()), + -- | Store the items that were in a conflict but the conflict was resolved correctly. + -- These items should be marked as changed. + clientSyncProcessorSyncChangeConflictMerged :: !(Map si (Timed a) -> m ()), + -- | Store the items that were in a conflict but the client will take the remote values + -- These items should be marked as unchanged. + -- + -- You can likely implement this in the same way as @clientSyncProcessorSyncServerChanged@. + clientSyncProcessorSyncChangeConflictTakeRemote :: !(Map si (Timed a) -> m ()), + -- | Store the items that the server added + clientSyncProcessorSyncServerAdded :: !(Map si (Timed a) -> m ()), + -- | Store the items that the server changed + clientSyncProcessorSyncServerChanged :: !(Map si (Timed a) -> m ()), + -- | Store the items that the server deleted + clientSyncProcessorSyncServerDeleted :: !(Set si -> m ()) + } deriving (Generic) mergeSyncResponseCustom :: (Ord si, Monad m) => ItemMergeStrategy a -> ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m () mergeSyncResponseCustom ItemMergeStrategy {..} ClientSyncProcessor {..} SyncResponse {..} = do -- Every client deleted conflict needs to be added, if the sync processor says so - let resolvedClientDeletedConflicts = mergeClientDeletedConflicts itemMergeStrategyMergeClientDeletedConflict syncResponseConflictsClientDeleted + let (remoteChangeToTake, remoteChangesToIgnore) = mergeClientDeletedConflicts itemMergeStrategyMergeClientDeletedConflict syncResponseConflictsClientDeleted -- Every change conflict, unless the client item is kept, needs to be updated -- The unresolved conflicts don't need to be updated. clientChangeConflicts <- clientSyncProcessorQuerySyncedButChangedValues $ M.keysSet syncResponseConflicts - let (_, mergedChangeConflicts, resolvedChangeConflicts) = mergeSyncedButChangedConflicts itemMergeStrategyMergeChangeConflict clientChangeConflicts syncResponseConflicts + let (unresolvedChangeConflicts, mergedChangeConflicts, resolvedChangeConflicts) = mergeSyncedButChangedConflicts itemMergeStrategyMergeChangeConflict clientChangeConflicts syncResponseConflicts -- Every served deleted conflict needs to be deleted, if the sync processor says so clientServerDeletedConflicts <- clientSyncProcessorQuerySyncedButChangedValues syncResponseConflictsServerDeleted - let resolvedServerDeletedConflicts = mergeServerDeletedConflicts itemMergeStrategyMergeServerDeletedConflict clientServerDeletedConflicts + let (localChangesToDelete, localChangesToBeKept) = mergeServerDeletedConflicts itemMergeStrategyMergeServerDeletedConflict clientServerDeletedConflicts -- The order here matters. - clientSyncProcessorSyncServerAdded $ M.union syncResponseServerAdded resolvedClientDeletedConflicts - clientSyncProcessorSyncServerChanged $ M.union syncResponseServerChanged resolvedChangeConflicts - clientSyncProcessorSyncServerDeleted $ S.union syncResponseServerDeleted resolvedServerDeletedConflicts - clientSyncProcessorSyncMergedConflict mergedChangeConflicts + clientSyncProcessorSyncServerAdded syncResponseServerAdded + clientSyncProcessorSyncServerChanged syncResponseServerChanged + clientSyncProcessorSyncServerDeleted syncResponseServerDeleted + clientSyncProcessorSyncChangeConflictTakeRemote resolvedChangeConflicts + clientSyncProcessorSyncChangeConflictMerged mergedChangeConflicts + clientSyncProcessorSyncChangeConflictKeepLocal unresolvedChangeConflicts + clientSyncProcessorSyncClientDeletedConflictTakeRemoteChanged remoteChangeToTake + clientSyncProcessorSyncClientDeletedConflictStayDeleted remoteChangesToIgnore + clientSyncProcessorSyncServerDeletedConflictDelete localChangesToDelete + clientSyncProcessorSyncServerDeletedConflictKeepLocalChange localChangesToBeKept clientSyncProcessorSyncClientDeleted syncResponseClientDeleted clientSyncProcessorSyncClientChanged syncResponseClientChanged clientSyncProcessorSyncClientAdded syncResponseClientAdded @@ -783,8 +876,8 @@ -- | The conflicting items on the server side Map si (Timed a) -> -- | A map of items that need to be updated on the client. - Map si (Timed a) -mergeClientDeletedConflicts func = M.filter $ \(Timed si _) -> + (Map si (Timed a), Map si (Timed a)) +mergeClientDeletedConflicts func = M.partition $ \(Timed si _) -> case func si of TakeRemoteChange -> True StayDeleted -> False @@ -795,31 +888,34 @@ -- | The conflicting items on the client side Map si (Timed a) -> -- | The result is a map of items that need to be deleted on the client. - Set si -mergeServerDeletedConflicts func m = M.keysSet $ flip M.filter m $ \(Timed si _) -> case func si of - KeepLocalChange -> False - Delete -> True + (Set si, Set si) +mergeServerDeletedConflicts func m = both M.keysSet $ + flip M.partition m $ \(Timed si _) -> case func si of + KeepLocalChange -> False + Delete -> True + where + both :: (a -> b) -> (a, a) -> (b, b) + both f (a1, a2) = (f a1, f a2) data Identifier ci si - = OnlyServer si - | BothServerAndClient si ci + = OnlyServer !si + | BothServerAndClient !si !ci deriving (Show, Eq, Ord, Generic) instance (Validity ci, Validity si) => Validity (Identifier ci si) instance (NFData ci, NFData si) => NFData (Identifier ci si) -data ServerSyncProcessor ci si a m - = ServerSyncProcessor - { -- | Read all items - serverSyncProcessorRead :: !(m (Map si (Timed a))), - -- | Add an item with 'initialServerTime' - serverSyncProcessorAddItem :: !(a -> m si), - -- | Update an item - serverSyncProcessorChangeItem :: !(si -> ServerTime -> a -> m ()), - -- | Delete an item - serverSyncProcessorDeleteItem :: !(si -> m ()) - } +data ServerSyncProcessor ci si a m = ServerSyncProcessor + { -- | Read all items + serverSyncProcessorRead :: !(m (Map si (Timed a))), + -- | Add an item with 'initialServerTime', can fail. + serverSyncProcessorAddItem :: !(ci -> a -> m (Maybe si)), + -- | Update an item + serverSyncProcessorChangeItem :: !(si -> ServerTime -> a -> m ()), + -- | Delete an item + serverSyncProcessorDeleteItem :: !(si -> m ()) + } deriving (Generic) -- | Process a server sync @@ -872,9 +968,10 @@ processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do serverItems <- serverSyncProcessorRead -- A: CA (generate a new identifier) - syncResponseClientAdded <- forM syncRequestNewItems $ \a -> do - si <- serverSyncProcessorAddItem a - pure $ ClientAddition {clientAdditionId = si, clientAdditionServerTime = initialServerTime} + syncResponseClientAdded <- fmap (M.mapMaybe id) $ + flip M.traverseWithKey syncRequestNewItems $ \cid a -> do + msi <- serverSyncProcessorAddItem cid a + pure $ (\si -> ClientAddition {clientAdditionId = si, clientAdditionServerTime = initialServerTime}) <$> (msi :: Maybe si) -- C: let decideOnSynced tup@(sc, sd) (si, ct) = case M.lookup si serverItems of @@ -945,10 +1042,10 @@ pureServerSyncProcessor genId = ServerSyncProcessor {..} where serverSyncProcessorRead = gets serverStoreItems - serverSyncProcessorAddItem a = do + serverSyncProcessorAddItem _ a = do i <- lift genId modify (\(ServerStore m) -> ServerStore (M.insert i (Timed a initialServerTime) m)) - pure i + pure (Just i) -- Always succeed serverSyncProcessorChangeItem si st a = modify ( \(ServerStore m) -> diff --git a/src/Data/Mergeful/Item.hs b/src/Data/Mergeful/Item.hs --- a/src/Data/Mergeful/Item.hs +++ b/src/Data/Mergeful/Item.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -72,10 +74,11 @@ ) where -import Control.Applicative +import Autodocodec import Control.DeepSeq -import Data.Aeson as JSON +import Data.Aeson (FromJSON, ToJSON) import Data.Mergeful.Timed +import Data.Text (Text) import Data.Validity import GHC.Generics (Generic) @@ -90,35 +93,45 @@ ClientItemSyncedButChanged !(Timed a) | -- | There was an item, and it has been deleted locally, but the server has not been made aware of this. ClientDeleted !ServerTime - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ClientItem a)) instance Validity a => Validity (ClientItem a) instance NFData a => NFData (ClientItem a) -instance FromJSON a => FromJSON (ClientItem a) where - parseJSON = - withObject "ClientItem" $ \o -> do - typ <- o .: "type" - case typ :: String of - "empty" -> pure ClientEmpty - "added" -> ClientAdded <$> o .: "value" - "synced" -> ClientItemSynced <$> (Timed <$> o .: "value" <*> o .: "time") - "changed" -> ClientItemSyncedButChanged <$> (Timed <$> o .: "value" <*> o .: "time") - "deleted" -> ClientDeleted <$> o .: "time" - _ -> fail "unknown item type" +instance HasCodec a => HasCodec (ClientItem a) where + codec = + object "ClientItem" $ + dimapCodec f g $ + disjointEitherCodec + ( disjointEitherCodec + (typeField "empty" <*> pure ()) + (typeField "added" <*> requiredField "value" "item that was added, client-side") + ) + ( disjointEitherCodec + (typeField "synced" <*> timedObjectCodec) + ( disjointEitherCodec + (typeField "changed" <*> timedObjectCodec) + (typeField "deleted" <*> requiredField "time" "last time the server confirmed a change, from the client's perspective") + ) + ) + where + f = \case + Left (Left ()) -> ClientEmpty + Left (Right v) -> ClientAdded v + Right (Left tv) -> ClientItemSynced tv + Right (Right (Left tv)) -> ClientItemSyncedButChanged tv + Right (Right (Right st)) -> ClientDeleted st + g = \case + ClientEmpty -> Left (Left ()) + ClientAdded v -> Left (Right v) + ClientItemSynced tv -> Right (Left tv) + ClientItemSyncedButChanged tv -> Right (Right (Left tv)) + ClientDeleted st -> Right (Right (Right st)) -instance ToJSON a => ToJSON (ClientItem a) where - toJSON ci = - object $ - case ci of - ClientEmpty -> ["type" .= ("empty" :: String)] - ClientAdded a -> ["type" .= ("added" :: String), "value" .= a] - ClientItemSynced Timed {..} -> - ["type" .= ("synced" :: String), "value" .= timedValue, "time" .= timedTime] - ClientItemSyncedButChanged Timed {..} -> - ["type" .= ("changed" :: String), "value" .= timedValue, "time" .= timedTime] - ClientDeleted t -> ["type" .= ("deleted" :: String), "time" .= t] + typeField :: Text -> ObjectCodec b (a -> a) + typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName -- | A client item to start with. -- @@ -131,23 +144,24 @@ ServerEmpty | -- | There is an item on the server side, and it was last synced at the given 'ServerTime'. ServerFull !(Timed a) - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ServerItem a)) instance Validity a => Validity (ServerItem a) instance NFData a => NFData (ServerItem a) -instance FromJSON a => FromJSON (ServerItem a) where - parseJSON = - withObject "ServerItem" $ \o -> - ServerFull <$> (Timed <$> o .: "value" <*> o .: "time") <|> pure ServerEmpty - -instance ToJSON a => ToJSON (ServerItem a) where - toJSON si = - object $ - case si of - ServerEmpty -> [] - ServerFull Timed {..} -> ["value" .= timedValue, "time" .= timedTime] +instance HasCodec a => HasCodec (ServerItem a) where + codec = + object "ServerItem" $ + dimapCodec f g $ possiblyJointEitherCodec timedObjectCodec (pure ()) + where + f = \case + Left tv -> ServerFull tv + Right () -> ServerEmpty + g = \case + ServerFull tv -> Left tv + ServerEmpty -> Right () -- | A server item to start with. -- @@ -168,36 +182,45 @@ | -- | There was an item locally that has been deleted but the -- deletion wasn't synced to the server yet. ItemSyncRequestDeletedLocally !ServerTime - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ItemSyncRequest a)) instance Validity a => Validity (ItemSyncRequest a) instance NFData a => NFData (ItemSyncRequest a) -instance FromJSON a => FromJSON (ItemSyncRequest a) where - parseJSON = - withObject "ItemSyncRequest" $ \o -> do - typ <- o .: "type" - case typ :: String of - "empty" -> pure ItemSyncRequestPoll - "added" -> ItemSyncRequestNew <$> o .: "value" - "synced" -> ItemSyncRequestKnown <$> o .: "time" - "changed" -> ItemSyncRequestKnownButChanged <$> (Timed <$> o .: "value" <*> o .: "time") - "deleted" -> ItemSyncRequestDeletedLocally <$> o .: "time" - _ -> fail "unknown item type" +instance HasCodec a => HasCodec (ItemSyncRequest a) where + codec = + object "ItemSyncRequest" $ + dimapCodec f g $ + disjointEitherCodec + ( disjointEitherCodec + (typeField "empty" <*> pure ()) + (typeField "added" <*> requiredField "value" "item that was added, client-side") + ) + ( disjointEitherCodec + (typeField "synced" <*> requiredField "time" "last time the server confirmed a change, from the client's perspective") + ( disjointEitherCodec + (typeField "changed" <*> timedObjectCodec) + (typeField "deleted" <*> requiredField "time" "last time the server confirmed a change, from the client's perspective") + ) + ) + where + f = \case + Left (Left ()) -> ItemSyncRequestPoll + Left (Right v) -> ItemSyncRequestNew v + Right (Left tv) -> ItemSyncRequestKnown tv + Right (Right (Left tv)) -> ItemSyncRequestKnownButChanged tv + Right (Right (Right st)) -> ItemSyncRequestDeletedLocally st + g = \case + ItemSyncRequestPoll -> Left (Left ()) + ItemSyncRequestNew v -> Left (Right v) + ItemSyncRequestKnown tv -> Right (Left tv) + ItemSyncRequestKnownButChanged tv -> Right (Right (Left tv)) + ItemSyncRequestDeletedLocally st -> Right (Right (Right st)) -instance ToJSON a => ToJSON (ItemSyncRequest a) where - toJSON ci = - object $ - let o n rest = ("type" .= (n :: String)) : rest - oe n = o n [] - in case ci of - ItemSyncRequestPoll -> oe "empty" - ItemSyncRequestNew a -> o "added" ["value" .= a] - ItemSyncRequestKnown t -> o "synced" ["time" .= t] - ItemSyncRequestKnownButChanged Timed {..} -> - o "changed" ["value" .= timedValue, "time" .= timedTime] - ItemSyncRequestDeletedLocally t -> o "deleted" ["time" .= t] + typeField :: Text -> ObjectCodec b (a -> a) + typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName -- | An intial 'ItemSyncRequest' to start with. -- @@ -253,50 +276,75 @@ -- or deal with the conflict somehow, and then try to re-sync. ItemSyncResponseConflictClientDeleted !(Timed a) | ItemSyncResponseConflictServerDeleted - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ItemSyncResponse a)) instance Validity a => Validity (ItemSyncResponse a) instance NFData a => NFData (ItemSyncResponse a) -instance FromJSON a => FromJSON (ItemSyncResponse a) where - parseJSON = - withObject "ItemSyncResponse" $ \o -> do - typ <- o .: "type" - case typ :: String of - "in-sync-empty" -> pure ItemSyncResponseInSyncEmpty - "in-sync-full" -> pure ItemSyncResponseInSyncFull - "client-added" -> ItemSyncResponseClientAdded <$> o .: "time" - "client-changed" -> ItemSyncResponseClientChanged <$> o .: "time" - "client-deleted" -> pure ItemSyncResponseClientDeleted - "server-added" -> ItemSyncResponseServerAdded <$> (Timed <$> o .: "value" <*> o .: "time") - "server-changed" -> - ItemSyncResponseServerChanged <$> (Timed <$> o .: "value" <*> o .: "time") - "server-deleted" -> pure ItemSyncResponseServerDeleted - "conflict" -> ItemSyncResponseConflict <$> o .: "value" - "conflict-client-deleted" -> ItemSyncResponseConflictClientDeleted <$> o .: "value" - "conflict-server-deleted" -> pure ItemSyncResponseConflictServerDeleted - _ -> fail "unknown type" +instance HasCodec a => HasCodec (ItemSyncResponse a) where + codec = + object "ItemSyncResponse" $ + dimapCodec f g $ + disjointEitherCodec + ( disjointEitherCodec + ( disjointEitherCodec + (typeField "in-sync-empty" <*> pure ()) + (typeField "in-sync-full" <*> pure ()) + ) + ( disjointEitherCodec + (typeField "client-added" <*> requiredField "time" "server's confirmation of the addition") + (typeField "client-changed" <*> requiredField "time" "server's confirmation of the addition") + ) + ) + ( disjointEitherCodec + ( disjointEitherCodec + ( disjointEitherCodec + (typeField "client-deleted" <*> pure ()) + (typeField "server-added" <*> timedObjectCodec) + ) + ( disjointEitherCodec + (typeField "server-changed" <*> timedObjectCodec) + (typeField "server-deleted" <*> pure ()) + ) + ) + ( disjointEitherCodec + ( disjointEitherCodec + (typeField "conflict" <*> timedObjectCodec) + (typeField "conflict-client-deleted" <*> timedObjectCodec) + ) + (typeField "conflict-server-deleted" <*> pure ()) + ) + ) + where + f = \case + Left (Left (Left ())) -> ItemSyncResponseInSyncEmpty + Left (Left (Right ())) -> ItemSyncResponseInSyncFull + Left (Right (Left st)) -> ItemSyncResponseClientAdded st + Left (Right (Right st)) -> ItemSyncResponseClientChanged st + Right (Left (Left (Left ()))) -> ItemSyncResponseClientDeleted + Right (Left (Left (Right tv))) -> ItemSyncResponseServerAdded tv + Right (Left (Right (Left tv))) -> ItemSyncResponseServerChanged tv + Right (Left (Right (Right ()))) -> ItemSyncResponseServerDeleted + Right (Right (Left (Left tv))) -> ItemSyncResponseConflict tv + Right (Right (Left (Right tv))) -> ItemSyncResponseConflictClientDeleted tv + Right (Right (Right ())) -> ItemSyncResponseConflictServerDeleted + g = \case + ItemSyncResponseInSyncEmpty -> Left (Left (Left ())) + ItemSyncResponseInSyncFull -> Left (Left (Right ())) + ItemSyncResponseClientAdded st -> Left (Right (Left st)) + ItemSyncResponseClientChanged st -> Left (Right (Right st)) + ItemSyncResponseClientDeleted -> Right (Left (Left (Left ()))) + ItemSyncResponseServerAdded tv -> Right (Left (Left (Right tv))) + ItemSyncResponseServerChanged tv -> Right (Left (Right (Left tv))) + ItemSyncResponseServerDeleted -> Right (Left (Right (Right ()))) + ItemSyncResponseConflict tv -> Right (Right (Left (Left tv))) + ItemSyncResponseConflictClientDeleted tv -> Right (Right (Left (Right tv))) + ItemSyncResponseConflictServerDeleted -> Right (Right (Right ())) -instance ToJSON a => ToJSON (ItemSyncResponse a) where - toJSON isr = - object $ - let o s rest = ("type" .= (s :: String)) : rest - oe s = o s [] - in case isr of - ItemSyncResponseInSyncEmpty -> oe "in-sync-empty" - ItemSyncResponseInSyncFull -> oe "in-sync-full" - ItemSyncResponseClientAdded t -> o "client-added" ["time" .= t] - ItemSyncResponseClientChanged t -> o "client-changed" ["time" .= t] - ItemSyncResponseClientDeleted -> oe "client-deleted" - ItemSyncResponseServerAdded Timed {..} -> - o "server-added" ["value" .= timedValue, "time" .= timedTime] - ItemSyncResponseServerChanged Timed {..} -> - o "server-changed" ["value" .= timedValue, "time" .= timedTime] - ItemSyncResponseServerDeleted -> oe "server-deleted" - ItemSyncResponseConflict a -> o "conflict" ["value" .= a] - ItemSyncResponseConflictClientDeleted a -> o "conflict-client-deleted" ["value" .= a] - ItemSyncResponseConflictServerDeleted -> oe "conflict-server-deleted" + typeField :: Text -> ObjectCodec b (a -> a) + typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. -- @@ -379,17 +427,16 @@ mergeItemSyncResponseUsingCRDT = mergeItemSyncResponseUsingStrategy . mergeUsingCRDTStrategy -- | A strategy to merge conflicts for item synchronisation -data ItemMergeStrategy a - = ItemMergeStrategy - { -- | How to merge modification conflicts - -- - -- The first argument is the client item and the second argument is the server item. - itemMergeStrategyMergeChangeConflict :: a -> a -> ChangeConflictResolution a, - -- | How to merge conflicts where the client deleted an item that the server modified - itemMergeStrategyMergeClientDeletedConflict :: a -> ClientDeletedConflictResolution, - -- | How to merge conflicts where the server deleted an item that the client modified - itemMergeStrategyMergeServerDeletedConflict :: a -> ServerDeletedConflictResolution - } +data ItemMergeStrategy a = ItemMergeStrategy + { -- | How to merge modification conflicts + -- + -- The first argument is the client item and the second argument is the server item. + itemMergeStrategyMergeChangeConflict :: !(a -> a -> ChangeConflictResolution a), + -- | How to merge conflicts where the client deleted an item that the server modified + itemMergeStrategyMergeClientDeletedConflict :: !(a -> ClientDeletedConflictResolution), + -- | How to merge conflicts where the server deleted an item that the client modified + itemMergeStrategyMergeServerDeletedConflict :: !(a -> ServerDeletedConflictResolution) + } deriving (Generic) data ChangeConflictResolution a @@ -548,13 +595,13 @@ (ItemSyncResponseConflict t, store) ItemSyncRequestKnown ct -> if ct >= st - then-- The client time is equal to the server time. + then -- The client time is equal to the server time. -- The client indicates that the item was not modified at their side. -- This means that the items are in sync. -- (Unless the server somehow modified the item but not its server time, -- which would beconsidered a bug.) (ItemSyncResponseInSyncFull, store) - else-- The client time is less than the server time + else -- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item was not modified at their side, -- we can just send it back to the client to have them update their version. @@ -565,25 +612,25 @@ ) ItemSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} -> if ct >= st - then-- The client time is equal to the server time. + then -- The client time is equal to the server time. -- The client indicates that the item *was* modified at their side. -- This means that the server needs to be updated. ( ItemSyncResponseClientChanged st', ServerFull (Timed {timedValue = ci, timedTime = st'}) ) - else-- The client time is less than the server time + else -- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item *was* modified at their side, -- there is a conflict. (ItemSyncResponseConflict t, store) ItemSyncRequestDeletedLocally ct -> if ct >= st - then-- The client time is equal to the server time. + then -- The client time is equal to the server time. -- The client indicates that the item was deleted on their side. -- This means that the server item needs to be deleted as well. (ItemSyncResponseClientDeleted, ServerEmpty) - else-- The client time is less than the server time + else -- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item was deleted at their side, -- there is a conflict. diff --git a/src/Data/Mergeful/Timed.hs b/src/Data/Mergeful/Timed.hs --- a/src/Data/Mergeful/Timed.hs +++ b/src/Data/Mergeful/Timed.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -- | Dealing with server times. -- @@ -11,11 +10,13 @@ initialServerTime, incrementServerTime, Timed (..), + timedObjectCodec, ) where +import Autodocodec import Control.DeepSeq -import Data.Aeson as JSON +import Data.Aeson (FromJSON, ToJSON) import Data.Validity import Data.Word import GHC.Generics (Generic) @@ -32,16 +33,19 @@ -- will not happen in practice, we will not worry about it. -- You would have to sync millions of modifications every second -- until long after the sun consumes the earth for this to be a problem. -newtype ServerTime - = ServerTime - { unServerTime :: Word64 - } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) +newtype ServerTime = ServerTime + { unServerTime :: Word64 + } + deriving stock (Show, Eq, Ord, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec ServerTime) instance Validity ServerTime instance NFData ServerTime +instance HasCodec ServerTime where + codec = dimapCodec ServerTime unServerTime codec "Server time" + -- | A server time to start with. initialServerTime :: ServerTime initialServerTime = ServerTime 0 @@ -51,19 +55,22 @@ incrementServerTime (ServerTime w) = ServerTime (succ w) -- | A value along with a server time. -data Timed a - = Timed - { timedValue :: !a, - timedTime :: !ServerTime - } - deriving (Show, Eq, Generic) +data Timed a = Timed + { timedValue :: !a, + timedTime :: !ServerTime + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (Timed a)) instance Validity a => Validity (Timed a) instance NFData a => NFData (Timed a) -instance FromJSON a => FromJSON (Timed a) where - parseJSON = withObject "Timed" $ \o -> Timed <$> o .: "value" <*> o .: "time" +instance HasCodec a => HasCodec (Timed a) where + codec = object "Timed" timedObjectCodec -instance ToJSON a => ToJSON (Timed a) where - toJSON Timed {..} = object ["value" .= timedValue, "time" .= timedTime] +timedObjectCodec :: HasCodec a => JSONObjectCodec (Timed a) +timedObjectCodec = + Timed + <$> requiredField "value" "timed value" .= timedValue + <*> requiredField "time" "timed time" .= timedTime diff --git a/src/Data/Mergeful/Value.hs b/src/Data/Mergeful/Value.hs --- a/src/Data/Mergeful/Value.hs +++ b/src/Data/Mergeful/Value.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -- | A way to synchronise a single value with safe merge conflicts. -- @@ -60,21 +61,34 @@ ) where +import Autodocodec import Control.DeepSeq -import Data.Aeson as JSON +import Data.Aeson (FromJSON, ToJSON) import Data.Mergeful.Timed +import Data.Text (Text) import Data.Validity import GHC.Generics (Generic) data ChangedFlag = Changed | NotChanged - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec ChangedFlag) instance Validity ChangedFlag instance NFData ChangedFlag +instance HasCodec ChangedFlag where + codec = dimapCodec f g codec + where + f = \case + True -> Changed + False -> NotChanged + g = \case + Changed -> True + NotChanged -> False + -- | The client side value. -- -- The only differences between `a` and 'ClientValue a' are that @@ -82,37 +96,23 @@ -- the server, and whether the item has been modified at the client -- -- There cannot be an unsynced 'ClientValue'. -data ClientValue a - = ClientValue !(Timed a) !ChangedFlag - deriving (Show, Eq, Generic) +data ClientValue a = ClientValue + { clientValueTimedValue :: !(Timed a), + clientValueChanged :: !ChangedFlag + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ClientValue a)) instance Validity a => Validity (ClientValue a) instance NFData a => NFData (ClientValue a) -instance FromJSON a => FromJSON (ClientValue a) where - parseJSON = - withObject "ClientValue" $ \o -> - ClientValue <$> (Timed <$> o .: "value" <*> o .: "time") - <*> ( ( \b -> - if b - then Changed - else NotChanged - ) - <$> o .: "changed" - ) - -instance ToJSON a => ToJSON (ClientValue a) where - toJSON (ClientValue Timed {..} cf) = - object - [ "value" .= timedValue, - "time" .= timedTime, - "changed" - .= ( case cf of - Changed -> True - NotChanged -> False - ) - ] +instance HasCodec a => HasCodec (ClientValue a) where + codec = + object "ClientValue" $ + ClientValue + <$> timedObjectCodec .= clientValueTimedValue + <*> requiredField "changed" "whether the value has changed, client-side" .= clientValueChanged -- | Produce a client value based on an initial synchronisation request initialClientValue :: Timed a -> ClientValue a @@ -122,20 +122,16 @@ -- -- The only difference between 'a' and 'ServerValue a' is that 'ServerValue a' also -- remembers the last time this value was changed during synchronisation. -newtype ServerValue a - = ServerValue (Timed a) - deriving (Show, Eq, Generic) +newtype ServerValue a = ServerValue {unServerValue :: Timed a} + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ServerValue a)) instance Validity a => Validity (ServerValue a) instance NFData a => NFData (ServerValue a) -instance FromJSON a => FromJSON (ServerValue a) where - parseJSON = - withObject "ServerValue" $ \o -> ServerValue <$> (Timed <$> o .: "value" <*> o .: "time") - -instance ToJSON a => ToJSON (ServerValue a) where - toJSON (ServerValue Timed {..}) = object ["value" .= timedValue, "time" .= timedTime] +instance HasCodec a => HasCodec (ServerValue a) where + codec = object "ServerValue" $ ServerValue <$> timedObjectCodec .= unServerValue -- | Initialise a server value. -- @@ -149,29 +145,30 @@ | -- | There is an item locally that was synced at the given 'ServerTime' -- but it has been changed since then. ValueSyncRequestKnownButChanged !(Timed a) - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ValueSyncRequest a)) instance Validity a => Validity (ValueSyncRequest a) instance NFData a => NFData (ValueSyncRequest a) -instance FromJSON a => FromJSON (ValueSyncRequest a) where - parseJSON = - withObject "ValueSyncRequest" $ \o -> do - typ <- o .: "type" - case typ :: String of - "synced" -> ValueSyncRequestKnown <$> o .: "time" - "changed" -> ValueSyncRequestKnownButChanged <$> (Timed <$> o .: "value" <*> o .: "time") - _ -> fail "unknown item type" +instance HasCodec a => HasCodec (ValueSyncRequest a) where + codec = + object "ValueSyncRequest" $ + dimapCodec f g $ + disjointEitherCodec + (typeField "synced" <*> requiredField "time" "time at which the server said the value was last synced") + (typeField "changed" <*> timedObjectCodec) + where + f = \case + Left st -> ValueSyncRequestKnown st + Right tv -> ValueSyncRequestKnownButChanged tv + g = \case + ValueSyncRequestKnown st -> Left st + ValueSyncRequestKnownButChanged tv -> Right tv -instance ToJSON a => ToJSON (ValueSyncRequest a) where - toJSON ci = - object $ - let o n rest = ("type" .= (n :: String)) : rest - in case ci of - ValueSyncRequestKnown t -> o "synced" ["time" .= t] - ValueSyncRequestKnownButChanged Timed {..} -> - o "changed" ["value" .= timedValue, "time" .= timedTime] + typeField :: Text -> ObjectCodec b (a -> a) + typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName data ValueSyncResponse a = -- | The client and server are fully in sync. @@ -188,35 +185,40 @@ ValueSyncResponseServerChanged !(Timed a) | -- | The item at the server side ValueSyncResponseConflict !(Timed a) - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec (ValueSyncResponse a)) instance Validity a => Validity (ValueSyncResponse a) instance NFData a => NFData (ValueSyncResponse a) -instance FromJSON a => FromJSON (ValueSyncResponse a) where - parseJSON = - withObject "ValueSyncResponse" $ \o -> do - typ <- o .: "type" - case typ :: String of - "in-sync" -> pure ValueSyncResponseInSync - "client-changed" -> ValueSyncResponseClientChanged <$> o .: "time" - "server-changed" -> - ValueSyncResponseServerChanged <$> (Timed <$> o .: "value" <*> o .: "time") - "conflict" -> ValueSyncResponseConflict <$> o .: "value" - _ -> fail "unknown type" +instance HasCodec a => HasCodec (ValueSyncResponse a) where + codec = + object "ValueSyncResponse" $ + dimapCodec f g $ + disjointEitherCodec + ( disjointEitherCodec + (typeField "in-sync" <*> pure ()) + (typeField "client-changed" <*> requiredField "time" "server time") + ) + ( disjointEitherCodec + (typeField "server-changed" <*> timedObjectCodec) + (typeField "conflict" <*> timedObjectCodec) + ) + where + f = \case + Left (Left ()) -> ValueSyncResponseInSync + Left (Right st) -> ValueSyncResponseClientChanged st + Right (Left tv) -> ValueSyncResponseServerChanged tv + Right (Right tv) -> ValueSyncResponseConflict tv + g = \case + ValueSyncResponseInSync -> Left (Left ()) + ValueSyncResponseClientChanged st -> Left (Right st) + ValueSyncResponseServerChanged tv -> Right (Left tv) + ValueSyncResponseConflict tv -> Right (Right tv) -instance ToJSON a => ToJSON (ValueSyncResponse a) where - toJSON isr = - object $ - let o s rest = ("type" .= (s :: String)) : rest - oe s = o s [] - in case isr of - ValueSyncResponseInSync -> oe "in-sync" - ValueSyncResponseClientChanged t -> o "client-changed" ["time" .= t] - ValueSyncResponseServerChanged Timed {..} -> - o "server-changed" ["value" .= timedValue, "time" .= timedTime] - ValueSyncResponseConflict a -> o "conflict" ["value" .= a] + typeField :: Text -> ObjectCodec b (a -> a) + typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName -- | Produce an 'ItemSyncRequest' from a 'ClientItem'. -- @@ -322,13 +324,13 @@ case sr of ValueSyncRequestKnown ct -> if ct >= st - then-- The client time is equal to the server time. + then -- The client time is equal to the server time. -- The client indicates that the item was not modified at their side. -- This means that the items are in sync. -- (Unless the server somehow modified the item but not its server time, -- which would beconsidered a bug.) (ValueSyncResponseInSync, sv) - else-- The client time is less than the server time + else -- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item was not modified at their side, -- we can just send it back to the client to have them update their version. @@ -336,7 +338,7 @@ (ValueSyncResponseServerChanged t, sv) ValueSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} -> if ct >= st - then-- The client time is equal to the server time. + then -- The client time is equal to the server time. -- The client indicates that the item *was* modified at their side. -- This means that the server needs to be updated. @@ -344,7 +346,7 @@ in ( ValueSyncResponseClientChanged st', ServerValue (Timed {timedValue = ci, timedTime = st'}) ) - else-- The client time is less than the server time + else -- The client time is less than the server time -- That means that the server has synced with another client in the meantime. -- Since the client indicates that the item *was* modified at their side, -- there is a conflict.