{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A way to synchronise a single value with safe merge conflicts.
--
-- The setup is as follows:
--
-- * A central server is set up to synchronise with
-- * Each client synchronises with the central server, but never with eachother
--
--
--
-- = A client should operate as follows:
--
-- == For the first sychronisation
--
-- The client should ask the server for the current server value.
-- The server should send over a 'Timed' vaule, and the client should create its 'ClientValue' with 'initialClientValue'.
--
-- == For any following synchronisation:
--
--   * The client produces a 'ValueSyncRequest' with 'makeValueSyncRequest'.
--   * The client sends that request to the central server and gets a 'ValueSyncResponse'.
--   * The client then updates its local store with 'mergeValueSyncResponseRaw' or 'mergeValueSyncResponseIgnoreProblems'.
--
--
-- = The central server should operate as follows:
--
-- * The server should create an initial 'ServerValue' using 'initialServerValue'.
-- * The server accepts a 'ValueSyncRequest'.
-- * The server performs operations according to the functionality of 'processServerValueSync'.
-- * The server respons with a 'ValueSyncResponse'.
--
--
-- WARNING:
-- This whole approach can break down if a server resets its server times
-- or if a client syncs with two different servers using the same server times.
module Data.Mergeful.Value
  ( initialClientValue,
    makeValueSyncRequest,
    mergeValueSyncResponseRaw,
    ValueMergeResult (..),
    mergeValueSyncResponseIgnoreProblems,
    mergeIgnoringProblems,
    mergeFromServer,
    mergeUsingFunction,

    -- * Server side
    initialServerValue,
    processServerValueSync,

    -- * Types, for reference
    ChangedFlag (..),
    ClientValue (..),
    ValueSyncRequest (..),
    ValueSyncResponse (..),
    ServerValue (..),
  )
where

import Autodocodec
import Control.DeepSeq
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 stock (Int -> ChangedFlag -> ShowS
[ChangedFlag] -> ShowS
ChangedFlag -> String
(Int -> ChangedFlag -> ShowS)
-> (ChangedFlag -> String)
-> ([ChangedFlag] -> ShowS)
-> Show ChangedFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChangedFlag] -> ShowS
$cshowList :: [ChangedFlag] -> ShowS
show :: ChangedFlag -> String
$cshow :: ChangedFlag -> String
showsPrec :: Int -> ChangedFlag -> ShowS
$cshowsPrec :: Int -> ChangedFlag -> ShowS
Show, ChangedFlag -> ChangedFlag -> Bool
(ChangedFlag -> ChangedFlag -> Bool)
-> (ChangedFlag -> ChangedFlag -> Bool) -> Eq ChangedFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChangedFlag -> ChangedFlag -> Bool
$c/= :: ChangedFlag -> ChangedFlag -> Bool
== :: ChangedFlag -> ChangedFlag -> Bool
$c== :: ChangedFlag -> ChangedFlag -> Bool
Eq, (forall x. ChangedFlag -> Rep ChangedFlag x)
-> (forall x. Rep ChangedFlag x -> ChangedFlag)
-> Generic ChangedFlag
forall x. Rep ChangedFlag x -> ChangedFlag
forall x. ChangedFlag -> Rep ChangedFlag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChangedFlag x -> ChangedFlag
$cfrom :: forall x. ChangedFlag -> Rep ChangedFlag x
Generic)
  deriving (Value -> Parser [ChangedFlag]
Value -> Parser ChangedFlag
(Value -> Parser ChangedFlag)
-> (Value -> Parser [ChangedFlag]) -> FromJSON ChangedFlag
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChangedFlag]
$cparseJSONList :: Value -> Parser [ChangedFlag]
parseJSON :: Value -> Parser ChangedFlag
$cparseJSON :: Value -> Parser ChangedFlag
FromJSON, [ChangedFlag] -> Encoding
[ChangedFlag] -> Value
ChangedFlag -> Encoding
ChangedFlag -> Value
(ChangedFlag -> Value)
-> (ChangedFlag -> Encoding)
-> ([ChangedFlag] -> Value)
-> ([ChangedFlag] -> Encoding)
-> ToJSON ChangedFlag
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChangedFlag] -> Encoding
$ctoEncodingList :: [ChangedFlag] -> Encoding
toJSONList :: [ChangedFlag] -> Value
$ctoJSONList :: [ChangedFlag] -> Value
toEncoding :: ChangedFlag -> Encoding
$ctoEncoding :: ChangedFlag -> Encoding
toJSON :: ChangedFlag -> Value
$ctoJSON :: ChangedFlag -> Value
ToJSON) via (Autodocodec ChangedFlag)

instance Validity ChangedFlag

instance NFData ChangedFlag

instance HasCodec ChangedFlag where
  codec :: JSONCodec ChangedFlag
codec = (Bool -> ChangedFlag)
-> (ChangedFlag -> Bool)
-> Codec Value Bool Bool
-> JSONCodec ChangedFlag
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Bool -> ChangedFlag
f ChangedFlag -> Bool
g Codec Value Bool Bool
forall value. HasCodec value => JSONCodec value
codec
    where
      f :: Bool -> ChangedFlag
f = \case
        Bool
True -> ChangedFlag
Changed
        Bool
False -> ChangedFlag
NotChanged
      g :: ChangedFlag -> Bool
g = \case
        ChangedFlag
Changed -> Bool
True
        ChangedFlag
NotChanged -> Bool
False

-- | The client side value.
--
-- The only differences between `a` and 'ClientValue a' are that
-- 'ClientValue a' also remembers the last synchronisation time from
-- the server, and whether the item has been modified at the client
--
-- There cannot be an unsynced 'ClientValue'.
data ClientValue a = ClientValue
  { ClientValue a -> Timed a
clientValueTimedValue :: !(Timed a),
    ClientValue a -> ChangedFlag
clientValueChanged :: !ChangedFlag
  }
  deriving stock (Int -> ClientValue a -> ShowS
[ClientValue a] -> ShowS
ClientValue a -> String
(Int -> ClientValue a -> ShowS)
-> (ClientValue a -> String)
-> ([ClientValue a] -> ShowS)
-> Show (ClientValue a)
forall a. Show a => Int -> ClientValue a -> ShowS
forall a. Show a => [ClientValue a] -> ShowS
forall a. Show a => ClientValue a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientValue a] -> ShowS
$cshowList :: forall a. Show a => [ClientValue a] -> ShowS
show :: ClientValue a -> String
$cshow :: forall a. Show a => ClientValue a -> String
showsPrec :: Int -> ClientValue a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ClientValue a -> ShowS
Show, ClientValue a -> ClientValue a -> Bool
(ClientValue a -> ClientValue a -> Bool)
-> (ClientValue a -> ClientValue a -> Bool) -> Eq (ClientValue a)
forall a. Eq a => ClientValue a -> ClientValue a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientValue a -> ClientValue a -> Bool
$c/= :: forall a. Eq a => ClientValue a -> ClientValue a -> Bool
== :: ClientValue a -> ClientValue a -> Bool
$c== :: forall a. Eq a => ClientValue a -> ClientValue a -> Bool
Eq, (forall x. ClientValue a -> Rep (ClientValue a) x)
-> (forall x. Rep (ClientValue a) x -> ClientValue a)
-> Generic (ClientValue a)
forall x. Rep (ClientValue a) x -> ClientValue a
forall x. ClientValue a -> Rep (ClientValue a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ClientValue a) x -> ClientValue a
forall a x. ClientValue a -> Rep (ClientValue a) x
$cto :: forall a x. Rep (ClientValue a) x -> ClientValue a
$cfrom :: forall a x. ClientValue a -> Rep (ClientValue a) x
Generic)
  deriving (Value -> Parser [ClientValue a]
Value -> Parser (ClientValue a)
(Value -> Parser (ClientValue a))
-> (Value -> Parser [ClientValue a]) -> FromJSON (ClientValue a)
forall a. HasCodec a => Value -> Parser [ClientValue a]
forall a. HasCodec a => Value -> Parser (ClientValue a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ClientValue a]
$cparseJSONList :: forall a. HasCodec a => Value -> Parser [ClientValue a]
parseJSON :: Value -> Parser (ClientValue a)
$cparseJSON :: forall a. HasCodec a => Value -> Parser (ClientValue a)
FromJSON, [ClientValue a] -> Encoding
[ClientValue a] -> Value
ClientValue a -> Encoding
ClientValue a -> Value
(ClientValue a -> Value)
-> (ClientValue a -> Encoding)
-> ([ClientValue a] -> Value)
-> ([ClientValue a] -> Encoding)
-> ToJSON (ClientValue a)
forall a. HasCodec a => [ClientValue a] -> Encoding
forall a. HasCodec a => [ClientValue a] -> Value
forall a. HasCodec a => ClientValue a -> Encoding
forall a. HasCodec a => ClientValue a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ClientValue a] -> Encoding
$ctoEncodingList :: forall a. HasCodec a => [ClientValue a] -> Encoding
toJSONList :: [ClientValue a] -> Value
$ctoJSONList :: forall a. HasCodec a => [ClientValue a] -> Value
toEncoding :: ClientValue a -> Encoding
$ctoEncoding :: forall a. HasCodec a => ClientValue a -> Encoding
toJSON :: ClientValue a -> Value
$ctoJSON :: forall a. HasCodec a => ClientValue a -> Value
ToJSON) via (Autodocodec (ClientValue a))

instance Validity a => Validity (ClientValue a)

instance NFData a => NFData (ClientValue a)

instance HasCodec a => HasCodec (ClientValue a) where
  codec :: JSONCodec (ClientValue a)
codec =
    Text
-> ObjectCodec (ClientValue a) (ClientValue a)
-> JSONCodec (ClientValue a)
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
object Text
"ClientValue" (ObjectCodec (ClientValue a) (ClientValue a)
 -> JSONCodec (ClientValue a))
-> ObjectCodec (ClientValue a) (ClientValue a)
-> JSONCodec (ClientValue a)
forall a b. (a -> b) -> a -> b
$
      Timed a -> ChangedFlag -> ClientValue a
forall a. Timed a -> ChangedFlag -> ClientValue a
ClientValue
        (Timed a -> ChangedFlag -> ClientValue a)
-> Codec Object (ClientValue a) (Timed a)
-> Codec Object (ClientValue a) (ChangedFlag -> ClientValue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONObjectCodec (Timed a)
forall a. HasCodec a => JSONObjectCodec (Timed a)
timedObjectCodec JSONObjectCodec (Timed a)
-> (ClientValue a -> Timed a)
-> Codec Object (ClientValue a) (Timed a)
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= ClientValue a -> Timed a
forall a. ClientValue a -> Timed a
clientValueTimedValue
        Codec Object (ClientValue a) (ChangedFlag -> ClientValue a)
-> Codec Object (ClientValue a) ChangedFlag
-> ObjectCodec (ClientValue a) (ClientValue a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Text -> ObjectCodec ChangedFlag ChangedFlag
forall output.
HasCodec output =>
Text -> Text -> ObjectCodec output output
requiredField Text
"changed" Text
"whether the value has changed, client-side" ObjectCodec ChangedFlag ChangedFlag
-> (ClientValue a -> ChangedFlag)
-> Codec Object (ClientValue a) ChangedFlag
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= ClientValue a -> ChangedFlag
forall a. ClientValue a -> ChangedFlag
clientValueChanged

-- | Produce a client value based on an initial synchronisation request
initialClientValue :: Timed a -> ClientValue a
initialClientValue :: Timed a -> ClientValue a
initialClientValue Timed a
t = Timed a -> ChangedFlag -> ClientValue a
forall a. Timed a -> ChangedFlag -> ClientValue a
ClientValue Timed a
t ChangedFlag
NotChanged

-- | The server-side value.
--
-- 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 {ServerValue a -> Timed a
unServerValue :: Timed a}
  deriving stock (Int -> ServerValue a -> ShowS
[ServerValue a] -> ShowS
ServerValue a -> String
(Int -> ServerValue a -> ShowS)
-> (ServerValue a -> String)
-> ([ServerValue a] -> ShowS)
-> Show (ServerValue a)
forall a. Show a => Int -> ServerValue a -> ShowS
forall a. Show a => [ServerValue a] -> ShowS
forall a. Show a => ServerValue a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerValue a] -> ShowS
$cshowList :: forall a. Show a => [ServerValue a] -> ShowS
show :: ServerValue a -> String
$cshow :: forall a. Show a => ServerValue a -> String
showsPrec :: Int -> ServerValue a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ServerValue a -> ShowS
Show, ServerValue a -> ServerValue a -> Bool
(ServerValue a -> ServerValue a -> Bool)
-> (ServerValue a -> ServerValue a -> Bool) -> Eq (ServerValue a)
forall a. Eq a => ServerValue a -> ServerValue a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerValue a -> ServerValue a -> Bool
$c/= :: forall a. Eq a => ServerValue a -> ServerValue a -> Bool
== :: ServerValue a -> ServerValue a -> Bool
$c== :: forall a. Eq a => ServerValue a -> ServerValue a -> Bool
Eq, (forall x. ServerValue a -> Rep (ServerValue a) x)
-> (forall x. Rep (ServerValue a) x -> ServerValue a)
-> Generic (ServerValue a)
forall x. Rep (ServerValue a) x -> ServerValue a
forall x. ServerValue a -> Rep (ServerValue a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ServerValue a) x -> ServerValue a
forall a x. ServerValue a -> Rep (ServerValue a) x
$cto :: forall a x. Rep (ServerValue a) x -> ServerValue a
$cfrom :: forall a x. ServerValue a -> Rep (ServerValue a) x
Generic)
  deriving (Value -> Parser [ServerValue a]
Value -> Parser (ServerValue a)
(Value -> Parser (ServerValue a))
-> (Value -> Parser [ServerValue a]) -> FromJSON (ServerValue a)
forall a. HasCodec a => Value -> Parser [ServerValue a]
forall a. HasCodec a => Value -> Parser (ServerValue a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ServerValue a]
$cparseJSONList :: forall a. HasCodec a => Value -> Parser [ServerValue a]
parseJSON :: Value -> Parser (ServerValue a)
$cparseJSON :: forall a. HasCodec a => Value -> Parser (ServerValue a)
FromJSON, [ServerValue a] -> Encoding
[ServerValue a] -> Value
ServerValue a -> Encoding
ServerValue a -> Value
(ServerValue a -> Value)
-> (ServerValue a -> Encoding)
-> ([ServerValue a] -> Value)
-> ([ServerValue a] -> Encoding)
-> ToJSON (ServerValue a)
forall a. HasCodec a => [ServerValue a] -> Encoding
forall a. HasCodec a => [ServerValue a] -> Value
forall a. HasCodec a => ServerValue a -> Encoding
forall a. HasCodec a => ServerValue a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ServerValue a] -> Encoding
$ctoEncodingList :: forall a. HasCodec a => [ServerValue a] -> Encoding
toJSONList :: [ServerValue a] -> Value
$ctoJSONList :: forall a. HasCodec a => [ServerValue a] -> Value
toEncoding :: ServerValue a -> Encoding
$ctoEncoding :: forall a. HasCodec a => ServerValue a -> Encoding
toJSON :: ServerValue a -> Value
$ctoJSON :: forall a. HasCodec a => ServerValue a -> Value
ToJSON) via (Autodocodec (ServerValue a))

instance Validity a => Validity (ServerValue a)

instance NFData a => NFData (ServerValue a)

instance HasCodec a => HasCodec (ServerValue a) where
  codec :: JSONCodec (ServerValue a)
codec = Text
-> ObjectCodec (ServerValue a) (ServerValue a)
-> JSONCodec (ServerValue a)
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
object Text
"ServerValue" (ObjectCodec (ServerValue a) (ServerValue a)
 -> JSONCodec (ServerValue a))
-> ObjectCodec (ServerValue a) (ServerValue a)
-> JSONCodec (ServerValue a)
forall a b. (a -> b) -> a -> b
$ Timed a -> ServerValue a
forall a. Timed a -> ServerValue a
ServerValue (Timed a -> ServerValue a)
-> Codec Object (ServerValue a) (Timed a)
-> ObjectCodec (ServerValue a) (ServerValue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONObjectCodec (Timed a)
forall a. HasCodec a => JSONObjectCodec (Timed a)
timedObjectCodec JSONObjectCodec (Timed a)
-> (ServerValue a -> Timed a)
-> Codec Object (ServerValue a) (Timed a)
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= ServerValue a -> Timed a
forall a. ServerValue a -> Timed a
unServerValue

-- | Initialise a server value.
--
-- Note that the server has to start with a value, the value 'a' cannot be omitted.
initialServerValue :: a -> ServerValue a
initialServerValue :: a -> ServerValue a
initialServerValue a
a = Timed a -> ServerValue a
forall a. Timed a -> ServerValue a
ServerValue (Timed a -> ServerValue a) -> Timed a -> ServerValue a
forall a b. (a -> b) -> a -> b
$ Timed :: forall a. a -> ServerTime -> Timed a
Timed {timedValue :: a
timedValue = a
a, timedTime :: ServerTime
timedTime = ServerTime
initialServerTime}

data ValueSyncRequest a
  = -- | There is an item locally that was synced at the given 'ServerTime'
    ValueSyncRequestKnown !ServerTime
  | -- | There is an item locally that was synced at the given 'ServerTime'
    -- but it has been changed since then.
    ValueSyncRequestKnownButChanged !(Timed a)
  deriving stock (Int -> ValueSyncRequest a -> ShowS
[ValueSyncRequest a] -> ShowS
ValueSyncRequest a -> String
(Int -> ValueSyncRequest a -> ShowS)
-> (ValueSyncRequest a -> String)
-> ([ValueSyncRequest a] -> ShowS)
-> Show (ValueSyncRequest a)
forall a. Show a => Int -> ValueSyncRequest a -> ShowS
forall a. Show a => [ValueSyncRequest a] -> ShowS
forall a. Show a => ValueSyncRequest a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueSyncRequest a] -> ShowS
$cshowList :: forall a. Show a => [ValueSyncRequest a] -> ShowS
show :: ValueSyncRequest a -> String
$cshow :: forall a. Show a => ValueSyncRequest a -> String
showsPrec :: Int -> ValueSyncRequest a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ValueSyncRequest a -> ShowS
Show, ValueSyncRequest a -> ValueSyncRequest a -> Bool
(ValueSyncRequest a -> ValueSyncRequest a -> Bool)
-> (ValueSyncRequest a -> ValueSyncRequest a -> Bool)
-> Eq (ValueSyncRequest a)
forall a. Eq a => ValueSyncRequest a -> ValueSyncRequest a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueSyncRequest a -> ValueSyncRequest a -> Bool
$c/= :: forall a. Eq a => ValueSyncRequest a -> ValueSyncRequest a -> Bool
== :: ValueSyncRequest a -> ValueSyncRequest a -> Bool
$c== :: forall a. Eq a => ValueSyncRequest a -> ValueSyncRequest a -> Bool
Eq, (forall x. ValueSyncRequest a -> Rep (ValueSyncRequest a) x)
-> (forall x. Rep (ValueSyncRequest a) x -> ValueSyncRequest a)
-> Generic (ValueSyncRequest a)
forall x. Rep (ValueSyncRequest a) x -> ValueSyncRequest a
forall x. ValueSyncRequest a -> Rep (ValueSyncRequest a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ValueSyncRequest a) x -> ValueSyncRequest a
forall a x. ValueSyncRequest a -> Rep (ValueSyncRequest a) x
$cto :: forall a x. Rep (ValueSyncRequest a) x -> ValueSyncRequest a
$cfrom :: forall a x. ValueSyncRequest a -> Rep (ValueSyncRequest a) x
Generic)
  deriving (Value -> Parser [ValueSyncRequest a]
Value -> Parser (ValueSyncRequest a)
(Value -> Parser (ValueSyncRequest a))
-> (Value -> Parser [ValueSyncRequest a])
-> FromJSON (ValueSyncRequest a)
forall a. HasCodec a => Value -> Parser [ValueSyncRequest a]
forall a. HasCodec a => Value -> Parser (ValueSyncRequest a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ValueSyncRequest a]
$cparseJSONList :: forall a. HasCodec a => Value -> Parser [ValueSyncRequest a]
parseJSON :: Value -> Parser (ValueSyncRequest a)
$cparseJSON :: forall a. HasCodec a => Value -> Parser (ValueSyncRequest a)
FromJSON, [ValueSyncRequest a] -> Encoding
[ValueSyncRequest a] -> Value
ValueSyncRequest a -> Encoding
ValueSyncRequest a -> Value
(ValueSyncRequest a -> Value)
-> (ValueSyncRequest a -> Encoding)
-> ([ValueSyncRequest a] -> Value)
-> ([ValueSyncRequest a] -> Encoding)
-> ToJSON (ValueSyncRequest a)
forall a. HasCodec a => [ValueSyncRequest a] -> Encoding
forall a. HasCodec a => [ValueSyncRequest a] -> Value
forall a. HasCodec a => ValueSyncRequest a -> Encoding
forall a. HasCodec a => ValueSyncRequest a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ValueSyncRequest a] -> Encoding
$ctoEncodingList :: forall a. HasCodec a => [ValueSyncRequest a] -> Encoding
toJSONList :: [ValueSyncRequest a] -> Value
$ctoJSONList :: forall a. HasCodec a => [ValueSyncRequest a] -> Value
toEncoding :: ValueSyncRequest a -> Encoding
$ctoEncoding :: forall a. HasCodec a => ValueSyncRequest a -> Encoding
toJSON :: ValueSyncRequest a -> Value
$ctoJSON :: forall a. HasCodec a => ValueSyncRequest a -> Value
ToJSON) via (Autodocodec (ValueSyncRequest a))

instance Validity a => Validity (ValueSyncRequest a)

instance NFData a => NFData (ValueSyncRequest a)

instance HasCodec a => HasCodec (ValueSyncRequest a) where
  codec :: JSONCodec (ValueSyncRequest a)
codec =
    Text
-> ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a)
-> JSONCodec (ValueSyncRequest a)
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
object Text
"ValueSyncRequest" (ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a)
 -> JSONCodec (ValueSyncRequest a))
-> ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a)
-> JSONCodec (ValueSyncRequest a)
forall a b. (a -> b) -> a -> b
$
      (Either ServerTime (Timed a) -> ValueSyncRequest a)
-> (ValueSyncRequest a -> Either ServerTime (Timed a))
-> Codec
     Object (Either ServerTime (Timed a)) (Either ServerTime (Timed a))
-> ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a)
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Either ServerTime (Timed a) -> ValueSyncRequest a
forall a. Either ServerTime (Timed a) -> ValueSyncRequest a
f ValueSyncRequest a -> Either ServerTime (Timed a)
forall a. ValueSyncRequest a -> Either ServerTime (Timed a)
g (Codec
   Object (Either ServerTime (Timed a)) (Either ServerTime (Timed a))
 -> ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a))
-> Codec
     Object (Either ServerTime (Timed a)) (Either ServerTime (Timed a))
-> ObjectCodec (ValueSyncRequest a) (ValueSyncRequest a)
forall a b. (a -> b) -> a -> b
$
        Codec Object ServerTime ServerTime
-> Codec Object (Timed a) (Timed a)
-> Codec
     Object (Either ServerTime (Timed a)) (Either ServerTime (Timed a))
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec
          (Text -> ObjectCodec ServerTime (ServerTime -> ServerTime)
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"synced" ObjectCodec ServerTime (ServerTime -> ServerTime)
-> Codec Object ServerTime ServerTime
-> Codec Object ServerTime ServerTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Text -> Codec Object ServerTime ServerTime
forall output.
HasCodec output =>
Text -> Text -> ObjectCodec output output
requiredField Text
"time" Text
"time at which the server said the value was last synced")
          (Text -> ObjectCodec (Timed a) (Timed a -> Timed a)
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"changed" ObjectCodec (Timed a) (Timed a -> Timed a)
-> Codec Object (Timed a) (Timed a)
-> Codec Object (Timed a) (Timed a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec Object (Timed a) (Timed a)
forall a. HasCodec a => JSONObjectCodec (Timed a)
timedObjectCodec)
    where
      f :: Either ServerTime (Timed a) -> ValueSyncRequest a
f = \case
        Left ServerTime
st -> ServerTime -> ValueSyncRequest a
forall a. ServerTime -> ValueSyncRequest a
ValueSyncRequestKnown ServerTime
st
        Right Timed a
tv -> Timed a -> ValueSyncRequest a
forall a. Timed a -> ValueSyncRequest a
ValueSyncRequestKnownButChanged Timed a
tv
      g :: ValueSyncRequest a -> Either ServerTime (Timed a)
g = \case
        ValueSyncRequestKnown ServerTime
st -> ServerTime -> Either ServerTime (Timed a)
forall a b. a -> Either a b
Left ServerTime
st
        ValueSyncRequestKnownButChanged Timed a
tv -> Timed a -> Either ServerTime (Timed a)
forall a b. b -> Either a b
Right Timed a
tv

      typeField :: Text -> ObjectCodec b (a -> a)
      typeField :: Text -> ObjectCodec b (a -> a)
typeField Text
typeName = a -> a
forall a. a -> a
id (a -> a) -> Codec Object b Text -> ObjectCodec b (a -> a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueCodec Text Text -> ObjectCodec Text Text
forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
"type" (Text -> ValueCodec Text Text
literalTextCodec Text
typeName) ObjectCodec Text Text -> (b -> Text) -> Codec Object b Text
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= Text -> b -> Text
forall a b. a -> b -> a
const Text
typeName

data ValueSyncResponse a
  = -- | The client and server are fully in sync.
    --
    -- Nothing needs to be done at the client side.
    ValueSyncResponseInSync
  | -- | The client changed the value and server has succesfully been made aware of that.
    --
    -- The client needs to update its server time
    ValueSyncResponseClientChanged !ServerTime
  | -- | This value has been changed on the server side.
    --
    -- The client should change it too.
    ValueSyncResponseServerChanged !(Timed a)
  | -- | The item at the server side
    ValueSyncResponseConflict !(Timed a)
  deriving stock (Int -> ValueSyncResponse a -> ShowS
[ValueSyncResponse a] -> ShowS
ValueSyncResponse a -> String
(Int -> ValueSyncResponse a -> ShowS)
-> (ValueSyncResponse a -> String)
-> ([ValueSyncResponse a] -> ShowS)
-> Show (ValueSyncResponse a)
forall a. Show a => Int -> ValueSyncResponse a -> ShowS
forall a. Show a => [ValueSyncResponse a] -> ShowS
forall a. Show a => ValueSyncResponse a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueSyncResponse a] -> ShowS
$cshowList :: forall a. Show a => [ValueSyncResponse a] -> ShowS
show :: ValueSyncResponse a -> String
$cshow :: forall a. Show a => ValueSyncResponse a -> String
showsPrec :: Int -> ValueSyncResponse a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ValueSyncResponse a -> ShowS
Show, ValueSyncResponse a -> ValueSyncResponse a -> Bool
(ValueSyncResponse a -> ValueSyncResponse a -> Bool)
-> (ValueSyncResponse a -> ValueSyncResponse a -> Bool)
-> Eq (ValueSyncResponse a)
forall a.
Eq a =>
ValueSyncResponse a -> ValueSyncResponse a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueSyncResponse a -> ValueSyncResponse a -> Bool
$c/= :: forall a.
Eq a =>
ValueSyncResponse a -> ValueSyncResponse a -> Bool
== :: ValueSyncResponse a -> ValueSyncResponse a -> Bool
$c== :: forall a.
Eq a =>
ValueSyncResponse a -> ValueSyncResponse a -> Bool
Eq, (forall x. ValueSyncResponse a -> Rep (ValueSyncResponse a) x)
-> (forall x. Rep (ValueSyncResponse a) x -> ValueSyncResponse a)
-> Generic (ValueSyncResponse a)
forall x. Rep (ValueSyncResponse a) x -> ValueSyncResponse a
forall x. ValueSyncResponse a -> Rep (ValueSyncResponse a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ValueSyncResponse a) x -> ValueSyncResponse a
forall a x. ValueSyncResponse a -> Rep (ValueSyncResponse a) x
$cto :: forall a x. Rep (ValueSyncResponse a) x -> ValueSyncResponse a
$cfrom :: forall a x. ValueSyncResponse a -> Rep (ValueSyncResponse a) x
Generic)
  deriving (Value -> Parser [ValueSyncResponse a]
Value -> Parser (ValueSyncResponse a)
(Value -> Parser (ValueSyncResponse a))
-> (Value -> Parser [ValueSyncResponse a])
-> FromJSON (ValueSyncResponse a)
forall a. HasCodec a => Value -> Parser [ValueSyncResponse a]
forall a. HasCodec a => Value -> Parser (ValueSyncResponse a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ValueSyncResponse a]
$cparseJSONList :: forall a. HasCodec a => Value -> Parser [ValueSyncResponse a]
parseJSON :: Value -> Parser (ValueSyncResponse a)
$cparseJSON :: forall a. HasCodec a => Value -> Parser (ValueSyncResponse a)
FromJSON, [ValueSyncResponse a] -> Encoding
[ValueSyncResponse a] -> Value
ValueSyncResponse a -> Encoding
ValueSyncResponse a -> Value
(ValueSyncResponse a -> Value)
-> (ValueSyncResponse a -> Encoding)
-> ([ValueSyncResponse a] -> Value)
-> ([ValueSyncResponse a] -> Encoding)
-> ToJSON (ValueSyncResponse a)
forall a. HasCodec a => [ValueSyncResponse a] -> Encoding
forall a. HasCodec a => [ValueSyncResponse a] -> Value
forall a. HasCodec a => ValueSyncResponse a -> Encoding
forall a. HasCodec a => ValueSyncResponse a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ValueSyncResponse a] -> Encoding
$ctoEncodingList :: forall a. HasCodec a => [ValueSyncResponse a] -> Encoding
toJSONList :: [ValueSyncResponse a] -> Value
$ctoJSONList :: forall a. HasCodec a => [ValueSyncResponse a] -> Value
toEncoding :: ValueSyncResponse a -> Encoding
$ctoEncoding :: forall a. HasCodec a => ValueSyncResponse a -> Encoding
toJSON :: ValueSyncResponse a -> Value
$ctoJSON :: forall a. HasCodec a => ValueSyncResponse a -> Value
ToJSON) via (Autodocodec (ValueSyncResponse a))

instance Validity a => Validity (ValueSyncResponse a)

instance NFData a => NFData (ValueSyncResponse a)

instance HasCodec a => HasCodec (ValueSyncResponse a) where
  codec :: JSONCodec (ValueSyncResponse a)
codec =
    Text
-> ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a)
-> JSONCodec (ValueSyncResponse a)
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
object Text
"ValueSyncResponse" (ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a)
 -> JSONCodec (ValueSyncResponse a))
-> ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a)
-> JSONCodec (ValueSyncResponse a)
forall a b. (a -> b) -> a -> b
$
      (Either (Either () ServerTime) (Either (Timed a) (Timed a))
 -> ValueSyncResponse a)
-> (ValueSyncResponse a
    -> Either (Either () ServerTime) (Either (Timed a) (Timed a)))
-> Codec
     Object
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
-> ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a)
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Either (Either () ServerTime) (Either (Timed a) (Timed a))
-> ValueSyncResponse a
forall a.
Either (Either () ServerTime) (Either (Timed a) (Timed a))
-> ValueSyncResponse a
f ValueSyncResponse a
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
forall a.
ValueSyncResponse a
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
g (Codec
   Object
   (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
   (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
 -> ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a))
-> Codec
     Object
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
-> ObjectCodec (ValueSyncResponse a) (ValueSyncResponse a)
forall a b. (a -> b) -> a -> b
$
        Codec Object (Either () ServerTime) (Either () ServerTime)
-> Codec
     Object (Either (Timed a) (Timed a)) (Either (Timed a) (Timed a))
-> Codec
     Object
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
     (Either (Either () ServerTime) (Either (Timed a) (Timed a)))
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec
          ( Codec Object () ()
-> Codec Object ServerTime ServerTime
-> Codec Object (Either () ServerTime) (Either () ServerTime)
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec
              (Text -> ObjectCodec () (() -> ())
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"in-sync" ObjectCodec () (() -> ())
-> Codec Object () () -> Codec Object () ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> Codec Object () ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (Text -> ObjectCodec ServerTime (ServerTime -> ServerTime)
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"client-changed" ObjectCodec ServerTime (ServerTime -> ServerTime)
-> Codec Object ServerTime ServerTime
-> Codec Object ServerTime ServerTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Text -> Codec Object ServerTime ServerTime
forall output.
HasCodec output =>
Text -> Text -> ObjectCodec output output
requiredField Text
"time" Text
"server time")
          )
          ( Codec Object (Timed a) (Timed a)
-> Codec Object (Timed a) (Timed a)
-> Codec
     Object (Either (Timed a) (Timed a)) (Either (Timed a) (Timed a))
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec
              (Text -> ObjectCodec (Timed a) (Timed a -> Timed a)
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"server-changed" ObjectCodec (Timed a) (Timed a -> Timed a)
-> Codec Object (Timed a) (Timed a)
-> Codec Object (Timed a) (Timed a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec Object (Timed a) (Timed a)
forall a. HasCodec a => JSONObjectCodec (Timed a)
timedObjectCodec)
              (Text -> ObjectCodec (Timed a) (Timed a -> Timed a)
forall b a. Text -> ObjectCodec b (a -> a)
typeField Text
"conflict" ObjectCodec (Timed a) (Timed a -> Timed a)
-> Codec Object (Timed a) (Timed a)
-> Codec Object (Timed a) (Timed a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec Object (Timed a) (Timed a)
forall a. HasCodec a => JSONObjectCodec (Timed a)
timedObjectCodec)
          )
    where
      f :: Either (Either () ServerTime) (Either (Timed a) (Timed a))
-> ValueSyncResponse a
f = \case
        Left (Left ()) -> ValueSyncResponse a
forall a. ValueSyncResponse a
ValueSyncResponseInSync
        Left (Right ServerTime
st) -> ServerTime -> ValueSyncResponse a
forall a. ServerTime -> ValueSyncResponse a
ValueSyncResponseClientChanged ServerTime
st
        Right (Left Timed a
tv) -> Timed a -> ValueSyncResponse a
forall a. Timed a -> ValueSyncResponse a
ValueSyncResponseServerChanged Timed a
tv
        Right (Right Timed a
tv) -> Timed a -> ValueSyncResponse a
forall a. Timed a -> ValueSyncResponse a
ValueSyncResponseConflict Timed a
tv
      g :: ValueSyncResponse a
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
g = \case
        ValueSyncResponse a
ValueSyncResponseInSync -> Either () ServerTime
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
forall a b. a -> Either a b
Left (() -> Either () ServerTime
forall a b. a -> Either a b
Left ())
        ValueSyncResponseClientChanged ServerTime
st -> Either () ServerTime
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
forall a b. a -> Either a b
Left (ServerTime -> Either () ServerTime
forall a b. b -> Either a b
Right ServerTime
st)
        ValueSyncResponseServerChanged Timed a
tv -> Either (Timed a) (Timed a)
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
forall a b. b -> Either a b
Right (Timed a -> Either (Timed a) (Timed a)
forall a b. a -> Either a b
Left Timed a
tv)
        ValueSyncResponseConflict Timed a
tv -> Either (Timed a) (Timed a)
-> Either (Either () ServerTime) (Either (Timed a) (Timed a))
forall a b. b -> Either a b
Right (Timed a -> Either (Timed a) (Timed a)
forall a b. b -> Either a b
Right Timed a
tv)

      typeField :: Text -> ObjectCodec b (a -> a)
      typeField :: Text -> ObjectCodec b (a -> a)
typeField Text
typeName = a -> a
forall a. a -> a
id (a -> a) -> Codec Object b Text -> ObjectCodec b (a -> a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> ValueCodec Text Text -> ObjectCodec Text Text
forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
"type" (Text -> ValueCodec Text Text
literalTextCodec Text
typeName) ObjectCodec Text Text -> (b -> Text) -> Codec Object b Text
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= Text -> b -> Text
forall a b. a -> b -> a
const Text
typeName

-- | Produce an 'ItemSyncRequest' from a 'ClientItem'.
--
-- Send this to the server for synchronisation.
makeValueSyncRequest :: ClientValue a -> ValueSyncRequest a
makeValueSyncRequest :: ClientValue a -> ValueSyncRequest a
makeValueSyncRequest (ClientValue Timed a
t ChangedFlag
cf) =
  case ChangedFlag
cf of
    ChangedFlag
NotChanged -> ServerTime -> ValueSyncRequest a
forall a. ServerTime -> ValueSyncRequest a
ValueSyncRequestKnown (Timed a -> ServerTime
forall a. Timed a -> ServerTime
timedTime Timed a
t)
    ChangedFlag
Changed -> Timed a -> ValueSyncRequest a
forall a. Timed a -> ValueSyncRequest a
ValueSyncRequestKnownButChanged Timed a
t

data ValueMergeResult a
  = -- | The merger went succesfully, no conflicts or desyncs
    MergeSuccess !(ClientValue a)
  | -- | The item at the server side
    MergeConflict !a !(Timed a)
  | -- | The server responded with a response that did not make sense given the client's request.
    --
    -- This should not happen in practice.
    MergeMismatch
  deriving (Int -> ValueMergeResult a -> ShowS
[ValueMergeResult a] -> ShowS
ValueMergeResult a -> String
(Int -> ValueMergeResult a -> ShowS)
-> (ValueMergeResult a -> String)
-> ([ValueMergeResult a] -> ShowS)
-> Show (ValueMergeResult a)
forall a. Show a => Int -> ValueMergeResult a -> ShowS
forall a. Show a => [ValueMergeResult a] -> ShowS
forall a. Show a => ValueMergeResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueMergeResult a] -> ShowS
$cshowList :: forall a. Show a => [ValueMergeResult a] -> ShowS
show :: ValueMergeResult a -> String
$cshow :: forall a. Show a => ValueMergeResult a -> String
showsPrec :: Int -> ValueMergeResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ValueMergeResult a -> ShowS
Show, ValueMergeResult a -> ValueMergeResult a -> Bool
(ValueMergeResult a -> ValueMergeResult a -> Bool)
-> (ValueMergeResult a -> ValueMergeResult a -> Bool)
-> Eq (ValueMergeResult a)
forall a. Eq a => ValueMergeResult a -> ValueMergeResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueMergeResult a -> ValueMergeResult a -> Bool
$c/= :: forall a. Eq a => ValueMergeResult a -> ValueMergeResult a -> Bool
== :: ValueMergeResult a -> ValueMergeResult a -> Bool
$c== :: forall a. Eq a => ValueMergeResult a -> ValueMergeResult a -> Bool
Eq, (forall x. ValueMergeResult a -> Rep (ValueMergeResult a) x)
-> (forall x. Rep (ValueMergeResult a) x -> ValueMergeResult a)
-> Generic (ValueMergeResult a)
forall x. Rep (ValueMergeResult a) x -> ValueMergeResult a
forall x. ValueMergeResult a -> Rep (ValueMergeResult a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ValueMergeResult a) x -> ValueMergeResult a
forall a x. ValueMergeResult a -> Rep (ValueMergeResult a) x
$cto :: forall a x. Rep (ValueMergeResult a) x -> ValueMergeResult a
$cfrom :: forall a x. ValueMergeResult a -> Rep (ValueMergeResult a) x
Generic)

instance Validity a => Validity (ValueMergeResult a)

instance NFData a => NFData (ValueMergeResult a)

-- | Merge an 'ValueSyncResponse' into the current 'ClientValue'.
--
-- This function will not make any decisions about what to do with
-- conflicts or mismatches between the request and the response.
-- It only produces a 'ValueMergeResult' so you can decide what to do with it.
mergeValueSyncResponseRaw :: ClientValue a -> ValueSyncResponse a -> ValueMergeResult a
mergeValueSyncResponseRaw :: ClientValue a -> ValueSyncResponse a -> ValueMergeResult a
mergeValueSyncResponseRaw cv :: ClientValue a
cv@(ClientValue Timed a
ct ChangedFlag
cf) ValueSyncResponse a
sr =
  case ChangedFlag
cf of
    ChangedFlag
NotChanged ->
      case ValueSyncResponse a
sr of
        ValueSyncResponse a
ValueSyncResponseInSync -> ClientValue a -> ValueMergeResult a
forall a. ClientValue a -> ValueMergeResult a
MergeSuccess ClientValue a
cv
        ValueSyncResponseServerChanged Timed a
st -> ClientValue a -> ValueMergeResult a
forall a. ClientValue a -> ValueMergeResult a
MergeSuccess (ClientValue a -> ValueMergeResult a)
-> ClientValue a -> ValueMergeResult a
forall a b. (a -> b) -> a -> b
$ Timed a -> ChangedFlag -> ClientValue a
forall a. Timed a -> ChangedFlag -> ClientValue a
ClientValue Timed a
st ChangedFlag
NotChanged
        ValueSyncResponse a
_ -> ValueMergeResult a
forall a. ValueMergeResult a
MergeMismatch
    ChangedFlag
Changed ->
      case ValueSyncResponse a
sr of
        ValueSyncResponseClientChanged ServerTime
st ->
          ClientValue a -> ValueMergeResult a
forall a. ClientValue a -> ValueMergeResult a
MergeSuccess (ClientValue a -> ValueMergeResult a)
-> ClientValue a -> ValueMergeResult a
forall a b. (a -> b) -> a -> b
$ Timed a -> ChangedFlag -> ClientValue a
forall a. Timed a -> ChangedFlag -> ClientValue a
ClientValue (Timed a
ct {timedTime :: ServerTime
timedTime = ServerTime
st}) ChangedFlag
NotChanged
        ValueSyncResponseConflict Timed a
si -> a -> Timed a -> ValueMergeResult a
forall a. a -> Timed a -> ValueMergeResult a
MergeConflict (Timed a -> a
forall a. Timed a -> a
timedValue Timed a
ct) Timed a
si
        ValueSyncResponse a
_ -> ValueMergeResult a
forall a. ValueMergeResult a
MergeMismatch

-- | Resolve a 'ValueSyncResponse' into the current 'ClientValue'.
--
-- This function ignores any problems that may occur.
-- In the case of a conclict, it will just not update the client item.
-- The next sync request will then produce a conflict again.
--
-- > mergeValueSyncResponseIgnoreProblems cs = mergeIgnoringProblems cs . mergeValueSyncResponseRaw cs
mergeValueSyncResponseIgnoreProblems :: ClientValue a -> ValueSyncResponse a -> ClientValue a
mergeValueSyncResponseIgnoreProblems :: ClientValue a -> ValueSyncResponse a -> ClientValue a
mergeValueSyncResponseIgnoreProblems ClientValue a
cs = ClientValue a -> ValueMergeResult a -> ClientValue a
forall a. ClientValue a -> ValueMergeResult a -> ClientValue a
mergeIgnoringProblems ClientValue a
cs (ValueMergeResult a -> ClientValue a)
-> (ValueSyncResponse a -> ValueMergeResult a)
-> ValueSyncResponse a
-> ClientValue a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientValue a -> ValueSyncResponse a -> ValueMergeResult a
forall a.
ClientValue a -> ValueSyncResponse a -> ValueMergeResult a
mergeValueSyncResponseRaw ClientValue a
cs

-- | Ignore any merge problems in a 'ValueMergeResult'.
--
-- This function just returns the original 'ClientValue' if anything other than 'MergeSuccess' occurs.
--
-- This function ignores any problems that may occur.
-- In the case of a conclict, it will just not update the client item.
-- The next sync request will then produce a conflict again.
--
-- Pro: does not lose data
--
-- __Con: Clients will diverge when a conflict occurs__
mergeIgnoringProblems :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeIgnoringProblems :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeIgnoringProblems ClientValue a
cs ValueMergeResult a
mr =
  case ValueMergeResult a
mr of
    MergeSuccess ClientValue a
cs' -> ClientValue a
cs'
    MergeConflict a
_ Timed a
_ -> ClientValue a
cs
    ValueMergeResult a
MergeMismatch -> ClientValue a
cs

-- | Resolve a 'ValueMergeResult' using a given merge strategy.
--
-- This function ignores 'MergeMismatch' and will just return the original 'ClientValue' in that case.
--
-- In order for clients to converge on the same value correctly, this function must be:
--
-- * Associative
-- * Idempotent
-- * The same on all clients
mergeUsingFunction ::
  (a -> Timed a -> Timed a) -> ClientValue a -> ValueMergeResult a -> ClientValue a
mergeUsingFunction :: (a -> Timed a -> Timed a)
-> ClientValue a -> ValueMergeResult a -> ClientValue a
mergeUsingFunction a -> Timed a -> Timed a
func ClientValue a
cs ValueMergeResult a
mr =
  case ValueMergeResult a
mr of
    MergeSuccess ClientValue a
cs' -> ClientValue a
cs'
    MergeConflict a
a1 Timed a
a2 -> Timed a -> ChangedFlag -> ClientValue a
forall a. Timed a -> ChangedFlag -> ClientValue a
ClientValue (a -> Timed a -> Timed a
func a
a1 Timed a
a2) ChangedFlag
NotChanged
    ValueMergeResult a
MergeMismatch -> ClientValue a
cs

-- | Resolve a 'ValueMergeResult' by taking whatever the server gave the client.
--
-- Pro: Clients will converge on the same value.
--
-- __Con: Conflicting updates will be lost.__
mergeFromServer :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeFromServer :: ClientValue a -> ValueMergeResult a -> ClientValue a
mergeFromServer = (a -> Timed a -> Timed a)
-> ClientValue a -> ValueMergeResult a -> ClientValue a
forall a.
(a -> Timed a -> Timed a)
-> ClientValue a -> ValueMergeResult a -> ClientValue a
mergeUsingFunction (\a
_ Timed a
serverItem -> Timed a
serverItem)

-- | Serve an 'ValueSyncRequest' using the current 'ServerValue', producing an 'ValueSyncResponse' and a new 'ServerValue'.
processServerValueSync ::
  ServerValue a -> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a)
processServerValueSync :: ServerValue a
-> ValueSyncRequest a -> (ValueSyncResponse a, ServerValue a)
processServerValueSync sv :: ServerValue a
sv@(ServerValue t :: Timed a
t@(Timed a
_ ServerTime
st)) ValueSyncRequest a
sr =
  case ValueSyncRequest a
sr of
    ValueSyncRequestKnown ServerTime
ct ->
      if ServerTime
ct ServerTime -> ServerTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ServerTime
st
        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.)
          (ValueSyncResponse a
forall a. ValueSyncResponse a
ValueSyncResponseInSync, ServerValue a
sv)
        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.
        -- No conflict here.
          (Timed a -> ValueSyncResponse a
forall a. Timed a -> ValueSyncResponse a
ValueSyncResponseServerChanged Timed a
t, ServerValue a
sv)
    ValueSyncRequestKnownButChanged Timed {timedValue :: forall a. Timed a -> a
timedValue = a
ci, timedTime :: forall a. Timed a -> ServerTime
timedTime = ServerTime
ct} ->
      if ServerTime
ct ServerTime -> ServerTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ServerTime
st
        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.

          let st' :: ServerTime
st' = ServerTime -> ServerTime
incrementServerTime ServerTime
st
           in ( ServerTime -> ValueSyncResponse a
forall a. ServerTime -> ValueSyncResponse a
ValueSyncResponseClientChanged ServerTime
st',
                Timed a -> ServerValue a
forall a. Timed a -> ServerValue a
ServerValue (Timed :: forall a. a -> ServerTime -> Timed a
Timed {timedValue :: a
timedValue = a
ci, timedTime :: ServerTime
timedTime = ServerTime
st'})
              )
        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.
          (Timed a -> ValueSyncResponse a
forall a. Timed a -> ValueSyncResponse a
ValueSyncResponseConflict Timed a
t, ServerValue a
sv)