{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module RON.Data.LWW
( LwwRep (..)
, assignField
, lwwType
, newObject
, readField
, viewField
, zoomField
) where
import RON.Prelude
import qualified Data.Map.Strict as Map
import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,
Replicated, 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 LwwRep = LwwRep (Map UUID Op)
deriving (Eq, Monoid, Show)
instance Semigroup LwwRep where
LwwRep fields1 <> LwwRep fields2 =
LwwRep $ Map.unionWith lww fields1 fields2
instance Reducible LwwRep where
reducibleOpType = lwwType
stateFromChunk ops =
LwwRep $ Map.fromListWith lww [(refId, op) | op@Op{refId} <- ops]
stateToChunk (LwwRep fields) = mkStateChunk lwwType $ Map.elems fields
lwwType :: UUID
lwwType = $(UUID.liftName "lww")
newObject
:: (MonadState StateFrame m, ReplicaClock m)
=> [(UUID, Instance Replicated)] -> m UUID
newObject fields = do
payloads <- for fields $ \(_, Instance value) -> newRon value
event <- getEventUuid
modify' $
(<>) $ 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, MonadState StateFrame m)
=> UUID
-> StateChunk
-> m a
viewField field StateChunk{..} =
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
readField
:: (MonadE m, MonadObjectState struct m, Replicated field)
=> UUID
-> m field
readField field = do
stateChunk <- getObjectStateChunk
viewField field stateChunk
assignField
:: (Replicated field, ReplicaClock m, MonadE m, MonadObjectState struct m)
=> UUID
-> field
-> m ()
assignField field value = do
StateChunk{stateBody, stateVersion} <- getObjectStateChunk
advanceToUuid stateVersion
let chunk = filter (\Op{refId} -> refId /= field) stateBody
event <- getEventUuid
p <- newRon value
let newOp = Op event field p
let chunk' = sortOn refId $ newOp : chunk
let state' = StateChunk
{stateVersion = event, stateBody = chunk', stateType = lwwType}
Object uuid <- ask
modify' $ Map.insert uuid state'
zoomField
:: MonadE m
=> UUID
-> ObjectStateT field m a
-> ObjectStateT struct m a
zoomField field innerModifier =
errorContext ("LWW.zoomField" <> show field) $ do
StateChunk{stateBody} <- getObjectStateChunk
let ops = filter (\Op{refId} -> refId == field) stateBody
Op{payload} <- case ops of
[] -> throwError "empty chunk"
[op] -> pure op
_ -> throwError "unreduced state"
fieldObjectId <- errorContext "inner object" $ case payload of
[AUuid oid] -> pure oid
_ -> throwError "Expected object UUID"
lift $ runReaderT innerModifier $ Object fieldObjectId