From c83a163c0a97e5e06c50872899489c89d06d0a14 Mon Sep 17 00:00:00 2001 From: mk Date: Thu, 13 Oct 2022 06:36:38 -0300 Subject: [PATCH 1/6] port: Fix ignoring non-object items --- ron-rdt/lib/RON/Store/FS.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/ron-rdt/lib/RON/Store/FS.hs b/ron-rdt/lib/RON/Store/FS.hs index be25bdaf..172427aa 100644 --- a/ron-rdt/lib/RON/Store/FS.hs +++ b/ron-rdt/lib/RON/Store/FS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} @@ -46,8 +47,8 @@ import RON.Store (MonadStore (..)) import RON.Text.Parse (parseOpenFrame) import RON.Text.Serialize.Experimental (serializeOpenFrame) import RON.Types (Op (..), UUID) -import RON.Util.Word (Word60, leastSignificant60) import qualified RON.UUID as UUID +import RON.Util.Word (Word60, leastSignificant60) -- | Store handle (uses the “Handle pattern”). data Handle = Handle @@ -180,13 +181,15 @@ debugDump dataDir = do objectDirs <- do exists <- doesDirectoryExist dataDir if exists then listDirectory dataDir else pure [] - for_ (sort objectDirs) $ \objectDir -> do - let logsDir = dataDir objectDir "log" - logs <- listDirectory logsDir - for_ (sort logs) $ \logName -> do - let logPath = logsDir logName - BSL.putStr =<< BSL.readFile logPath - BSLC.putStrLn "" + for_ (sort objectDirs) \objectDir -> do + isDir <- doesDirectoryExist $ dataDir objectDir + when isDir $ do + let logsDir = dataDir objectDir "log" + logs <- listDirectory logsDir + for_ (sort logs) $ \logName -> do + let logPath = logsDir logName + BSL.putStr =<< BSL.readFile logPath + BSLC.putStrLn "" fetchUpdates :: Handle -> IO (TChan UUID) fetchUpdates Handle{onObjectChanged} = atomically $ dupTChan onObjectChanged From 94511f5a39fb86feb2f3cf2fcf60c4fecdb2d469 Mon Sep 17 00:00:00 2001 From: mk Date: Thu, 13 Oct 2022 06:56:52 -0300 Subject: [PATCH 2/6] port: ron: Fix RONt parsing of -0.1 --- ron/lib/Attoparsec/Extra.hs | 70 ++++++++++++++++++++++--------------- ron/lib/RON/Text/Parse.hs | 4 +-- 2 files changed, 44 insertions(+), 30 deletions(-) diff --git a/ron/lib/Attoparsec/Extra.hs b/ron/lib/Attoparsec/Extra.hs index 73d92676..bc88b2cc 100644 --- a/ron/lib/Attoparsec/Extra.hs +++ b/ron/lib/Attoparsec/Extra.hs @@ -20,7 +20,8 @@ import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, isDigit_w8, import qualified Data.Attoparsec.Internal.Types as Internal import Data.Attoparsec.Lazy as Attoparsec import qualified Data.ByteString as BS -import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Lazy (fromStrict) +import Data.Maybe (isJust) import qualified Data.Scientific as Sci import GHC.Real (toInteger) @@ -91,33 +92,46 @@ char c = do -- | Parses a definite double, i.e. it is not an integer. For this, the double has either a '.', and 'e'/'E' part or both. {-# INLINE definiteDouble #-} definiteDouble :: Parser Double -definiteDouble = do - let parseIntegerPart = signed decimal - let parseDot = char '.' - let parseFractionalPartWithLength = - BS.foldl' step (0, 0) `fmap` Attoparsec.takeWhile1 isDigit_w8 - where step (a, l) w = (a * 10 + fromIntegral (w - 48), l + 1) - let parseExponent = (char 'e' <|> char 'E') *> signed decimal - - let withDot = do - i <- optional parseIntegerPart - _ <- parseDot - (f, l) <- parseFractionalPartWithLength - e <- optional parseExponent - pure $ buildDouble (fromMaybe 0 i) f l (fromMaybe 0 e) - - let withE = do - i <- optional parseIntegerPart - buildDouble (fromMaybe 0 i) 0 0 <$> parseExponent - - withDot <|> withE - -buildDouble :: Integer -> Integer -> Int -> Int -> Double -buildDouble integerPart fractionalPart fractionalPartLength exponentPart = - let addOrSubFractionalPart = if integerPart < 0 then -fractionalPart else fractionalPart - coeff = integerPart * 10 ^ toInteger fractionalPartLength + toInteger addOrSubFractionalPart - exponent = exponentPart - fractionalPartLength - in Sci.toRealFloat $ Sci.scientific coeff exponent +definiteDouble = withDot <|> noDot where + + dot = char '.' + minus = char '-' + + integerPart = decimal + + fractionalPartWithLength = + BS.foldl' step (0, 0) `fmap` Attoparsec.takeWhile1 isDigit_w8 + where + step (a, l) w = (a * 10 + fromIntegral (w - 48), l + 1) + + exponent = (char 'e' <|> char 'E') *> signed decimal + + withDot = do + m <- isJust <$> optional minus + i <- integerPart + _ <- dot + (f, l) <- fractionalPartWithLength + e <- optional exponent + pure $ buildDouble m i f l (fromMaybe 0 e) + + noDot = do + m <- isJust <$> optional minus + i <- integerPart + buildDouble m i 0 0 <$> exponent + +buildDouble :: Bool -> Integer -> Integer -> Int -> Int -> Double +buildDouble + isNegative integerPart fractionalPart fractionalPartLength exponentPart = + Sci.toRealFloat $ Sci.scientific coeff exponent + where + addOrSubFractionalPart + | integerPart < 0 = -fractionalPart + | otherwise = fractionalPart + coeff = + (if isNegative then negate else id) $ + integerPart * 10 ^ toInteger fractionalPartLength + + toInteger addOrSubFractionalPart + exponent = exponentPart - fractionalPartLength (<+>) :: Parser a -> Parser a -> Parser a (<+>) p1 p2 = Internal.Parser $ \t pos more lose suc -> let diff --git a/ron/lib/RON/Text/Parse.hs b/ron/lib/RON/Text/Parse.hs index 944b0d21..447f79f8 100644 --- a/ron/lib/RON/Text/Parse.hs +++ b/ron/lib/RON/Text/Parse.hs @@ -380,8 +380,8 @@ atom prevUuid = skipSpace *> atom' atomUnprefixed :: Parser Atom atomUnprefixed = (AFloat <$> definiteDouble) <+> - (AInteger <$> integer ) <+> - (AUuid <$> uuidUnzipped ) + (AInteger <$> integer ) <+> + (AUuid <$> uuidUnzipped ) where integer = signed decimal uuidUnzipped = uuid22 <+> uuid11 <+> uuidZip' From 3e56e9e47619ff2d0e8a651dc734d10a9126d475 Mon Sep 17 00:00:00 2001 From: mk Date: Thu, 13 Oct 2022 09:36:23 -0300 Subject: [PATCH 3/6] port: ron: Add experimental Ref; ron-rdt: Remove experimental globals --- demo/chat/Database.hs | 32 +++++---- demo/chat/NetNode.hs | 9 +++ demo/chat/README.md | 18 +++++ demo/demo.cabal | 1 + ron-rdt/lib/RON/Data/Experimental.hs | 10 +++ ron-rdt/lib/RON/Data/ORSet/Experimental.hs | 21 +++--- ron-rdt/lib/RON/Store.hs | 79 +++++++--------------- ron/lib/RON/Types.hs | 3 +- ron/lib/RON/Types/Experimental.hs | 26 +++++++ ron/ron.cabal | 1 + 10 files changed, 122 insertions(+), 78 deletions(-) create mode 100644 demo/chat/README.md create mode 100644 ron/lib/RON/Types/Experimental.hs diff --git a/demo/chat/Database.hs b/demo/chat/Database.hs index b14aa9a9..dbe6dcbd 100644 --- a/demo/chat/Database.hs +++ b/demo/chat/Database.hs @@ -1,5 +1,6 @@ module Database - ( databaseToUIUpdater + ( chatroomUuid + , databaseToUIUpdater , loadAllMessages , messagePoster , newMessage @@ -16,10 +17,12 @@ import RON.Data.ORSet.Experimental (ORSet) import qualified RON.Data.ORSet.Experimental as ORSet import RON.Error (MonadE) import RON.Event (ReplicaClock) -import RON.Store (MonadStore, newObject, openNamedObject, readObject) +import RON.Store (MonadStore, newObject, readObject) import RON.Store.FS (runStore) import qualified RON.Store.FS as Store -import RON.Types (Atom (AString), ObjectRef (ObjectRef)) +import RON.Types (Atom (AString, AUuid), UUID) +import RON.Types.Experimental (Ref (Ref)) +import qualified RON.UUID as UUID import Types (MessageContent (MessageContent), MessageView, postTime) import qualified Types @@ -27,8 +30,7 @@ import qualified Types loadAllMessages :: Store.Handle -> IO [MessageView] loadAllMessages db = runStore db $ do - gMessages <- openMessages - mMessageSet <- readObject gMessages + mMessageSet <- readObject gMessageSetRef case mMessageSet of Nothing -> do liftIO $ putStrLn "!!! messages collection doesn't exist !!!" @@ -37,20 +39,15 @@ loadAllMessages db = messageRefs <- ORSet.toList messageSet sortOn postTime . catMaybes <$> for messageRefs readObject -openMessages :: - (MonadE m, MonadStore m, ReplicaClock m) => - m (ObjectRef (ORSet (ObjectRef MessageView))) -openMessages = openNamedObject "messages" - newMessage :: (MonadE m, MonadStore m, ReplicaClock m) => - MessageContent -> m (ObjectRef MessageView) + MessageContent -> m (Ref MessageView) newMessage MessageContent{username, text} = do gMessages <- openMessages msgRef <- newObject @MessageView ORSet.add_ msgRef ("username", [AString username]) ORSet.add_ msgRef ("text", [AString text ]) - ORSet.add_ gMessages msgRef + ORSet.add_ gMessageSetRef msgRef pure msgRef messagePoster :: TChan MessageContent -> Store.Handle -> IO () @@ -61,12 +58,17 @@ messagePoster onMessagePosted db = databaseToUIUpdater :: Store.Handle -> TChan [MessageView] -> IO () databaseToUIUpdater db onMessageListUpdated = do - ObjectRef messageSetId <- runStore db openMessages - Store.subcribeToObject db messageSetId + Store.subcribeToObject db chatroomUuid onObjectChanged <- Store.fetchUpdates db forever $ do objectId <- atomically $ readTChan onObjectChanged - when (objectId == messageSetId) $ do + when (objectId == chatroomUuid) $ do messages <- loadAllMessages db atomically $ writeTChan onMessageListUpdated messages -- ignore other changes + +chatroomUuid :: UUID +chatroomUuid = $(UUID.liftName "chatroom") + +gMessageSetRef :: Ref (ORSet (Ref MessageView)) +gMessageSetRef = Ref chatroomUuid [AUuid $(UUID.liftName "message")] \ No newline at end of file diff --git a/demo/chat/NetNode.hs b/demo/chat/NetNode.hs index 8cdbc42f..bfa903cb 100644 --- a/demo/chat/NetNode.hs +++ b/demo/chat/NetNode.hs @@ -12,6 +12,7 @@ import System.Exit (ExitCode (ExitFailure)) import System.IO (hPutStrLn, stderr) import System.Posix.Process (exitImmediately) +import Database (chatroomUuid) import Fork (fork) startWorkers :: @@ -34,6 +35,14 @@ dialog db conn = do -- send object update requests -- fork $ do + ops <- fmap fold $ Store.runStore db $ Store.loadObjectLog chatroomUuid mempty + let netMessage = ObjectOps chatroomUuid ops + if null ops then do + putLog "No ops for chatroom" + else do + putLog $ "Log for chatroom " <> show netMessage + WS.sendBinaryData conn $ Aeson.encode netMessage + objectSubscriptions <- Store.readObjectSubscriptions db for_ objectSubscriptions $ \object -> WS.sendBinaryData conn =<< encodeNetMessage RequestChanges{object} diff --git a/demo/chat/README.md b/demo/chat/README.md new file mode 100644 index 00000000..50f8a9d4 --- /dev/null +++ b/demo/chat/README.md @@ -0,0 +1,18 @@ +# RON demo chat + +## PoC. One god room + +# Room + +There must be a god object with id `chatroom` of type ORSet (`:set`). + +If it does not exist, it must be created on first run. + +Room references a message with op with payload starting with `message` keyword +followed by the message object id: + + message {object_id : UUID} + +# Messages + +Each message is an object of type ORSet (`:set`). \ No newline at end of file diff --git a/demo/demo.cabal b/demo/demo.cabal index 717a1fce..52233040 100644 --- a/demo/demo.cabal +++ b/demo/demo.cabal @@ -80,6 +80,7 @@ executable demo-chat OverloadedStrings RecordWildCards ScopedTypeVariables + TemplateHaskell TypeApplications TypeFamilies ghc-options: -dynamic -rtsopts -with-rtsopts=-N diff --git a/ron-rdt/lib/RON/Data/Experimental.hs b/ron-rdt/lib/RON/Data/Experimental.hs index 377b85be..fe6382e4 100644 --- a/ron-rdt/lib/RON/Data/Experimental.hs +++ b/ron-rdt/lib/RON/Data/Experimental.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -18,6 +19,7 @@ import RON.Prelude import RON.Error (MonadE, throwErrorText) import RON.Types (Atom (AString, AUuid), ObjectRef (..), OpenFrame, UUID) +import RON.Types.Experimental (Ref (..)) class Replicated a where @@ -91,3 +93,11 @@ instance (AsAtom head, AsAtoms tail) => AsAtoms (head, tail) where fromAtoms = \case [] -> throwErrorText "Expected some atoms, got none" head : tail -> (,) <$> fromAtom head <*> fromAtoms tail + +instance AsAtoms (Ref a) where + toAtoms Ref{object, path} = AUuid object : path + + fromAtoms = \case + [] -> throwErrorText "Expected some atoms, got none" + AUuid object : path -> pure Ref{object, path} + a : _ -> throwErrorText $ "Expected UUID, got " <> show a diff --git a/ron-rdt/lib/RON/Data/ORSet/Experimental.hs b/ron-rdt/lib/RON/Data/ORSet/Experimental.hs index d8864232..4d97daa7 100644 --- a/ron-rdt/lib/RON/Data/ORSet/Experimental.hs +++ b/ron-rdt/lib/RON/Data/ORSet/Experimental.hs @@ -33,7 +33,8 @@ import RON.Error (MonadE, liftMaybe) import RON.Event (ReplicaClock, advanceToUuid, getEventUuid) import RON.Store.Class (MonadStore, appendPatch) import RON.Text.Serialize (serializeAtom) -import RON.Types (ObjectRef (..), Op (..), Payload, UUID) +import RON.Types (Op (..), Payload, UUID) +import RON.Types.Experimental (Ref (..)) -- | Observed-Remove Set. -- Implementation: a map from the itemId to the original op. @@ -65,23 +66,25 @@ instance ReplicatedObject (ORSet a) where -- | Add value to the set. Return the reference to the set item. add :: (Rep container ~ ORSet item, AsAtoms item, MonadStore m, ReplicaClock m) => - ObjectRef container -> item -> m UUID -add (ObjectRef object) value = do + Ref container -> item -> m UUID +add (Ref object path) value = do advanceToUuid object opId <- getEventUuid - appendPatch object [Op{opId, refId = object, payload = toAtoms value}] + appendPatchFromOneOrigin + object + [Op{opId, refId = object, payload = toAtoms value}] + [Op{opId, refId = object, payload = path ++ toAtoms value}] pure opId - {- | Add value to the set or map. - @add_ :: ObjectRef (ORSet a) -> a -> m ()@ - @add_ :: ObjectRef (ORMap k v) -> (k, v) -> m ()@ + @add_ :: Ref (ORSet a) -> a -> m ()@ + @add_ :: Ref (ORMap k v) -> (k, v) -> m ()@ -} add_ :: (Rep container ~ ORSet item, AsAtoms item, MonadStore m, ReplicaClock m) => - ObjectRef container -> item -> m () -add_ objectRef payload = void $ add objectRef payload + Ref container -> item -> m () +add_ ref payload = void $ add ref payload toList :: (AsAtoms a, MonadE m) => ORSet a -> m [a] toList (ORSet rep) = diff --git a/ron-rdt/lib/RON/Store.hs b/ron-rdt/lib/RON/Store.hs index ce89cf02..8ada6cc8 100644 --- a/ron-rdt/lib/RON/Store.hs +++ b/ron-rdt/lib/RON/Store.hs @@ -1,85 +1,58 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module RON.Store ( MonadStore (..), newObject, - openNamedObject, - readGlobalSet, readObject, ) where import RON.Prelude -import RON.Data.Experimental (AsAtoms, Rep, ReplicatedObject, - replicatedTypeId, stateFromFrame, view) -import RON.Data.ORSet (setType) -import RON.Data.ORSet.Experimental (ORMap) -import qualified RON.Data.ORSet.Experimental as ORMap +import RON.Data.Experimental (Rep, ReplicatedObject, replicatedTypeId, + stateFromFrame, view) import RON.Error (MonadE, errorContext) import RON.Event (ReplicaClock, getEventUuid) import RON.Store.Class (MonadStore (..)) -import RON.Types (Atom, ObjectRef (..), Op (..), UUID) +import RON.Types (Op (..), UUID) +import RON.Types.Experimental (Ref (..)) import qualified RON.UUID as UUID newObject :: - forall a m. - (MonadStore m, ReplicatedObject a, ReplicaClock m) => m (ObjectRef a) + forall a m. (MonadStore m, ReplicatedObject a, ReplicaClock m) => m (Ref a) newObject = do objectId <- getEventUuid let typeId = replicatedTypeId @(Rep a) let initOp = Op{opId = objectId, refId = typeId, payload = []} appendPatch objectId [initOp] - pure $ ObjectRef objectId + pure $ Ref objectId [] -- | Nothing if object doesn't exist in the replica. readObject :: (MonadE m, MonadStore m, ReplicatedObject a, Typeable a) => - ObjectRef a -> m (Maybe a) -readObject object@(ObjectRef objectId) = + Ref a -> m (Maybe a) +readObject object@(Ref objectId path) = errorContext ("readObject " <> show object) $ do ops <- fold <$> loadObjectLog objectId mempty case ops of [] -> pure Nothing - _ -> Just <$> view objectId (stateFromFrame objectId $ sortOn opId ops) - --- | Read global variable identified by atom and return result as set. -readGlobalSet :: - (MonadE m, MonadStore m, AsAtoms a, Typeable a) => Atom -> m [a] -readGlobalSet name = - errorContext ("readGlobalSet " <> show name) $ do - mGlobals <- readObject globalsRef - globals <- case mGlobals of - Just globals -> pure globals - Nothing -> do - createGlobals - pure ORMap.empty - ORMap.lookupSet name globals - where - createGlobals = - appendPatch - globalsId - [Op{opId = globalsId, refId = setType, payload = []}] - -globalsId :: UUID -globalsId = $(UUID.liftName "globals") - -globalsRef :: ObjectRef (ORMap Atom a) -globalsRef = ObjectRef globalsId - -openNamedObject :: - (MonadE m, MonadStore m, ReplicaClock m, ReplicatedObject a, Typeable a) => - Atom -> m (ObjectRef a) -openNamedObject name = do - set <- readGlobalSet name - case set of - [obj] -> pure obj - [] -> do - obj <- newObject - ORMap.add_ globalsRef (name, obj) - pure obj - _ -> error "TODO: merge objects" + _ -> + fmap Just $ + view objectId $ + stateFromFrame objectId $ + sortOn opId $ filter ((path `isPrefixOf`) . payload) ops + +-- TODO: Check when this was introduced, and if is needed +-- | Append an arbitrary sequence of operations to an object. No preconditions. +-- appendPatches :: MonadStore m => UUID -> [Op] -> m () +-- appendPatches object ops = +-- for_ patches $ appendPatchFromOneOrigin object +-- where +-- patches = +-- Map.fromListWith +-- (++) +-- [ (uuidOrigin, [op]) +-- | op@Op{opId = UUID.split -> UuidFields{uuidOrigin}} <- ops +-- ] \ No newline at end of file diff --git a/ron/lib/RON/Types.hs b/ron/lib/RON/Types.hs index e80ab6ce..9e9c7a33 100644 --- a/ron/lib/RON/Types.hs +++ b/ron/lib/RON/Types.hs @@ -48,9 +48,9 @@ import Data.Typeable (typeRep) import Text.Show (showParen, showString, showsPrec) import qualified Text.Show -import RON.Util.Word (pattern B00, pattern B10, pattern B11, Word2) import RON.UUID (UUID (UUID), uuidVersion) import qualified RON.UUID as UUID +import RON.Util.Word (Word2, pattern B00, pattern B10, pattern B11) -- | Atom — a payload element data Atom = AFloat Double | AInteger Int64 | AString Text | AUuid UUID @@ -135,6 +135,7 @@ type StateFrame = Map UUID WireStateChunk -- | Reference to an object -- TODO hide data constructor in Internal module +-- TODO deprecate in favor of 'Ref'? newtype ObjectRef a = ObjectRef UUID deriving newtype (Eq, Hashable) deriving stock (Generic) diff --git a/ron/lib/RON/Types/Experimental.hs b/ron/lib/RON/Types/Experimental.hs new file mode 100644 index 00000000..c4f178c6 --- /dev/null +++ b/ron/lib/RON/Types/Experimental.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module RON.Types.Experimental (Ref (..)) where + +import RON.Prelude + +import Data.Typeable (typeRep) +import Text.Show (showParen, showString, showsPrec) + +import RON.Types (Atom, UUID) + +-- | References to a RON object or a subobject +-- TODO hide data constructor in Internal module +data Ref a = Ref{object :: UUID, path :: [Atom]} + +instance Typeable a => Show (Ref a) where + showsPrec a Ref{object, path} = + showParen (a >= 11) $ + showString "Ref @" + . showsPrec 11 (typeRep $ Proxy @a) + . showString " " + . showsPrec 11 object + . showString " " + . showsPrec 11 path diff --git a/ron/ron.cabal b/ron/ron.cabal index dbcf20c1..e7048daa 100644 --- a/ron/ron.cabal +++ b/ron/ron.cabal @@ -63,6 +63,7 @@ library RON.Text.Serialize.Experimental RON.Text.Serialize.UUID RON.Types + RON.Types.Experimental RON.Util RON.Util.Word RON.UUID From 5121cf802cc6249ac7ca3b68dcb92f0f4f4a2464 Mon Sep 17 00:00:00 2001 From: mk Date: Thu, 13 Oct 2022 09:43:36 -0300 Subject: [PATCH 4/6] port: store: Fix readObject: strip subobject prefix --- demo/chat/Database.hs | 21 ++++++++++---------- ron-rdt/lib/RON/Store.hs | 9 ++++++++- ron-rdt/lib/RON/Store/FS.hs | 39 ++++++++++++++++++++++++------------- 3 files changed, 44 insertions(+), 25 deletions(-) diff --git a/demo/chat/Database.hs b/demo/chat/Database.hs index dbe6dcbd..73499631 100644 --- a/demo/chat/Database.hs +++ b/demo/chat/Database.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} + module Database ( chatroomUuid , databaseToUIUpdater @@ -6,13 +8,11 @@ module Database , newMessage ) where +import RON.Prelude + import Control.Concurrent.STM (TChan, atomically, readTChan, writeTChan) -import Control.Monad (forever, when) -import Control.Monad.IO.Class (liftIO) -import Data.List (sortOn) -import Data.Maybe (catMaybes) -import Data.Traversable (for) +import Control.Monad (forever) import RON.Data.ORSet.Experimental (ORSet) import qualified RON.Data.ORSet.Experimental as ORSet import RON.Error (MonadE) @@ -21,11 +21,11 @@ import RON.Store (MonadStore, newObject, readObject) import RON.Store.FS (runStore) import qualified RON.Store.FS as Store import RON.Types (Atom (AString, AUuid), UUID) -import RON.Types.Experimental (Ref (Ref)) +import RON.Types.Experimental (Ref (..)) import qualified RON.UUID as UUID +import System.IO (putStrLn) -import Types (MessageContent (MessageContent), MessageView, postTime) -import qualified Types +import Types (Env (..), MessageContent (..), MessageView, postTime) loadAllMessages :: Store.Handle -> IO [MessageView] loadAllMessages db = @@ -50,10 +50,11 @@ newMessage MessageContent{username, text} = do ORSet.add_ gMessageSetRef msgRef pure msgRef -messagePoster :: TChan MessageContent -> Store.Handle -> IO () -messagePoster onMessagePosted db = +messagePoster :: TChan MessageContent -> Store.Handle -> Env -> IO () +messagePoster onMessagePosted db Env{putLog} = forever $ do message <- atomically $ readTChan onMessagePosted + putLog $ "Saving message " <> show message runStore db $ newMessage message databaseToUIUpdater :: Store.Handle -> TChan [MessageView] -> IO () diff --git a/ron-rdt/lib/RON/Store.hs b/ron-rdt/lib/RON/Store.hs index 8ada6cc8..8a69a27c 100644 --- a/ron-rdt/lib/RON/Store.hs +++ b/ron-rdt/lib/RON/Store.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -11,6 +12,7 @@ module RON.Store ( import RON.Prelude +import Data.List (stripPrefix) import RON.Data.Experimental (Rep, ReplicatedObject, replicatedTypeId, stateFromFrame, view) import RON.Error (MonadE, errorContext) @@ -42,7 +44,12 @@ readObject object@(Ref objectId path) = fmap Just $ view objectId $ stateFromFrame objectId $ - sortOn opId $ filter ((path `isPrefixOf`) . payload) ops + sortOn + opId + [ op{payload = payload'} + | op@Op{payload} <- ops + , Just payload' <- [stripPrefix path payload] + ] -- TODO: Check when this was introduced, and if is needed -- | Append an arbitrary sequence of operations to an object. No preconditions. diff --git a/ron-rdt/lib/RON/Store/FS.hs b/ron-rdt/lib/RON/Store/FS.hs index 172427aa..a3b0d3f0 100644 --- a/ron-rdt/lib/RON/Store/FS.hs +++ b/ron-rdt/lib/RON/Store/FS.hs @@ -40,7 +40,8 @@ import System.Random.TF.Instances (random) import RON.Data.VersionVector (VV, mkVV, (·≼)) import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock) -import RON.Error (Error (..), MonadE, liftEitherString, tryIO) +import RON.Error (Error (..), MonadE, errorContext, liftEitherString, + throwErrorText, tryIO) import RON.Event (OriginVariety (ApplicationSpecific), Replica, ReplicaClock, getEventUuid, mkReplica) import RON.Store (MonadStore (..)) @@ -68,21 +69,23 @@ newtype Store a = Store (ExceptT Error (ReaderT Handle EpochClock) a) (Applicative, Functor, Monad, MonadError Error, MonadIO, ReplicaClock) instance MonadStore Store where - listObjects = do - Handle{dataDir} <- Store ask - objectDirs <- - tryIO $ do - exists <- doesDirectoryExist dataDir - if exists then listDirectory dataDir else pure [] - traverse uuidFromFileName objectDirs + listObjects = + errorContext "Store.listObjects" $ do + Handle{dataDir} <- Store ask + objectDirs <- + tryIO $ do + exists <- doesDirectoryExist dataDir + if exists then listDirectoryDirs dataDir else pure [] + traverse uuidFromFileName objectDirs appendPatch = appendPatchFS loadObjectLog = loadObjectLogFS - getObjectVersion objectId = do - patchNames <- getObjectPatches objectId - mkVV <$> for patchNames uuidFromFileName + getObjectVersion objectId = + errorContext "Store.getObjectVersion" $ do + patchNames <- getObjectPatches objectId + mkVV <$> for patchNames uuidFromFileName askObjectLogsDir :: MonadReader Handle m => UUID -> m FilePath askObjectLogsDir objectId = @@ -169,9 +172,13 @@ getMacAddress = + fromIntegral b0 uuidFromFileName :: MonadE m => FilePath -> m UUID -uuidFromFileName = - maybe (throwError "UUID.decodeBase32: filename is not a valid UUID") pure - . UUID.decodeBase32 +uuidFromFileName name = + maybe + ( throwErrorText $ + "UUID.decodeBase32: file name " <> show name <> " is not a valid UUID" + ) + pure + (UUID.decodeBase32 name) uuidToFileName :: UUID -> FilePath uuidToFileName = UUID.encodeBase32 @@ -201,3 +208,7 @@ subcribeToObject Handle{objectSubscriptions} object = readObjectSubscriptions :: Handle -> IO (Set UUID) readObjectSubscriptions Handle{objectSubscriptions} = readIORef objectSubscriptions + +listDirectoryDirs :: FilePath -> IO [FilePath] +listDirectoryDirs dir = + listDirectory dir >>= filterM \name -> doesDirectoryExist (dir name) \ No newline at end of file From 351db94d1423feb59757e78634d1dfb5e11caad8 Mon Sep 17 00:00:00 2001 From: mk Date: Thu, 13 Oct 2022 10:06:26 -0300 Subject: [PATCH 5/6] old: use appendPatchFromOneOrigin instead of patch --- ron-rdt/lib/RON/Data/ORSet/Experimental.hs | 4 ++-- ron-rdt/lib/RON/Store.hs | 2 +- ron-rdt/lib/RON/Store/Class.hs | 8 ++++---- ron-rdt/lib/RON/Store/FS.hs | 2 +- ron-rdt/lib/RON/Store/Test.hs | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ron-rdt/lib/RON/Data/ORSet/Experimental.hs b/ron-rdt/lib/RON/Data/ORSet/Experimental.hs index 4d97daa7..196248d6 100644 --- a/ron-rdt/lib/RON/Data/ORSet/Experimental.hs +++ b/ron-rdt/lib/RON/Data/ORSet/Experimental.hs @@ -31,7 +31,7 @@ import RON.Data.Experimental (AsAtom, AsAtoms, Rep, Replicated, import RON.Data.ORSet (setType) import RON.Error (MonadE, liftMaybe) import RON.Event (ReplicaClock, advanceToUuid, getEventUuid) -import RON.Store.Class (MonadStore, appendPatch) +import RON.Store.Class (MonadStore, appendPatchFromOneOrigin) import RON.Text.Serialize (serializeAtom) import RON.Types (Op (..), Payload, UUID) import RON.Types.Experimental (Ref (..)) @@ -72,9 +72,9 @@ add (Ref object path) value = do opId <- getEventUuid appendPatchFromOneOrigin object - [Op{opId, refId = object, payload = toAtoms value}] [Op{opId, refId = object, payload = path ++ toAtoms value}] pure opId + {- | Add value to the set or map. diff --git a/ron-rdt/lib/RON/Store.hs b/ron-rdt/lib/RON/Store.hs index 8a69a27c..d40718f7 100644 --- a/ron-rdt/lib/RON/Store.hs +++ b/ron-rdt/lib/RON/Store.hs @@ -28,7 +28,7 @@ newObject = do objectId <- getEventUuid let typeId = replicatedTypeId @(Rep a) let initOp = Op{opId = objectId, refId = typeId, payload = []} - appendPatch objectId [initOp] + appendPatchFromOneOrigin objectId [initOp] pure $ Ref objectId [] -- | Nothing if object doesn't exist in the replica. diff --git a/ron-rdt/lib/RON/Store/Class.hs b/ron-rdt/lib/RON/Store/Class.hs index be6df6e8..4389914f 100644 --- a/ron-rdt/lib/RON/Store/Class.hs +++ b/ron-rdt/lib/RON/Store/Class.hs @@ -11,10 +11,10 @@ class Monad m => MonadStore m where listObjects :: m [UUID] {- | - Append a sequence of operations to an existing object. - Must have the same origin. - -} - appendPatch :: UUID -> [Op] -> m () + Append a sequence of operations to an object. + Precondition: all operations must have the same origin. + -} + appendPatchFromOneOrigin :: UUID -> [Op] -> m () -- | Get all object logs split by replicas. Replicas order is not guaranteed. loadObjectLog :: diff --git a/ron-rdt/lib/RON/Store/FS.hs b/ron-rdt/lib/RON/Store/FS.hs index a3b0d3f0..873a7a72 100644 --- a/ron-rdt/lib/RON/Store/FS.hs +++ b/ron-rdt/lib/RON/Store/FS.hs @@ -78,7 +78,7 @@ instance MonadStore Store where if exists then listDirectoryDirs dataDir else pure [] traverse uuidFromFileName objectDirs - appendPatch = appendPatchFS + appendPatchFromOneOrigin = appendPatchFS loadObjectLog = loadObjectLogFS diff --git a/ron-rdt/lib/RON/Store/Test.hs b/ron-rdt/lib/RON/Store/Test.hs index 061cd6db..4e5bf602 100644 --- a/ron-rdt/lib/RON/Store/Test.hs +++ b/ron-rdt/lib/RON/Store/Test.hs @@ -48,7 +48,7 @@ thisReplicaId = mkReplica ApplicationSpecific 2020 instance MonadStore StoreSim where listObjects = StoreSim $ gets Map.keys - appendPatch objectId patch = + appendPatchFromOneOrigin objectId patch = StoreSim $ atObject . #logs . atReplica <>= Seq.fromList patch where atObject = at objectId . non emptyObject From 891f7898fc4bf7c17228708c7c417cf4d6d3d5cc Mon Sep 17 00:00:00 2001 From: mk Date: Fri, 14 Oct 2022 11:06:32 -0300 Subject: [PATCH 6/6] force text2 --- ron-rdt/ron-rdt.cabal | 2 +- ron-schema/ron-schema.cabal | 2 +- ron-storage/ron-storage.cabal | 2 +- ron/ron.cabal | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ron-rdt/ron-rdt.cabal b/ron-rdt/ron-rdt.cabal index ceb17b46..f555bd8a 100644 --- a/ron-rdt/ron-rdt.cabal +++ b/ron-rdt/ron-rdt.cabal @@ -43,7 +43,7 @@ library mtl, network-info, stm, - text, + text >= 2.0, tf-random, time, transformers, diff --git a/ron-schema/ron-schema.cabal b/ron-schema/ron-schema.cabal index 41bb902b..7f44a9d4 100644 --- a/ron-schema/ron-schema.cabal +++ b/ron-schema/ron-schema.cabal @@ -37,7 +37,7 @@ library megaparsec, mtl, template-haskell, - text, + text >= 2.0, transformers, -- project ron >= 0.9, diff --git a/ron-storage/ron-storage.cabal b/ron-storage/ron-storage.cabal index ebbb8f3e..68ac3c55 100644 --- a/ron-storage/ron-storage.cabal +++ b/ron-storage/ron-storage.cabal @@ -38,7 +38,7 @@ library mtl, network-info, stm, - text, + text >= 2.0, transformers, tf-random, unliftio-core, diff --git a/ron/ron.cabal b/ron/ron.cabal index e7048daa..f35146cb 100644 --- a/ron/ron.cabal +++ b/ron/ron.cabal @@ -39,7 +39,7 @@ library mtl, scientific, template-haskell, - text, + text >= 2.0, time, -- transformers >= 0.5.6.0, -- ^ TODO Writer.CPS