{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Mergeful.Item
( initialClientItem,
initialItemSyncRequest,
makeItemSyncRequest,
mergeItemSyncResponseFromServer,
mergeItemSyncResponseFromClient,
mergeItemSyncResponseUsingCRDT,
mergeItemSyncResponseUsingStrategy,
mergeFromServer,
mergeFromServerStrategy,
mergeFromClient,
mergeFromClientStrategy,
mergeUsingCRDT,
mergeUsingCRDTStrategy,
ItemMergeStrategy (..),
ChangeConflictResolution (..),
ClientDeletedConflictResolution (..),
ServerDeletedConflictResolution (..),
mergeUsingStrategy,
mergeItemSyncResponseRaw,
ItemMergeResult (..),
initialServerItem,
processServerItemSync,
ClientItem (..),
ItemSyncRequest (..),
ItemSyncResponse (..),
ServerItem (..),
)
where
import Control.Applicative
import Control.DeepSeq
import Data.Aeson as JSON
import Data.Mergeful.Timed
import Data.Validity
import GHC.Generics (Generic)
data ClientItem a
=
ClientEmpty
|
ClientAdded !a
|
ClientItemSynced !(Timed a)
|
ClientItemSyncedButChanged !(Timed a)
|
ClientDeleted !ServerTime
deriving (Show, Eq, Generic)
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 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]
initialClientItem :: ClientItem a
initialClientItem = ClientEmpty
data ServerItem a
=
ServerEmpty
|
ServerFull !(Timed a)
deriving (Show, Eq, Generic)
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]
initialServerItem :: ServerItem a
initialServerItem = ServerEmpty
data ItemSyncRequest a
=
ItemSyncRequestPoll
|
ItemSyncRequestNew !a
|
ItemSyncRequestKnown !ServerTime
|
ItemSyncRequestKnownButChanged !(Timed a)
|
ItemSyncRequestDeletedLocally !ServerTime
deriving (Show, Eq, Generic)
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 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]
initialItemSyncRequest :: ItemSyncRequest a
initialItemSyncRequest = ItemSyncRequestPoll
data ItemSyncResponse a
=
ItemSyncResponseInSyncEmpty
|
ItemSyncResponseInSyncFull
|
ItemSyncResponseClientAdded !ServerTime
|
ItemSyncResponseClientChanged !ServerTime
|
ItemSyncResponseClientDeleted
|
ItemSyncResponseServerAdded !(Timed a)
|
ItemSyncResponseServerChanged !(Timed a)
|
ItemSyncResponseServerDeleted
|
ItemSyncResponseConflict !(Timed a)
|
ItemSyncResponseConflictClientDeleted !(Timed a)
| ItemSyncResponseConflictServerDeleted
deriving (Show, Eq, Generic)
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 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"
makeItemSyncRequest :: ClientItem a -> ItemSyncRequest a
makeItemSyncRequest cs =
case cs of
ClientEmpty -> ItemSyncRequestPoll
ClientAdded i -> ItemSyncRequestNew i
ClientItemSynced t -> ItemSyncRequestKnown (timedTime t)
ClientItemSyncedButChanged t -> ItemSyncRequestKnownButChanged t
ClientDeleted st -> ItemSyncRequestDeletedLocally st
data ItemMergeResult a
=
MergeSuccess !(ClientItem a)
|
MergeConflict !a !(Timed a)
|
MergeConflictClientDeleted !(Timed a)
|
MergeConflictServerDeleted !a
| MergeMismatch
deriving (Show, Eq, Generic)
instance Validity a => Validity (ItemMergeResult a)
instance NFData a => NFData (ItemMergeResult a)
mergeItemSyncResponseRaw :: ClientItem a -> ItemSyncResponse a -> ItemMergeResult a
mergeItemSyncResponseRaw cs sr =
case cs of
ClientEmpty ->
case sr of
ItemSyncResponseInSyncEmpty -> MergeSuccess cs
ItemSyncResponseServerAdded t -> MergeSuccess $ ClientItemSynced t
_ -> MergeMismatch
ClientAdded ci ->
case sr of
ItemSyncResponseClientAdded st ->
MergeSuccess $ ClientItemSynced $ Timed {timedValue = ci, timedTime = st}
ItemSyncResponseConflict si -> MergeConflict ci si
_ -> MergeMismatch
ClientItemSynced t ->
case sr of
ItemSyncResponseInSyncFull -> MergeSuccess $ ClientItemSynced t
ItemSyncResponseServerChanged st -> MergeSuccess $ ClientItemSynced st
ItemSyncResponseServerDeleted -> MergeSuccess ClientEmpty
_ -> MergeMismatch
ClientItemSyncedButChanged ct ->
case sr of
ItemSyncResponseClientChanged st -> MergeSuccess $ ClientItemSynced $ ct {timedTime = st}
ItemSyncResponseConflict si -> MergeConflict (timedValue ct) si
ItemSyncResponseConflictServerDeleted -> MergeConflictServerDeleted (timedValue ct)
_ -> MergeMismatch
ClientDeleted _ ->
case sr of
ItemSyncResponseClientDeleted -> MergeSuccess ClientEmpty
ItemSyncResponseConflictClientDeleted si -> MergeConflictClientDeleted si
_ -> MergeMismatch
mergeItemSyncResponseUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemSyncResponse a -> ClientItem a
mergeItemSyncResponseUsingStrategy strat ci sr = mergeUsingStrategy strat ci $ mergeItemSyncResponseRaw ci sr
mergeItemSyncResponseFromServer :: ClientItem a -> ItemSyncResponse a -> ClientItem a
mergeItemSyncResponseFromServer = mergeItemSyncResponseUsingStrategy mergeFromServerStrategy
mergeItemSyncResponseFromClient :: ClientItem a -> ItemSyncResponse a -> ClientItem a
mergeItemSyncResponseFromClient = mergeItemSyncResponseUsingStrategy mergeFromClientStrategy
mergeItemSyncResponseUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemSyncResponse a -> ClientItem a
mergeItemSyncResponseUsingCRDT = mergeItemSyncResponseUsingStrategy . mergeUsingCRDTStrategy
data ItemMergeStrategy a
= ItemMergeStrategy
{
itemMergeStrategyMergeChangeConflict :: a -> a -> ChangeConflictResolution a,
itemMergeStrategyMergeClientDeletedConflict :: a -> ClientDeletedConflictResolution,
itemMergeStrategyMergeServerDeletedConflict :: a -> ServerDeletedConflictResolution
}
deriving (Generic)
data ChangeConflictResolution a
= KeepLocal
| TakeRemote
| Merged a
deriving (Show, Eq, Generic)
data ClientDeletedConflictResolution
= TakeRemoteChange
| StayDeleted
deriving (Show, Eq, Generic)
data ServerDeletedConflictResolution
= KeepLocalChange
| Delete
deriving (Show, Eq, Generic)
mergeUsingStrategy :: ItemMergeStrategy a -> ClientItem a -> ItemMergeResult a -> ClientItem a
mergeUsingStrategy ItemMergeStrategy {..} ci mr =
case mr of
MergeSuccess ci' -> ci'
MergeConflict a1 ri -> mergeChangeConflict itemMergeStrategyMergeChangeConflict ci a1 ri
MergeConflictClientDeleted ri -> mergeClientDeletedConflict itemMergeStrategyMergeClientDeletedConflict ci ri
MergeConflictServerDeleted ca -> mergeServerDeletedConflict itemMergeStrategyMergeServerDeletedConflict ci ca
MergeMismatch -> ci
mergeChangeConflict :: (a -> a -> ChangeConflictResolution a) -> ClientItem a -> a -> Timed a -> ClientItem a
mergeChangeConflict func ci a1 ri@(Timed a2 st) = case func a1 a2 of
KeepLocal -> ci
TakeRemote -> ClientItemSynced ri
Merged ma -> ClientItemSynced $ Timed ma st
mergeClientDeletedConflict :: (a -> ClientDeletedConflictResolution) -> ClientItem a -> Timed a -> ClientItem a
mergeClientDeletedConflict func ci ri@(Timed sa _) = case func sa of
TakeRemoteChange -> ClientItemSynced ri
StayDeleted -> ci
mergeServerDeletedConflict :: (a -> ServerDeletedConflictResolution) -> ClientItem a -> a -> ClientItem a
mergeServerDeletedConflict func ci ca = case func ca of
KeepLocalChange -> ci
Delete -> ClientEmpty
mergeFromServer :: ClientItem a -> ItemMergeResult a -> ClientItem a
mergeFromServer =
mergeUsingStrategy mergeFromServerStrategy
mergeFromServerStrategy :: ItemMergeStrategy a
mergeFromServerStrategy =
ItemMergeStrategy
{ itemMergeStrategyMergeChangeConflict = \_ _ -> TakeRemote,
itemMergeStrategyMergeClientDeletedConflict = \_ -> TakeRemoteChange,
itemMergeStrategyMergeServerDeletedConflict = \_ -> Delete
}
mergeFromClient :: ClientItem a -> ItemMergeResult a -> ClientItem a
mergeFromClient = mergeUsingStrategy mergeFromClientStrategy
mergeFromClientStrategy :: ItemMergeStrategy a
mergeFromClientStrategy =
ItemMergeStrategy
{ itemMergeStrategyMergeChangeConflict = \_ _ -> KeepLocal,
itemMergeStrategyMergeClientDeletedConflict = \_ -> StayDeleted,
itemMergeStrategyMergeServerDeletedConflict = \_ -> KeepLocalChange
}
mergeUsingCRDT :: (a -> a -> a) -> ClientItem a -> ItemMergeResult a -> ClientItem a
mergeUsingCRDT = mergeUsingStrategy . mergeUsingCRDTStrategy
mergeUsingCRDTStrategy :: (a -> a -> a) -> ItemMergeStrategy a
mergeUsingCRDTStrategy merge =
mergeFromServerStrategy
{ itemMergeStrategyMergeChangeConflict = \a1 a2 -> Merged (merge a1 a2)
}
processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a)
processServerItemSync store sr =
case store of
ServerEmpty ->
let t = initialServerTime
in case sr of
ItemSyncRequestPoll -> (ItemSyncResponseInSyncEmpty, store)
ItemSyncRequestNew ci ->
(ItemSyncResponseClientAdded t, ServerFull $ Timed {timedValue = ci, timedTime = t})
ItemSyncRequestKnown _ ->
(ItemSyncResponseServerDeleted, store)
ItemSyncRequestKnownButChanged _ ->
(ItemSyncResponseConflictServerDeleted, store)
ItemSyncRequestDeletedLocally _ ->
(ItemSyncResponseClientDeleted, store)
ServerFull t@(Timed si st) ->
let st' = incrementServerTime st
in case sr of
ItemSyncRequestPoll ->
(ItemSyncResponseServerAdded (Timed {timedValue = si, timedTime = st}), store)
ItemSyncRequestNew _ ->
(ItemSyncResponseConflict t, store)
ItemSyncRequestKnown ct ->
if ct >= st
then
(ItemSyncResponseInSyncFull, store)
else
( ItemSyncResponseServerChanged (Timed {timedValue = si, timedTime = st}),
store
)
ItemSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} ->
if ct >= st
then
( ItemSyncResponseClientChanged st',
ServerFull (Timed {timedValue = ci, timedTime = st'})
)
else
(ItemSyncResponseConflict t, store)
ItemSyncRequestDeletedLocally ct ->
if ct >= st
then
(ItemSyncResponseClientDeleted, ServerEmpty)
else
(ItemSyncResponseConflictClientDeleted t, store)