{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module RON.Data.ORSet (
ORSet (..),
ORSetItem (..),
ORSetMap,
ORSetRep (..),
addRef,
addValue,
findAnyAlive,
findAnyAlive',
removeObjectIf,
removeRef,
removeValue,
zoomItem,
addFieldValue,
assignField,
getFieldObject,
newStruct,
removeFieldValue,
removeFieldValueIf,
viewField,
viewFieldLWW,
viewFieldMax,
viewFieldMin,
viewFieldSet,
zoomFieldObject,
) where
import RON.Prelude
import qualified Data.Map.Strict as Map
import RON.Data.Internal (MonadObjectState, ObjectStateT, Reducible,
Rep, Replicated (encoding),
ReplicatedAsObject,
ReplicatedAsPayload (fromPayload),
eqPayload, eqRef, evalObjectState, fromRon,
getObjectState, getObjectStateChunk,
modifyObjectStateChunk_, newObject, newRon,
objectEncoding, rconcat, readObject,
reduceObjectStates, reducibleOpType,
stateFromChunk, stateToChunk)
import RON.Error (MonadE, errorContext, throwErrorText)
import RON.Event (ReplicaClock, getEventUuid)
import RON.Semilattice (Semilattice)
import RON.Types (Atom (AUuid),
ObjectFrame (ObjectFrame, frame, uuid),
ObjectRef (ObjectRef),
Op (Op, opId, payload, refId), Payload,
StateChunk (StateChunk), StateFrame, UUID,
WireStateChunk (WireStateChunk, stateBody, stateType))
import RON.Util (Instance (Instance))
import RON.UUID (pattern Zero)
import qualified RON.UUID as UUID
newtype ORSetRep = ORSetRep (Map UUID Op)
deriving (Eq, Show)
itemKey :: Op -> UUID
itemKey Op{opId, refId} = case refId of
Zero -> opId
_ -> refId
preferTombstone :: Op -> Op -> Op
preferTombstone = maxOn refId
instance Semigroup ORSetRep where
ORSetRep set1 <> ORSetRep set2 =
ORSetRep $ Map.unionWith preferTombstone set1 set2
instance Monoid ORSetRep where
mempty = ORSetRep mempty
instance Semilattice ORSetRep
instance Reducible ORSetRep where
reducibleOpType = setType
stateFromChunk ops = ORSetRep $
Map.fromListWith preferTombstone [(itemKey op, op) | op <- ops]
stateToChunk (ORSetRep set) = sortOn opId $ Map.elems set
wireStateChunk :: [Op] -> WireStateChunk
wireStateChunk stateBody = WireStateChunk{stateType = setType, stateBody}
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
type Rep (ORSet a) = ORSetRep
newObject (ORSet items) = do
ops <- for items $ \item -> do
event <- getEventUuid
payload <- newRon item
pure $ Op event Zero payload
oid <- getEventUuid
modify' $ Map.insert oid $ wireStateChunk ops
pure $ ObjectRef oid
readObject = do
StateChunk ops <- getObjectStateChunk
mItems <- for ops $ \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) => Payload -> m ()
commonAdd payload =
modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do
event <- getEventUuid
pure $ StateChunk $ stateBody ++ [Op event Zero payload]
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)
=> ObjectRef a -> m ()
addRef (ObjectRef itemUuid) = commonAdd [AUuid itemUuid]
commonRemove
:: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)
=> (Payload -> m Bool) -> m ()
commonRemove isTarget =
modifyObjectStateChunk_ $ \(StateChunk chunk) -> do
let state0@(ORSetRep opMap) = stateFromChunk chunk
targetEvents <-
fmap catMaybes
$ for (toList opMap) $ \op@Op{refId, payload} ->
case refId of
Zero -> do
t <- isTarget payload
pure $ if t then Just op else Nothing
_ -> pure Nothing
StateChunk <$>
case targetEvents of
[] -> pure chunk
_ -> do
tombstone <- getEventUuid
let patch =
[ op{opId = tombstone, refId = observed}
| op@Op{opId = observed} <- targetEvents
]
let state' = state0 <> stateFromChunk patch
pure $ stateToChunk state'
removeObjectIf
:: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)
=> ObjectStateT a m Bool -> m ()
removeObjectIf isTarget = commonRemove $ \case
AUuid uuid' : _ -> do
frame <- get
evalObjectState ObjectFrame{uuid = uuid', frame} isTarget
_ -> pure False
removeValue
:: ( ReplicatedAsPayload a
, MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m
)
=> a -> m ()
removeValue v = commonRemove $ pure . eqPayload v
removeFieldValue
:: ( MonadE m
, MonadObjectState struct m
, ReplicaClock m
, ReplicatedAsPayload a
)
=> UUID
-> a
-> m ()
removeFieldValue field value =
removeFieldValueIfP field $ pure . eqPayload value
removeFieldValueIf
:: ( MonadE m
, MonadObjectState struct m
, ReplicaClock m
, ReplicatedAsPayload a
)
=> UUID
-> (a -> m Bool)
-> m ()
removeFieldValueIf field isTarget =
removeFieldValueIfP field $ \valuePayload -> do
value <- fromPayload valuePayload
isTarget value
removeFieldValueIfP
:: (MonadE m, MonadObjectState struct m, ReplicaClock m)
=> UUID
-> (Payload -> m Bool)
-> m ()
removeFieldValueIfP field isTarget =
modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do
(observedOps, stateBody1) <-
partitionM isFieldAliveAndSameValue stateBody
removeOps <- for observedOps $ \op@Op{opId = observedEvent} -> do
tombstone <- getEventUuid
pure op{opId = tombstone, refId = observedEvent}
let stateBody2 = stateBody1 ++ removeOps
pure $ StateChunk stateBody2
where
isFieldAliveAndSameValue = \case
Op{refId = Zero, payload = AUuid field' : valuePayload}
| field' == field -> isTarget valuePayload
_ -> pure False
removeRef
:: (MonadE m, ReplicaClock m, MonadObjectState (ORSet a) m)
=> ObjectRef a -> m ()
removeRef r = commonRemove $ pure . eqRef r
newtype ORSetItem a = ORSetItem UUID
deriving (Show)
zoomItem
:: MonadE m
=> ORSetItem item -> ObjectStateT item m a -> ObjectStateT (ORSet item) m a
zoomItem (ORSetItem key) innerModifier = do
ORSetRep opMap <- getObjectState
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 $ ObjectRef itemValueRef
findAnyAlive
:: (MonadE m, MonadObjectState (ORSet item) m) => m (Maybe (ORSetItem item))
findAnyAlive = do
ORSetRep opMap <- getObjectState
let aliveItems = [op | op@Op{refId = Zero} <- toList opMap]
pure $ 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)
assignField
:: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState struct m)
=> UUID
-> Maybe a
-> m ()
assignField field mvalue =
modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do
addOp <- case mvalue of
Just value -> do
event <- getEventUuid
valuePayload <- newRon value
pure $ Just Op
{ opId = event
, refId = Zero
, payload = AUuid field : valuePayload
}
Nothing -> pure Nothing
let (observedOps, stateBody1) = partition (isAliveField field) stateBody
removeOps <- for observedOps $ \op@Op{opId = observedEvent} -> do
tombstone <- getEventUuid
pure op{opId = tombstone, refId = observedEvent}
let stateBody2 = stateBody1 ++ toList addOp ++ removeOps
pure $ StateChunk stateBody2
addFieldValue
:: (Replicated a, ReplicaClock m, MonadE m, MonadObjectState struct m)
=> UUID
-> a
-> m ()
addFieldValue field value =
modifyObjectStateChunk_ $ \(StateChunk stateBody) -> do
event <- getEventUuid
valuePayload <- newRon value
let addOp = Op
{ opId = event
, refId = Zero
, payload = AUuid field : valuePayload
}
pure $ StateChunk $ stateBody ++ [addOp]
isAliveField :: UUID -> Op -> Bool
isAliveField field = \case
Op{refId = Zero, payload = AUuid field' : _} -> field == field'
_ -> False
filterAliveFieldPayloads
:: UUID
-> [Op]
-> [Payload]
filterAliveFieldPayloads field ops =
[ valuePayload
| Op{refId = Zero, payload = AUuid field' : valuePayload} <- ops
, field' == field
]
filterAliveFieldIdsAndPayloads
:: UUID
-> [Op]
-> [(UUID, Payload)]
filterAliveFieldIdsAndPayloads field ops =
[ (opId, valuePayload)
| Op{opId, refId = Zero, payload = AUuid field' : valuePayload} <- ops
, field' == field
]
getFieldObject
:: (MonadE m, MonadObjectState struct m, ReplicatedAsObject a)
=> UUID
-> m (Maybe (ObjectRef a))
getFieldObject field =
errorContext "ORSet.getFieldObject" $ do
StateChunk ops <- getObjectStateChunk
let payloads = filterAliveFieldPayloads field ops
refs = [ref | AUuid ref : _ <- payloads]
case refs of
[] -> pure Nothing
p:ps -> fmap Just $ reduceObjectStates $ fmap ObjectRef $ p :| ps
viewField
:: (MonadE m, MonadState StateFrame m, ReplicatedAsObject a)
=> UUID
-> StateChunk ORSetRep
-> m (Maybe a)
viewField field (StateChunk stateBody) =
errorContext "ORSet.viewField" $ do
let payloads = filterAliveFieldPayloads field stateBody
refs = [ref | AUuid ref : _ <- payloads]
case refs of
[] -> pure Nothing
p:ps -> fmap Just . rconcat $ p :| ps
viewFieldLWW
:: (MonadE m, MonadState StateFrame m, Replicated a)
=> UUID
-> StateChunk ORSetRep
-> m (Maybe a)
viewFieldLWW field (StateChunk stateBody) =
errorContext "ORSet.viewFieldLWW" $ do
let mPayload =
fmap snd . maximumMayOn fst $
filterAliveFieldIdsAndPayloads field stateBody
case mPayload of
Nothing -> pure Nothing
Just [] -> pure Nothing
Just payload -> Just <$> fromRon payload
viewFieldMax
:: (MonadE m, Ord a, ReplicatedAsPayload a)
=> UUID
-> StateChunk ORSetRep
-> m (Maybe a)
viewFieldMax field (StateChunk stateBody) =
errorContext "ORSet.viewFieldMax" $
fmap maximumMay $
traverse fromPayload $
filterAliveFieldPayloads field stateBody
viewFieldMin
:: (MonadE m, Ord a, ReplicatedAsPayload a)
=> UUID
-> StateChunk ORSetRep
-> m (Maybe a)
viewFieldMin field (StateChunk stateBody) =
errorContext "ORSet.viewFieldMin" $
fmap minimumMay $
traverse fromPayload $
filterAliveFieldPayloads field stateBody
viewFieldSet
:: (MonadE m, MonadState StateFrame m, Replicated a)
=> UUID
-> StateChunk ORSetRep
-> m [a]
viewFieldSet field (StateChunk stateBody) =
errorContext "ORSet.viewFieldSet" $
traverse fromRon $
filterAliveFieldPayloads field stateBody
zoomFieldObject
:: forall a field m struct
. ( MonadE m
, ReplicaClock m
, ReplicatedAsObject field
, ReplicatedAsObject struct
)
=> UUID
-> ObjectStateT field m a
-> ObjectStateT struct m a
zoomFieldObject field innerModifier =
errorContext ("ORSet.zoomFieldObject " <> show field) $ do
(StateChunk stateBody) <- getObjectStateChunk
let objectIds =
[ objectId
| AUuid objectId : _ <- filterAliveFieldPayloads field stateBody
]
object <- case objectIds of
[] -> ObjectRef <$> getEventUuid
oid:oids -> reduceObjectStates @field $ fmap ObjectRef $ oid :| oids
lift $ runReaderT innerModifier object
newStruct
:: (MonadState StateFrame m, ReplicaClock m)
=> [(UUID, Instance Replicated)] -> m UUID
newStruct fields = do
objectId <- getEventUuid
stateBody <-
for fields $ \(name, Instance value) -> do
opId <- getEventUuid
valuePayload <- newRon value
pure Op{opId, refId = Zero, payload = AUuid name : valuePayload}
modify' $ Map.insert objectId $ wireStateChunk stateBody
pure objectId
partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM f = \case
[] -> pure ([], [])
x:xs -> do
res <- f x
(as, bs) <- partitionM f xs
pure ([x | res] ++ as, [x | not res] ++ bs)