mergeful 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+632/−474 lines, 9 filesdep +autodocodecsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: autodocodec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−1
• LICENSE +1/−1
• README.md +0/−1
• Setup.hs +0/−3
• mergeful.cabal +5/−5
• src/Data/Mergeful/Collection.hs +344/−247
• src/Data/Mergeful/Item.hs +163/−116
• src/Data/Mergeful/Timed.hs +25/−18
• src/Data/Mergeful/Value.hs +84/−82

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

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

@@ -1,1 +0,0 @@-# mergeful

@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain

@@ -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 <https://github.com/NorfairKing/mergeful#readme> 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

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

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

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

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