{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module RON.Data.LWW
( LwwPerField (..)
, assignField
, lwwType
, newObject
, readField
, viewField
, zoomField
) where
import qualified Data.Map.Strict as Map
import RON.Data.Internal (Reducible, Replicated, collectFrame,
fromRon, getObjectStateChunk, mkStateChunk,
newRon, reducibleOpType, stateFromChunk,
stateToChunk)
import RON.Error (MonadE, errorContext)
import RON.Event (ReplicaClock, advanceToUuid, getEventUuid)
import RON.Types (Atom (AUuid), Object (..), Op (..), StateChunk (..),
StateFrame, UUID)
import RON.Util (Instance (Instance))
import qualified RON.UUID as UUID
lww :: Op -> Op -> Op
lww = maxOn opId
newtype LwwPerField = LwwPerField (Map UUID Op)
deriving (Eq, Monoid, Show)
instance Semigroup LwwPerField where
LwwPerField fields1 <> LwwPerField fields2 =
LwwPerField $ Map.unionWith lww fields1 fields2
instance Reducible LwwPerField where
reducibleOpType = lwwType
stateFromChunk ops =
LwwPerField $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops]
stateToChunk (LwwPerField fields) = mkStateChunk lwwType $ Map.elems fields
lwwType :: UUID
lwwType = $(UUID.liftName "lww")
newObject :: ReplicaClock m => [(UUID, Instance Replicated)] -> m (Object a)
newObject fields = collectFrame $ do
payloads <- for fields $ \(_, Instance value) -> newRon value
event <- lift getEventUuid
tell $
Map.singleton event $
StateChunk
{ stateType = lwwType
, stateVersion = event
, stateBody =
[Op event name p | ((name, _), p) <- zip fields payloads]
}
pure event
viewField
:: (Replicated a, MonadE m)
=> UUID
-> StateChunk
-> StateFrame
-> m a
viewField field StateChunk{..} frame =
errorContext ("LWW.viewField " <> show field) $ do
let ops = filter (\Op{refId} -> refId == field) stateBody
Op{payload} <- case ops of
[] -> throwError "no field in lww chunk"
[op] -> pure op
_ -> throwError "unreduced state"
fromRon payload frame
readField
:: (MonadE m, MonadState (Object a) m, Replicated b)
=> UUID
-> m b
readField field = do
obj@Object{..} <- get
stateChunk <- getObjectStateChunk obj
viewField field stateChunk frame
assignField
:: forall a b m
. (Replicated b, ReplicaClock m, MonadE m, MonadState (Object a) m)
=> UUID
-> b
-> m ()
assignField field value = do
obj@Object{id, frame} <- get
StateChunk{..} <- getObjectStateChunk obj
advanceToUuid stateVersion
let chunk = filter (\Op{refId} -> refId /= field) stateBody
event <- getEventUuid
(p, frame') <- runWriterT $ newRon value
let newOp = Op event field p
let chunk' = sortOn refId $ newOp : chunk
let state' = StateChunk
{stateVersion = event, stateBody = chunk', stateType = lwwType}
put obj{frame = Map.insert id state' frame <> frame'}
zoomField
:: MonadE m
=> UUID
-> StateT (Object inner) m a
-> StateT (Object outer) m a
zoomField field innerModifier =
errorContext ("LWW.zoomField" <> show field) $ do
obj@Object{..} <- get
StateChunk{..} <- getObjectStateChunk obj
let ops = filter (\Op{refId} -> refId == field) stateBody
Op{payload} <- case ops of
[] -> throwError "empty chunk"
[op] -> pure op
_ -> throwError "unreduced state"
innerObjectId <- errorContext "inner object" $ case payload of
[AUuid oid] -> pure oid
_ -> throwError "Expected object UUID"
let innerObject = Object innerObjectId frame
(a, Object{frame = frame'}) <-
lift $ runStateT innerModifier innerObject
put obj{frame = frame'}
pure a