{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Mergeful.Value
( initialClientValue
, makeValueSyncRequest
, mergeValueSyncResponseRaw
, ValueMergeResult(..)
, mergeValueSyncResponseIgnoreProblems
, mergeIgnoringProblems
, mergeFromServer
, mergeUsingFunction
, initialServerValue
, processServerValueSync
, ChangedFlag(..)
, ClientValue(..)
, ValueSyncRequest(..)
, ValueSyncResponse(..)
, ServerValue(..)
) where
import GHC.Generics (Generic)
import Data.Aeson as JSON
import Data.Validity
import Data.Mergeful.Timed
data ChangedFlag
= Changed
| NotChanged
deriving (Show, Eq, Generic)
instance Validity ChangedFlag
data ClientValue a =
ClientValue !(Timed a) !ChangedFlag
deriving (Show, Eq, Generic)
instance Validity a => Validity (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)
]
initialClientValue :: Timed a -> ClientValue a
initialClientValue t = ClientValue t NotChanged
newtype ServerValue a =
ServerValue (Timed a)
deriving (Show, Eq, Generic)
instance Validity a => Validity (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]
initialServerValue :: a -> ServerValue a
initialServerValue a = ServerValue $ Timed {timedValue = a, timedTime = initialServerTime}
data ValueSyncRequest a
= ValueSyncRequestKnown !ServerTime
| ValueSyncRequestKnownButChanged !(Timed a)
deriving (Show, Eq, Generic)
instance Validity a => Validity (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 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]
data ValueSyncResponse a
= ValueSyncResponseInSync
| ValueSyncResponseClientChanged !ServerTime
| ValueSyncResponseServerChanged !(Timed a)
| ValueSyncResponseConflict !(Timed a)
deriving (Show, Eq, Generic)
instance Validity a => Validity (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 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]
makeValueSyncRequest :: ClientValue a -> ValueSyncRequest a
makeValueSyncRequest (ClientValue t cf) =
case cf of
NotChanged -> ValueSyncRequestKnown (timedTime t)
Changed -> ValueSyncRequestKnownButChanged t
data ValueMergeResult a
= MergeSuccess !(ClientValue a)
| MergeConflict !a !(Timed a)
| MergeMismatch
deriving (Show, Eq, Generic)
instance Validity a => Validity (ValueMergeResult a)
mergeValueSyncResponseRaw :: ClientValue a -> ValueSyncResponse a -> ValueMergeResult a
mergeValueSyncResponseRaw cv@(ClientValue ct cf) sr =
case cf of
NotChanged ->
case sr of
ValueSyncResponseInSync -> MergeSuccess cv
ValueSyncResponseServerChanged st -> MergeSuccess $ ClientValue st NotChanged
_ -> MergeMismatch
Changed ->
case sr of
ValueSyncResponseClientChanged st ->
MergeSuccess $ ClientValue (ct {timedTime = st}) NotChanged
ValueSyncResponseConflict si -> MergeConflict (timedValue ct) si
_ -> MergeMismatch
mergeValueSyncResponseIgnoreProblems :: ClientValue a -> ValueSyncResponse a -> ClientValue a
mergeValueSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeValueSyncResponseRaw cs
mergeIgnoringProblems :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeIgnoringProblems cs mr =
case mr of
MergeSuccess cs' -> cs'
MergeConflict _ _ -> cs
MergeMismatch -> cs
mergeUsingFunction ::
(a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a
mergeUsingFunction func cs mr =
case mr of
MergeSuccess cs' -> cs'
MergeConflict a1 a2 -> ClientValue (func a1 a2) NotChanged
MergeMismatch -> cs
mergeFromServer :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeFromServer = mergeUsingFunction (\_ serverItem -> serverItem)
processServerValueSync ::
ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a)
processServerValueSync sv@(ServerValue t@(Timed _ st)) sr =
case sr of
ValueSyncRequestKnown ct ->
if ct >= st
then (ValueSyncResponseInSync, sv)
else (ValueSyncResponseServerChanged t, sv)
ValueSyncRequestKnownButChanged Timed {timedValue = ci, timedTime = ct} ->
if ct >= st
then let st' = incrementServerTime st
in ( ValueSyncResponseClientChanged st'
, ServerValue (Timed {timedValue = ci, timedTime = st'}))
else (ValueSyncResponseConflict t, sv)