diff --git a/lib/RON/Data/RGA.hs b/lib/RON/Data/RGA.hs --- a/lib/RON/Data/RGA.hs +++ b/lib/RON/Data/RGA.hs @@ -16,10 +16,18 @@ , RgaString , edit , editText + , getAliveIndices , getList , getText + , insert + , insertAfter + , insertAtBegin + , insertText + , insertTextAfter + , insertTextAtBegin , newFromList , newFromText + , remove , rgaType ) where @@ -31,7 +39,7 @@ import qualified Data.Text as Text import RON.Data.Internal -import RON.Error (MonadE) +import RON.Error (MonadE, errorContext, throwErrorText) import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, getEventUuids) import RON.Types (Object (..), Op (..), StateChunk (..), UUID) @@ -39,6 +47,8 @@ import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + -- | opId = vertex id -- refId: -- 0 = value is alive, @@ -343,10 +353,12 @@ => [a] -> m () edit newItems = do obj@Object{id, frame} <- get - StateChunk{..} <- getObjectStateChunk obj + StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj advanceToUuid stateVersion let newItems' = [Op Zero Zero $ toPayload item | item <- newItems] + -- TODO(2019-04-17, #59, cblp) replace 'toPayload' with 'newRon' and + -- relax constraint on 'a' from 'ReplicatedAsPayload' to 'Replicated' let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems' (stateBody', Last lastEvent) <- runWriterT . fmap fold . for diff $ \case First removed -> for removed $ \case @@ -399,10 +411,114 @@ newFromText :: ReplicaClock m => Text -> m (Object RgaString) newFromText = newFromList . Text.unpack +getAliveIndices :: MonadE m => Object (RGA a) -> m [UUID] +getAliveIndices obj = do + StateChunk{stateBody} <- getObjectStateChunk obj + let mItems = + [ case refId of + Zero -> Just opId + _ -> Nothing + | Op{opId, refId} <- stateBody + ] + pure $ catMaybes mItems + -- | Read elements from RGA -getList :: forall a m . (Replicated a, MonadE m) => Object (RGA a) -> m [a] +getList :: (Replicated a, MonadE m) => Object (RGA a) -> m [a] getList = fmap coerce . getObject -- | Read characters from 'RgaString' getText :: MonadE m => Object RgaString -> m Text getText = fmap Text.pack . getList + +-- | Insert a sequence of elements after the specified position. +-- Position is identified by 'UUID'. 'Nothing' means the beginning. +insert + :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m) + => [a] + -> Maybe UUID -- ^ position + -> m () +insert [] _ = pure () +insert items mPosition = do + obj@Object{id, frame} <- get + stateChunk@StateChunk{stateVersion, stateBody} <- getObjectStateChunk obj + advanceToUuid stateVersion + + vertexIds <- getEventUuids $ ls60 $ genericLength items + (ops, newFrame) <- runWriterT $ + for (zip items vertexIds) $ \(item, vertexId) -> do + payload <- newRon item + pure $ Op vertexId Zero payload + + let stateVersion' = maximumDef stateVersion $ map opId ops + stateBody' <- case mPosition of + Nothing -> pure $ ops <> stateBody + Just position -> findAndInsertAfter position ops stateBody + let stateChunk' = + stateChunk{stateVersion = stateVersion', stateBody = stateBody'} + put obj{frame = Map.insert id stateChunk' frame <> newFrame} + where + findAndInsertAfter pos newOps = go where + go = \case + [] -> throwErrorText "Position not found" + op@Op{opId} : ops + | opId == pos -> pure $ op : newOps ++ ops + | otherwise -> (op :) <$> go ops + +insertAtBegin + :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m) + => [a] -> m () +insertAtBegin items = insert items Nothing + +insertAfter + :: (Replicated a, MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m) + => [a] + -> UUID -- ^ position + -> m () +insertAfter items = insert items . Just + +-- | Insert a text after the specified position. +-- Position is identified by 'UUID'. 'Nothing' means the beginning. +insertText + :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m) + => Text + -> Maybe UUID -- ^ position + -> m () +insertText = insert . Text.unpack + +insertTextAtBegin + :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m) + => Text -> m () +insertTextAtBegin text = insertText text Nothing + +insertTextAfter + :: (ReplicaClock m, MonadE m, MonadState (Object RgaString) m) + => Text + -> UUID -- ^ position + -> m () +insertTextAfter text = insertText text . Just + +-- | Record a removal of a specific item +remove + :: (MonadE m, MonadState (Object (RGA a)) m, ReplicaClock m) + => UUID -- ^ position + -> m () +remove position = + errorContext "RGA.remove" $ + errorContext ("position = " <> show position) $ do + obj@Object{id, frame} <- get + stateChunk@StateChunk{stateVersion, stateBody} <- + getObjectStateChunk obj + advanceToUuid stateVersion + + event <- getEventUuid + stateBody' <- findAndTombstone event stateBody + let stateChunk' = + stateChunk{stateVersion = event, stateBody = stateBody'} + put obj{frame = Map.insert id stateChunk' frame} + where + findAndTombstone event = go where + go = \case + [] -> throwErrorText "Position not found" + op@Op{opId} : ops + | opId == position -> pure $ op{refId = event} : ops + | otherwise -> (op :) <$> go ops diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs --- a/prelude/Prelude.hs +++ b/prelude/Prelude.hs @@ -5,13 +5,18 @@ module X, fmapL, foldr1, + headMay, identity, lastDef, maximumDef, maxOn, minOn, + note, + replicateM2, + replicateM3, show, whenJust, + (!!), (?:), ) where @@ -40,10 +45,11 @@ import Data.Int as X (Int, Int16, Int32, Int64, Int8) import Data.IORef as X (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) -import Data.List as X (filter, genericLength, intercalate, isPrefixOf, - isSuffixOf, lookup, map, partition, repeat, - replicate, sortBy, sortOn, span, splitAt, take, - takeWhile, unlines, unwords, zip, (++)) +import Data.List as X (drop, filter, genericLength, intercalate, + isPrefixOf, isSuffixOf, lookup, map, partition, + repeat, replicate, sortBy, sortOn, span, + splitAt, take, takeWhile, unlines, unwords, + zip, (++)) import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) @@ -131,6 +137,11 @@ foldr1 :: (a -> a -> a) -> NonEmpty a -> a foldr1 = Data.Foldable.foldr1 +headMay :: [a] -> Maybe a +headMay = \case + [] -> Nothing + a:_ -> Just a + identity :: a -> a identity x = x @@ -151,11 +162,25 @@ minOn :: Ord b => (a -> b) -> a -> a -> a minOn f x y = if f x < f y then x else y +note :: e -> Maybe a -> Either e a +note e = maybe (Left e) Right + +replicateM2 :: Applicative m => m a -> m (a, a) +replicateM2 ma = (,) <$> ma <*> ma + +replicateM3 :: Applicative m => m a -> m (a, a, a) +replicateM3 ma = (,,) <$> ma <*> ma <*> ma + show :: (Show a, IsString s) => a -> s show = fromString . Text.Show.show whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust m f = maybe (pure ()) f m + +(!!) :: [a] -> Int -> Maybe a +xs !! i + | i < 0 = Nothing + | otherwise = headMay $ drop i xs -- | An infix form of 'fromMaybe' with arguments flipped. (?:) :: Maybe a -> a -> a diff --git a/ron-rdt.cabal b/ron-rdt.cabal --- a/ron-rdt.cabal +++ b/ron-rdt.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-rdt -version: 0.5 +version: 0.6 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database @@ -19,7 +19,7 @@ . > import RON.Data > import RON.Schema.TH - > import RON.Storage.IO as Storage + > import RON.Storage.FS as Storage > > [mkReplicated| > (struct_lww Note