{-# 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 Control.DeepSeq
import Data.Aeson as JSON
import Data.Mergeful.Timed
import Data.Validity
import GHC.Generics (Generic)
data ChangedFlag
= Changed
| NotChanged
deriving (Show, Eq, Generic)
instance Validity ChangedFlag
instance NFData ChangedFlag
data ClientValue a
= ClientValue !(Timed a) !ChangedFlag
deriving (Show, Eq, Generic)
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
)
]
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 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]
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 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 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 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 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)
instance NFData a => NFData (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)