{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module RON.Data.ORSet
( ORSet (..)
, ORSetItem (..)
, ORSetMap
, ORSetRep
, addRef
, addValue
, findAnyAlive
, findAnyAlive'
, removeRef
, removeValue
, zoom
) where
import RON.Prelude
import qualified Data.Map.Strict as Map
import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,
Replicated, ReplicatedAsObject,
ReplicatedAsPayload, encoding, eqPayload,
eqRef, fromRon, getObject,
getObjectStateChunk, mkStateChunk,
modifyObjectStateChunk_, newObject, newRon,
objectEncoding, objectOpType,
reducibleOpType, stateFromChunk,
stateToChunk)
import RON.Error (MonadE, throwErrorText)
import RON.Event (ReplicaClock, getEventUuid)
import RON.Types (Atom (AUuid), Object (Object),
Op (Op, opId, payload, refId),
StateChunk (StateChunk, stateBody, stateType, stateVersion),
UUID)
import RON.UUID (pattern Zero)
import qualified RON.UUID as UUID
newtype ORSetRep = ORSetRep (Map UUID Op)
deriving (Eq, Show)
opKey :: Op -> UUID
opKey Op{opId, refId} = case refId of
Zero -> opId
_ -> refId
observedRemove :: Op -> Op -> Op
observedRemove = maxOn refId
instance Semigroup ORSetRep where
ORSetRep set1 <> ORSetRep set2 =
ORSetRep $ Map.unionWith observedRemove set1 set2
instance Monoid ORSetRep where
mempty = ORSetRep mempty
instance Reducible ORSetRep where
reducibleOpType = setType
stateFromChunk ops =
ORSetRep $ Map.fromListWith observedRemove [(opKey op, op) | op <- ops]
stateToChunk (ORSetRep set) =
mkStateChunk setType . sortOn opId $ Map.elems set
setType :: UUID
setType = $(UUID.liftName "set")
newtype ORSet a = ORSet [a]
deriving (Eq, Show)
instance Replicated a => Replicated (ORSet a) where
encoding = objectEncoding
instance Replicated a => ReplicatedAsObject (ORSet a) where
objectOpType = setType
newObject (ORSet items) = do
ops <- for items $ \item -> do
event <- getEventUuid
payload <- newRon item
pure $ Op event Zero payload
oid <- getEventUuid
let stateVersion = maximumDef oid $ map opId ops
modify' $
(<>) $ Map.singleton oid $
StateChunk{stateType = setType, stateVersion, stateBody = ops}
pure $ Object oid
getObject = do
StateChunk{stateBody} <- getObjectStateChunk
mItems <- for stateBody $ \Op{refId, payload} -> case refId of
Zero -> do
item <- fromRon payload
pure $ Just item
_ -> pure Nothing
pure . ORSet $ catMaybes mItems
commonAdd :: (MonadE m, MonadObjectState a m, ReplicaClock m) => [Atom] -> m ()
commonAdd payload =
modifyObjectStateChunk_ $ \StateChunk{stateBody} -> do
event <- getEventUuid
let newOp = Op event Zero payload
let chunk' = stateBody ++ [newOp]
pure StateChunk
{stateType = setType, stateVersion = event, stateBody = chunk'}
addValue
:: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState (ORSet a) m)
=> a -> m ()
addValue item = do
payload <- newRon item
commonAdd payload
addRef
:: (ReplicaClock m, MonadE m, MonadObjectState (ORSet a) m)
=> Object a -> m ()
addRef (Object itemUuid) = commonAdd [AUuid itemUuid]
commonRemove
:: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)
=> ([Atom] -> Bool) -> m ()
commonRemove isTarget =
modifyObjectStateChunk_ $ \chunk@StateChunk{stateBody} -> do
let state0@(ORSetRep opMap) = stateFromChunk stateBody
let targetEvents =
[ opId
| Op{opId, refId, payload} <- toList opMap
, refId == Zero
, isTarget payload
]
case targetEvents of
[] -> pure chunk
_ -> do
tombstone <- getEventUuid
let patch =
[ Op{opId = tombstone, refId, payload = []}
| refId <- targetEvents
]
let state' = state0 <> stateFromChunk patch
pure $ stateToChunk state'
removeValue
:: ( ReplicatedAsPayload a
, MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m
)
=> a -> m ()
removeValue = commonRemove . eqPayload
removeRef
:: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)
=> Object a -> m ()
removeRef = commonRemove . eqRef
newtype ORSetItem a = ORSetItem UUID
deriving (Show)
zoom
:: MonadE m
=> ORSetItem item -> ObjectStateT item m a -> ObjectStateT (ORSet item) m a
zoom (ORSetItem key) innerModifier = do
StateChunk{stateBody} <- getObjectStateChunk
let ORSetRep opMap = stateFromChunk stateBody
itemValueRef <- case Map.lookup key opMap of
Nothing ->
throwErrorText "no such key in ORSet"
Just Op{payload} -> case payload of
[AUuid itemValueRef] -> pure itemValueRef
_ -> throwErrorText "item payload is not an object ref"
lift $ runReaderT innerModifier $ Object itemValueRef
findAnyAlive
:: (MonadE m, MonadObjectState (ORSet item) m) => m (Maybe (ORSetItem item))
findAnyAlive = do
StateChunk{stateBody} <- getObjectStateChunk
pure $ let
ORSetRep opMap = stateFromChunk stateBody
aliveItems = [op | op@Op{refId = UUID.Zero} <- toList opMap]
in
case listToMaybe aliveItems of
Nothing -> Nothing
Just Op{opId} -> Just $ ORSetItem opId
findAnyAlive'
:: (MonadE m, MonadObjectState (ORSet item) m) => m (ORSetItem item)
findAnyAlive' = do
mx <- findAnyAlive
case mx of
Just x -> pure x
Nothing -> throwErrorText "empty set"
type ORSetMap k v = ORSet (k, v)