{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
module RON.Data.RGA
( RGA (..)
, RgaRaw
, RgaString
, edit
, editText
, getList
, getText
, newFromList
, newFromText
, rgaType
) where
import RON.Internal.Prelude
import Control.Monad.Except (MonadError, liftEither)
import Control.Monad.State.Strict (MonadState, get, put)
import Control.Monad.Writer.Strict (lift, runWriterT, tell)
import Data.Algorithm.Diff (Diff (Both, First, Second),
getGroupedDiffBy)
import Data.Bifunctor (bimap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (genericLength)
import qualified Data.Map.Strict as Map
import Data.Monoid (Last (..))
import qualified Data.Text as Text
import RON.Data.Internal
import RON.Event (ReplicaClock, advanceToUuid, getEventUuid,
getEventUuids)
import RON.Internal.Word (pattern B11, ls60)
import RON.Types (Object (..), Op (..), StateChunk (..), UUID)
import RON.UUID (pattern Zero, uuidVersion)
import qualified RON.UUID as UUID
type Vertex = Op
data VertexListItem = VertexListItem
{ itemValue :: Vertex
, itemNext :: Maybe UUID
}
deriving (Eq, Show)
data VertexList = VertexList
{ listHead :: UUID
, listItems :: HashMap UUID VertexListItem
}
deriving (Eq, Show)
instance Semigroup VertexList where
(<>) = merge
vertexListToOps :: Maybe VertexList -> [Vertex]
vertexListToOps mv = case mv of
Nothing -> []
Just VertexList{..} -> go listHead listItems
where
go root items = let
VertexListItem{..} =
HashMap.lookupDefault
(error $ unlines
$ ["Cannot find vertex id", show root, "in array"]
++ map show (HashMap.toList items)
++ ["Original array is", show $ fromJust mv])
root
items
rest = case itemNext of
Just next -> go next (HashMap.delete root items)
Nothing -> []
in itemValue : rest
vertexListFromOps :: [Vertex] -> Maybe VertexList
vertexListFromOps = foldr go mempty where
go v@Op{opEvent = vid} vlist =
Just $ VertexList{listHead = vid, listItems = vlist'}
where
item itemNext = VertexListItem{itemValue = v, itemNext}
vlist' = case vlist of
Nothing -> HashMap.singleton vid (item Nothing)
Just VertexList{listHead, listItems} ->
HashMap.insert vid (item $ Just listHead) listItems
newtype RgaRaw = RgaRaw (Maybe VertexList)
deriving (Eq, Monoid, Semigroup, Show)
data PatchSet = PatchSet
{ psPatches :: Map UUID VertexList
, psRemovals :: Map UUID UUID
}
deriving (Eq, Show)
instance Semigroup PatchSet where
rga1 <> rga2 = reapplyPatchSet $ preMerge rga1 rga2
preMerge :: PatchSet -> PatchSet -> PatchSet
preMerge (PatchSet p1 r1) (PatchSet p2 r2) = PatchSet
{psPatches = Map.unionWith (<>) p1 p2, psRemovals = Map.unionWith max r1 r2}
instance Monoid PatchSet where
mempty = PatchSet{psPatches = mempty, psRemovals = mempty}
patchSetFromRawOp :: Op -> PatchSet
patchSetFromRawOp op@Op{opEvent, opRef, opPayload} = case opPayload of
[] ->
mempty{psRemovals = Map.singleton opRef opEvent}
_:_ ->
mempty
{ psPatches =
Map.singleton
opRef
VertexList
{ listHead = opEvent
, listItems =
HashMap.singleton
opEvent
VertexListItem
{ itemValue = op{opRef = Zero}
, itemNext = Nothing
}
}
}
patchSetFromChunk :: ReducedChunk -> PatchSet
patchSetFromChunk ReducedChunk{rcRef, rcBody} =
case uuidVersion $ UUID.split rcRef of
B11 ->
foldMap patchSetFromRawOp rcBody
_ ->
case vertexListFromOps rcBody of
Just patch -> mempty{psPatches = Map.singleton rcRef patch}
Nothing -> mempty
instance Reducible RgaRaw where
reducibleOpType = rgaType
stateFromChunk = RgaRaw . vertexListFromOps
stateToChunk (RgaRaw rga) = StateChunk (chunkVersion ops) ops where
ops = vertexListToOps rga
applyPatches rga (patches, ops) =
bimap id patchSetToChunks . reapplyPatchSetToState rga $
foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops
reduceUnappliedPatches (patches, ops) =
patchSetToChunks . reapplyPatchSet $
foldMap patchSetFromChunk patches <> foldMap patchSetFromRawOp ops
patchSetToChunks :: PatchSet -> Unapplied
patchSetToChunks PatchSet{..} =
( [ ReducedChunk{rcVersion = chunkVersion rcBody, ..}
| (rcRef, vertices) <- Map.assocs psPatches
, let rcBody = vertexListToOps $ Just vertices
]
, [ Op{opEvent = tombstone, opRef = vid, opPayload = []}
| (vid, tombstone) <- Map.assocs psRemovals
]
)
chunkVersion :: [Op] -> UUID
chunkVersion ops = maximumDef Zero
[ max vertexId tombstone
| Op{opEvent = vertexId, opRef = tombstone} <- ops
]
reapplyPatchSet :: PatchSet -> PatchSet
reapplyPatchSet ps =
continue ps [reapplyPatchesToOtherPatches, reapplyRemovalsToPatches]
reapplyPatchSetToState :: RgaRaw -> PatchSet -> (RgaRaw, PatchSet)
reapplyPatchSetToState rga ps =
continue (rga, ps) [reapplyPatchesToState, reapplyRemovalsToState]
continue :: x -> [x -> Maybe x] -> x
continue x fs = case asum $ map ($ x) fs of
Nothing -> x
Just x' -> continue x' fs
reapplyPatchesToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet)
reapplyPatchesToState (RgaRaw state, ps@PatchSet{..}) = case state of
Just VertexList{listHead = targetHead, listItems = targetItems} -> asum
[ do
targetItems' <- applyPatch parent patch targetItems
pure
( RgaRaw . Just $ VertexList targetHead targetItems'
, ps{psPatches = Map.delete parent psPatches}
)
| (parent, patch) <- Map.assocs psPatches
]
Nothing -> do
patch <- Map.lookup Zero psPatches
pure (RgaRaw $ Just patch, ps{psPatches = Map.delete Zero psPatches})
reapplyPatchesToOtherPatches :: PatchSet -> Maybe PatchSet
reapplyPatchesToOtherPatches ps@PatchSet{..} = asum
[ do
targetItems' <- applyPatch parent patch targetItems
pure ps
{ psPatches =
Map.insert targetParent (VertexList targetHead targetItems') $
Map.delete parent psPatches
}
| (parent, patch) <- Map.assocs psPatches
, (targetParent, targetPatch) <- Map.assocs psPatches
, parent /= targetParent
, let VertexList targetHead targetItems = targetPatch
]
applyPatch
:: UUID
-> VertexList
-> HashMap UUID VertexListItem
-> Maybe (HashMap UUID VertexListItem)
applyPatch parent patch targetItems = case parent of
Zero -> undefined
_ -> do
item@VertexListItem{itemNext} <- HashMap.lookup parent targetItems
let VertexList next' newItems = case itemNext of
Nothing -> patch
Just next -> VertexList next targetItems <> patch
let item' = item{itemNext = Just next'}
pure $ HashMap.insert parent item' targetItems <> newItems
reapplyRemovalsToState :: (RgaRaw, PatchSet) -> Maybe (RgaRaw, PatchSet)
reapplyRemovalsToState (RgaRaw state, ps@PatchSet{..}) = do
VertexList{listHead = targetHead, listItems = targetItems} <- state
asum
[ do
targetItems' <- applyRemoval parent tombstone targetItems
pure
( RgaRaw . Just $ VertexList targetHead targetItems'
, ps{psRemovals = Map.delete parent psRemovals}
)
| (parent, tombstone) <- Map.assocs psRemovals
]
reapplyRemovalsToPatches :: PatchSet -> Maybe PatchSet
reapplyRemovalsToPatches PatchSet{..} = asum
[ do
targetItems' <- applyRemoval parent tombstone targetItems
pure PatchSet
{ psRemovals = Map.delete parent psRemovals
, psPatches =
Map.insert
targetParent (VertexList targetHead targetItems') psPatches
}
| (parent, tombstone) <- Map.assocs psRemovals
, (targetParent, targetPatch) <- Map.assocs psPatches
, let VertexList targetHead targetItems = targetPatch
]
applyRemoval
:: UUID
-> UUID
-> HashMap UUID VertexListItem
-> Maybe (HashMap UUID VertexListItem)
applyRemoval parent tombstone targetItems = do
item@VertexListItem{itemValue = v@Op{opRef}} <-
HashMap.lookup parent targetItems
let item' = item{itemValue = v{opRef = max opRef tombstone}}
pure $ HashMap.insert parent item' targetItems
merge :: VertexList -> VertexList -> VertexList
merge v1 v2 =
fromMaybe undefined . vertexListFromOps $
(merge' `on` vertexListToOps . Just) v1 v2
merge' :: [Vertex] -> [Vertex] -> [Vertex]
merge' [] vs2 = vs2
merge' vs1 [] = vs1
merge' w1@(v1 : vs1) w2@(v2 : vs2) =
case compare e1 e2 of
LT -> v2 : merge' w1 vs2
GT -> v1 : merge' vs1 w2
EQ -> mergeVertices : merge' vs1 vs2
where
Op{opEvent = e1, opRef = tombstone1, opPayload = p1} = v1
Op{opEvent = e2, opRef = tombstone2, opPayload = p2} = v2
mergeVertices = Op
{ opEvent = e1
, opRef = max tombstone1 tombstone2
, opPayload = maxOn length p1 p2
}
rgaType :: UUID
rgaType = fromJust $ UUID.mkName "rga"
newtype RGA a = RGA [a]
deriving (Eq)
instance Replicated a => Replicated (RGA a) where encoding = objectEncoding
instance Replicated a => ReplicatedAsObject (RGA a) where
objectOpType = rgaType
newObject (RGA items) = collectFrame $ do
vertexIds <- lift $ getEventUuids $ ls60 $ genericLength items
ops <- for (zip items vertexIds) $ \(item, vertexId) -> do
payload <- newRon item
pure $ Op vertexId Zero payload
oid <- lift getEventUuid
let version = maximumDef oid $ map opEvent ops
tell $ Map.singleton (rgaType, oid) $ StateChunk version ops
pure oid
getObject obj@Object{..} = do
StateChunk{..} <- getObjectStateChunk obj
mItems <- for stateBody $ \Op{..} -> case opRef of
Zero -> Just <$> fromRon opPayload objectFrame
_ -> pure Nothing
pure . RGA $ catMaybes mItems
edit
:: ( Replicated a, ReplicatedAsPayload a
, ReplicaClock m, MonadError String m, MonadState (Object (RGA a)) m
)
=> [a] -> m ()
edit newItems = do
obj@Object{..} <- get
StateChunk{..} <- liftEither $ getObjectStateChunk obj
advanceToUuid stateVersion
let newItems' = [Op Zero Zero $ toPayload item | item <- newItems]
let diff = getGroupedDiffBy ((==) `on` opPayload) stateBody newItems'
(stateBody', Last lastEvent) <- runWriterT . fmap concat . for diff $ \case
First removed -> for removed $ \case
op@Op{opRef = Zero} -> do
tombstone <- lift getEventUuid
tell . Last $ Just tombstone
pure op{opRef = tombstone}
op ->
pure op
Both v _ -> pure v
Second added -> for added $ \op -> do
opEvent <- lift getEventUuid
tell . Last $ Just opEvent
pure op{opEvent}
case lastEvent of
Nothing -> pure ()
Just stateVersion' -> do
let state' = StateChunk stateVersion' stateBody'
put Object
{ objectFrame =
Map.insert (rgaType, objectId) state' objectFrame
, ..
}
editText
:: (ReplicaClock m, MonadError String m, MonadState (Object RgaString) m)
=> Text -> m ()
editText = edit . Text.unpack
type RgaString = RGA Char
newFromList :: (Replicated a, ReplicaClock m) => [a] -> m (Object (RGA a))
newFromList = newObject . RGA
newFromText :: ReplicaClock m => Text -> m (Object RgaString)
newFromText = newFromList . Text.unpack
getList :: Replicated a => Object (RGA a) -> Either String [a]
getList = coerce . getObject
getText :: Object RgaString -> Either String Text
getText = fmap Text.pack . getList