diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + ] diff --git a/lib/Attoparsec/Extra.hs b/lib/Attoparsec/Extra.hs new file mode 100644 --- /dev/null +++ b/lib/Attoparsec/Extra.hs @@ -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 <+> diff --git a/lib/Data/ZigZag.hs b/lib/Data/ZigZag.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ZigZag.hs @@ -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 diff --git a/lib/RON/Base64.hs b/lib/RON/Base64.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Base64.hs @@ -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) diff --git a/lib/RON/Binary.hs b/lib/RON/Binary.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Binary.hs @@ -0,0 +1,5 @@ +-- | RON-Binary wire format +module RON.Binary (parse, serialize) where + +import RON.Binary.Parse (parse) +import RON.Binary.Serialize (serialize) diff --git a/lib/RON/Binary/Parse.hs b/lib/RON/Binary/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Binary/Parse.hs @@ -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 diff --git a/lib/RON/Binary/Serialize.hs b/lib/RON/Binary/Serialize.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Binary/Serialize.hs @@ -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 diff --git a/lib/RON/Binary/Types.hs b/lib/RON/Binary/Types.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Binary/Types.hs @@ -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 diff --git a/lib/RON/Data.hs b/lib/RON/Data.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data.hs @@ -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 diff --git a/lib/RON/Data/Internal.hs b/lib/RON/Data/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/Internal.hs @@ -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" diff --git a/lib/RON/Data/LWW.hs b/lib/RON/Data/LWW.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/LWW.hs @@ -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 diff --git a/lib/RON/Data/ORSet.hs b/lib/RON/Data/ORSet.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/ORSet.hs @@ -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 diff --git a/lib/RON/Data/RGA.hs b/lib/RON/Data/RGA.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/RGA.hs @@ -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 diff --git a/lib/RON/Data/Time.hs b/lib/RON/Data/Time.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/Time.hs @@ -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"} diff --git a/lib/RON/Data/VersionVector.hs b/lib/RON/Data/VersionVector.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Data/VersionVector.hs @@ -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 diff --git a/lib/RON/Epoch.hs b/lib/RON/Epoch.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Epoch.hs @@ -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 diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Event.hs @@ -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 diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Event/Simulation.hs @@ -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) diff --git a/lib/RON/Internal/Prelude.hs b/lib/RON/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Internal/Prelude.hs @@ -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 -: diff --git a/lib/RON/Internal/Word.hs b/lib/RON/Internal/Word.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Internal/Word.hs @@ -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 diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema.hs @@ -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 diff --git a/lib/RON/Schema/TH.hs b/lib/RON/Schema/TH.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema/TH.hs @@ -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 diff --git a/lib/RON/Text.hs b/lib/RON/Text.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Text.hs @@ -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) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Text/Parse.hs @@ -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 = []} + } diff --git a/lib/RON/Text/Serialize.hs b/lib/RON/Text/Serialize.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Text/Serialize.hs @@ -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 = []} + } diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Text/Serialize/UUID.hs @@ -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 diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Types.hs @@ -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} diff --git a/lib/RON/UUID.hs b/lib/RON/UUID.hs new file mode 100644 --- /dev/null +++ b/lib/RON/UUID.hs @@ -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) diff --git a/ron.cabal b/ron.cabal new file mode 100644 --- /dev/null +++ b/ron.cabal @@ -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 +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