ron (empty) → 0.1
raw patch · 29 files changed
+4309/−0 lines, 29 filesdep +Diffdep +aesondep +attoparsec
Dependencies added: Diff, aeson, attoparsec, base, binary, bytestring, containers, criterion, data-default, deepseq, errors, extra, hashable, mtl, ron, safe, stringsearch, template-haskell, text, time, unordered-containers, vector
Files
- bench/Main.hs +29/−0
- lib/Attoparsec/Extra.hs +100/−0
- lib/Data/ZigZag.hs +75/−0
- lib/RON/Base64.hs +235/−0
- lib/RON/Binary.hs +5/−0
- lib/RON/Binary/Parse.hs +234/−0
- lib/RON/Binary/Serialize.hs +149/−0
- lib/RON/Binary/Types.hs +42/−0
- lib/RON/Data.hs +178/−0
- lib/RON/Data/Internal.hs +246/−0
- lib/RON/Data/LWW.hs +149/−0
- lib/RON/Data/ORSet.hs +169/−0
- lib/RON/Data/RGA.hs +411/−0
- lib/RON/Data/Time.hs +31/−0
- lib/RON/Data/VersionVector.hs +70/−0
- lib/RON/Epoch.hs +76/−0
- lib/RON/Event.hs +287/−0
- lib/RON/Event/Simulation.hs +99/−0
- lib/RON/Internal/Prelude.hs +63/−0
- lib/RON/Internal/Word.hs +193/−0
- lib/RON/Schema.hs +121/−0
- lib/RON/Schema/TH.hs +253/−0
- lib/RON/Text.hs +16/−0
- lib/RON/Text/Parse.hs +401/−0
- lib/RON/Text/Serialize.hs +168/−0
- lib/RON/Text/Serialize/UUID.hs +130/−0
- lib/RON/Types.hs +112/−0
- lib/RON/UUID.hs +182/−0
- ron.cabal +85/−0
+ bench/Main.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE NamedFieldPuns #-}++import RON.Internal.Prelude++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Criterion (bench, nf)+import Criterion.Main (defaultConfig, defaultMainWith)+import Criterion.Types (timeLimit)++import RON.Text (parseWireFrames, serializeWireFrames)+import RON.Types (Op (..), RawOp (..), WireChunk (Raw))+import qualified RON.UUID as UUID++main :: IO ()+main = do+ void . evaluate $ force serialized+ defaultMainWith+ defaultConfig{timeLimit = 1}+ [bench (show n) $ nf parseWireFrames batch | (n, batch) <- serialized]+ where+ rawop = RawOp{opType = UUID.zero, opObject = UUID.zero, op}+ op = Op{opEvent = UUID.zero, opRef = UUID.zero, opPayload = []}+ frame n = replicate n $ Raw rawop++ serialized =+ [ (n :: Int, serializeWireFrames $ replicate 100 $ frame n)+ | i <- [1 .. 10], let n = 100 * i+ ]
+ lib/Attoparsec/Extra.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Attoparsec.Extra+ ( module Attoparsec+ , char+ , endOfInputEx+ , getPos+ , isSuccessful+ , label+ , label'+ , parseOnlyL+ , takeL+ , withInputSize+ , (??)+ , (<+>)+ ) where++import RON.Internal.Prelude++import Data.Attoparsec.ByteString.Char8 (anyChar)+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.List (intercalate)++parseOnlyL :: Parser a -> ByteStringL -> Either String a+parseOnlyL p = parseOnly p . toStrict++-- | 'Attoparsec.take' adapter to 'ByteStringL'+takeL :: Int -> Parser ByteStringL+takeL = fmap fromStrict . Attoparsec.take++getPos :: Parser Int+getPos =+ Internal.Parser $ \t pos more _ suc -> suc t pos more $ Internal.fromPos pos++withInputSize :: Parser a -> Parser (Int, a)+withInputSize p = do+ posBefore <- getPos+ r <- p+ posAfter <- getPos+ pure (posAfter - posBefore, r)++label :: String -> Parser a -> Parser a+label = flip (<?>)++label' :: String -> Parser a -> Parser a+label' name p = do+ pos <- getPos+ label (name ++ ':' : show pos) p++-- | Variant of 'endOfInput' with a more debuggable message.+endOfInputEx :: Parser ()+endOfInputEx = do+ weAreAtEnd <- atEnd+ unless weAreAtEnd $ do+ pos <- getPos+ rest <- takeAtMost 11+ let cite+ | BS.length rest < 11 = rest+ | otherwise = BS.take 10 rest <> "..."+ fail $ show pos <> ": extra input: " <> show cite++takeAtMost :: Int -> Parser ByteString+takeAtMost limit = do+ pos0 <- getPos+ BS.pack <$> manyTill anyWord8 (checkLimit $ pos0 + limit)+ where+ checkLimit maxPos = do+ pos <- getPos+ guard (pos >= maxPos) <|> endOfInput++(??) :: Maybe a -> Parser a -> Parser a+(??) a alt = maybe alt pure a++-- | Apply parser and check it is applied successfully.+-- Kinda opposite to 'guard'.+isSuccessful :: Alternative f => f a -> f Bool+isSuccessful p = p $> True <|> pure False++char :: Char -> Parser Char+char c = do+ c' <- anyChar+ if c == c' then+ pure c+ else+ fail $ "Expected " ++ show c ++ ", got " ++ show c'++(<+>) :: Parser a -> Parser a -> Parser a+(<+>) p1 p2 = Internal.Parser $ \t pos more lose suc -> let+ lose1 t' _pos more1 ctx1 msg1 = Internal.runParser p2 t' pos more1 lose2 suc+ where+ lose2 _t _pos _more ctx2 msg2 = lose t pos more [] $ unwords+ [ "Many fails:\n"+ , intercalate " > " ctx1, ":", msg1, "|\n"+ , intercalate " > " ctx2, ":", msg2+ ]+ in Internal.runParser p1 t pos more lose1 suc+infixl 3 <+>
+ lib/Data/ZigZag.hs view
@@ -0,0 +1,75 @@+-- Copyright (c) 2016, Pasqualino `Titto` Assini++module Data.ZigZag+ ( zzEncode+ , zzEncodeInteger+ , zzDecode8+ , zzDecode16+ , zzDecode32+ , zzDecode64+ , zzDecodeInteger+ , zzDecode+ ) where++import Data.Word+import Data.Int+import Data.Bits++{-# SPECIALIZE INLINE zzEncode :: Int8 -> Word8 #-}+{-# SPECIALIZE INLINE zzEncode :: Int16 -> Word16 #-}+{-# SPECIALIZE INLINE zzEncode :: Int32 -> Word32 #-}+{-# SPECIALIZE INLINE zzEncode :: Int64 -> Word64 #-}+zzEncode :: (Num b, Integral a, FiniteBits a) => a -> b+zzEncode w = fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w -1)))++--{-# INLINE zzEncode8 #-}+--zzEncode8 :: Int8 -> Word8+-- zzEncode8 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 7))++-- {-# INLINE zzEncode16 #-}+-- zzEncode16 :: Int16 -> Word16+-- zzEncode16 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 15))++-- {-# INLINE zzEncode32 #-}+-- zzEncode32 :: Int32 -> Word32+-- zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31))++-- {-# INLINE zzEncode64 #-}+-- zzEncode64 :: Int64 -> Word64+-- zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))++{-# INLINE zzEncodeInteger #-}+zzEncodeInteger :: Integer -> Integer+zzEncodeInteger x | x>=0 = x `shiftL` 1+ | otherwise = negate (x `shiftL` 1) - 1++-- {-# SPECIALIZE INLINE zzDecode :: Word8 -> Int8 #-}+-- {-# SPECIALIZE INLINE zzDecode :: Word16 -> Int16 #-}+-- {-# SPECIALIZE INLINE zzDecode :: Word32 -> Int32 #-}+-- {-# SPECIALIZE INLINE zzDecode :: Word64 -> Int64 #-}+-- {-# SPECIALIZE INLINE zzDecode :: Integer -> Integer #-}++{-# INLINE zzDecode #-}+zzDecode :: (Num a, Integral a1, Bits a1) => a1 -> a+zzDecode w = fromIntegral ((w `shiftR` 1) `xor` negate (w .&. 1))+-- zzDecode w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1)))++{-# INLINE zzDecode8 #-}+zzDecode8 :: Word8 -> Int8+zzDecode8 = zzDecode++{-# INLINE zzDecode16 #-}+zzDecode16 :: Word16 -> Int16+zzDecode16 = zzDecode++{-# INLINE zzDecode32 #-}+zzDecode32 :: Word32 -> Int32+zzDecode32 = zzDecode++{-# INLINE zzDecode64 #-}+zzDecode64 :: Word64 -> Int64+zzDecode64 = zzDecode++{-# INLINE zzDecodeInteger #-}+zzDecodeInteger :: Integer -> Integer+zzDecodeInteger = zzDecode
+ lib/RON/Base64.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | RON version of Base64 encoding+module RON.Base64+ ( decode+ , decode60+ , decode60base32+ , decode64+ , decode64base32+ , decodeLetter+ , decodeLetter4+ , encode+ , encode60+ , encode60short+ , encode64+ , encode64base32short+ , encodeLetter+ , encodeLetter4+ , isLetter+ ) where++import RON.Internal.Prelude++import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Char (isAlphaNum, ord)++import RON.Internal.Word (Word4, Word6 (W6), Word60,+ leastSignificant4, leastSignificant6,+ leastSignificant60, safeCast)++alphabet :: ByteString+alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~"++-- | Check if a character is in the Base64 alphabet.+-- TODO use approach from 'isUpperHexDigit'+isLetter :: Char -> Bool+isLetter c = isAlphaNum c || c == '_' || c == '~'++-- | Convert a Base64 letter to a number [0-63]+decodeLetter :: Word8 -> Maybe Word6+decodeLetter x+ | x < ord0 = Nothing+ | x <= ord9 = Just . leastSignificant6 $ x - ord0+ | x < ordA = Nothing+ | x <= ordZ = Just . leastSignificant6 $ x - ordA + posA+ | x == ord_ = Just $ leastSignificant6 pos_+ | x < orda = Nothing+ | x <= ordz = Just . leastSignificant6 $ x - orda + posa+ | x == ordõ = Just $ leastSignificant6 posõ+ | otherwise = Nothing++-- ASCII milestone codes+ord0, ord9, ordA, ordZ, ord_, orda, ordz, ordõ :: Word8+ord0 = fromIntegral $ ord '0'+ord9 = fromIntegral $ ord '9'+ordA = fromIntegral $ ord 'A'+ordZ = fromIntegral $ ord 'Z'+ord_ = fromIntegral $ ord '_'+orda = fromIntegral $ ord 'a'+ordz = fromIntegral $ ord 'z'+ordõ = fromIntegral $ ord '~'++-- Base64 milestone codes+posA, pos_, posa, posõ :: Word8+posA = 10+pos_ = 36+posa = 37+posõ = 63++-- | Convert a subset [0-F] of Base64 letters to a number [0-15]+decodeLetter4 :: Word8 -> Maybe Word4+decodeLetter4 x+ | x < ord0 = Nothing+ | x <= ord9 = Just . leastSignificant4 $ x - ord0+ | x < ordA = Nothing+ | x <= ordZ = Just . leastSignificant4 $ x - ordA + posA+ | otherwise = Nothing++-- | Decode a blob from a Base64 string+decode :: ByteStringL -> Maybe ByteStringL+decode =+ fmap (BSL.pack . go . map safeCast) . traverse decodeLetter . BSL.unpack+ where+ go = \case+ [a, b] -> decode2 a b+ [a, b, c] -> decode3 a b c+ a:b:c:d:rest -> decode4 a b c d ++ go rest+ _ -> []+ decode2 a b = [(a `shiftL` 2) .|. (b `shiftR` 4)]+ decode3 a b c =+ [ ( a `shiftL` 2) .|. (b `shiftR` 4)+ , ((b .&. 0b1111) `shiftL` 4) .|. (c `shiftR` 2)+ ]+ decode4 a b c d =+ [ ( a `shiftL` 2) .|. (b `shiftR` 4)+ , ((b .&. 0b1111) `shiftL` 4) .|. (c `shiftR` 2)+ , ((c .&. 0b11) `shiftL` 6) .|. d+ ]++-- | Decode a 60-bit number from a Base64 string+decode60 :: ByteString -> Maybe Word60+decode60 =+ fmap leastSignificant60 . go 10+ <=< traverse (fmap safeCast . decodeLetter) . BS.unpack+ where+ go :: Int -> [Word8] -> Maybe Word64+ go n+ | n > 0 = \case+ [] -> Just 0+ [a] -> Just $ decode4 a 0 0 0+ [a, b] -> Just $ decode4 a b 0 0+ [a, b, c] -> Just $ decode4 a b c 0+ a:b:c:d:rest -> do+ lowerPart <- go (n - 4) rest+ pure $ decode4 a b c d .|. (lowerPart `shiftR` 24)+ | otherwise = \case+ [] -> Just 0+ _ -> Nothing -- extra input+ decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Word64+ decode4 a b c d =+ (safeCast a `shiftL` 54) .|.+ (safeCast b `shiftL` 48) .|.+ (safeCast c `shiftL` 42) .|.+ (safeCast d `shiftL` 36)++-- | Decode a 60-bit number from a Base32 string+decode60base32 :: ByteString -> Maybe Word60+decode60base32 =+ fmap leastSignificant60 . go12+ <=< traverse (fmap safeCast . decodeLetter) . BS.unpack+ where+ go12 :: [Word8] -> Maybe Word64+ go12 letters = do+ let (letters8, letters4) = splitAt 8 letters+ w8 = decodeBase32 8 letters8+ w4 <- go4 letters4+ pure $ (w8 `shiftL` 20) .|. w4+ go4 :: [Word8] -> Maybe Word64+ go4 letters = case splitAt 4 letters of+ (letters4, []) -> pure $ decodeBase32 4 letters4+ _ -> Nothing -- extra input+ decodeBase32 :: Int -> [Word8] -> Word64+ decodeBase32 len+ = foldl' (\acc b -> (acc `shiftL` 5) .|. safeCast b) 0+ . take len+ . (++ repeat 0)++-- | Decode a 64-bit number from a Base64 string+decode64 :: ByteString -> Maybe Word64+decode64 s = do+ (s0, s1) <- BS.uncons s+ cons64 <$> decodeLetter4 s0 <*> decode60 s1++-- | Decode a 64-bit number from a Base32 string+decode64base32 :: ByteString -> Maybe Word64+decode64base32 s = do+ (s0, s1) <- BS.uncons s+ cons64 <$> decodeLetter4 s0 <*> decode60base32 s1++cons64 :: Word4 -> Word60 -> Word64+cons64 v w = (safeCast v `shiftL` 60) .|. safeCast w++-- | Encode a blob to a Base64 string+encode :: ByteStringL -> ByteStringL+encode = BSL.pack . go . BSL.unpack+ where+ go = \case+ [] -> []+ [a] -> encode1 a+ [a, b] -> encode2 a b+ a:b:c:rest -> encode3 a b c ++ go rest+ encode1 a =+ map (encodeLetter . leastSignificant6)+ [a `shiftR` 2, (a .&. 0b11) `shiftL` 4]+ encode2 a b = map (encodeLetter . leastSignificant6)+ [ a `shiftR` 2+ , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4)+ , (b .&. 0b1111) `shiftL` 2+ ]+ encode3 a b c = map (encodeLetter . leastSignificant6)+ [ a `shiftR` 2+ , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4)+ , ((b .&. 0b1111) `shiftL` 2) .|. (c `shiftR` 6)+ , c .&. 0b111111+ ]++-- | Convert a number from [0..63] to a single letter+encodeLetter :: Word6 -> Word8+encodeLetter i = alphabet `BS.index` safeCast i++-- | Convert a number from [0..15] to a single letter+encodeLetter4 :: Word4 -> Word8+encodeLetter4 i = alphabet `BS.index` safeCast i++-- | Encode a 60-bit number to a Base64 string+encode60 :: Word60 -> ByteString+encode60 w = BS.pack $+ map (encodeLetter . leastSignificant6)+ [ (safeCast w `shiftR` (6 * i)) .&. 0b111111 :: Word64+ | i <- [9, 8 .. 0]+ ]++-- | Encode a 60-bit number to a Base64 string, dropping trailing zeroes+encode60short :: Word60 -> ByteString+encode60short v = case safeCast v :: Word64 of+ 0 -> "0"+ x -> BS.pack . map (encodeLetter . leastSignificant6) $ go 9 x+ where+ go _ 0 = []+ go i w =+ (w `shiftR` (6 * i)) .&. 0b111111 :+ go (i - 1) (w .&. complement (0b111111 `shiftL` (6 * i)))++-- | Encode a 64-bit number to a Base32 string, dropping trailing zeroes+encode64base32short :: Word64 -> ByteString+encode64base32short = \case+ 0 -> "0"+ x -> BS.pack . map (encodeLetter . leastSignificant5) $ go 12 x+ where+ go _ 0 = []+ go i w =+ (w `shiftR` (5 * i)) .&. 0b11111 :+ go (i - 1) (w .&. complement (0b11111 `shiftL` (5 * i)))++ leastSignificant5 w = W6 $ fromIntegral w .&. 0b11111++-- | Encode a 64-bit number to a Base64 string+encode64 :: Word64 -> ByteString+encode64 w =+ encodeLetter (leastSignificant6 $ w `shiftR` 60)+ `BS.cons` encode60 (leastSignificant60 w)
+ lib/RON/Binary.hs view
@@ -0,0 +1,5 @@+-- | RON-Binary wire format+module RON.Binary (parse, serialize) where++import RON.Binary.Parse (parse)+import RON.Binary.Serialize (serialize)
+ lib/RON/Binary/Parse.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | Binary parser elements+module RON.Binary.Parse (+ parse,+ parseAtom,+ parseString,+) where++import RON.Internal.Prelude++import Attoparsec.Extra (Parser, anyWord8, endOfInputEx, label,+ parseOnlyL, takeL, withInputSize)+import qualified Attoparsec.Extra as Atto+import qualified Data.Binary as Binary+import Data.Binary.Get (getDoublebe, runGet)+import Data.Bits (shiftR, testBit, (.&.))+import Data.ByteString.Lazy (cons, toStrict)+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.ZigZag (zzDecode64)++import RON.Binary.Types (Desc (..), Size, descIsOp)+import RON.Internal.Word (safeCast)+import RON.Types (Atom (AFloat, AInteger, AString, AUuid), Op (..),+ OpTerm (THeader, TQuery, TRaw, TReduced),+ RawOp (..), UUID (UUID),+ WireChunk (Query, Raw, Value), WireFrame,+ WireReducedChunk (..))++-- | 'Parser' for descriptor+parseDesc :: Parser (Desc, Size)+parseDesc = label "desc" $ do+ b <- label "start byte" anyWord8+ let typeCode = b `shiftR` 4+ let sizeCode = b .&. 0b1111+ let desc = toEnum $ fromIntegral typeCode+ size <- case (sizeCode, desc) of+ (0, DAtomString) -> extendedLength+ (0, d) | descIsOp d -> pure 0+ (0, _) -> pure 16+ _ -> pure $ fromIntegral sizeCode+ pure (desc, size)++-- | 'Parser' for extended length field+extendedLength :: Parser Size+extendedLength = do+ b <- anyWord8+ if testBit b 7 then do+ bbb <- takeL 3+ pure $ leastSignificant31 $ Binary.decode (b `cons` bbb)+ else+ pure $ safeCast b++-- | Parse frame+parse :: ByteStringL -> Either String WireFrame+parse = parseOnlyL $ parseFrame <* endOfInputEx++-- | 'Parser' for frame+parseFrame :: Parser WireFrame+parseFrame = label "WireFrame" $ do+ _ <- Atto.string "RON2" <|> do+ magic <- takeL 4+ fail $ "unsupported magic sequence " ++ show magic+ parseChunks++-- | 'Parser' for chunk sequence+parseChunks :: Parser [WireChunk]+parseChunks = do+ size :: Size <- Binary.decode <$> takeL 4+ if | testBit size 31 ->+ liftA2 (:) (parseChunk $ leastSignificant31 size) parseChunks+ | size > 0 ->+ (:[]) <$> parseChunk size+ | True ->+ pure []++-- | Clear upper bit of 'Word32'+leastSignificant31 :: Word32 -> Word32+leastSignificant31 x = x .&. 0x7FFFFFFF++-- | 'Parser' for a chunk+parseChunk+ :: Size -- ^ expected input length+ -> Parser WireChunk+parseChunk size = label "WireChunk" $ do+ (consumed0, (term, op)) <- withInputSize parseDescAndRawOp+ let parseReducedChunk wrcHeader isQuery = do+ wrcBody <- parseReducedOps $ fromIntegral size - consumed0+ pure $ (if isQuery then Query else Value) WireReducedChunk{..}+ case term of+ THeader -> parseReducedChunk op False+ TQuery -> parseReducedChunk op True+ TReduced -> fail "reduced op without a chunk"+ TRaw -> assertSize size consumed0 $> Raw op++-- | Assert that is such as expected+assertSize :: Monad f => Size -> Int -> f ()+assertSize expected consumed =+ when (consumed /= fromIntegral expected) $+ fail $+ "size mismatch: expected " ++ show expected ++ ", got " ++ show consumed++-- | 'Parser' for a sequence of reduced ops+parseReducedOps :: Int -> Parser [Op]+parseReducedOps = label "[Op]" . go+ where+ go = \case+ 0 -> pure []+ expected -> do+ (consumed, (TReduced, op)) <- withInputSize parseDescAndReducedOp+ case compare consumed expected of+ LT -> (op :) <$> go (expected - consumed)+ EQ -> pure [op]+ GT -> fail "impossible"++-- | 'Parser' for raw op, returning the op's terminator along with the op+parseDescAndRawOp :: Parser (OpTerm, RawOp)+parseDescAndRawOp = label "d+RawOp" $ do+ (desc, size) <- parseDesc+ unless (size == 0) $+ fail $ "desc = " ++ show desc ++ ", size = " ++ show size+ case desc of+ DOpRaw -> (TRaw,) <$> parseRawOp+ DOpHeader -> (THeader,) <$> parseRawOp+ DOpQueryHeader -> (TQuery,) <$> parseRawOp+ _ -> fail $ "unimplemented " ++ show desc++-- | 'Parser' for reduced op, returning the op's terminator along with the op+parseDescAndReducedOp :: Parser (OpTerm, Op)+parseDescAndReducedOp = label "d+RawOp" $ do+ (desc, size) <- parseDesc+ unless (size == 0) $+ fail $ "desc = " ++ show desc ++ ", size = " ++ show size+ case desc of+ DOpReduced -> (TReduced,) <$> parseReducedOp+ _ -> fail $ "unimplemented " ++ show desc++-- | 'Parser' for raw op without terminator+parseRawOp :: Parser RawOp+parseRawOp = label "RawOp" $ do+ opType <- parseOpKey DUuidType+ opObject <- parseOpKey DUuidObject+ op <- parseReducedOp+ pure RawOp{..}++-- | 'Parser' for reduced op without terminator+parseReducedOp :: Parser Op+parseReducedOp = label "Op" $ do+ opEvent <- parseOpKey DUuidEvent+ opRef <- parseOpKey DUuidRef+ opPayload <- parsePayload+ pure Op{..}++-- | 'Parser' for an op key (type, object, event, or reference)+parseOpKey :: Desc -> Parser UUID+parseOpKey expectedType = label "OpKey" $ do+ (desc, size) <- parseDesc+ let go = do+ guard $ desc == expectedType+ uuid size+ case desc of+ DUuidType -> go+ DUuidObject -> go+ DUuidEvent -> go+ DUuidRef -> go+ _ -> fail $ show desc++-- | 'Parser' for UUID+uuid+ :: Size -- ^ expected input length+ -> Parser UUID+uuid size = label "UUID" $+ case size of+ 16 -> do+ x <- Binary.decode <$> takeL 8+ y <- Binary.decode <$> takeL 8+ pure $ UUID x y+ _ -> fail "expected uuid of size 16"++-- | 'Parser' for a payload (sequence of atoms)+parsePayload :: Parser [Atom]+parsePayload = label "payload" $ many atom++-- | 'Parser' for an atom+atom :: Parser Atom+atom = label "Atom" $ do+ (desc, size) <- parseDesc+ case desc of+ DAtomFloat -> AFloat <$> float size+ DAtomInteger -> AInteger <$> integer size+ DAtomString -> AString <$> string size+ DAtomUuid -> AUuid <$> uuid size+ _ -> fail "expected Atom"++-- | Parse an 'Atom'+parseAtom :: ByteStringL -> Either String Atom+parseAtom = parseOnlyL $ atom <* endOfInputEx++-- | 'Parser' for a float atom+float+ :: Size -- ^ expected input length+ -> Parser Double+float = \case+ 8 -> runGet getDoublebe <$> takeL 8+ _ -> undefined++-- | 'Parser' for an integer atom+integer+ :: Size -- ^ expected input length+ -> Parser Int64+integer size = label "Integer" $ do+ -- big-endian, zigzag-coded, lengths 1..8+ unless (size >= 1 && size <= 8) $ fail "integer size must be 1..8"+ unless (size == 8) $ fail "integer size /=8 not implemented"+ zzDecode64 . Binary.decode <$> takeL (fromIntegral size)++-- | 'Parser' for an string+string+ :: Size -- ^ expected input length+ -> Parser Text+string size = decodeUtf8 . toStrict <$> takeL (fromIntegral size)++-- | Parse a string atom+parseString :: ByteStringL -> Either String Text+parseString bs =+ parseOnlyL (string (fromIntegral $ BSL.length bs) <* endOfInputEx) bs
+ lib/RON/Binary/Serialize.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Binary serializer elements+module RON.Binary.Serialize (+ serialize,+ serializeAtom,+ serializeString,+) where++import RON.Internal.Prelude++import qualified Data.Binary as Binary+import Data.Binary.Put (putDoublebe, runPut)+import Data.Bits (bit, shiftL, (.|.))+import Data.ByteString.Lazy (cons, fromStrict)+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.ZigZag (zzEncode)++import RON.Binary.Types (Desc (..), Size, descIsOp)+import RON.Internal.Word (Word4, b0000, leastSignificant4, safeCast)+import RON.Types (Atom (AFloat, AInteger, AString, AUuid), Op (..),+ RawOp (..), UUID (UUID),+ WireChunk (Query, Raw, Value), WireFrame,+ WireReducedChunk (..))++-- | Serialize a frame+serialize :: WireFrame -> Either String ByteStringL+serialize chunks = ("RON2" <>) <$> serializeBody+ where+ serializeBody = foldChunks =<< traverse serializeChunk chunks++ chunkSize :: Bool -> Int64 -> Either String ByteStringL+ chunkSize continue x+ | x < bit 31 = Right $ Binary.encode s'+ | otherwise = Left $ "chunk size is too big: " ++ show x+ where+ s = fromIntegral x :: Size+ s' | continue = s .|. bit 31+ | otherwise = s++ foldChunks :: [ByteStringL] -> Either String ByteStringL+ foldChunks = \case+ [] -> chunkSize False 0+ [c] -> (<> c) <$> chunkSize False (BSL.length c)+ c:cs ->+ mconcat <$>+ sequence [chunkSize True (BSL.length c), pure c, foldChunks cs]++-- | Serialize a chunk+serializeChunk :: WireChunk -> Either String ByteStringL+serializeChunk = \case+ Raw op -> serializeRawOp DOpRaw op+ Value rchunk -> serializeReducedChunk False rchunk+ Query rchunk -> serializeReducedChunk True rchunk++-- | Serialize a raw op+serializeRawOp :: Desc -> RawOp -> Either String ByteStringL+serializeRawOp desc RawOp{..} = do+ keys <- sequenceA+ [ serializeUuidType opType+ , serializeUuidObject opObject+ , serializeUuidEvent opEvent+ , serializeUuidRef opRef+ ]+ payload <- traverse serializeAtom opPayload+ serializeWithDesc desc $ mconcat $ keys ++ payload+ where+ Op{..} = op+ serializeUuidType = serializeWithDesc DUuidType . serializeUuid+ serializeUuidObject = serializeWithDesc DUuidObject . serializeUuid+ serializeUuidEvent = serializeWithDesc DUuidEvent . serializeUuid+ serializeUuidRef = serializeWithDesc DUuidRef . serializeUuid++-- | Serialize a reduced op+serializeReducedOp :: Desc -> UUID -> UUID -> Op -> Either String ByteStringL+serializeReducedOp d opType opObject op = serializeRawOp d RawOp{..}++-- | Serialize a 'UUID'+serializeUuid :: UUID -> ByteStringL+serializeUuid (UUID x y) = Binary.encode x <> Binary.encode y++-- | Encode descriptor+encodeDesc :: Desc -> Word4+encodeDesc = leastSignificant4 . fromEnum++-- | Prepend serialized bytes with descriptor+serializeWithDesc+ :: Desc+ -> ByteStringL -- ^ body+ -> Either String ByteStringL+serializeWithDesc d body = do+ (lengthDesc, lengthExtended) <- lengthFields+ let descByte = safeCast (encodeDesc d) `shiftL` 4 .|. safeCast lengthDesc+ pure $ descByte `cons` lengthExtended <> body+ where+ len = BSL.length body+ lengthFields = case d of+ DAtomString+ | len == 0 -> Right (b0000, mkLengthExtended)+ | len < 16 -> Right (leastSignificant4 len, BSL.empty)+ | len < bit 31 -> Right (b0000, mkLengthExtended)+ | otherwise -> Left "String is too long"+ _+ | descIsOp d -> Right (b0000, BSL.empty)+ | len < 16 -> Right (leastSignificant4 len, BSL.empty)+ | len == 16 -> Right (b0000, BSL.empty)+ | otherwise -> Left "impossible"+ mkLengthExtended+ | len < 128 = Binary.encode (fromIntegral len :: Word8)+ | otherwise = Binary.encode (fromIntegral len .|. bit 31 :: Word32)++-- | Serialize an 'Atom'+serializeAtom :: Atom -> Either String ByteStringL+serializeAtom = \case+ AFloat f -> serializeWithDesc DAtomFloat $ serializeFloat f+ AInteger i -> serializeWithDesc DAtomInteger $ Binary.encode $ zzEncode64 i+ AString s -> serializeWithDesc DAtomString $ serializeString s+ AUuid u -> serializeWithDesc DAtomUuid $ serializeUuid u+ where+ {-# INLINE zzEncode64 #-}+ zzEncode64 :: Int64 -> Word64+ zzEncode64 = zzEncode++-- | Serialize a float atom+serializeFloat :: Double -> ByteStringL+serializeFloat = runPut . putDoublebe++-- | Serialize a reduced chunk+serializeReducedChunk :: Bool -> WireReducedChunk -> Either String ByteStringL+serializeReducedChunk isQuery WireReducedChunk{..} = do+ header <-+ serializeRawOp (if isQuery then DOpQueryHeader else DOpHeader) wrcHeader+ body <- foldMapA (serializeReducedOp DOpReduced opType opObject) wrcBody+ pure $ header <> body+ where+ RawOp{..} = wrcHeader++-- | Serialize a string atom+serializeString :: Text -> ByteStringL+serializeString = fromStrict . encodeUtf8++foldMapA :: (Monoid b, Applicative f, Foldable t) => (a -> f b) -> t a -> f b+foldMapA f = fmap fold . traverse f . toList
+ lib/RON/Binary/Types.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE LambdaCase #-}++-- | Common types for binary format (parser and serializer)+module RON.Binary.Types where++import RON.Internal.Prelude++type Size = Word32++-- | Data block descriptor+data Desc++ = DOpRaw+ | DOpReduced+ | DOpHeader+ | DOpQueryHeader++ | DUuidType+ | DUuidObject+ | DUuidEvent+ | DUuidRef++ | DAtomUuidZip+ | DUuidZipObject+ | DUuidZipEvent+ | DUuidZipRef++ | DAtomUuid+ | DAtomInteger+ | DAtomString+ | DAtomFloat++ deriving (Enum, Eq, Show)++-- | Does the descriptor refer to an op+descIsOp :: Desc -> Bool+descIsOp = \case+ DOpRaw -> True+ DOpReduced -> True+ DOpHeader -> True+ DOpQueryHeader -> True+ _ -> False
+ lib/RON/Data.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Typed and untyped RON tools+module RON.Data+ ( Reducible (..)+ , Replicated (..)+ , ReplicatedAsObject (..)+ , ReplicatedAsPayload (..)+ , fromRon+ , newRon+ , objectEncoding+ , payloadEncoding+ , reduceObject+ , reduceStateFrame+ , reduceWireFrame+ ) where++import RON.Internal.Prelude++import Control.Monad.State.Strict (execStateT, lift, modify')+import Data.Foldable (fold)+import Data.List (partition)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map, (!?))+import qualified Data.Map.Strict as Map++import RON.Data.Internal+import RON.Data.LWW (LwwPerField)+import RON.Data.ORSet (ORSetRaw)+import RON.Data.RGA (RgaRaw)+import RON.Data.VersionVector (VersionVector)+import RON.Types (Object (..), Op (..), RawOp (..), StateChunk (..),+ StateFrame, UUID, WireChunk (Query, Raw, Value),+ WireFrame, WireReducedChunk (..))+import RON.UUID (pattern Zero)+import qualified RON.UUID as UUID++reducers :: Map UUID Reducer+reducers = Map.fromList+ [ mkReducer @LwwPerField+ , mkReducer @RgaRaw+ , mkReducer @ORSetRaw+ , mkReducer @VersionVector+ ]++reduceWireFrame :: WireFrame -> WireFrame+reduceWireFrame chunks = values' ++ queries where+ chunkTypeAndObject = opTypeAndObject . \case+ Raw op -> op+ Value WireReducedChunk{wrcHeader = op} -> op+ Query WireReducedChunk{wrcHeader = op} -> op+ opTypeAndObject RawOp{..} = (opType, opObject)+ (queries, values) = partition isQuery chunks+ values' =+ fold $+ Map.mapWithKey reduceWireFrameByType $+ NonEmpty.fromList <$>+ Map.fromListWith (++)+ [(chunkTypeAndObject value, [value]) | value <- values]++reduceWireFrameByType :: (UUID, UUID) -> NonEmpty WireChunk -> [WireChunk]+reduceWireFrameByType (typ, obj) = case reducers !? typ of+ Nothing -> toList -- TODO use default reducer+ Just Reducer{wireReducer} -> wireReducer obj++isQuery :: WireChunk -> Bool+isQuery = \case+ Query _ -> True+ _ -> False++mkReducer :: forall a . Reducible a => (UUID, Reducer)+mkReducer =+ ( reducibleOpType @a+ , Reducer{wireReducer = mkWireReducer @a, stateReducer = reduceState @a}+ )++mkWireReducer :: forall a . Reducible a => WireReducer+mkWireReducer obj chunks = chunks' <> leftovers where+ chunks'+ = maybeToList stateChunk'+ ++ map (Value . wrapRChunk) unappliedPatches+ ++ map (Raw . wrapOp) unappliedOps+ mStates = nonEmpty states+ (stateChunk', (unappliedPatches, unappliedOps)) = case mStates of+ Nothing -> (Nothing, reduceUnappliedPatches @a (patches, rawops))+ Just nStates -> let+ state = sconcat $ fmap snd nStates+ (reducedState, unapplied') = applyPatches state (patches, rawops)+ StateChunk reducedStateVersion reducedStateBody =+ stateToChunk @a reducedState+ MaxOnFst (seenStateVersion, seenState) =+ sconcat $ fmap MaxOnFst nStates+ stateVersion = if+ | reducedStateVersion > seenStateVersion -> reducedStateVersion+ | reducedState == seenState -> seenStateVersion+ | otherwise -> UUID.succValue seenStateVersion+ rc = ReducedChunk+ { rcVersion = stateVersion+ , rcRef = Zero+ , rcBody = reducedStateBody+ }+ in+ (Just $ Value $ wrapRChunk rc, reduceUnappliedPatches @a unapplied')+ typ = reducibleOpType @a+ wrapOp = RawOp typ obj+ (states, patches, rawops, leftovers) = foldMap load chunks+ load chunk = fromMaybe ([], [], [], [chunk]) $ load' chunk+ load' chunk = case chunk of+ Raw rawop@RawOp{op} -> do+ guardSameObject rawop+ pure ([], [], [op], [])+ Value WireReducedChunk{wrcHeader, wrcBody} -> do+ guardSameObject wrcHeader+ let ref = opRef $ op wrcHeader+ case ref of+ Zero -> -- state+ pure+ ( [ ( opEvent $ op wrcHeader+ , stateFromChunk wrcBody+ ) ]+ , []+ , []+ , []+ )+ _ -> -- patch+ pure+ ( []+ , [ ReducedChunk+ { rcVersion = opEvent $ op wrcHeader+ , rcRef = ref+ , rcBody = wrcBody+ }+ ]+ , []+ , []+ )+ _ -> Nothing+ guardSameObject RawOp{opType, opObject} =+ guard $ opType == typ && opObject == obj+ wrapRChunk ReducedChunk{..} = WireReducedChunk+ { wrcHeader = wrapOp+ Op{opEvent = rcVersion, opRef = rcRef, opPayload = []}+ , wrcBody = rcBody+ }++reduceState :: forall a . Reducible a => StateChunk -> StateChunk -> StateChunk+reduceState s1 s2 =+ stateToChunk @a $ ((<>) `on` (stateFromChunk . stateBody)) s1 s2++reduceStateFrame :: StateFrame -> StateFrame -> Either String StateFrame+reduceStateFrame s1 s2 =+ (`execStateT` s1) . (`Map.traverseWithKey` s2) $ \oid@(typ, _) chunk ->+ case reducers !? typ of+ Just Reducer{stateReducer} ->+ modify' $ Map.insertWith stateReducer oid chunk+ Nothing -> lift $+ Left $ "Cannot reduce StateFrame of unknown type " ++ show typ++unsafeReduceObject :: Object a -> StateFrame -> Either String (Object a)+unsafeReduceObject Object{objectId, objectFrame = s1} s2 = do+ objectFrame <- reduceStateFrame s1 s2+ pure Object{..}++-- | Reduce object with frame from another version of the same object.+reduceObject :: Object a -> Object a -> Either String (Object a)+reduceObject o1 o2+ | id1 == id2 = unsafeReduceObject o1 $ objectFrame o2+ | otherwise = Left $ "Object ids differ: " ++ show (id1, id2)+ where+ id1 = objectId o1+ id2 = objectId o2
+ lib/RON/Data/Internal.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module RON.Data.Internal where++import RON.Internal.Prelude++import Control.Monad.Writer.Strict (WriterT, lift, runWriterT, tell)+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text++import RON.Event (ReplicaClock)+import RON.Types (Atom (..), Object (..), Op (..), StateChunk (..),+ StateFrame, UUID (..), WireChunk)+import RON.UUID (zero)++-- | Reduce all chunks of specific type and object in the frame+type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk]++data Reducer = Reducer+ { wireReducer :: WireReducer+ , stateReducer :: StateChunk -> StateChunk -> StateChunk+ }++-- | Unapplied patches and raw ops+type Unapplied = ([ReducedChunk], [Op])++-- TODO(2018-08-24, cblp) Semilattice a?+-- | Untyped-reducible types.+-- Untyped means if this type is a container then the types of data contained in+-- it is not considered.+class (Eq a, Monoid a) => Reducible a where++ -- | UUID of the type+ reducibleOpType :: UUID++ -- | Load a state from a state chunk+ stateFromChunk :: [Op] -> a++ -- | Store a state to a state chunk+ stateToChunk :: a -> StateChunk++ -- | Merge a state with patches and raw ops+ applyPatches :: a -> Unapplied -> (a, Unapplied)+ applyPatches a (patches, ops) =+ ( a <> foldMap (patchValue . patchFromChunk) patches+ <> foldMap (patchValue . patchFromRawOp) ops+ , mempty+ )++ -- | Merge patches and raw ops into bigger patches or throw obsolete ops+ reduceUnappliedPatches :: Unapplied -> Unapplied+ reduceUnappliedPatches (patches, ops) =+ ( maybeToList .+ fmap (patchToChunk @a . sconcat) .+ nonEmpty $+ map patchFromChunk patches <> map patchFromRawOp ops+ , []+ )++data ReducedChunk = ReducedChunk+ { rcVersion :: UUID+ , rcRef :: UUID+ , rcBody :: [Op]+ }+ deriving (Show)++mkChunkVersion :: [Op] -> UUID+mkChunkVersion = maximumDef zero . map opEvent++mkRC :: UUID -> [Op] -> ReducedChunk+mkRC ref rcBody =+ ReducedChunk{rcVersion = mkChunkVersion rcBody, rcRef = ref, ..}++mkStateChunk :: [Op] -> StateChunk+mkStateChunk ops = StateChunk (mkChunkVersion ops) ops++data Patch a = Patch{patchRef :: UUID, patchValue :: a}++instance Semigroup a => Semigroup (Patch a) where+ Patch ref1 a1 <> Patch ref2 a2 = Patch (min ref1 ref2) (a1 <> a2)++patchFromRawOp :: Reducible a => Op -> Patch a+patchFromRawOp op@Op{..} = Patch+ { patchRef = opEvent+ , patchValue = stateFromChunk [op]+ }++patchFromChunk :: Reducible a => ReducedChunk -> Patch a+patchFromChunk ReducedChunk{..} =+ Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody}++patchToChunk :: Reducible a => Patch a -> ReducedChunk+patchToChunk Patch{..} = ReducedChunk{..} where+ rcRef = patchRef+ StateChunk rcVersion rcBody = stateToChunk patchValue++-- | Base class for typed encoding+class Replicated a where+ -- | Instances SHOULD implement 'encoding' either as 'objectEncoding' or as+ -- 'payloadEncoding'+ encoding :: Encoding a++data Encoding a = Encoding+ { encodingNewRon+ :: forall m . ReplicaClock m => a -> WriterT StateFrame m [Atom]+ , encodingFromRon :: [Atom] -> StateFrame -> Either String a+ }++-- | Encode typed data to a payload with possible addition objects+newRon :: (Replicated a, ReplicaClock m) => a -> WriterT StateFrame m [Atom]+newRon = encodingNewRon encoding++-- | Decode typed data from a payload.+-- The implementation may use other objects in the frame to resolve references.+fromRon :: Replicated a => [Atom] -> StateFrame -> Either String a+fromRon = encodingFromRon encoding++-- | Standard implementation of 'Replicated' for 'ReplicatedAsObject' types.+objectEncoding :: ReplicatedAsObject a => Encoding a+objectEncoding = Encoding+ { encodingNewRon = \a -> do+ Object oid frame <- lift $ newObject a+ tell frame+ pure [AUuid oid]+ , encodingFromRon = objectFromRon getObject+ }++-- | Standard implementation of 'Replicated' for 'ReplicatedAsPayload' types.+payloadEncoding :: ReplicatedAsPayload a => Encoding a+payloadEncoding = Encoding+ { encodingNewRon = pure . toPayload+ , encodingFromRon = \atoms _ -> fromPayload atoms+ }++-- | Instances of this class are encoded as payload only.+class ReplicatedAsPayload a where++ -- | Encode data+ toPayload :: a -> [Atom]++ -- | Decode data+ fromPayload :: [Atom] -> Either String a++instance Replicated Int64 where encoding = payloadEncoding++instance ReplicatedAsPayload Int64 where+ toPayload int = [AInteger int]+ fromPayload atoms = case atoms of+ [AInteger int] -> pure int+ _ -> Left "Int64: bad payload"++instance Replicated UUID where encoding = payloadEncoding++instance ReplicatedAsPayload UUID where+ toPayload u = [AUuid u]+ fromPayload atoms = case atoms of+ [AUuid u] -> pure u+ _ -> Left "UUID: bad payload"++instance Replicated Text where encoding = payloadEncoding++instance ReplicatedAsPayload Text where+ toPayload t = [AString t]+ fromPayload atoms = case atoms of+ [AString t] -> pure t+ _ -> Left "String: bad payload"++instance Replicated Char where encoding = payloadEncoding++instance ReplicatedAsPayload Char where+ toPayload c = [AString $ Text.singleton c]+ fromPayload atoms = case atoms of+ [AString s] -> case Text.uncons s of+ Just (c, "") -> pure c+ _ -> Left "too long string to encode a single character"+ _ -> Left "Char: bad payload"++-- | Instances of this class are encoded as objects.+-- An enclosing object's payload will be filled with this object's id.+class ReplicatedAsObject a where++ -- | UUID of the type+ objectOpType :: UUID++ -- | Encode data+ newObject :: ReplicaClock m => a -> m (Object a)++ -- | Decode data+ getObject :: Object a -> Either String a++objectFromRon+ :: (Object a -> Either String a) -> [Atom] -> StateFrame -> Either String a+objectFromRon handler atoms frame = case atoms of+ [AUuid oid] -> handler $ Object oid frame+ _ -> Left "bad payload"++-- | Helper to build an object frame using arbitrarily nested serializers.+collectFrame :: Functor m => WriterT StateFrame m UUID -> m (Object a)+collectFrame = fmap (uncurry Object) . runWriterT++getObjectStateChunk+ :: forall a . ReplicatedAsObject a => Object a -> Either String StateChunk+getObjectStateChunk (Object oid frame) =+ maybe (Left "no such object in chunk") Right $+ Map.lookup (objectOpType @a, oid) frame++eqRef :: Object a -> [Atom] -> Bool+eqRef (Object oid _) atoms = case atoms of+ [AUuid ref] -> oid == ref+ _ -> False++eqPayload :: ReplicatedAsPayload a => a -> [Atom] -> Bool+eqPayload a atoms = toPayload a == atoms++pattern None :: Atom+pattern None = AUuid (UUID 0xcb3ca9000000000 0)++pattern Some :: Atom+pattern Some = AUuid (UUID 0xdf3c69000000000 0)++instance Replicated a => Replicated (Maybe a) where+ encoding = Encoding+ { encodingNewRon = \case+ Just a -> (Some :) <$> newRon a+ Nothing -> pure [None]+ , encodingFromRon = \atoms frame -> case atoms of+ Some : atoms' -> Just <$> fromRon atoms' frame+ [None] -> pure Nothing+ _ -> Left "Bad Option"+ }++instance ReplicatedAsPayload a => ReplicatedAsPayload (Maybe a) where+ toPayload = \case+ Just a -> Some : toPayload a+ Nothing -> [None]+ fromPayload = \case+ Some : atoms -> Just <$> fromPayload atoms+ [None] -> pure Nothing+ _ -> Left "Bad Option"
+ lib/RON/Data/LWW.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | LWW-per-field RDT+module RON.Data.LWW+ ( LwwPerField (..)+ , assignField+ , lwwType+ , newObject+ , readField+ , viewField+ , zoomField+ ) where++import RON.Internal.Prelude++import Control.Error (fmapL)+import Control.Monad.Except (MonadError, liftEither)+import Control.Monad.State.Strict (MonadState, StateT, get, put,+ runStateT)+import Control.Monad.Writer.Strict (lift, runWriterT, tell)+import qualified Data.Map.Strict as Map++import RON.Data.Internal (Reducible, Replicated, ReplicatedAsObject,+ collectFrame, fromRon, getObjectStateChunk,+ mkStateChunk, newRon, objectOpType,+ reducibleOpType, stateFromChunk,+ stateToChunk)+import RON.Event (ReplicaClock, advanceToUuid, getEventUuid)+import RON.Types (Atom (AUuid), Object (..), Op (..), StateChunk (..),+ StateFrame, UUID)+import qualified RON.UUID as UUID++-- | Last-Write-Wins: select an op with latter event+lww :: Op -> Op -> Op+lww = maxOn opEvent++-- | Untyped LWW. Implementation: a map from 'opRef' to the original op.+newtype LwwPerField = LwwPerField (Map UUID Op)+ deriving (Eq, Monoid, Show)++instance Semigroup LwwPerField where+ LwwPerField fields1 <> LwwPerField fields2 =+ LwwPerField $ Map.unionWith lww fields1 fields2++instance Reducible LwwPerField where+ reducibleOpType = lwwType++ stateFromChunk ops =+ LwwPerField $ Map.fromListWith lww [(opRef op, op) | op <- ops]++ stateToChunk (LwwPerField fields) = mkStateChunk $ Map.elems fields++-- | Name-UUID to use as LWW type marker.+lwwType :: UUID+lwwType = fromJust $ UUID.mkName "lww"++-- | Create LWW object from a list of named fields.+newObject :: ReplicaClock m => [(UUID, I Replicated)] -> m (Object a)+newObject fields = collectFrame $ do+ payloads <- for fields $ \(_, I value) -> newRon value+ e <- lift getEventUuid+ tell $ Map.singleton (lwwType, e) $ StateChunk e+ [Op e name p | ((name, _), p) <- zip fields payloads]+ pure e++-- | Decode field value+viewField+ :: Replicated a+ => UUID -- ^ Field name+ -> StateChunk -- ^ LWW object chunk+ -> StateFrame+ -> Either String a+viewField field StateChunk{..} frame =+ fmapL (("LWW.viewField " <> show field <> ":\n") <>) $ do+ let ops = filter ((field ==) . opRef) stateBody+ Op{..} <- case ops of+ [] -> Left $ unwords ["no field", show field, "in lww chunk"]+ [op] -> pure op+ _ -> Left "unreduced state"+ fromRon opPayload frame++-- | Decode field value+readField+ :: ( MonadError String m+ , MonadState (Object a) m+ , ReplicatedAsObject a+ , Replicated b+ )+ => UUID -- ^ Field name+ -> m b+readField field = do+ obj@Object{..} <- get+ liftEither $ do+ stateChunk <- getObjectStateChunk obj+ viewField field stateChunk objectFrame++-- | Assign a value to a field+assignField+ :: forall a b m+ . ( ReplicatedAsObject a+ , Replicated b+ , ReplicaClock m, MonadError String m, MonadState (Object a) m+ )+ => UUID -- ^ Field name+ -> b -- ^ Value (from untyped world)+ -> m ()+assignField field value = do+ obj@Object{..} <- get+ StateChunk{..} <- liftEither $ getObjectStateChunk obj+ advanceToUuid stateVersion+ let chunk = filter ((field /=) . opRef) stateBody+ e <- getEventUuid+ (p, frame') <- runWriterT $ newRon value+ let newOp = Op e field p+ let chunk' = sortOn opRef $ newOp : chunk+ let state' = StateChunk e chunk'+ put Object+ { objectFrame =+ Map.insert (objectOpType @a, objectId) state' objectFrame <> frame'+ , ..+ }++-- | Anti-lens to an object inside a specified field+zoomField+ :: (ReplicatedAsObject outer, MonadError String m)+ => UUID -- ^ Field name+ -> StateT (Object inner) m a -- ^ Nested object modifier+ -> StateT (Object outer) m a+zoomField field innerModifier = do+ obj@Object{..} <- get+ StateChunk{..} <- liftEither $ getObjectStateChunk obj+ let ops = filter ((field ==) . opRef) stateBody+ Op{..} <- case ops of+ [] -> throwError $ unwords ["no field", show field, "in lww chunk"]+ [op] -> pure op+ _ -> throwError "unreduced state"+ innerObjectId <- case opPayload of+ [AUuid oid] -> pure oid+ _ -> throwError "bad payload"+ let innerObject = Object innerObjectId objectFrame+ (a, Object{objectFrame = objectFrame'}) <-+ lift $ runStateT innerModifier innerObject+ put Object{objectFrame = objectFrame', ..}+ pure a
+ lib/RON/Data/ORSet.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Observed-Remove Set (OR-Set)+module RON.Data.ORSet+ ( ORSet (..)+ , ObjectORSet (..)+ , ORSetRaw+ , addNewRef+ , addRef+ , addValue+ , removeRef+ , removeValue+ ) where++import RON.Internal.Prelude++import Control.Monad.Except (MonadError, liftEither)+import Control.Monad.State.Strict (StateT, get, modify, put)+import Control.Monad.Writer.Strict (lift, tell)+import qualified Data.Map.Strict as Map++import RON.Data.Internal+import RON.Event (ReplicaClock, getEventUuid)+import RON.Types (Atom, Object (..), Op (..), StateChunk (..), UUID)+import RON.UUID (pattern Zero)+import qualified RON.UUID as UUID++data SetItem = SetItem{itemIsAlive :: Bool, itemOriginalOp :: Op}+ deriving (Eq, Show)++instance Semigroup SetItem where+ (<>) = minOn itemIsAlive++itemFromOp :: Op -> (UUID, SetItem)+itemFromOp itemOriginalOp@Op{..} = (itemId, item) where+ itemIsAlive = opRef == Zero+ itemId = if itemIsAlive then opEvent else opRef+ item = SetItem{..}++-- | Untyped OR-Set.+-- Implementation:+-- a map from the last change (creation or deletion) to the original op.+newtype ORSetRaw = ORSetRaw (Map UUID SetItem)+ deriving (Eq, Show)++instance Semigroup ORSetRaw where+ ORSetRaw set1 <> ORSetRaw set2 = ORSetRaw $ Map.unionWith (<>) set1 set2++instance Monoid ORSetRaw where+ mempty = ORSetRaw mempty++instance Reducible ORSetRaw where+ reducibleOpType = setType++ stateFromChunk = ORSetRaw . Map.fromListWith (<>) . map itemFromOp++ stateToChunk (ORSetRaw set) =+ mkStateChunk . sortOn opEvent . map itemOriginalOp $ Map.elems set++-- | Name-UUID to use as OR-Set type marker.+setType :: UUID+setType = fromJust $ UUID.mkName "set"++-- | Type-directing wrapper for typed OR-Set of atomic values+newtype ORSet a = ORSet [a]++-- | Type-directing wrapper for typed OR-Set of objects+newtype ObjectORSet a = ObjectORSet [a]++instance ReplicatedAsPayload a => Replicated (ORSet a) where+ encoding = objectEncoding++instance ReplicatedAsPayload a => ReplicatedAsObject (ORSet a) where+ objectOpType = setType++ newObject (ORSet items) = collectFrame $ do+ ops <- for items $ \item -> do+ e <- lift getEventUuid+ pure $ Op e Zero $ toPayload item+ oid <- lift getEventUuid+ let version = maximumDef oid $ map opEvent ops+ tell $ Map.singleton (setType, oid) $ StateChunk version ops+ pure oid++ getObject obj@Object{..} = do+ StateChunk{..} <- getObjectStateChunk obj+ mItems <- for stateBody $ \Op{..} -> case opRef of+ Zero -> Just <$> fromPayload opPayload+ _ -> pure Nothing+ pure . ORSet $ catMaybes mItems++instance ReplicatedAsObject a => Replicated (ObjectORSet a) where+ encoding = objectEncoding++instance ReplicatedAsObject a => ReplicatedAsObject (ObjectORSet a) where+ objectOpType = setType++ newObject (ObjectORSet items) = collectFrame $ do+ ops <- for items $ \item -> do+ e <- lift getEventUuid+ Object{objectId = itemId} <- lift $ newObject item+ pure . Op e Zero $ toPayload itemId+ oid <- lift getEventUuid+ let version = maximumDef oid $ map opEvent ops+ tell . Map.singleton (setType, oid) $ StateChunk version ops+ pure oid++ getObject obj@Object{..} = do+ StateChunk{..} <- getObjectStateChunk obj+ mItems <- for stateBody $ \Op{..} -> case opRef of+ Zero -> do+ oid <- fromPayload opPayload+ Just <$> getObject (Object oid objectFrame)+ _ -> pure Nothing+ pure . ObjectORSet $ catMaybes mItems++-- | XXX Internal. Common implementation of 'addValue' and 'addRef'.+add :: ( ReplicatedAsObject a+ , ReplicatedAsPayload b+ , ReplicaClock m, MonadError String m+ )+ => b -> StateT (Object a) m ()+add item = do+ obj@Object{..} <- get+ StateChunk{..} <- liftEither $ getObjectStateChunk obj+ e <- getEventUuid+ let p = toPayload item+ let newOp = Op e Zero p+ let chunk' = stateBody ++ [newOp]+ let state' = StateChunk e chunk'+ put Object+ {objectFrame = Map.insert (setType, objectId) state' objectFrame, ..}++-- | Add atomic value to the OR-Set+addValue+ :: (ReplicatedAsPayload a, ReplicaClock m, MonadError String m)+ => a -> StateT (Object (ORSet a)) m ()+addValue = add++-- | Add a reference to the object to the OR-Set+addRef+ :: (ReplicatedAsObject a, ReplicaClock m, MonadError String m)+ => Object a -> StateT (Object (ObjectORSet a)) m ()+addRef = add . objectId++-- | Encode an object and add a reference to it to the OR-Set+addNewRef+ :: forall a m+ . (ReplicatedAsObject a, ReplicaClock m, MonadError String m)+ => a -> StateT (Object (ObjectORSet a)) m ()+addNewRef item = do+ itemObj@(Object _ itemFrame) <- lift $ newObject item+ modify $ \Object{..} -> Object{objectFrame = objectFrame <> itemFrame, ..}+ addRef itemObj++removeBy :: ([Atom] -> Bool) -> StateT (Object (ORSet a)) m ()+removeBy = undefined++-- | Remove an atomic value from the OR-Set+removeValue :: ReplicatedAsPayload a => a -> StateT (Object (ORSet a)) m ()+removeValue = removeBy . eqPayload++-- | Remove an object reference from the OR-Set+removeRef :: Object a -> StateT (Object (ORSet a)) m ()+removeRef = removeBy . eqRef
+ lib/RON/Data/RGA.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}++-- | Replicated Growable Array (RGA)+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 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)+import RON.Internal.Word (pattern B11)+import RON.Types (Object (..), Op (..), StateChunk (..), UUID)+import RON.UUID (pattern Zero, uuidScheme)+import qualified RON.UUID as UUID++-- | opEvent = vertex id+-- opRef:+-- 0 = value is alive,+-- _ = tombstone event, value is backup for undo+-- opPayload: the value+-- TODO record pattern synonyms+newtype Vertex = Vertex Op+ deriving (Eq, Show)++unVertex :: Vertex -> Op+unVertex (Vertex op) = op++data VertexListItem = VertexListItem+ { itemValue :: Vertex+ , itemNext :: Maybe UUID+ }+ deriving (Eq, Show)++-- | TODO(2018-11-07, cblp) MonoFoldable?+data VertexList = VertexList+ { listHead :: UUID+ , listItems :: HashMap UUID VertexListItem+ }+ deriving (Eq, Show)++instance Semigroup VertexList where+ (<>) = merge++vertexListToList :: Maybe VertexList -> [Vertex]+vertexListToList 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++vertexListToOps :: Maybe VertexList -> [Op]+vertexListToOps = map unVertex . vertexListToList++vertexListFromList :: [Vertex] -> Maybe VertexList+vertexListFromList = foldr go mempty where+ go v@(Vertex 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++vertexListFromOps :: [Op] -> Maybe VertexList+vertexListFromOps = vertexListFromList . map Vertex++-- | Untyped RGA+newtype RgaRaw = RgaRaw (Maybe VertexList)+ deriving (Eq, Monoid, Semigroup, Show)++data PatchSet = PatchSet+ { psPatches :: Map UUID VertexList+ -- ^ the key is the parent event, the value is a non-empty VertexList+ , psRemovals :: Map UUID UUID+ -- ^ the key is the target event, the value is the tombstone event+ }+ 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+ [] -> -- remove op+ mempty{psRemovals = Map.singleton opRef opEvent}+ _:_ -> -- append op+ mempty+ { psPatches =+ Map.singleton+ opRef+ VertexList+ { listHead = opEvent+ , listItems =+ HashMap.singleton+ opEvent+ VertexListItem+ { itemValue = Vertex op{opRef = Zero}+ , itemNext = Nothing+ }+ }+ }++patchSetFromChunk :: ReducedChunk -> PatchSet+patchSetFromChunk ReducedChunk{rcRef, rcBody} =+ case uuidScheme $ UUID.split rcRef of+ B11 ->+ -- derived event -- rm-patch compatibility+ foldMap patchSetFromRawOp rcBody+ _ -> -- patch+ 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+ -- state is empty => only virtual 0 node exists+ -- => we can apply only 0 patch+ 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 = Vertex v@Op{opRef}} <-+ HashMap.lookup parent targetItems+ let item' = item{itemValue = Vertex v{opRef = max opRef tombstone}}+ pure $ HashMap.insert parent item' targetItems++merge :: VertexList -> VertexList -> VertexList+merge v1 v2 =+ fromMaybe undefined . vertexListFromList $+ (merge' `on` vertexListToList . 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+ Vertex Op{opEvent = e1, opRef = tombstone1, opPayload = p1} = v1+ Vertex Op{opEvent = e2, opRef = tombstone2, opPayload = p2} = v2++ -- priority of deletion+ mergeVertices = Vertex Op+ { opEvent = e1+ , opRef = max tombstone1 tombstone2+ , opPayload = maxOn length p1 p2+ }++-- | Name-UUID to use as RGA type marker.+rgaType :: UUID+rgaType = fromJust $ UUID.mkName "rga"++-- | Typed 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+ ops <- for items $ \item -> do+ vertexId <- lift getEventUuid+ 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++-- | Replace content of the RGA throug introducing changes detected by+-- 'getGroupedDiffBy'.+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 -- not deleted yet+ -- TODO(2018-11-03, #15, cblp) get sequential ids+ tombstone <- lift getEventUuid+ tell . Last $ Just tombstone+ pure op{opRef = tombstone}+ op -> -- deleted already+ pure op+ Both v _ -> pure v+ Second added -> for added $ \op -> do+ -- TODO(2018-11-03, #15, cblp) get sequential ids+ 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+ , ..+ }++-- | Speciaization of 'edit' for 'Text'+editText+ :: (ReplicaClock m, MonadError String m, MonadState (Object RgaString) m)+ => Text -> m ()+editText = edit . Text.unpack++-- | Speciaization of 'RGA' to 'Char'.+-- This is the recommended way to store a string.+type RgaString = RGA Char++-- | Create an RGA from a list+newFromList :: (Replicated a, ReplicaClock m) => [a] -> m (Object (RGA a))+newFromList = newObject . RGA++-- | Create an 'RgaString' from a text+newFromText :: ReplicaClock m => Text -> m (Object RgaString)+newFromText = newFromList . Text.unpack++-- | Read elements from RGA+getList :: Replicated a => Object (RGA a) -> Either String [a]+getList = coerce . getObject++-- | Read characters from 'RgaString'+getText :: Object RgaString -> Either String Text+getText = fmap Text.pack . getList
+ lib/RON/Data/Time.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS -Wno-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | 'Day' instances+module RON.Data.Time (Day, day) where++import Data.Time (Day, fromGregorian, toGregorian)++import RON.Data (Replicated (..), ReplicatedAsPayload (..),+ payloadEncoding)+import RON.Schema (OpaqueAnnotations (..), RonType, def, opaqueAtoms)+import RON.Types (Atom (..))++instance Replicated Day where encoding = payloadEncoding++instance ReplicatedAsPayload Day where+ toPayload+ = (\(y, m, d) ->+ map AInteger [fromIntegral y, fromIntegral m, fromIntegral d])+ . toGregorian++ fromPayload = \case+ [AInteger y, AInteger m, AInteger d] -> pure $+ fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)+ _ -> Left "bad Day"++-- | RON-Schema type for 'Day'+day :: RonType+day = opaqueAtoms def{oaHaskellType = Just "Day"}
+ lib/RON/Data/VersionVector.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Version Vector+module RON.Data.VersionVector+ ( VersionVector+ ) where++import RON.Internal.Prelude++import Control.Monad.Writer.Strict (lift, tell)+import qualified Data.Map.Strict as Map++import RON.Data.Internal+import RON.Event (getEventUuid)+import RON.Types (Op (..), StateChunk (..), UUID (UUID))+import qualified RON.UUID as UUID++type Origin = Word64++opTime :: Op -> Word64+opTime Op{opEvent = UUID time _} = time++opOrigin :: Op -> Word64+opOrigin Op{opEvent = UUID _ origin} = origin++latter :: Op -> Op -> Op+latter = maxOn opTime++-- | Version Vector type. May be used both in typed and untyped contexts.+newtype VersionVector = VersionVector (Map Origin Op)+ deriving (Eq, Show)++instance Hashable VersionVector where+ hashWithSalt s (VersionVector vv) = hashWithSalt s $ Map.assocs vv++instance Semigroup VersionVector where+ (<>) = coerce $ Map.unionWith latter++instance Monoid VersionVector where+ mempty = VersionVector mempty++instance Reducible VersionVector where+ reducibleOpType = vvType++ stateFromChunk ops =+ VersionVector $ Map.fromListWith latter [(opOrigin op, op) | op <- ops]++ stateToChunk (VersionVector vv) = mkStateChunk $ Map.elems vv++-- | Name-UUID to use as Version Vector type marker.+vvType :: UUID+vvType = fromJust $ UUID.mkName "vv"++instance Replicated VersionVector where+ encoding = objectEncoding++instance ReplicatedAsObject VersionVector where+ objectOpType = vvType++ newObject (VersionVector vv) = collectFrame $ do+ oid <- lift getEventUuid+ let ops = Map.elems vv+ let version = maximumDef oid $ map opEvent ops+ tell $ Map.singleton (vvType, oid) $ StateChunk version ops+ pure oid++ getObject obj = do+ StateChunk{..} <- getObjectStateChunk obj+ pure $ stateFromChunk stateBody
+ lib/RON/Epoch.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}++module RON.Epoch (+ EpochClock,+ getCurrentEpochTime,+ localEpochTimeFromUnix,+ runEpochClock,+ runEpochClockFromCurrentTime,+) where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ReaderT (ReaderT), reader, runReaderT)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Word (Word64)++import RON.Event (EpochEvent (EpochEvent), EpochTime,+ LocalTime (TEpoch), ReplicaClock, ReplicaId,+ advance, getEvents, getPid)+import RON.Internal.Word (leastSignificant60, ls60, word60add)++-- | Real epoch clock.+-- Uses kind of global variable to ensure strict monotonicity.+newtype EpochClock a = EpochClock (ReaderT (ReplicaId, IORef EpochTime) IO a)+ deriving (Applicative, Functor, Monad, MonadIO)++instance ReplicaClock EpochClock where+ getPid = EpochClock $ reader fst++ advance time = EpochClock $ ReaderT $ \(_pid, timeVar) ->+ atomicModifyIORef' timeVar $ \t0 -> (max time t0, ())++ getEvents n0 = EpochClock $ ReaderT $ \(pid, timeVar) -> do+ let n = max n0 $ ls60 1+ realTime <- getCurrentEpochTime+ timeRangeStart <- atomicModifyIORef' timeVar $ \timeCur ->+ let timeRangeStart = max realTime $ succ timeCur+ in (timeRangeStart `word60add` pred n, timeRangeStart)+ pure+ [ EpochEvent t pid+ | t <- [timeRangeStart .. timeRangeStart `word60add` pred n]+ ]++-- | Run 'EpochClock' action with explicit time variable.+runEpochClock :: ReplicaId -> IORef EpochTime -> EpochClock a -> IO a+runEpochClock replicaId timeVar (EpochClock action) =+ runReaderT action (replicaId, timeVar)++-- | Like 'runEpochClock', but initialize time variable with current wall time.+runEpochClockFromCurrentTime :: ReplicaId -> EpochClock a -> IO a+runEpochClockFromCurrentTime replicaId clock = do+ time <- getCurrentEpochTime+ timeVar <- newIORef time+ runEpochClock replicaId timeVar clock++-- | Get current time in 'EpochTime' format (with 100 ns resolution).+-- Monotonicity is not guaranteed.+getCurrentEpochTime :: IO EpochTime+getCurrentEpochTime+ = epochTimeFromUnix @Word64+ . round+ . (* 10000000)+ <$> getPOSIXTime++-- | Convert unix time in hundreds of milliseconds to RFC 4122 time.+epochTimeFromUnix :: Integral int => int -> EpochTime+epochTimeFromUnix+ = leastSignificant60+ . (+ 0x01B21DD213814000)+ -- the difference between Unix epoch and UUID epoch;+ -- the constant is taken from RFC 4122++-- | Convert unix time in hundreds of milliseconds to RFC 4122 time.+localEpochTimeFromUnix :: Integral int => int -> LocalTime+localEpochTimeFromUnix = TEpoch . epochTimeFromUnix
+ lib/RON/Event.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}++module RON.Event+ ( CalendarTime (..)+ , CalendarEvent (..)+ , EpochEvent (..)+ , EpochTime+ , Event (..)+ , LocalTime (..)+ , Naming (..)+ , ReplicaClock (..)+ , ReplicaId (..)+ , advanceToUuid+ , applicationSpecific+ , decodeEvent+ , encodeEvent+ , fromCalendarEvent+ , fromEpochEvent+ , getEvent+ , getEventUuid+ , getEventUuids+ , mkCalendarDate+ , mkCalendarDateTime+ , mkCalendarDateTimeNano+ , toEpochEvent+ ) where++import Control.Monad.Except (ExceptT, lift)+import Control.Monad.State.Strict (StateT)+import Data.Bits (shiftL, shiftR, (.|.))+import Data.Hashable (Hashable, hashUsing, hashWithSalt)++import RON.Internal.Word (pattern B00, pattern B01, pattern B10,+ pattern B11, Word12, Word16, Word2, Word24,+ Word32, Word6, Word60, Word64, Word8,+ leastSignificant12, leastSignificant2,+ leastSignificant24, leastSignificant4,+ leastSignificant6, ls12, ls24, ls6, ls60,+ safeCast)+import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin,+ uuidScheme, uuidValue, uuidVariant, uuidVariety)+import qualified RON.UUID as UUID++-- | Calendar format. See https://github.com/gritzko/ron/issues/19.+-- Year range is 2010—2350.+-- Precision is 100 ns.+data CalendarTime = CalendarTime+ { months :: Word12+ , days :: Word6+ , hours :: Word6+ , minutes :: Word6+ , seconds :: Word6+ , nanosecHundreds :: Word24+ }+ deriving (Eq, Ord, Show)++-- | RFC 4122 epoch, hundreds of nanoseconds since 1582.+-- Year range is 1582—5235.+type EpochTime = Word60++-- | Clock type is encoded in 2 higher bits of variety, value in uuidValue+data LocalTime+ = TCalendar !CalendarTime+ | TLogical !Word60+ -- ^ https://en.wikipedia.org/wiki/Logical_clock+ | TEpoch !EpochTime+ | TUnknown !Word60+ deriving (Eq, Show)++-- | Replica id assignment style+data Naming+ = TrieForked+ | CryptoForked+ | RecordForked+ | ApplicationSpecific+ deriving (Bounded, Enum, Eq, Show)++instance Hashable Naming where+ hashWithSalt = hashUsing fromEnum++-- | Replica identifier+data ReplicaId = ReplicaId !Naming !Word60+ deriving (Eq, Show)++instance Hashable ReplicaId where+ hashWithSalt = hashUsing $ \(ReplicaId n r) -> (n, r)++-- | Generic Lamport time event.+-- Cannot be 'Ord' because we can't compare different types of clocks.+-- If you want comparable events, use specific 'EpochEvent'.+data Event = Event !LocalTime !ReplicaId+ deriving (Eq, Show)++-- | Calendar-based Lamport time event, specific case of 'Event'.+data CalendarEvent = CalendarEvent !CalendarTime !ReplicaId+ deriving (Eq, Show)++instance Ord CalendarEvent where+ compare (CalendarEvent t1 (ReplicaId n1 r1))+ (CalendarEvent t2 (ReplicaId n2 r2))+ = compare+ (t1, fromEnum n1, r1)+ (t2, fromEnum n2, r2)++fromCalendarEvent :: CalendarEvent -> Event+fromCalendarEvent (CalendarEvent t r) = Event (TCalendar t) r++-- | Epoch-based Lamport time event, specific case of 'Event'.+data EpochEvent = EpochEvent !EpochTime !ReplicaId+ deriving (Eq, Show)++instance Ord EpochEvent where+ compare (EpochEvent t1 (ReplicaId n1 r1))+ (EpochEvent t2 (ReplicaId n2 r2))+ = compare+ (t1, fromEnum n1, r1)+ (t2, fromEnum n2, r2)++fromEpochEvent :: EpochEvent -> Event+fromEpochEvent (EpochEvent t r) = Event (TEpoch t) r++toEpochEvent :: Event -> Maybe EpochEvent+toEpochEvent (Event t r) = case t of+ TEpoch t' -> Just $ EpochEvent t' r+ _ -> Nothing++class Monad m => ReplicaClock m where++ -- | Get current replica id+ getPid :: m ReplicaId++ -- | Get sequential timestamps.+ --+ -- Laws:+ --+ -- 1. @+ --t <- getEvents n+ --(t !! i) == head t + i+ -- @+ --+ -- 2. @+ --t1 <- 'getEvent'+ --t2 <- 'getEvent'+ --t2 >= t1 + 1+ -- @+ --+ -- 3. @getEvents 0 == getEvents 1@+ getEvents+ :: EpochTime -- ^ number of needed timestamps+ -> m [EpochEvent]++ -- | Make local time not less than this+ advance :: EpochTime -> m ()++instance ReplicaClock m => ReplicaClock (ExceptT e m) where+ getPid = lift getPid+ getEvents = lift . getEvents+ advance = lift . advance++instance ReplicaClock m => ReplicaClock (StateT s m) where+ getPid = lift getPid+ getEvents = lift . getEvents+ advance = lift . advance++-- | 'advance' variant for any UUID+advanceToUuid :: ReplicaClock clock => UUID -> clock ()+advanceToUuid = advance . uuidValue . UUID.split++-- | Get a single event+getEvent :: ReplicaClock m => m EpochEvent+getEvent = head <$> getEvents (ls60 1)++-- | Get a single event as UUID+getEventUuid :: ReplicaClock m => m UUID+getEventUuid = encodeEvent . fromEpochEvent <$> getEvent++-- | Get event sequence as UUIDs+getEventUuids :: ReplicaClock m => Word60 -> m [UUID]+getEventUuids = fmap (map $ encodeEvent . fromEpochEvent) . getEvents++encodeCalendar :: CalendarTime -> Word60+encodeCalendar CalendarTime{..} = ls60 $+ (safeCast months `shiftL` 48) .|.+ (safeCast days `shiftL` 42) .|.+ (safeCast hours `shiftL` 36) .|.+ (safeCast minutes `shiftL` 30) .|.+ (safeCast seconds `shiftL` 24) .|.+ safeCast nanosecHundreds++decodeCalendar :: Word60 -> CalendarTime+decodeCalendar w = CalendarTime+ { months = leastSignificant12 $ v `shiftR` 48+ , days = leastSignificant6 $ v `shiftR` 42+ , hours = leastSignificant6 $ v `shiftR` 36+ , minutes = leastSignificant6 $ v `shiftR` 30+ , seconds = leastSignificant6 $ v `shiftR` 24+ , nanosecHundreds = leastSignificant24 v+ }+ where+ v = safeCast w :: Word64++encodeLocalTime :: LocalTime -> (Word2, Word60)+encodeLocalTime = \case+ TCalendar t -> (B00, encodeCalendar t)+ TLogical t -> (B01, t)+ TEpoch t -> (B10, t)+ TUnknown t -> (B11, t)++decodeLocalTime :: Word2 -> Word60 -> LocalTime+decodeLocalTime = \case+ B00 -> TCalendar . decodeCalendar+ B01 -> TLogical+ B10 -> TEpoch+ B11 -> TUnknown++encodeEvent :: Event -> UUID+encodeEvent (Event time replicaId) = UUID.build UuidFields+ { uuidVariety+ , uuidValue+ , uuidVariant = B00+ , uuidScheme = B10+ , uuidOrigin+ }+ where+ (varietyMS2, uuidValue) = encodeLocalTime time+ (varietyLS2, uuidOrigin) = encodeReplicaId replicaId+ uuidVariety = leastSignificant4 $+ ((safeCast varietyMS2 :: Word8) `shiftL` 2) .|.+ ( safeCast varietyLS2 :: Word8)++decodeEvent :: UUID -> Event+decodeEvent uuid = Event+ (decodeLocalTime+ (leastSignificant2 (safeCast uuidVariety `shiftR` 2 :: Word8))+ uuidValue)+ (decodeReplicaId+ (leastSignificant2 (safeCast uuidVariety :: Word8)) uuidOrigin)+ where+ UuidFields{uuidVariety, uuidValue, uuidOrigin} = UUID.split uuid++decodeReplicaId :: Word2 -> Word60 -> ReplicaId+decodeReplicaId varietyLS2 = ReplicaId $ toEnum $ safeCast varietyLS2++encodeReplicaId :: ReplicaId -> (Word2, Word60)+encodeReplicaId (ReplicaId naming origin) =+ ( leastSignificant2 $ fromEnum naming+ , origin+ )++-- | Make a calendar timestamp from a date+mkCalendarDate+ :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..])+ -> Maybe CalendarTime+mkCalendarDate ymd = mkCalendarDateTime ymd (0, 0, 0)++-- | Make a calendar timestamp from a date and a day time+mkCalendarDateTime+ :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..])+ -> (Word8, Word8, Word8) -- ^ day time as (hours, minutes, seconds)+ -> Maybe CalendarTime+mkCalendarDateTime ymd hms = mkCalendarDateTimeNano ymd hms 0++-- | Make a calendar timestamp from a date, a day time, and a second fraction+mkCalendarDateTimeNano+ :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..])+ -> (Word8, Word8, Word8) -- ^ day time as (hours, minutes, seconds)+ -> Word32 -- ^ fraction of a second in hundreds of+ -- nanosecond+ -> Maybe CalendarTime+mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) ns =+ -- TODO(2018-08-19, cblp) check bounds+ pure CalendarTime+ { months = ls12 $ (y - 2010) * 12 + m - 1+ , days = ls6 $ d - 1+ , hours = ls6 hh+ , minutes = ls6 mm+ , seconds = ls6 ss+ , nanosecHundreds = ls24 ns+ }++-- | Make an 'ApplicationSpecific' replica id from arbitrary number+applicationSpecific :: Word64 -> ReplicaId+applicationSpecific = ReplicaId ApplicationSpecific . ls60
+ lib/RON/Event/Simulation.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++-- | Lamport clock network simulation.+-- 'ReplicaSim' provides 'Replica' and 'Clock' instances,+-- replicas may interchange data while they are connected in a 'NetworkSim'.+module RON.Event.Simulation+ ( NetworkSim+ , NetworkSimT+ , ReplicaSim+ , ReplicaSimT+ , runNetworkSim+ , runNetworkSimT+ , runReplicaSim+ , runReplicaSimT+ ) where++import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State.Strict (StateT, evalState, evalStateT,+ modify, state)+import Control.Monad.Trans (MonadTrans, lift)+import Data.Functor.Identity (Identity)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe)++import RON.Event (EpochEvent (EpochEvent), ReplicaClock, ReplicaId,+ advance, getEvents, getPid)+import RON.Internal.Word (Word60, Word64, ls60, word60add)++-- | Lamport clock simulation. Key is 'ReplicaId'.+-- Non-present value is equivalent to (0, initial).+newtype NetworkSimT m a = NetworkSim (StateT (HashMap ReplicaId Word60) m a)+ deriving (Applicative, Functor, Monad)++instance MonadTrans NetworkSimT where+ lift = NetworkSim . lift++type NetworkSim = NetworkSimT Identity++-- | ReplicaSim inside Lamport clock simulation.+newtype ReplicaSimT m a = ReplicaSim (ReaderT ReplicaId (NetworkSimT m) a)+ deriving (Applicative, Functor, Monad)++type ReplicaSim = ReplicaSimT Identity++instance MonadTrans ReplicaSimT where+ lift = ReplicaSim . lift . lift++instance Monad m => ReplicaClock (ReplicaSimT m) where+ getPid = ReplicaSim ask++ getEvents n' = ReplicaSim $ do+ rid <- ask+ t0 <- lift $ preIncreaseTime rid+ pure [EpochEvent t rid | t <- [t0 .. t0 `word60add` n]]+ where+ n = max n' (ls60 (1 :: Word64))++ advance time = ReplicaSim $ do+ rid <- ask+ lift . NetworkSim . modify $ HM.alter (Just . advancePS) rid+ where+ advancePS = \case+ Nothing -> time+ Just current -> max time current++-- | Execute network simulation+--+-- Usage:+--+-- @+-- runNetworkSim $ do+-- 'runReplicaSim' r1 $ do+-- actions...+-- 'runReplicaSim' r2 $ do+-- actions...+-- 'runReplicaSim' r1 $ ...+-- @+--+-- Each 'runNetworkSim' starts its own networks.+-- One shouldn't use in one network events generated in another.+runNetworkSim :: NetworkSim a -> a+runNetworkSim (NetworkSim action) = evalState action mempty++runNetworkSimT :: Monad m => NetworkSimT m a -> m a+runNetworkSimT (NetworkSim action) = evalStateT action mempty++runReplicaSim :: ReplicaId -> ReplicaSim a -> NetworkSim a+runReplicaSim rid (ReplicaSim action) = runReaderT action rid++runReplicaSimT :: ReplicaId -> ReplicaSimT m a -> NetworkSimT m a+runReplicaSimT rid (ReplicaSim action) = runReaderT action rid++-- | Increase time by rid and return new value+preIncreaseTime :: Monad m => ReplicaId -> NetworkSimT m Word60+preIncreaseTime rid = NetworkSim $ state $ \pss ->+ let time = succ $ fromMaybe (ls60 0) $ HM.lookup rid pss+ in (time, HM.insert rid time pss)
+ lib/RON/Internal/Prelude.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}++module RON.Internal.Prelude+ ( module RON.Internal.Prelude+ , module X+ ) where++import Control.Applicative as X+import Control.Monad as X+import Control.Monad.Except as X (throwError)+import Data.ByteString as X (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Coerce as X+import Data.Either as X+import Data.Foldable as X+import Data.Function as X+import Data.Functor as X+import Data.Functor.Identity as X+import Data.Hashable as X (Hashable, hashWithSalt)+import Data.HashMap.Strict as X (HashMap)+import Data.HashSet as X (HashSet)+import Data.Int as X (Int16, Int32, Int64, Int8)+import Data.List as X (foldl', partition, sort, sortBy, sortOn)+import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)+import Data.Map.Strict as X (Map)+import Data.Maybe as X+import Data.Proxy as X+import Data.Semigroup as X (sconcat, (<>))+import Data.Set as X (Set)+import Data.Text as X (Text)+import Data.Traversable as X+import Data.Tuple.Extra as X+import Data.Vector as X (Vector)+import Data.Word as X (Word16, Word32, Word64, Word8)+import GHC.Generics as X+import GHC.TypeLits as X+import Safe.Foldable as X++type ByteStringL = BSL.ByteString++maxOn :: Ord b => (a -> b) -> a -> a -> a+maxOn f x y = if f x < f y then y else x++minOn :: Ord b => (a -> b) -> a -> a -> a+minOn f x y = if f x < f y then x else y++newtype MaxOnFst a b = MaxOnFst (a, b)++instance Ord a => Semigroup (MaxOnFst a b) where+ mof1@(MaxOnFst (a1, _)) <> mof2@(MaxOnFst (a2, _))+ | a1 < a2 = mof2+ | otherwise = mof1++listSingleton :: a -> [a]+listSingleton a = [a]++-- | Instance+data I c = forall a . c a => I a++(-:) :: a -> b -> (a, b)+a -: b = (a, b)+infixr 0 -:
+ lib/RON/Internal/Word.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}++module RON.Internal.Word+ (+ -- * Word2+ Word2+ , b00, b01, b10, b11+ , pattern B00, pattern B01, pattern B10, pattern B11+ , leastSignificant2+ -- * Word4+ , Word4+ , b0000, b0001, b0010, b0011, b0100, b0101, b0110, b0111+ , b1000, b1001, b1010, b1011, b1100, b1101, b1110, b1111+ , pattern B0000+ , leastSignificant4+ -- * Word6+ , Word6 (..)+ , leastSignificant6+ , ls6+ -- * Word8+ , Word8+ -- * Word12+ , Word12+ , leastSignificant12+ , ls12+ -- * Word16+ , Word16+ -- * Word24+ , Word24+ , leastSignificant24+ , ls24+ -- * Word32+ , Word32+ -- * Word60+ , Word60+ , leastSignificant60+ , ls60+ , toWord60+ , word60add+ -- * Word64+ , Word64+ -- * SafeCast+ , SafeCast (..)+ ) where++import Data.Bits ((.&.))+import Data.Coerce (coerce)+import Data.Fixed (Fixed, HasResolution)+import Data.Hashable (Hashable, hashUsing, hashWithSalt)+import Data.Word (Word16, Word32, Word64, Word8)++newtype Word2 = W2 Word8+ deriving (Eq, Ord, Show)++b00, b01, b10, b11 :: Word2+b00 = W2 0b00+b01 = W2 0b01+b10 = W2 0b10+b11 = W2 0b11++pattern B00 :: Word2+pattern B00 = W2 0b00+pattern B01 :: Word2+pattern B01 = W2 0b01+pattern B10 :: Word2+pattern B10 = W2 0b10+pattern B11 :: Word2+pattern B11 = W2 0b11+{-# COMPLETE B00, B01, B10, B11 #-}++-- | 'Word2' smart constructor dropping upper bits+leastSignificant2 :: Integral integral => integral -> Word2+leastSignificant2 = W2 . (0b11 .&.) . fromIntegral++newtype Word4 = W4 Word8+ deriving (Eq, Ord, Show)++b0000, b0001, b0010, b0011, b0100, b0101, b0110, b0111 :: Word4+b1000, b1001, b1010, b1011, b1100, b1101, b1110, b1111 :: Word4+b0000 = W4 0b0000+b0001 = W4 0b0001+b0010 = W4 0b0010+b0011 = W4 0b0011+b0100 = W4 0b0100+b0101 = W4 0b0101+b0110 = W4 0b0110+b0111 = W4 0b0111+b1000 = W4 0b1000+b1001 = W4 0b1001+b1010 = W4 0b1010+b1011 = W4 0b1011+b1100 = W4 0b1100+b1101 = W4 0b1101+b1110 = W4 0b1110+b1111 = W4 0b1111++pattern B0000 :: Word4+pattern B0000 = W4 0b0000++-- | 'Word4' smart constructor dropping upper bits+leastSignificant4 :: Integral integral => integral -> Word4+leastSignificant4 = W4 . (0xF .&.) . fromIntegral++newtype Word6 = W6 Word8+ deriving (Eq, Ord, Show)++-- | 'Word6' smart constructor dropping upper bits+leastSignificant6 :: Integral integral => integral -> Word6+leastSignificant6 = W6 . (0x3F .&.) . fromIntegral++-- | 'leastSignificant6' specialized for 'Word8'+ls6 :: Word8 -> Word6+ls6 = W6 . (0x3F .&.)++newtype Word12 = W12 Word16+ deriving (Eq, Ord, Show)++-- | 'Word12' smart constructor dropping upper bits+leastSignificant12 :: Integral integral => integral -> Word12+leastSignificant12 = W12 . (0xFFF .&.) . fromIntegral++-- | 'leastSignificant12' specialized for 'Word16'+ls12 :: Word16 -> Word12+ls12 = W12 . (0xFFF .&.)++newtype Word24 = W24 Word32+ deriving (Eq, Ord, Show)++-- | 'Word24' smart constructor dropping upper bits+leastSignificant24 :: Integral integral => integral -> Word24+leastSignificant24 = W24 . (0xFFFFFF .&.) . fromIntegral++-- | 'leastSignificant24' specialized for 'Word32'+ls24 :: Word32 -> Word24+ls24 = W24 . (0xFFF .&.)++newtype Word60 = W60 Word64+ deriving (Enum, Eq, Ord, Show)++instance Bounded Word60 where+ minBound = W60 0+ maxBound = W60 0xFFFFFFFFFFFFFFF++instance Hashable Word60 where+ hashWithSalt = hashUsing @Word64 coerce++-- | 'Word60' smart constructor dropping upper bits+leastSignificant60 :: Integral integral => integral -> Word60+leastSignificant60 = W60 . (0xFFFFFFFFFFFFFFF .&.) . fromIntegral++-- | 'leastSignificant60' specialized for 'Word64'+ls60 :: Word64 -> Word60+ls60 = W60 . (0xFFFFFFFFFFFFFFF .&.)++-- | 'Word60' smart constructor checking domain+toWord60 :: Word64 -> Maybe Word60+toWord60 w+ | w < 0x1000000000000000 = Just $ W60 w+ | otherwise = Nothing++word60add :: Word60 -> Word60 -> Word60+word60add (W60 a) (W60 b) = leastSignificant60 $ a + b++class SafeCast v w where+ safeCast :: v -> w++instance SafeCast Word2 Int where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word2 Word4 where safeCast = coerce+instance SafeCast Word2 Word8 where safeCast = coerce+instance SafeCast Word2 Word64 where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word4 Int where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word4 Word64 where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word4 Word8 where safeCast = coerce+instance SafeCast Word6 Int where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word6 Word8 where safeCast = coerce+instance SafeCast Word6 Word60 where safeCast = coerce @Word64+ . fromIntegral @Word8 . coerce+instance SafeCast Word6 Word64 where safeCast = fromIntegral @Word8 . coerce+instance SafeCast Word8 Word32 where safeCast = fromIntegral+instance SafeCast Word8 Word64 where safeCast = fromIntegral+instance SafeCast Word12 Word64 where safeCast = fromIntegral @Word16 . coerce+instance SafeCast Word24 Word64 where safeCast = fromIntegral @Word32 . coerce+instance SafeCast Word24 Word32 where safeCast = coerce+instance SafeCast Word60 Word64 where safeCast = coerce+instance SafeCast Word64 Integer where safeCast = fromIntegral++-- Fixed are Integers inside, so have arbitrary magnitude+instance HasResolution e => SafeCast Word64 (Fixed e) where+ safeCast = fromIntegral
+ lib/RON/Schema.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module RON.Schema+ ( Declaration (..)+ , Field (..)+ , FieldAnnotations (..)+ , OpaqueAnnotations (..)+ , RonType (..)+ , Schema+ , StructAnnotations (..)+ , StructLww (..)+ , TAtom (..)+ , TComposite (..)+ , TObject (..)+ , TOpaque (..)+ , atomInteger+ , atomString+ , char+ , def+ , field+ , opaqueAtoms+ , opaqueObject+ , option+ , orSet+ , rgaString+ , structLww+ , versionVector+ ) where++import RON.Internal.Prelude++import Data.Default (Default, def)++data TAtom = TAInteger | TAString+ deriving (Show)++data RonType+ = TAtom TAtom+ | TComposite TComposite+ | TObject TObject+ | TOpaque TOpaque+ deriving (Show)++newtype TComposite+ = TOption RonType+ deriving (Show)++data TObject+ = TORSet RonType+ | TRga RonType+ | TStructLww StructLww+ | TVersionVector+ deriving (Show)++data StructLww = StructLww+ { structName :: Text+ , structFields :: Map Text Field+ , structAnnotations :: StructAnnotations+ }+ deriving (Show)++data StructAnnotations = StructAnnotations+ {saHaskellDeriving :: Set Text, saHaskellFieldPrefix :: Text}+ deriving (Show)++instance Default StructAnnotations where def = StructAnnotations def ""++data Field = Field{fieldType :: RonType, fieldAnnotations :: FieldAnnotations}+ deriving (Show)++field :: RonType -> Field+field fieldType = Field{fieldType, fieldAnnotations = def}++data FieldAnnotations = FieldAnnotations+ deriving (Show)++instance Default FieldAnnotations where+ def = FieldAnnotations++newtype Declaration = DStructLww StructLww++type Schema = [Declaration]++newtype OpaqueAnnotations = OpaqueAnnotations{oaHaskellType :: Maybe Text}+ deriving (Default, Show)++char :: RonType+char = opaqueAtoms def{oaHaskellType = Just "Char"}++rgaString :: RonType+rgaString = TObject $ TRga char++data TOpaque =+ Opaque{opaqueIsObject :: Bool, opaqueAnnotations :: OpaqueAnnotations}+ deriving (Show)++opaqueObject :: OpaqueAnnotations -> RonType+opaqueObject = TOpaque . Opaque True++opaqueAtoms :: OpaqueAnnotations -> RonType+opaqueAtoms = TOpaque . Opaque False++option :: RonType -> RonType+option = TComposite . TOption++structLww :: StructLww -> RonType+structLww = TObject . TStructLww++atomString :: RonType+atomString = TAtom TAString++atomInteger :: RonType+atomInteger = TAtom TAInteger++orSet :: RonType -> RonType+orSet = TObject . TORSet++versionVector :: RonType+versionVector = TObject TVersionVector
+ lib/RON/Schema/TH.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module RON.Schema.TH+ ( mkReplicated+ ) where++import Prelude hiding (read)+import RON.Internal.Prelude++import Control.Error (fmapL)+import Control.Monad.Except (MonadError)+import Control.Monad.State.Strict (MonadState, StateT)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import Language.Haskell.TH (Exp (VarE), bindS, conE, conP, conT,+ dataD, doE, letS, listE, noBindS, recC,+ recConE, sigD, varE, varP, varT)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (lift, liftData)++import RON.Data (Replicated (..), ReplicatedAsObject (..),+ objectEncoding)+import RON.Data.Internal (getObjectStateChunk)+import RON.Data.LWW (lwwType)+import qualified RON.Data.LWW as LWW+import RON.Data.ORSet (ORSet (..), ObjectORSet (..))+import RON.Data.RGA (RGA (..))+import RON.Data.VersionVector (VersionVector)+import RON.Event (ReplicaClock)+import RON.Schema (Declaration (..), Field (..),+ FieldAnnotations (..), OpaqueAnnotations (..),+ RonType (..), Schema, StructAnnotations (..),+ StructLww (..), TAtom (..), TComposite (..),+ TObject (..), TOpaque (..))+import RON.Types (Object (..), UUID)+import qualified RON.UUID as UUID++-- | Generate Haskell types from RON-Schema+mkReplicated :: Schema -> TH.DecsQ+mkReplicated = fmap fold . traverse fromDecl where+ fromDecl decl = case decl of+ DStructLww s -> mkReplicatedStructLww s++-- | Type-directing newtype+fieldWrapperC :: RonType -> Maybe TH.Name+fieldWrapperC typ = case typ of+ TAtom _ -> Nothing+ TComposite _ -> Nothing+ TObject t -> case t of+ TORSet a+ | isObjectType a -> Just 'ObjectORSet+ | otherwise -> Just 'ORSet+ TRga _ -> Just 'RGA+ TStructLww _ -> Nothing+ TVersionVector -> Nothing+ TOpaque _ -> Nothing++mkGuideType :: RonType -> TH.TypeQ+mkGuideType typ = case typ of+ TAtom _ -> view+ TComposite _ -> view+ TObject t -> case t of+ TORSet a+ | isObjectType a -> wrap ''ObjectORSet a+ | otherwise -> wrap ''ORSet a+ TRga a -> wrap ''RGA a+ TStructLww _ -> view+ TVersionVector -> view+ TOpaque _ -> view+ where+ view = mkViewType typ+ wrap w item = [t| $(conT w) $(mkGuideType item) |]++data Field' = Field'+ { field'Name :: Text+ , field'RonName :: UUID+ , field'Type :: RonType+ , field'Var :: TH.Name+ }++mkReplicatedStructLww :: StructLww -> TH.DecsQ+mkReplicatedStructLww struct = do+ fields <- for (Map.assocs structFields) $ \(field'Name, field) -> let+ Field{fieldType} = field+ field'Type = fieldType+ in+ case UUID.mkName . BSC.pack $ Text.unpack field'Name of+ Just field'RonName -> do+ field'Var <- TH.newName $ Text.unpack field'Name+ pure Field'{..}+ Nothing -> fail $+ "Field name is not representable in RON: " ++ show field'Name+ dataType <- mkDataType+ [instanceReplicated] <- mkInstanceReplicated+ [instanceReplicatedAsObject] <- mkInstanceReplicatedAsObject fields+ accessors <- fold <$> traverse mkAccessors fields+ pure $+ dataType : instanceReplicated : instanceReplicatedAsObject : accessors+ where++ StructLww{structName, structFields, structAnnotations} = struct++ StructAnnotations{saHaskellDeriving, saHaskellFieldPrefix} =+ structAnnotations++ name = mkNameT structName++ structT = conT name++ objectT = [t| Object $structT |]++ mkDataType = dataD (TH.cxt []) name [] Nothing+ [recC name+ [ TH.varBangType (mkNameT $ mkHaskellFieldName fieldName) $+ TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) viewType+ | (fieldName, Field fieldType FieldAnnotations) <-+ Map.assocs structFields+ , let viewType = mkViewType fieldType+ ]]+ [TH.derivClause Nothing . map (conT . mkNameT) $+ toList saHaskellDeriving]++ mkInstanceReplicated = [d|+ instance Replicated $structT where+ encoding = objectEncoding+ |]++ mkInstanceReplicatedAsObject fields = do+ obj <- TH.newName "obj"+ frame <- TH.newName "frame"+ ops <- TH.newName "ops"+ let fieldsToUnpack =+ [ bindS var [|+ LWW.viewField+ $(liftData field'RonName) $(varE ops) $(varE frame)+ |]+ | Field'{field'Type, field'Var, field'RonName} <- fields+ , let+ fieldP = varP field'Var+ var = maybe fieldP (\w -> conP w [fieldP]) $+ fieldWrapperC field'Type+ ]+ let getObjectImpl = doE+ $ letS [valD' frame [| objectFrame $(varE obj) |]]+ : bindS (varP ops) [| getObjectStateChunk $(varE obj) |]+ : fieldsToUnpack+ ++ [noBindS [| pure $consE |]]+ [d| instance ReplicatedAsObject $structT where+ objectOpType = lwwType+ newObject $consP = LWW.newObject $fieldsToPack+ getObject $(varP obj) = fmapL ($(lift errCtx) ++) $getObjectImpl+ |]+ where+ fieldsToPack = listE+ [ [| ($(liftData field'RonName), I $var) |]+ | Field'{field'Type, field'Var, field'RonName} <- fields+ , let+ fieldVarE = varE field'Var+ var = case fieldWrapperC field'Type of+ Nothing -> fieldVarE+ Just con -> [| $(conE con) $fieldVarE |]+ ]+ errCtx = "getObject @" ++ Text.unpack structName ++ ":\n"+ consE = recConE name+ [ pure (fieldName, VarE field'Var)+ | Field'{field'Name, field'Var} <- fields+ , let fieldName = mkNameT $ mkHaskellFieldName field'Name+ ]+ consP = conP name [varP field'Var | Field'{field'Var} <- fields]++ mkHaskellFieldName = (saHaskellFieldPrefix <>)++ mkAccessors field' = do+ a <- varT <$> TH.newName "a"+ m <- varT <$> TH.newName "m"+ let assignF =+ [ sigD assign [t|+ (ReplicaClock $m, MonadError String $m, MonadState $objectT $m)+ => $fieldViewType -> $m ()+ |]+ , valD' assign+ [| LWW.assignField $(liftData field'RonName) . $guide |]+ ]+ readF =+ [ sigD read [t|+ (MonadError String $m, MonadState $objectT $m)+ => $m $fieldViewType+ |]+ , valD' read+ [| $unguide <$> LWW.readField $(liftData field'RonName) |]+ ]+ zoomF =+ [ sigD zoom [t|+ MonadError String $m+ => StateT (Object $(mkGuideType field'Type)) $m $a+ -> StateT $objectT $m $a+ |]+ , valD' zoom [| LWW.zoomField $(liftData field'RonName) |]+ ]+ sequenceA $ assignF ++ readF ++ zoomF+ where+ Field'{field'Name, field'RonName, field'Type} = field'+ fieldViewType = mkViewType field'Type+ assign = mkNameT $ mkHaskellFieldName field'Name <> "_assign"+ read = mkNameT $ mkHaskellFieldName field'Name <> "_read"+ zoom = mkNameT $ mkHaskellFieldName field'Name <> "_zoom"+ guidedX = case fieldWrapperC field'Type of+ Just w -> conP w [x]+ Nothing -> x+ where+ x = varP $ TH.mkName "x"+ unguide = [| \ $guidedX -> x |]+ guide = case fieldWrapperC field'Type of+ Just w -> conE w+ Nothing -> [| id |]++mkNameT :: Text -> TH.Name+mkNameT = TH.mkName . Text.unpack++mkViewType :: RonType -> TH.TypeQ+mkViewType = \case+ TAtom atom -> case atom of+ TAInteger -> [t| Int64 |]+ TAString -> [t| Text |]+ TComposite t -> case t of+ TOption u -> [t| Maybe $(mkViewType u) |]+ TObject t -> case t of+ TORSet item -> wrapList item+ TRga item -> wrapList item+ TStructLww StructLww{structName} -> conT $ mkNameT structName+ TVersionVector -> [t| VersionVector |]+ TOpaque Opaque{opaqueAnnotations} -> let+ OpaqueAnnotations{oaHaskellType} = opaqueAnnotations+ in case oaHaskellType of+ Just name -> conT $ mkNameT name+ Nothing -> fail "Opaque type must define a Haskell type"+ where+ wrapList a = [t| [$(mkViewType a)] |]++valD' :: TH.Name -> TH.ExpQ -> TH.DecQ+valD' name body = TH.valD (varP name) (TH.normalB body) []++isObjectType :: RonType -> Bool+isObjectType = \case+ TAtom _ -> False+ TComposite _ -> False+ TObject _ -> True+ TOpaque Opaque{opaqueIsObject} -> opaqueIsObject
+ lib/RON/Text.hs view
@@ -0,0 +1,16 @@+-- | RON-Text wire format+module RON.Text+ ( parseObject+ , parseStateFrame+ , parseWireFrame+ , parseWireFrames+ , serializeObject+ , serializeStateFrame+ , serializeWireFrame+ , serializeWireFrames+ ) where++import RON.Text.Parse (parseObject, parseStateFrame, parseWireFrame,+ parseWireFrames)+import RON.Text.Serialize (serializeObject, serializeStateFrame,+ serializeWireFrame, serializeWireFrames)
+ lib/RON/Text/Parse.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | RON-Text parsing+module RON.Text.Parse+ ( parseAtom+ , parseObject+ , parseOp+ , parseStateFrame+ , parseString+ , parseUuid+ , parseUuidKey+ , parseUuidAtom+ , parseWireFrame+ , parseWireFrames+ ) where++import Prelude hiding (takeWhile)+import RON.Internal.Prelude++import Attoparsec.Extra (Parser, char, endOfInputEx, isSuccessful,+ label, manyTill, parseOnlyL, satisfy, (<+>),+ (??))+import qualified Data.Aeson as Json+import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, double,+ signed, skipSpace, takeWhile,+ takeWhile1)+import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Char (ord)+import qualified Data.Map.Strict as Map+import Data.Text (Text)++import qualified RON.Base64 as Base64+import RON.Internal.Word (Word2, Word4, Word60, b00, b0000, b01, b10,+ b11, ls60, safeCast)+import RON.Types (Atom (AFloat, AInteger, AString, AUuid),+ Object (..), Op (..),+ OpTerm (THeader, TQuery, TRaw, TReduced),+ RawOp (..), StateChunk (..), StateFrame,+ UUID (UUID), WireChunk (Query, Raw, Value),+ WireFrame, WireReducedChunk (..))+import RON.UUID (UuidFields (..))+import qualified RON.UUID as UUID++-- | Parse a common frame+parseWireFrame :: ByteStringL -> Either String WireFrame+parseWireFrame = parseOnlyL frame++chunksTill :: Parser () -> Parser [WireChunk]+chunksTill end = label "[WireChunk]" $ go opZero+ where+ go prev = do+ skipSpace+ atEnd <- isSuccessful end+ if atEnd then+ pure []+ else do+ (ch, lastOp) <- pChunk prev+ (ch :) <$> go lastOp++-- | Returns a chunk and the last op in it+pChunk :: RawOp -> Parser (WireChunk, RawOp)+pChunk prev = label "WireChunk" $ wireStateChunk prev <+> chunkRaw prev++chunkRaw :: RawOp -> Parser (WireChunk, RawOp)+chunkRaw prev = label "WireChunk-raw" $ do+ skipSpace+ (_, x) <- rawOp prev+ skipSpace+ void $ char ';'+ pure (Raw x, x)++-- | Returns a chunk and the last op (converted to raw) in it+wireStateChunk :: RawOp -> Parser (WireChunk, RawOp)+wireStateChunk prev = label "WireChunk-reduced" $ do+ (wrcHeader, isQuery) <- header prev+ let reducedOps y = do+ skipSpace+ (isNotEmpty, x) <- reducedOp (opObject wrcHeader) y+ t <- optional term+ unless (t == Just TReduced || isNothing t) $+ fail "reduced op may end with `,` only"+ unless (isNotEmpty || t == Just TReduced) $ fail "Empty reduced op"+ xs <- reducedOps x <|> stop+ pure $ x : xs+ wrcBody <- reducedOps (op wrcHeader) <|> stop+ let lastOp = case wrcBody of+ [] -> op wrcHeader+ _ -> last wrcBody+ wrap op = RawOp+ {opType = opType wrcHeader, opObject = opObject wrcHeader, op}+ pure ((if isQuery then Query else Value) WireReducedChunk{..}, wrap lastOp)+ where+ stop = pure []++frame :: Parser WireFrame+frame = label "WireFrame" $ chunksTill (endOfFrame <|> endOfInputEx)++-- | Parse a sequence of common frames+parseWireFrames :: ByteStringL -> Either String [WireFrame]+parseWireFrames = parseOnlyL $ manyTill frameInStream endOfInputEx++frameInStream :: Parser WireFrame+frameInStream = label "WireFrame-stream" $ chunksTill endOfFrame++-- | Parse a single context-free op+parseOp :: ByteStringL -> Either String RawOp+parseOp = parseOnlyL $ do+ (_, x) <- rawOp opZero <* skipSpace <* endOfInputEx+ pure x++-- | Parse a single context-free UUID+parseUuid :: ByteStringL -> Either String UUID+parseUuid = parseOnlyL $+ uuid UUID.zero UUID.zero PrevOpSameKey <* skipSpace <* endOfInputEx++-- | Parse a UUID in key position+parseUuidKey+ :: UUID -- ^ same key in the previous op (default is 'UUID.zero')+ -> UUID -- ^ previous key of the same op (default is 'UUID.zero')+ -> ByteStringL+ -> Either String UUID+parseUuidKey prevKey prev =+ parseOnlyL $ uuid prevKey prev PrevOpSameKey <* skipSpace <* endOfInputEx++-- | Parse a UUID in value (atom) position+parseUuidAtom+ :: UUID -- ^ previous+ -> ByteStringL+ -> Either String UUID+parseUuidAtom prev = parseOnlyL $ uuidAtom prev <* skipSpace <* endOfInputEx++endOfFrame :: Parser ()+endOfFrame = label "end of frame" $ void $ skipSpace *> char '.'++rawOp :: RawOp -> Parser (Bool, RawOp)+rawOp prev = label "RawOp-cont" $ do+ (hasTyp, opType) <- key "type" '*' (opType prev) UUID.zero+ (hasObj, opObject) <- key "object" '#' (opObject prev) opType+ (hasEvt, opEvent) <- key "event" '@' (opEvent prev') opObject+ (hasLoc, opRef) <- key "ref" ':' (opRef prev') opEvent+ opPayload <- payload opObject+ let op = Op{..}+ pure+ ( hasTyp || hasObj || hasEvt || hasLoc || not (null opPayload)+ , RawOp{..}+ )+ where+ prev' = op prev++reducedOp :: UUID -> Op -> Parser (Bool, Op)+reducedOp opObject prev = label "Op-cont" $ do+ (hasEvt, opEvent) <- key "event" '@' (opEvent prev) opObject+ (hasLoc, opRef) <- key "ref" ':' (opRef prev) opEvent+ opPayload <- payload opObject+ let op = Op{..}+ pure (hasEvt || hasLoc || not (null opPayload), op)++key :: String -> Char -> UUID -> UUID -> Parser (Bool, UUID)+key name keyChar prevOpSameKey sameOpPrevUuid = label name $ do+ skipSpace+ isKeyPresent <- isSuccessful $ char keyChar+ if isKeyPresent then do+ u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey+ pure (True, u)+ else+ -- no key => use previous key+ pure (False, prevOpSameKey)++uuid :: UUID -> UUID -> UuidZipBase -> Parser UUID+uuid prevOpSameKey sameOpPrevUuid defaultZipBase = label "UUID" $+ uuid22 <+> uuid11 <+> uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase++uuid11 :: Parser UUID+uuid11 = label "UUID-RON-11-letter-value" $ do+ rawX <- base64word 11+ guard $ BS.length rawX == 11+ x <- Base64.decode64 rawX ?? fail "Base64.decode64"+ skipSpace+ rawScheme <- optional pScheme+ rawOrigin <- optional $ base64word $ maybe 11 (const 10) rawScheme+ y <- case (rawScheme, BS.length <$> rawOrigin) of+ (Nothing, Just 11) ->+ case rawOrigin of+ Nothing -> pure 0+ Just origin -> Base64.decode64 origin ?? fail "Base64.decode64"+ _ -> do+ origin <- case rawOrigin of+ Nothing -> pure $ ls60 0+ Just origin -> Base64.decode60 origin ?? fail "Base64.decode60"+ pure $ UUID.buildY b00 (fromMaybe b00 rawScheme) origin+ pure $ UUID x y++data UuidZipBase = PrevOpSameKey | SameOpPrevUuid++uuidZip :: UUID -> UUID -> UuidZipBase -> Parser UUID+uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase = label "UUID-zip" $ do+ changeZipBase <- isSuccessful $ char '`'+ rawVariety <- optional pVariety+ rawReuseValue <- optional pReuse+ rawValue <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseValue+ skipSpace+ rawScheme <- optional pScheme+ rawReuseOrigin <- optional pReuse+ rawOrigin <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseOrigin++ let prev = UUID.split $ whichPrev changeZipBase+ let isSimple+ = uuidVariant prev /= b00+ || ( not changeZipBase+ && isNothing rawReuseValue && isJust rawValue+ && isNothing rawReuseOrigin+ && (isNothing rawScheme || isJust rawOrigin)+ )++ if isSimple then+ pure $ UUID.build UuidFields+ { uuidVariety = fromMaybe b0000 rawVariety+ , uuidValue = fromMaybe (ls60 0) rawValue+ , uuidVariant = b00+ , uuidScheme = fromMaybe b00 rawScheme+ , uuidOrigin = fromMaybe (ls60 0) rawOrigin+ }+ else do+ uuidVariety <- pure $ fromMaybe (uuidVariety prev) rawVariety+ uuidValue <- pure $ reuse rawReuseValue rawValue (uuidValue prev)+ let uuidVariant = b00+ uuidScheme <- pure $ fromMaybe (uuidScheme prev) rawScheme+ uuidOrigin <-+ pure $ reuse rawReuseOrigin rawOrigin (uuidOrigin prev)+ pure $ UUID.build UuidFields{..}+ where++ whichPrev changeZipBase+ | changeZipBase = sameOpPrevUuid+ | otherwise = case defaultZipBase of+ PrevOpSameKey -> prevOpSameKey+ SameOpPrevUuid -> sameOpPrevUuid++ reuse :: Maybe Int -> Maybe Word60 -> Word60 -> Word60+ reuse Nothing Nothing prev = prev+ reuse Nothing (Just new) _ = new+ reuse (Just prefixLen) Nothing prev =+ ls60 $ safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen)+ reuse (Just prefixLen) (Just new) prev = ls60 $ prefix .|. postfix+ where+ prefix = safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen)+ postfix = safeCast new `shiftR` (6 * prefixLen)++pReuse :: Parser Int+pReuse = anyChar >>= \case+ '(' -> pure 4+ '[' -> pure 5+ '{' -> pure 6+ '}' -> pure 7+ ']' -> pure 8+ ')' -> pure 9+ _ -> fail "not a reuse symbol"++uuid22 :: Parser UUID+uuid22 = label "UUID-Base64-double-word" $ do+ xy <- base64word 22+ guard $ BS.length xy == 22+ maybe (fail "Base64 decoding error") pure $+ UUID+ <$> Base64.decode64 (BS.take 11 xy)+ <*> Base64.decode64 (BS.drop 11 xy)++base64word :: Int -> Parser ByteString+base64word maxSize = label "Base64 word" $ do+ word <- takeWhile1 Base64.isLetter+ guard $ BS.length word <= maxSize+ pure word++base64word60 :: Int -> Parser Word60+base64word60 maxSize = label "Base64 word60" $ do+ word <- base64word maxSize+ Base64.decode60 word ?? fail "decode60"++isUpperHexDigit :: Word8 -> Bool+isUpperHexDigit c =+ (fromIntegral (c - fromIntegral (ord '0')) :: Word) <= 9 ||+ (fromIntegral (c - fromIntegral (ord 'A')) :: Word) <= 5++pVariety :: Parser Word4+pVariety = label "variety" $ do+ letter <- satisfy isUpperHexDigit <* "/"+ Base64.decodeLetter4 letter ?? fail "Base64.decodeLetter4"++pScheme :: Parser Word2+pScheme = label "scheme" $+ anyChar >>= \case+ '$' -> pure b00+ '%' -> pure b01+ '+' -> pure b10+ '-' -> pure b11+ _ -> fail "not a scheme"++payload :: UUID -> Parser [Atom]+payload = label "payload" . go+ where+ go prevUuid = do+ ma <- optional $ atom prevUuid+ case ma of+ Nothing -> pure []+ Just a -> (a :) <$> go newUuid+ where+ newUuid = case a of+ AUuid u -> u+ _ -> prevUuid++atom :: UUID -> Parser Atom+atom prevUuid = skipSpace *> atom'+ where+ atom' =+ char '^' *> skipSpace *> (AFloat <$> double ) <+>+ char '=' *> skipSpace *> (AInteger <$> integer) <+>+ char '>' *> skipSpace *> (AUuid <$> uuid' ) <+>+ AString <$> string+ integer = signed decimal+ uuid' = uuidAtom prevUuid++uuidAtom :: UUID -> Parser UUID+uuidAtom prev = uuid UUID.zero prev SameOpPrevUuid++-- | Parse an atom+parseAtom :: ByteStringL -> Either String Atom+parseAtom = parseOnlyL $ atom UUID.zero <* endOfInputEx++string :: Parser Text+string = do+ bs <- char '\'' *> content+ case Json.decodeStrict $ '"' `BSC.cons` (bs `BSC.snoc` '"') of+ Just s -> pure s+ Nothing -> fail "bad string"+ where+ content = do+ chunk <- takeWhile $ \c -> c /= '\'' && c /= '\\'+ anyChar >>= \case+ '\'' -> pure chunk+ '\\' -> anyChar >>= \case+ '\'' -> (chunk <>) . BSC.cons '\'' <$> content+ c -> (chunk <>) . BSC.cons '\\' . BSC.cons c <$> content+ _ -> fail "cannot happen"++-- | Parse a string atom+parseString :: ByteStringL -> Either String Text+parseString = parseOnlyL $ string <* endOfInputEx++-- | Return 'RawOp' and 'chunkIsQuery'+header :: RawOp -> Parser (RawOp, Bool)+header prev = do+ (_, x) <- rawOp prev+ t <- term+ case t of+ THeader -> pure (x, False)+ TQuery -> pure (x, True)+ _ -> fail "not a header"++term :: Parser OpTerm+term = do+ skipSpace+ anyChar >>= \case+ '!' -> pure THeader+ '?' -> pure TQuery+ ',' -> pure TReduced+ ';' -> pure TRaw+ _ -> fail "not a term"++-- | Parse a state frame+parseStateFrame :: ByteStringL -> Either String StateFrame+parseStateFrame = parseWireFrame >=> findObjects++-- | Parse a state frame as an object+parseObject :: UUID -> ByteStringL -> Either String (Object a)+parseObject oid bytes = Object oid <$> parseStateFrame bytes++-- | Extract object states from a common frame+findObjects :: WireFrame -> Either String StateFrame+findObjects = fmap Map.fromList . traverse loadBody where+ loadBody = \case+ Value WireReducedChunk{..} -> do+ let RawOp{..} = wrcHeader+ let Op{..} = op+ let stateVersion = opEvent+ let stateBody = wrcBody+ pure ((opType, opObject), StateChunk{..})+ _ -> Left "expected reduced chunk"++opZero :: RawOp+opZero = RawOp+ { opType = UUID.zero+ , opObject = UUID.zero+ , op = Op{opEvent = UUID.zero, opRef = UUID.zero, opPayload = []}+ }
+ lib/RON/Text/Serialize.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}++-- | RON-Text serialization+module RON.Text.Serialize+ ( serializeAtom+ , serializeObject+ , serializeRawOp+ , serializeStateFrame+ , serializeString+ , serializeUuid+ , serializeWireFrame+ , serializeWireFrames+ ) where++import RON.Internal.Prelude++import Control.Monad.State.Strict (State, evalState, runState, state)+import qualified Data.Aeson as Json+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.ByteString.Lazy.Search as BSL+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Data.Traversable (for)++import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom,+ serializeUuidKey)+import RON.Types (Atom (AFloat, AInteger, AString, AUuid),+ Object (..), Op (..), RawOp (..), StateChunk (..),+ StateFrame, WireChunk (Query, Raw, Value),+ WireFrame, WireReducedChunk (..))+import RON.UUID (UUID, zero)++-- | Serialize a common frame+serializeWireFrame :: WireFrame -> ByteStringL+serializeWireFrame chunks+ = (`BSLC.snoc` '.')+ . mconcat+ . (`evalState` opZero)+ $ traverse serializeChunk chunks++-- | Serialize a sequence of common frames+serializeWireFrames :: [WireFrame] -> ByteStringL+serializeWireFrames = foldMap serializeWireFrame++-- | Serialize a common chunk+serializeChunk :: WireChunk -> State RawOp ByteStringL+serializeChunk = \case+ Raw op -> (<> " ;\n") <$> serializeRawOpZip op+ Value chunk -> serializeReducedChunk False chunk+ Query chunk -> serializeReducedChunk True chunk++-- | Serialize a reduced chunk+serializeReducedChunk :: Bool -> WireReducedChunk -> State RawOp ByteStringL+serializeReducedChunk isQuery WireReducedChunk{wrcHeader, wrcBody} =+ BSLC.unlines <$> liftA2 (:) serializeHeader serializeBody+ where+ serializeHeader = do+ h <- serializeRawOpZip wrcHeader+ pure $ BSLC.unwords [h, if isQuery then "?" else "!"]+ serializeBody = state $ \RawOp{op = opBefore, ..} -> let+ (body, opAfter) =+ (`runState` opBefore) $+ for wrcBody $+ fmap ("\t" <>) . serializeReducedOpZip opObject+ in+ ( body+ , RawOp{op = opAfter, ..}+ )++-- | Serialize a context-free raw op+serializeRawOp :: RawOp -> ByteStringL+serializeRawOp op = evalState (serializeRawOpZip op) opZero++-- | Serialize a raw op with compression in stream context+serializeRawOpZip :: RawOp -> State RawOp ByteStringL+serializeRawOpZip this = state $ \prev -> let+ prev' = op prev+ typ = serializeUuidKey (opType prev) zero (opType this)+ obj = serializeUuidKey (opObject prev) (opType this) (opObject this)+ evt = serializeUuidKey (opEvent prev') (opObject this) (opEvent this')+ ref = serializeUuidKey (opRef prev') (opEvent this') (opRef this')+ payload = serializePayload (opObject this) (opPayload this')+ in+ ( BSLC.unwords+ $ key '*' typ+ ++ key '#' obj+ ++ key '@' evt+ ++ key ':' ref+ ++ [payload | not $ BSL.null payload]+ , this+ )+ where+ this' = op this+ key c u = [BSLC.cons c u | not $ BSL.null u]++-- | Serialize a reduced op with compression in stream context+serializeReducedOpZip+ :: UUID -- ^ enclosing object+ -> Op+ -> State Op ByteStringL+serializeReducedOpZip opObject this = state $ \prev -> let+ evt = serializeUuidKey (opEvent prev) opObject (opEvent this)+ ref = serializeUuidKey (opRef prev) (opEvent this) (opRef this)+ payload = serializePayload opObject (opPayload this)+ in+ ( BSLC.unwords+ $ (if BSL.null evt && BSL.null ref+ then ["@"]+ else key '@' evt ++ key ':' ref)+ ++ [payload | not $ BSL.null payload]+ , this+ )+ where+ key c u = [BSLC.cons c u | not $ BSL.null u]++-- | Serialize a context-free atom+serializeAtom :: Atom -> ByteStringL+serializeAtom a = evalState (serializeAtomZip a) zero++-- | Serialize an atom with compression for UUID in stream context+serializeAtomZip :: Atom -> State UUID ByteStringL+serializeAtomZip = \case+ AFloat f -> pure $ BSLC.cons '^' $ BSLC.pack (show f)+ AInteger i -> pure $ BSLC.cons '=' $ BSLC.pack (show i)+ AString s -> pure $ serializeString s+ AUuid u ->+ state $ \prev -> (BSLC.cons '>' $ serializeUuidAtom prev u, u)++-- | Serialize a string atom+serializeString :: Text -> ByteStringL+serializeString =+ fixQuotes . BSL.replace "'" ("\\'" :: ByteString) . Json.encode+ where+ fixQuotes = (`BSLC.snoc` '\'') . BSLC.cons '\'' . BSL.init . BSL.tail++-- | Serialize a payload in stream context+serializePayload+ :: UUID -- ^ previous UUID (default is 'zero')+ -> [Atom]+ -> ByteStringL+serializePayload prev =+ BSLC.unwords . (`evalState` prev) . traverse serializeAtomZip++-- | Serialize a state frame+serializeStateFrame :: StateFrame -> ByteStringL+serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs where+ wrapChunk ((opType, opObject), StateChunk{..}) = Value WireReducedChunk{..}+ where+ wrcHeader = RawOp{op = Op{opRef = zero, opPayload = [], ..}, ..}+ wrcBody = stateBody+ opEvent = stateVersion++-- | Serialize an object. Return object id that must be stored separately.+serializeObject :: Object a -> (UUID, ByteStringL)+serializeObject (Object oid frame) = (oid, serializeStateFrame frame)++opZero :: RawOp+opZero = RawOp+ { opType = zero+ , opObject = zero+ , op = Op{opEvent = zero, opRef = zero, opPayload = []}+ }
+ lib/RON/Text/Serialize/UUID.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module RON.Text.Serialize.UUID+ ( serializeUuid+ , serializeUuidAtom+ , serializeUuidKey+ ) where++import RON.Internal.Prelude++import Data.Bits (countLeadingZeros, shiftL, xor)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import Data.List (minimumBy)+import Data.Ord (comparing)++import qualified RON.Base64 as Base64+import RON.Internal.Word (pattern B00, pattern B0000, pattern B01,+ pattern B10, pattern B11, Word2, Word60,+ ls60, safeCast)+import RON.UUID (UUID (..), UuidFields (..), split, zero)++-- | Serialize UUID without context (used for test)+serializeUuid :: UUID -> ByteStringL+serializeUuid this =+ BSL.fromStrict $ case uuidVariant of+ B00 -> unzipped thisFields+ _ -> serializeUuidGeneric this+ where+ thisFields@UuidFields{..} = split this++-- | Serialize UUID in op key context+serializeUuidKey+ :: UUID -- ^ same key in the previous op (default is 'zero')+ -> UUID -- ^ previous key of the same op (default is 'zero')+ -> UUID -- ^ this+ -> ByteStringL+serializeUuidKey prevKey prev this =+ BSL.fromStrict $ case uuidVariant thisFields of+ B00 -> minimumByLength+ $ unzipped thisFields+ : [ z+ | uuidVariant (split prevKey) == B00+ , Just z <- [zipUuid (split prevKey) thisFields]+ ]+ ++ [ "`" <> z+ | prev /= zero+ , uuidVariant (split prev) == B00+ , Just z <- [zipUuid (split prev) thisFields]+ ]+ _ -> serializeUuidGeneric this+ where+ thisFields = split this++-- | Serialize UUID in op value (atom) context+serializeUuidAtom+ :: UUID -- ^ previous+ -> UUID -- ^ this+ -> ByteStringL+serializeUuidAtom prev this =+ BSL.fromStrict $ case uuidVariant thisFields of+ B00 -> minimumByLength+ $ unzipped thisFields+ : [ z+ | prev /= zero+ , uuidVariant (split prev) == B00+ , Just z <- [zipUuid (split prev) thisFields]+ ]+ _ -> serializeUuidGeneric this+ where+ thisFields = split this++unzipped :: UuidFields -> ByteString+unzipped UuidFields{..} = x' <> y'+ where+ variety = case uuidVariety of+ B0000 -> ""+ _ -> BS.singleton (Base64.encodeLetter4 uuidVariety) <> "/"+ x' = variety <> Base64.encode60short uuidValue+ y' = case (uuidScheme, uuidOrigin) of+ (B00, safeCast -> 0 :: Word64) -> ""+ _ ->+ serializeScheme uuidScheme+ `BSC.cons` Base64.encode60short uuidOrigin++zipUuid :: UuidFields -> UuidFields -> Maybe ByteString+zipUuid prev this+ | prev == this = Just ""+ | canReuseValue = valueZip+ | otherwise = Nothing+ where+ canReuseValue = prev{uuidValue = uuidValue this} == this+ valueZip = zipPrefix (uuidValue prev) (uuidValue this)++zipPrefix :: Word60 -> Word60 -> Maybe ByteString+zipPrefix prev this+ | commonBits >= 6 * 10 = pure ""+ | commonBits >= 6 * 9 = ok ')' 9+ | commonBits >= 6 * 8 = ok ']' 8+ | commonBits >= 6 * 7 = ok '}' 7+ | commonBits >= 6 * 6 = ok '{' 6+ | commonBits >= 6 * 5 = ok '[' 5+ | commonBits >= 6 * 4 = ok '(' 4+ | otherwise = Nothing+ where+ ok c n = pure $ BSC.cons c $ encode60short' $ safeCast this `shiftL` (6 * n)+ commonBits =+ countLeadingZeros (safeCast prev `xor` safeCast this :: Word64) - 4+ encode60short' = \case+ 0 -> ""+ w -> Base64.encode60short $ ls60 w++serializeScheme :: Word2 -> Char+serializeScheme = \case+ B00 -> '$'+ B01 -> '%'+ B10 -> '+'+ B11 -> '-'++serializeUuidGeneric :: UUID -> ByteString+serializeUuidGeneric (UUID x y) = Base64.encode64 x <> Base64.encode64 y++minimumByLength :: Foldable f => f ByteString -> ByteString+minimumByLength = minimumBy $ comparing BS.length
+ lib/RON/Types.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StrictData #-}++-- | RON model types+module RON.Types+ ( Atom (..)+ , Object (..)+ , ObjectId+ , ObjectPart (..)+ , Op (..)+ , OpTerm (..)+ , RawOp (..)+ , StateChunk (..)+ , StateFrame+ , UUID (..)+ , WireChunk (..)+ , WireFrame+ , WireReducedChunk (..)+ ) where++import RON.Internal.Prelude++import Control.DeepSeq (NFData)+import Data.Data (Data)+import Data.Text (Text)+import GHC.Generics (Generic)++import RON.UUID (UUID (..))++-- | Atom — a payload element+data Atom = AFloat Double | AInteger Int64 | AString Text | AUuid UUID+ deriving (Data, Eq, Generic, Hashable, NFData, Show)++-- | Raw op+data RawOp = RawOp+ { opType :: UUID+ -- ^ type+ , opObject :: UUID+ -- ^ object id+ , op :: Op+ -- ^ other keys and payload, that are common with reduced op+ }+ deriving (Data, Eq, Generic, NFData)++-- | “Reduced” op (op from reduced chunk)+data Op = Op+ { opEvent :: UUID+ -- ^ event id (usually timestamp)+ , opRef :: UUID+ -- ^ reference to other op; actual semantics depends on the type+ , opPayload :: [Atom]+ -- ^ payload+ }+ deriving (Data, Eq, Generic, Hashable, NFData, Show)++instance Show RawOp where+ show RawOp{opType, opObject, op = Op{opEvent, opRef, opPayload}} =+ unwords+ [ "RawOp"+ , insert '*' $ show opType+ , insert '#' $ show opObject+ , insert '@' $ show opEvent+ , insert ':' $ show opRef+ , show opPayload+ ]+ where+ insert k = \case+ [] -> [k]+ c:cs -> c:k:cs++-- | Common reduced chunk+data WireReducedChunk = WireReducedChunk+ { wrcHeader :: RawOp+ , wrcBody :: [Op]+ }+ deriving (Data, Eq, Generic, NFData, Show)++-- | Common chunk+data WireChunk = Raw RawOp | Value WireReducedChunk | Query WireReducedChunk+ deriving (Data, Eq, Generic, NFData, Show)++-- | Common frame+type WireFrame = [WireChunk]++-- | Op terminator+data OpTerm = TRaw | TReduced | THeader | TQuery+ deriving (Eq, Show)++-- | A pair of (type, object)+type ObjectId = (UUID, UUID)++-- | Reduced chunk representing an object state (i. e. high-level value)+data StateChunk = StateChunk+ { stateVersion :: UUID+ , stateBody :: [Op]+ }+ deriving (Eq, Show)++-- | Frame containing only state chunks+type StateFrame = Map ObjectId StateChunk++-- | Reference to an object inside a frame.+data Object a = Object{objectId :: UUID, objectFrame :: StateFrame}+ deriving (Eq, Show)++-- | Specific field or item in an object, identified by UUID.+data ObjectPart obj part = ObjectPart+ {partObject :: UUID, partLocation :: UUID, partFrame :: StateFrame}
+ lib/RON/UUID.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module RON.UUID+ ( UUID (..)+ , UuidFields (..)+ , build+ , buildX+ , buildY+ , split+ , succValue+ , zero+ , pattern Zero+ -- * Name+ , getName+ , mkName+ , mkScopedName+ -- * Base32 encoding, suitable for file names+ , decodeBase32+ , encodeBase32+ ) where++import RON.Internal.Prelude++import Control.DeepSeq (NFData)+import Data.Bits (shiftL, shiftR, (.|.))+import qualified Data.ByteString.Char8 as BSC+import Data.Char (chr, toUpper)+import Data.Data (Data)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)++import qualified RON.Base64 as Base64+import RON.Internal.Word (pattern B00, pattern B0000, pattern B01,+ pattern B10, pattern B11, Word2, Word4,+ Word60, leastSignificant2,+ leastSignificant4, leastSignificant60,+ safeCast)++-- | Universally unique identifier of anything+data UUID = UUID+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ deriving (Data, Eq, Generic, Hashable, NFData, Ord)++-- | RON-Text-encoding+instance Show UUID where+ -- showsPrec a (UUID x y) =+ -- showParen (a >= 11) $+ -- showString "UUID 0x" . showHex x . showString " 0x" . showHex y+ show this = show serialized+ where+ UUID x y = this+ UuidFields{..} = split this+ serialized = case uuidVariant of+ B00 -> unzipped+ _ -> generic+ unzipped = x' <> y'+ variety = case uuidVariety of+ B0000 -> ""+ _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/"+ x' = variety <> BSC.unpack (Base64.encode60short uuidValue)+ y' = case (uuidScheme, uuidOrigin) of+ (B00, safeCast -> 0 :: Word64) -> ""+ _ -> scheme : BSC.unpack (Base64.encode60short uuidOrigin)+ generic = BSC.unpack $ Base64.encode64 x <> Base64.encode64 y+ scheme = case uuidScheme of+ B00 -> '$'+ B01 -> '%'+ B10 -> '+'+ B11 -> '-'++-- | UUID split in parts+data UuidFields = UuidFields+ { uuidVariety :: !Word4+ , uuidValue :: !Word60+ , uuidVariant :: !Word2+ , uuidScheme :: !Word2+ , uuidOrigin :: !Word60+ }+ deriving (Eq, Show)++-- | Split UUID into parts+split :: UUID -> UuidFields+split (UUID x y) = UuidFields+ { uuidVariety = leastSignificant4 $ x `shiftR` 60+ , uuidValue = leastSignificant60 x+ , uuidVariant = leastSignificant2 $ y `shiftR` 62+ , uuidScheme = leastSignificant2 $ y `shiftR` 60+ , uuidOrigin = leastSignificant60 y+ }++-- | Build UUID from parts+build :: UuidFields -> UUID+build UuidFields{..} = UUID+ (buildX uuidVariety uuidValue)+ (buildY uuidVariant uuidScheme uuidOrigin)++-- | Build former 64 bits of UUID from parts+buildX :: Word4 -> Word60 -> Word64+buildX uuidVariety uuidValue =+ (safeCast uuidVariety `shiftL` 60) .|. safeCast uuidValue++-- | Build latter 64 bits of UUID from parts+buildY :: Word2 -> Word2 -> Word60 -> Word64+buildY uuidVariant uuidScheme uuidOrigin+ = (safeCast uuidVariant `shiftL` 62)+ .|. (safeCast uuidScheme `shiftL` 60)+ .|. safeCast uuidOrigin++-- | Make an unscoped (unqualified) name+mkName+ :: ByteString -- ^ name, max 10 Base64 letters+ -> Maybe UUID+mkName nam = mkScopedName nam ""++-- | Make a scoped (qualified) name+mkScopedName+ :: ByteString -- ^ scope, max 10 Base64 letters+ -> ByteString -- ^ local name, max 10 Base64 letters+ -> Maybe UUID+mkScopedName scope nam = do+ scope' <- Base64.decode60 scope+ nam' <- Base64.decode60 nam+ pure $ build UuidFields+ { uuidVariety = B0000+ , uuidValue = scope'+ , uuidVariant = B00+ , uuidScheme = B00+ , uuidOrigin = nam'+ }++-- | Convert UUID to a name+getName+ :: UUID+ -> Maybe (ByteString, ByteString)+ -- ^ @(scope, name)@ for a scoped name; @(name, "")@ for a global name+getName uuid = case split uuid of+ UuidFields{uuidVariety = B0000, uuidVariant = B00, uuidScheme = B00, ..} ->+ Just (x, y)+ where+ x = Base64.encode60short uuidValue+ y = case safeCast uuidOrigin :: Word64 of+ 0 -> ""+ _ -> Base64.encode60short uuidOrigin+ _ -> Nothing++-- | UUID with all zero fields+zero :: UUID+zero = UUID 0 0++-- | UUID with all zero fields+pattern Zero :: UUID+pattern Zero = UUID 0 0++-- | Increment field 'uuidValue' of a UUID+succValue :: UUID -> UUID+succValue = build . go . split where+ go u@UuidFields{uuidValue} = u+ {uuidValue = if uuidValue < maxBound then succ uuidValue else uuidValue}++-- | Encode a UUID to a Base32 string+encodeBase32 :: UUID -> FilePath+encodeBase32 (UUID x y) =+ BSC.unpack $+ Base64.encode64base32short x <> "-" <> Base64.encode64base32short y++-- | Decode a UUID from a Base32 string+decodeBase32 :: FilePath -> Maybe UUID+decodeBase32 fp = do+ let (x, dashy) = span (/= '-') $ map toUpper fp+ ("-", y) <- pure $ splitAt 1 dashy+ UUID+ <$> Base64.decode64base32 (BSC.pack x)+ <*> Base64.decode64base32 (BSC.pack y)
+ ron.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.2++name: ron+version: 0.1++category: Distributed Systems, Protocol, Database+copyright: 2018 Yuriy Syrovetskiy+description: Replicated Object Notation (RON), data types (RDT),+ and RON-Schema+license: BSD-3-Clause+maintainer: Yuriy Syrovetskiy <haskell@cblp.su>+synopsis: RON, RON-RDT, and RON-Schema++build-type: Simple++common language+ build-depends:+ base >= 4.11.1.0 && < 4.12,+ default-extensions: StrictData+ default-language: Haskell2010++library+ import: language+ build-depends:+ aeson,+ attoparsec,+ binary,+ bytestring,+ containers,+ data-default,+ deepseq,+ Diff,+ errors,+ extra,+ hashable,+ mtl,+ safe,+ stringsearch,+ template-haskell,+ text,+ time,+ unordered-containers,+ vector,+ exposed-modules:+ RON.Base64+ RON.Binary+ RON.Binary.Parse+ RON.Binary.Serialize+ RON.Binary.Types+ RON.Data+ RON.Data.Internal+ RON.Data.LWW+ RON.Data.ORSet+ RON.Data.RGA+ RON.Data.Time+ RON.Data.VersionVector+ RON.Epoch+ RON.Event+ RON.Event.Simulation+ RON.Internal.Prelude+ RON.Internal.Word+ RON.Schema+ RON.Schema.TH+ RON.Text+ RON.Text.Parse+ RON.Text.Serialize+ RON.Text.Serialize.UUID+ RON.Types+ RON.UUID+ other-modules:+ Attoparsec.Extra+ Data.ZigZag+ hs-source-dirs: lib++benchmark bench+ import: language+ build-depends:+ -- global+ criterion,+ deepseq,+ -- package+ ron,+ main-is: Main.hs+ hs-source-dirs: bench+ type: exitcode-stdio-1.0