diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,21 +4,18 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} -import Control.DeepSeq (NFData, force) -import Control.Exception (evaluate) -import Control.Monad (void) import Criterion (bench, nf) import Criterion.Main (defaultConfig, defaultMainWith) import Criterion.Types (timeLimit) import RON.Text (parseWireFrames, serializeWireFrames) -import RON.Types (Atom, Op (..), RawOp (..), UUID, WireChunk (Raw), - WireReducedChunk) +import RON.Types (Atom, ClosedOp (..), Op (..), UUID, + WireChunk (Closed), WireReducedChunk) import qualified RON.UUID as UUID deriving instance NFData Atom +deriving instance NFData ClosedOp deriving instance NFData Op -deriving instance NFData RawOp deriving instance NFData UUID deriving instance NFData WireChunk deriving instance NFData WireReducedChunk @@ -30,9 +27,9 @@ 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 + closedOp = ClosedOp{reducerId = UUID.zero, objectId = UUID.zero, op} + op = Op{opId = UUID.zero, refId = UUID.zero, payload = []} + frame n = replicate n $ Closed closedOp serialized = [ (n :: Int, serializeWireFrames $ replicate 100 $ frame n) diff --git a/lib/Attoparsec/Extra.hs b/lib/Attoparsec/Extra.hs --- a/lib/Attoparsec/Extra.hs +++ b/lib/Attoparsec/Extra.hs @@ -4,10 +4,8 @@ ( module Attoparsec , char , endOfInputEx - , getPos , isSuccessful , label - , label' , parseOnlyL , takeL , withInputSize @@ -15,15 +13,14 @@ , (<+>) ) 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) +import RON.Util (ByteStringL) + parseOnlyL :: Parser a -> ByteStringL -> Either String a parseOnlyL p = parseOnly p . toStrict @@ -45,10 +42,10 @@ 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 +-- 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 () diff --git a/lib/Data/ZigZag.hs b/lib/Data/ZigZag.hs --- a/lib/Data/ZigZag.hs +++ b/lib/Data/ZigZag.hs @@ -2,18 +2,11 @@ module Data.ZigZag ( zzEncode - , zzEncodeInteger - , zzDecode8 - , zzDecode16 - , zzDecode32 , zzDecode64 - , zzDecodeInteger - , zzDecode ) where -import Data.Word -import Data.Int -import Data.Bits +import Data.Bits (Bits, FiniteBits, finiteBitSize, shiftL, shiftR, + xor, (.&.)) {-# SPECIALIZE INLINE zzEncode :: Int8 -> Word8 #-} {-# SPECIALIZE INLINE zzEncode :: Int16 -> Word16 #-} @@ -22,54 +15,10 @@ 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 --- a/lib/RON/Base64.hs +++ b/lib/RON/Base64.hs @@ -22,13 +22,11 @@ , 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 (ord) +import RON.Util (ByteStringL) import RON.Util.Word (Word4, Word6 (W6), Word60, leastSignificant4, leastSignificant6, leastSignificant60, safeCast) diff --git a/lib/RON/Binary/Parse.hs b/lib/RON/Binary/Parse.hs --- a/lib/RON/Binary/Parse.hs +++ b/lib/RON/Binary/Parse.hs @@ -13,8 +13,6 @@ parseString, ) where -import RON.Internal.Prelude - import Attoparsec.Extra (Parser, anyWord8, endOfInputEx, label, parseOnlyL, takeL, withInputSize) import qualified Attoparsec.Extra as Atto @@ -23,17 +21,17 @@ 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.Types (Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (..), Op (..), + OpTerm (TClosed, THeader, TQuery, TReduced), + UUID (UUID), WireChunk (Closed, Query, Value), + WireFrame, WireReducedChunk (..)) +import RON.Util (ByteStringL) import RON.Util.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) @@ -91,7 +89,7 @@ :: Size -- ^ expected input length -> Parser WireChunk parseChunk size = label "WireChunk" $ do - (consumed0, (term, op)) <- withInputSize parseDescAndRawOp + (consumed0, (term, op)) <- withInputSize parseDescAndClosedOp let parseReducedChunk wrcHeader isQuery = do wrcBody <- parseReducedOps $ fromIntegral size - consumed0 pure $ (if isQuery then Query else Value) WireReducedChunk{..} @@ -99,10 +97,10 @@ THeader -> parseReducedChunk op False TQuery -> parseReducedChunk op True TReduced -> fail "reduced op without a chunk" - TRaw -> assertSize size consumed0 $> Raw op + TClosed -> assertSize size consumed0 $> Closed op -- | Assert that is such as expected -assertSize :: Monad f => Size -> Int -> f () +assertSize :: MonadFail f => Size -> Int -> f () assertSize expected consumed = when (consumed /= fromIntegral expected) $ fail $ @@ -121,42 +119,42 @@ 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 +-- | 'Parser' for closed op, returning the op's terminator along with the op +parseDescAndClosedOp :: Parser (OpTerm, ClosedOp) +parseDescAndClosedOp = label "d+ClosedOp" $ 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 + DOpClosed -> (TClosed,) <$> parseClosedOp + DOpHeader -> (THeader,) <$> parseClosedOp + DOpQueryHeader -> (TQuery,) <$> parseClosedOp _ -> 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 +parseDescAndReducedOp = label "d+ClosedOp" $ do (desc, size) <- parseDesc unless (size == 0) $ fail $ "desc = " ++ show desc ++ ", size = " ++ show size case desc of - DOpReduced -> (TReduced,) <$> parseReducedOp + DOpReduced -> (TReduced,) <$> parseOpenOp _ -> 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 closed op without terminator +parseClosedOp :: Parser ClosedOp +parseClosedOp = label "ClosedOp" $ do + reducerId <- parseOpKey DUuidReducer + objectId <- parseOpKey DUuidObject + op <- parseOpenOp + pure ClosedOp{..} -- | 'Parser' for reduced op without terminator -parseReducedOp :: Parser Op -parseReducedOp = label "Op" $ do - opEvent <- parseOpKey DUuidEvent - opRef <- parseOpKey DUuidRef - opPayload <- parsePayload +parseOpenOp :: Parser Op +parseOpenOp = label "Op" $ do + opId <- parseOpKey DUuidOp + refId <- parseOpKey DUuidRef + payload <- parsePayload pure Op{..} -- | 'Parser' for an op key (type, object, event, or reference) @@ -167,11 +165,11 @@ guard $ desc == expectedType uuid size case desc of - DUuidType -> go - DUuidObject -> go - DUuidEvent -> go - DUuidRef -> go - _ -> fail $ show desc + DUuidReducer -> go + DUuidObject -> go + DUuidOp -> go + DUuidRef -> go + _ -> fail $ show desc -- | 'Parser' for UUID uuid diff --git a/lib/RON/Binary/Serialize.hs b/lib/RON/Binary/Serialize.hs --- a/lib/RON/Binary/Serialize.hs +++ b/lib/RON/Binary/Serialize.hs @@ -11,22 +11,20 @@ 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.Types (Atom (AFloat, AInteger, AString, AUuid), Op (..), - RawOp (..), UUID (UUID), - WireChunk (Query, Raw, Value), WireFrame, +import RON.Types (Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (..), Op (..), UUID (UUID), + WireChunk (Closed, Query, Value), WireFrame, WireReducedChunk (..)) +import RON.Util (ByteStringL) import RON.Util.Word (Word4, b0000, leastSignificant4, safeCast) -- | Serialize a frame @@ -49,37 +47,38 @@ [] -> chunkSize False 0 [c] -> (<> c) <$> chunkSize False (BSL.length c) c:cs -> - mconcat <$> + fold <$> 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 + Closed op -> serializeClosedOp DOpClosed 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 +-- | Serialize a closed op +serializeClosedOp :: Desc -> ClosedOp -> Either String ByteStringL +serializeClosedOp desc ClosedOp{..} = do keys <- sequenceA - [ serializeUuidType opType - , serializeUuidObject opObject - , serializeUuidEvent opEvent - , serializeUuidRef opRef + [ serializeUuidReducer reducerId + , serializeUuidObject objectId + , serializeUuidOpId opId + , serializeUuidRef refId ] - payload <- traverse serializeAtom opPayload - serializeWithDesc desc $ mconcat $ keys ++ payload + payloadValue <- traverse serializeAtom payload + serializeWithDesc desc $ fold $ keys ++ payloadValue where - Op{..} = op - serializeUuidType = serializeWithDesc DUuidType . serializeUuid - serializeUuidObject = serializeWithDesc DUuidObject . serializeUuid - serializeUuidEvent = serializeWithDesc DUuidEvent . serializeUuid - serializeUuidRef = serializeWithDesc DUuidRef . serializeUuid + Op{opId, refId, payload} = op + serializeUuidReducer = serializeWithDesc DUuidReducer . serializeUuid + serializeUuidObject = serializeWithDesc DUuidObject . serializeUuid + serializeUuidOpId = serializeWithDesc DUuidOp . 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{..} +serializeReducedOp d reducerId objectId op = + serializeClosedOp d ClosedOp{reducerId, objectId, op} -- | Serialize a 'UUID' serializeUuid :: UUID -> ByteStringL @@ -135,11 +134,11 @@ 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 + serializeClosedOp (if isQuery then DOpQueryHeader else DOpHeader) wrcHeader + body <- foldMapA (serializeReducedOp DOpReduced reducerId objectId) wrcBody pure $ header <> body where - RawOp{..} = wrcHeader + ClosedOp{..} = wrcHeader -- | Serialize a string atom serializeString :: Text -> ByteStringL diff --git a/lib/RON/Binary/Types.hs b/lib/RON/Binary/Types.hs --- a/lib/RON/Binary/Types.hs +++ b/lib/RON/Binary/Types.hs @@ -3,26 +3,24 @@ -- | 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 + = DOpClosed | DOpReduced | DOpHeader | DOpQueryHeader - | DUuidType + | DUuidReducer | DUuidObject - | DUuidEvent + | DUuidOp | DUuidRef | DAtomUuidZip | DUuidZipObject - | DUuidZipEvent + | DUuidZipOp | DUuidZipRef | DAtomUuid @@ -35,7 +33,7 @@ -- | Does the descriptor refer to an op descIsOp :: Desc -> Bool descIsOp = \case - DOpRaw -> True + DOpClosed -> True DOpReduced -> True DOpHeader -> True DOpQueryHeader -> True diff --git a/lib/RON/Data.hs b/lib/RON/Data.hs deleted file mode 100644 --- a/lib/RON/Data.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# 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, - mkStateChunk, - 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(2018-11-08, cblp, #27) 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 deleted file mode 100644 --- a/lib/RON/Data/Internal.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# 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, #26) 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) -- none - -pattern Some :: Atom -pattern Some = AUuid (UUID 0xdf3c69000000000 0) -- some - -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" - -pattern ATrue :: Atom -pattern ATrue = AUuid (UUID 0xe36e69000000000 0) - -pattern AFalse :: Atom -pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0) - -instance Replicated Bool where encoding = payloadEncoding - -instance ReplicatedAsPayload Bool where - toPayload b - | b = [ATrue] - | otherwise = [AFalse] - - fromPayload = \case - [ATrue] -> pure True - [AFalse] -> pure False - _ -> fail "Expected single UUID" diff --git a/lib/RON/Data/LWW.hs b/lib/RON/Data/LWW.hs deleted file mode 100644 --- a/lib/RON/Data/LWW.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/lib/RON/Data/ORSet.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/lib/RON/Data/RGA.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# 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 Data.List (genericLength) -import qualified Data.Map.Strict as Map -import Data.Monoid (Last (..)) -import qualified Data.Text as Text - -import RON.Data.Internal -import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, - getEventUuids) -import RON.Types (Object (..), Op (..), StateChunk (..), UUID) -import RON.Util.Word (pattern B11, ls60) -import RON.UUID (pattern Zero, uuidVersion) -import qualified RON.UUID as UUID - --- | opEvent = vertex id --- opRef: --- 0 = value is alive, --- _ = tombstone event, value is backup for undo --- opPayload: the value -type Vertex = Op - -data VertexListItem = VertexListItem - { itemValue :: Vertex - , itemNext :: Maybe UUID - } - deriving (Eq, Show) - -data VertexList = VertexList - { listHead :: UUID - , listItems :: HashMap UUID VertexListItem - } - deriving (Eq, Show) - -instance Semigroup VertexList where - (<>) = merge - -vertexListToOps :: Maybe VertexList -> [Vertex] -vertexListToOps mv = case mv of - Nothing -> [] - Just VertexList{..} -> go listHead listItems - where - go root items = let - VertexListItem{..} = - HashMap.lookupDefault - (error $ unlines - $ ["Cannot find vertex id", show root, "in array"] - ++ map show (HashMap.toList items) - ++ ["Original array is", show $ fromJust mv]) - root - items - rest = case itemNext of - Just next -> go next (HashMap.delete root items) - Nothing -> [] - in itemValue : rest - -vertexListFromOps :: [Vertex] -> Maybe VertexList -vertexListFromOps = foldr go mempty where - go v@Op{opEvent = vid} vlist = - Just $ VertexList{listHead = vid, listItems = vlist'} - where - item itemNext = VertexListItem{itemValue = v, itemNext} - vlist' = case vlist of - Nothing -> HashMap.singleton vid (item Nothing) - Just VertexList{listHead, listItems} -> - HashMap.insert vid (item $ Just listHead) listItems - --- | 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 = op{opRef = Zero} - , itemNext = Nothing - } - } - } - -patchSetFromChunk :: ReducedChunk -> PatchSet -patchSetFromChunk ReducedChunk{rcRef, rcBody} = - case uuidVersion $ 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 = v@Op{opRef}} <- - HashMap.lookup parent targetItems - let item' = item{itemValue = v{opRef = max opRef tombstone}} - pure $ HashMap.insert parent item' targetItems - -merge :: VertexList -> VertexList -> VertexList -merge v1 v2 = - fromMaybe undefined . vertexListFromOps $ - (merge' `on` vertexListToOps . Just) v1 v2 - -merge' :: [Vertex] -> [Vertex] -> [Vertex] -merge' [] vs2 = vs2 -merge' vs1 [] = vs1 -merge' w1@(v1 : vs1) w2@(v2 : vs2) = - case compare e1 e2 of - LT -> v2 : merge' w1 vs2 - GT -> v1 : merge' vs1 w2 - EQ -> mergeVertices : merge' vs1 vs2 - where - Op{opEvent = e1, opRef = tombstone1, opPayload = p1} = v1 - Op{opEvent = e2, opRef = tombstone2, opPayload = p2} = v2 - - -- priority of deletion - mergeVertices = 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 - vertexIds <- lift $ getEventUuids $ ls60 $ genericLength items - ops <- for (zip items vertexIds) $ \(item, vertexId) -> do - payload <- newRon item - pure $ Op vertexId Zero payload - oid <- lift getEventUuid - let version = maximumDef oid $ map opEvent ops - tell $ Map.singleton (rgaType, oid) $ StateChunk version ops - pure oid - - getObject obj@Object{..} = do - StateChunk{..} <- getObjectStateChunk obj - mItems <- for stateBody $ \Op{..} -> case opRef of - Zero -> Just <$> fromRon opPayload objectFrame - _ -> pure Nothing - pure . RGA $ catMaybes mItems - --- | 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 eqAliveOnPayload 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 - , .. - } - - where - eqAliveOnPayload - Op{opRef = Zero, opPayload = p1} - Op{opRef = Zero, opPayload = p2} - = p1 == p2 - eqAliveOnPayload _ _ = False - --- | 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 deleted file mode 100644 --- a/lib/RON/Data/Time.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# 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 (RonType, 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_ "Day" diff --git a/lib/RON/Data/VersionVector.hs b/lib/RON/Data/VersionVector.hs deleted file mode 100644 --- a/lib/RON/Data/VersionVector.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# 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 --- a/lib/RON/Epoch.hs +++ b/lib/RON/Epoch.hs @@ -10,14 +10,8 @@ runEpochClockFromCurrentTime, ) where -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ReaderT (ReaderT), reader, runReaderT) -import Data.IORef (IORef, atomicModifyIORef', newIORef) -import Data.Ratio ((%)) -import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) -import Data.Word (Word64) import RON.Event (EpochEvent (EpochEvent), EpochTime, LocalTime (TEpoch), ReplicaClock, ReplicaId, diff --git a/lib/RON/Error.hs b/lib/RON/Error.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Error.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} + +module RON.Error ( + Error (..), + MonadE, + errorContext, + liftMaybe, + throwErrorString, + throwErrorText, +) where + +import Data.String (IsString, fromString) + +data Error + = Error Text [Error] + | ErrorContext Text Error + deriving (Exception, Eq, Show) + +instance IsString Error where + fromString s = Error (fromString s) [] + +type MonadE = MonadError Error + +errorContext :: MonadE m => Text -> m a -> m a +errorContext ctx action = action `catchError` (throwError . ErrorContext ctx) + +liftMaybe :: MonadE m => Text -> Maybe a -> m a +liftMaybe msg = maybe (throwErrorText msg) pure + +throwErrorText :: MonadE m => Text -> m a +throwErrorText msg = throwError $ Error msg [] + +throwErrorString :: (MonadError e m, IsString e) => String -> m a +throwErrorString = throwError . fromString diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} @@ -29,10 +31,8 @@ , 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 Data.Hashable (hashUsing, hashWithSalt) import RON.Util.Word (pattern B00, pattern B01, pattern B10, pattern B11, Word12, Word16, Word2, Word24, @@ -84,10 +84,7 @@ -- | Replica identifier data ReplicaId = ReplicaId !Naming !Word60 - deriving (Eq, Show) - -instance Hashable ReplicaId where - hashWithSalt = hashUsing $ \(ReplicaId n r) -> (n, r) + deriving (Eq, Show, Generic, Hashable) -- | Generic Lamport time event. -- Cannot be 'Ord' because we can't compare different types of clocks. @@ -171,8 +168,10 @@ advanceToUuid = advance . uuidValue . UUID.split -- | Get a single event -getEvent :: ReplicaClock m => m EpochEvent -getEvent = head <$> getEvents (ls60 1) +getEvent :: (HasCallStack, ReplicaClock m) => m EpochEvent +getEvent = getEvents (ls60 1) >>= \case + e:_ -> pure e + [] -> error "getEvents returned no events" -- | Get a single event as UUID getEventUuid :: ReplicaClock m => m UUID diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs --- a/lib/RON/Event/Simulation.hs +++ b/lib/RON/Event/Simulation.hs @@ -15,22 +15,16 @@ , 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 RON.Event (EpochEvent (EpochEvent), ReplicaClock, ReplicaId (ReplicaId), advance, getEvents, getPid) -import RON.Util.Word (Word60, ls60, safeCast, word60add) +import RON.Util.Word (Word60, 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) + deriving (Applicative, Functor, Monad, MonadError e) instance MonadTrans NetworkSimT where lift = NetworkSim . lift @@ -39,7 +33,7 @@ -- | ReplicaSim inside Lamport clock simulation. newtype ReplicaSimT m a = ReplicaSim (ReaderT ReplicaId (NetworkSimT m) a) - deriving (Applicative, Functor, Monad) + deriving (Applicative, Functor, Monad, MonadError e) type ReplicaSim = ReplicaSimT Identity @@ -56,7 +50,7 @@ t0orig = HM.lookupDefault (ls60 0) rid replicaStates ReplicaId _ r = rid randomLeap = - ls60 $ (safeCast t0orig + safeCast n + safeCast r) `mod` 41 + ls60 . fromIntegral $ hash (t0orig, n, r) `mod` 0x100000000 t0 = t0orig `word60add` randomLeap t1 = t0 `word60add` n in ((t0, t1), HM.insert rid t1 replicaStates) @@ -66,7 +60,7 @@ advance time = ReplicaSim $ do rid <- ask - lift . NetworkSim . modify $ HM.alter (Just . advancePS) rid + lift . NetworkSim . modify' $ HM.alter (Just . advancePS) rid where advancePS = \case Nothing -> time diff --git a/lib/RON/Internal/Prelude.hs b/lib/RON/Internal/Prelude.hs deleted file mode 100644 --- a/lib/RON/Internal/Prelude.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# 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/Schema.hs b/lib/RON/Schema.hs deleted file mode 100644 --- a/lib/RON/Schema.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module RON.Schema ( - CaseTransform (..), - Declaration (..), - Field (..), - Opaque (..), - OpaqueAnnotations (..), - RonType (..), - Schema, - StructAnnotations (..), - StructLww (..), - TAtom (..), - TEnum (..), - TComposite (..), - TObject (..), - defaultOpaqueAnnotations, - defaultStructAnnotations, - opaqueAtoms, - opaqueAtoms_, - opaqueObject, -) where - -import RON.Internal.Prelude - -import qualified Data.Text as Text - -data TAtom = TAInteger | TAString - deriving (Show) - -data RonType - = TAtom TAtom - | TComposite TComposite - | TObject TObject - | TOpaque Opaque - deriving (Show) - -data TComposite - = TOption RonType - | TEnum TEnum - deriving (Show) - -data TEnum = Enum {enumName :: Text, enumItems :: [Text]} - 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 - { saHaskellFieldPrefix :: Text - , saHaskellFieldCaseTransform :: Maybe CaseTransform - } - deriving (Show) - -defaultStructAnnotations :: StructAnnotations -defaultStructAnnotations = StructAnnotations - {saHaskellFieldPrefix = Text.empty, saHaskellFieldCaseTransform = Nothing} - -data CaseTransform = TitleCase - deriving (Show) - -newtype Field = Field{fieldType :: RonType} - deriving (Show) - -data Declaration = DEnum TEnum | DOpaque Opaque | DStructLww StructLww - -type Schema = [Declaration] - -newtype OpaqueAnnotations = OpaqueAnnotations{oaHaskellType :: Maybe Text} - deriving (Show) - -defaultOpaqueAnnotations :: OpaqueAnnotations -defaultOpaqueAnnotations = OpaqueAnnotations{oaHaskellType = Nothing} - -data Opaque = Opaque - { opaqueIsObject :: Bool - , opaqueName :: Text - , opaqueAnnotations :: OpaqueAnnotations - } - deriving (Show) - -opaqueObject :: Text -> OpaqueAnnotations -> RonType -opaqueObject name = TOpaque . Opaque True name - -opaqueAtoms :: Text -> OpaqueAnnotations -> RonType -opaqueAtoms name = TOpaque . Opaque False name - -opaqueAtoms_ :: Text -> RonType -opaqueAtoms_ name = TOpaque $ Opaque False name defaultOpaqueAnnotations diff --git a/lib/RON/Schema/EDN.hs b/lib/RON/Schema/EDN.hs deleted file mode 100644 --- a/lib/RON/Schema/EDN.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module RON.Schema.EDN (parseSchema) where - -import RON.Internal.Prelude - -import Control.Monad.State.Strict (StateT, evalStateT, get, gets, put) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Identity (runIdentityT) -import Data.Attoparsec.Lazy (Result (Done)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.Char (isSpace) -import Data.EDN (Tagged (NoTag, Tagged), Value (List, Map, Symbol), - (.!=), (.:?)) -import Data.EDN.Encode (fromTagged) -import Data.EDN.Parser (parseBSL) -import Data.EDN.Types (EDNList, EDNMap) -import Data.EDN.Types.Class (Parser, parseEither, typeMismatch) -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as TextL -import Data.Text.Lazy.Builder (toLazyText) -import qualified Data.Text.Lazy.Encoding as TextL - -import RON.Data.Time (day) -import RON.Schema - -newtype Env = Env {knownTypes :: Map Text RonType} - deriving (Show) - -startEnv :: Env -startEnv = Env - { knownTypes = Map.fromList - [ ("Boole", - opaqueAtoms "Boole" OpaqueAnnotations{oaHaskellType = Just "Bool"}) - , ("Day", day) - , ("Integer", TAtom TAInteger) - , ("RgaString", TObject $ TRga char) - , ("String", TAtom TAString) - , ("VersionVector", TObject TVersionVector) - ] - } - where - char = opaqueAtoms "Char" OpaqueAnnotations{oaHaskellType = Just "Char"} - -type Parser' = StateT Env Parser - -parseDeclaration :: Tagged Value -> Parser' Declaration -parseDeclaration = withNoTag $ withList "declaration" $ \case - func : args -> go =<< parseText "declaration name" func - where - go = \case - "enum" -> DEnum <$> parseEnum args - "opaque" -> DOpaque <$> parseOpaque args - "struct_lww" -> DStructLww <$> parseStructLww args - name -> fail $ "unknown declaration " ++ Text.unpack name - [] -> fail "empty declaration" - -parseEnum :: EDNList -> Parser' TEnum -parseEnum code = do - enum <- case code of - name : items -> Enum - <$> parseText "enum name" name - <*> traverse (parseText "enum item") items - [] -> fail - "Expected declaration in the form\ - \ (enum ...)" - insertKnownType (enumName enum) (TComposite $ TEnum enum) - pure enum - -parseOpaque :: EDNList -> Parser' Opaque -parseOpaque code = do - opaque <- case code of - kind : name : annotations -> - parseText "opaque kind" kind >>= \case - "atoms" -> go False - "object" -> go True - _ -> fail "opaque kind must be either atoms or object" - where - go isObject = - Opaque - isObject - <$> parseText "opaque name" name - <*> parseAnnotations - parseAnnotations = case annotations of - [] -> pure defaultOpaqueAnnotations - _ -> fail "opaque annotations are not implemented yet" - _ -> fail - "Expected declaration in the form\ - \ (opaque ...)" - insertKnownType (opaqueName opaque) (TOpaque opaque) - pure opaque - -insertKnownType :: Text -> RonType -> Parser' () -insertKnownType name typ = do - env@Env{knownTypes} <- get - case Map.lookup name knownTypes of - Nothing -> put env{knownTypes = Map.insert name typ knownTypes} - Just _ -> fail $ "duplicate declaration of type " ++ Text.unpack name - -parseStructLww :: EDNList -> Parser' StructLww -parseStructLww code = do - struct <- case code of - name : body -> do - let (annotations, fields) = span isTagged body - StructLww - <$> parseText "struct_lww name" name - <*> parseFields fields - <*> parseAnnotations annotations - [] -> fail - "Expected declaration in the form\ - \ (struct_lww ... ...)" - insertKnownType (structName struct) (TObject $ TStructLww struct) - pure struct - - where - - parseFields = \case - [] -> pure mempty - nameAsTagged : typeAsTagged : cont -> do - name <- parseText "struct_lww field name" nameAsTagged - typ <- parseType typeAsTagged - Map.insert name (Field typ) <$> parseFields cont - [f] -> fail $ "field " ++ showEdn f ++ " must have type" - - parseAnnotations annTaggedValues = do - annValues <- traverse unwrapTag annTaggedValues - case lookup "haskell" annValues of - Nothing -> pure defaultStructAnnotations - Just annValue -> - withMap "struct_lww haskell annotations map" go annValue - where - unwrapTag = \case - Tagged value prefix tag -> let - name | BS.null prefix = tag | otherwise = prefix <> "/" <> tag - in pure (name, value) - NoTag _ -> fail "annotation must be a tagged value" - go m = lift $ - StructAnnotations - <$> m .:? Symbol "" "field_prefix" .!= "" - <*> (m .:? Symbol "" "field_case" >>= traverse parseCaseTransform) - -parseCaseTransform :: Tagged Value -> Parser CaseTransform -parseCaseTransform v = - runIdentityT (parseText "case transformation" v) >>= \case - "title" -> pure TitleCase - _ -> fail "unknown case transformation" - -parseSchema :: Monad m => String -> m Schema -parseSchema string = either fail pure $ do - values <- parseEdnStream $ encodeUtf8L string - parseEither ((`evalStateT` startEnv) . traverse parseDeclaration) values - -parseEdnStream :: ByteStringL -> Either String EDNList -parseEdnStream input - | BSLC.all isSpace input = pure [] - | otherwise = - case parseBSL input of - Done rest value -> (value :) <$> parseEdnStream rest - failure -> Left $ show failure - -parseType :: Tagged Value -> Parser' RonType -parseType = withNoTag $ \case - Symbol "" name -> - gets (Map.lookup (Text.decodeUtf8 name) . knownTypes) >>= \case - Nothing -> fail $ "unknown type " ++ decodeUtf8 name - Just typ -> pure typ - Symbol _ _ -> fail "types must not be prefixed" - List expr -> evalType expr - value -> lift $ typeMismatch "type symbol or expression" value - -evalType :: EDNList -> Parser' RonType -evalType = \case - [] -> fail "empty type expression" - [a] -> parseType a - func : args -> applyType func =<< traverse parseType args - -applyType :: Tagged Value -> [RonType] -> Parser' RonType -applyType func args = parseText "parametric type" func >>= go - where - - go = \case - "Option" -> apply "Option" $ TComposite . TOption - "ORSet" -> apply "ORSet" $ TObject . TORSet - name -> fail $ "unknown parametric type " ++ Text.unpack name - - apply name wrapper = case args of - [a] -> pure $ wrapper a - _ -> fail $ name ++ " expects 1 argument, got " ++ show (length args) - --- * Parser helpers - -withNoPrefix - :: Monad m - => String -> (ByteString -> m a) -> ByteString -> ByteString -> m a -withNoPrefix ctx f prefix name = do - unless (prefix == "") $ fail $ ctx ++ ": empty prefix expected" - f name - -withList :: String -> (EDNList -> Parser' a) -> Value -> Parser' a -withList expected f = \case - List list -> f list - value -> lift $ typeMismatch expected value - -withMap :: String -> (EDNMap -> Parser' a) -> Value -> Parser' a -withMap expected f = \case - Map m -> f m - value -> lift $ typeMismatch expected value - -withNoTag :: Monad m => (Value -> m a) -> Tagged Value -> m a -withNoTag f = \case - NoTag value -> f value - Tagged _ prefix tag -> fail - $ "when expecting a non-tagged value, encountered tag " - ++ decodeUtf8 prefix ++ "/" ++ decodeUtf8 tag ++ " instead" - -withSymbol - :: MonadTrans t - => String -> (ByteString -> ByteString -> t Parser a) -> Value -> t Parser a -withSymbol expected f = \case - Symbol prefix symbol -> f prefix symbol - value -> lift $ typeMismatch expected value - -parseText - :: (MonadTrans t, Monad (t Parser)) - => String -> Tagged Value -> t Parser Text -parseText name = - withNoTag $ withSymbol (name ++ " symbol") $ withNoPrefix name $ - pure . Text.decodeUtf8 - --- * ByteString helpers - -decodeUtf8 :: ByteString -> String -decodeUtf8 = Text.unpack . Text.decodeUtf8 - -encodeUtf8L :: String -> ByteStringL -encodeUtf8L = TextL.encodeUtf8 . TextL.pack - -isTagged :: Tagged a -> Bool -isTagged = \case - NoTag {} -> False - Tagged{} -> True - -showEdn :: Tagged Value -> String -showEdn = TextL.unpack . toLazyText . fromTagged diff --git a/lib/RON/Schema/TH.hs b/lib/RON/Schema/TH.hs deleted file mode 100644 --- a/lib/RON/Schema/TH.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -module RON.Schema.TH( - module X, - mkReplicated, - 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 Data.Char (toTitle) -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GHC.Stack (HasCallStack) -import Language.Haskell.TH (Exp (VarE), bindS, conE, conP, conT, doE, - lamCaseE, letS, listE, noBindS, normalB, - recC, recConE, sigD, varE, varP, varT) -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), quoteDec, - quoteExp, quotePat, quoteType) -import Language.Haskell.TH.Syntax (dataToPatQ, lift, liftData) - -import RON.Data (Replicated (..), ReplicatedAsObject (..), - ReplicatedAsPayload (..), 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 as X -import qualified RON.Schema.EDN as EDN -import RON.Types (Object (..), UUID) -import qualified RON.UUID as UUID - -mkReplicated :: HasCallStack => QuasiQuoter -mkReplicated = QuasiQuoter{quoteDec, quoteExp = e, quotePat = e, quoteType = e} - where - e = error "declaration only" - quoteDec = EDN.parseSchema >=> mkReplicated' - --- | Generate Haskell types from RON-Schema -mkReplicated' :: HasCallStack => Schema -> TH.DecsQ -mkReplicated' = fmap fold . traverse fromDecl where - fromDecl decl = case decl of - DEnum e -> mkEnum e - DOpaque _ -> pure [] - 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 :: HasCallStack => StructLww -> TH.DecsQ -mkReplicatedStructLww struct = do - fields <- for (Map.assocs structFields) $ \(field'Name, Field{fieldType}) -> - case UUID.mkName . BSC.pack $ Text.unpack field'Name of - Just field'RonName -> do - field'Var <- TH.newName $ Text.unpack field'Name - pure Field'{field'Type = fieldType, ..} - 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{saHaskellFieldPrefix, saHaskellFieldCaseTransform} = - structAnnotations - - name = mkNameT structName - - structT = conT name - - objectT = [t| Object $structT |] - - mkDataType = TH.dataD (TH.cxt []) name [] Nothing - [recC name - [ TH.varBangType (mkNameT $ mkHaskellFieldName fieldName) $ - TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) viewType - | (fieldName, Field fieldType) <- Map.assocs structFields - , let viewType = mkViewType fieldType - ]] - [] - - 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 base = saHaskellFieldPrefix <> base' where - base' = case saHaskellFieldCaseTransform of - Nothing -> base - Just TitleCase -> case Text.uncons base of - Nothing -> base - Just (b, baseTail) -> Text.cons (toTitle b) baseTail - - 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 :: HasCallStack => RonType -> TH.TypeQ -mkViewType = \case - TAtom atom -> case atom of - TAInteger -> [t| Int64 |] - TAString -> [t| Text |] - TComposite t -> case t of - TEnum Enum{enumName} -> conT $ mkNameT enumName - 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{opaqueName, opaqueAnnotations} -> let - OpaqueAnnotations{oaHaskellType} = opaqueAnnotations - in conT $ mkNameT $ fromMaybe opaqueName oaHaskellType - where - wrapList a = [t| [$(mkViewType a)] |] - -valD' :: TH.Name -> TH.ExpQ -> TH.DecQ -valD' name body = TH.valD (varP name) (normalB body) [] - -isObjectType :: RonType -> Bool -isObjectType = \case - TAtom _ -> False - TComposite _ -> False - TObject _ -> True - TOpaque Opaque{opaqueIsObject} -> opaqueIsObject - -mkEnum :: TEnum -> TH.DecsQ -mkEnum Enum{enumName, enumItems} = do - itemsUuids <- for enumItems $ \item -> do - uuid <- UUID.mkName $ Text.encodeUtf8 item - pure (mkNameT item, uuid) - dataType <- mkDataType - [instanceReplicated] <- mkInstanceReplicated - [instanceReplicatedAsPayload] <- mkInstanceReplicatedAsPayload itemsUuids - pure [dataType, instanceReplicated, instanceReplicatedAsPayload] - - where - - typeName = conT $ mkNameT enumName - - mkDataType = TH.dataD (TH.cxt []) (mkNameT enumName) [] Nothing - [TH.normalC (mkNameT item) [] | item <- enumItems] [] - - mkInstanceReplicated = [d| - instance Replicated $typeName where - encoding = payloadEncoding - |] - - mkInstanceReplicatedAsPayload itemsUuids = [d| - instance ReplicatedAsPayload $typeName where - toPayload = toPayload . $toUuid - fromPayload = fromPayload >=> $fromUuid - |] - where - toUuid = lamCaseE - [match (conP name []) (liftData uuid) | (name, uuid) <- itemsUuids] - fromUuid = lamCaseE - $ [ match (liftDataP uuid) [| pure $(conE name) |] - | (name, uuid) <- itemsUuids - ] - ++ [match TH.wildP [| fail "expected one of enum items" |]] - liftDataP = dataToPatQ $ const Nothing - match pat body = TH.match pat (normalB body) [] diff --git a/lib/RON/Storage.hs b/lib/RON/Storage.hs deleted file mode 100644 --- a/lib/RON/Storage.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - --- | RON File Storage. For usage, see "RON.Storage.IO". -module RON.Storage ( - Collection (..), - CollectionName, - DocId (..), - Document (..), - DocVersion, - MonadStorage (..), - createDocument, - decodeDocId, - docIdFromUuid, - loadDocument, - modify, - readVersion, -) where - -import Control.Monad (unless, when) -import Control.Monad.Except (MonadError, catchError, liftEither, - throwError) -import Control.Monad.State.Strict (StateT, execStateT) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.Foldable (for_) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Traversable (for) -import Data.Typeable (Typeable) -import System.FilePath (()) - -import RON.Data (ReplicatedAsObject, reduceObject) -import RON.Event (ReplicaClock, getEventUuid) -import RON.Text (parseStateFrame, serializeStateFrame) -import RON.Types (Object (Object), UUID, objectFrame, objectId) -import qualified RON.UUID as UUID - --- | Document version identifier (file name) -type DocVersion = FilePath - --- | Document identifier (directory name), --- should be a RON-Base32-encoded RON-UUID. -newtype DocId a = DocId FilePath - deriving (Eq, Ord) - -instance Collection a => Show (DocId a) where - show (DocId file) = collectionName @a file - --- | Collection (directory name) -type CollectionName = FilePath - --- | A type that intended to be put in a separate collection must define a --- Collection instance. -class (ReplicatedAsObject a, Typeable a) => Collection a where - - collectionName :: CollectionName - - -- | Called when RON parser fails. - fallbackParse :: UUID -> ByteString -> Either String (Object a) - fallbackParse _ _ = Left "no fallback parser implemented" - --- | Storage backend interface -class (ReplicaClock m, MonadError String m) => MonadStorage m where - getCollections :: m [CollectionName] - - -- | Must return @[]@ for non-existent collection - getDocuments :: Collection a => m [DocId a] - - -- | Must return @[]@ for non-existent document - getDocumentVersions :: Collection a => DocId a -> m [DocVersion] - - -- | Must create collection and document if not exist - saveVersionContent - :: Collection a => DocId a -> DocVersion -> ByteString -> m () - - loadVersionContent :: Collection a => DocId a -> DocVersion -> m ByteString - - deleteVersion :: Collection a => DocId a -> DocVersion -> m () - - changeDocId :: Collection a => DocId a -> DocId a -> m () - --- | Try decode UUID from a file name -decodeDocId - :: DocId a - -> Maybe (Bool, UUID) -- ^ Bool = is document id a valid UUID encoding -decodeDocId (DocId file) = do - uuid <- UUID.decodeBase32 file - pure (UUID.encodeBase32 uuid == file, uuid) - --- | Load document version as an object -readVersion - :: MonadStorage m - => Collection a => DocId a -> DocVersion -> m (Object a, IsTouched) -readVersion docid version = do - (isObjectIdValid, objectId) <- - liftEither $ - maybe (Left $ "Bad Base32 UUID " ++ show docid) Right $ - decodeDocId docid - unless isObjectIdValid $ throwError $ "Not a Base32 UUID " ++ show docid - contents <- loadVersionContent docid version - case parseStateFrame contents of - Right objectFrame -> - pure (Object{objectId, objectFrame}, IsTouched False) - Left ronError -> case fallbackParse objectId contents of - Right object -> pure (object, IsTouched True) - Left fallbackError -> throwError $ case BSLC.head contents of - '{' -> fallbackError - _ -> ronError - --- | A thing (e.g. document) was fixed during loading. --- It it was fixed during loading it must be saved to the storage. -newtype IsTouched = IsTouched Bool - deriving Show - --- | Result of DB reading, loaded document with information about its versions -data Document a = Document - { value :: Object a - -- ^ Merged value. - , versions :: NonEmpty DocVersion - , isTouched :: IsTouched - } - deriving Show - --- | Load all versions of a document -loadDocument :: (Collection a, MonadStorage m) => DocId a -> m (Document a) -loadDocument docid = loadRetry (3 :: Int) - where - loadRetry n - | n > 0 = do - versions0 <- getDocumentVersions docid - case versions0 of - [] -> - throwError $ - "Document with id " ++ show docid ++ " has not found." - v:vs -> do - let versions = v :| vs - let wrapDoc (value, isTouched) = - Document{value, versions, isTouched} - e1 <- - for versions $ \ver -> do - let ctx = "document " ++ show docid - ++ ", version " ++ ver - ++ ": " - e1 <- try $ readVersion docid ver - pure $ fmapL (ctx ++) e1 - liftEither $ wrapDoc <$> vsconcat e1 - | otherwise = throwError "Maximum retries exceeded" - --- | Validation-like version of 'sconcat'. -vsconcat - :: NonEmpty (Either String (Object a, IsTouched)) - -> Either String (Object a, IsTouched) -vsconcat = foldr1 vappend - where - vappend (Left e1) (Left e2) = Left $ e1 ++ "\n" ++ e2 - vappend e1@(Left _ ) (Right _ ) = e1 - vappend (Right _ ) e2@(Left _ ) = e2 - vappend (Right r1) (Right r2) = - (, IsTouched (t1 || t2)) <$> reduceObject a1 a2 where - (a1, IsTouched t1) = r1 - (a2, IsTouched t2) = r2 - -try :: MonadError e m => m a -> m (Either e a) -try ma = (Right <$> ma) `catchError` (pure . Left) - -fmapL :: (a -> b) -> Either a c -> Either b c -fmapL f = \case - Left a -> Left $ f a - Right c -> Right c - --- | Load document, apply changes and put it back to storage -modify - :: (Collection a, MonadStorage m) - => DocId a -> StateT (Object a) m () -> m (Object a) -modify docid f = do - oldDoc <- loadDocument docid - newObj <- execStateT f $ value oldDoc - createVersion (Just (docid, oldDoc)) newObj - pure newObj - --- | Create new version of an object/document. --- If the document doesn't exist yet, it will be created. -createVersion - :: forall a m - . (Collection a, MonadStorage m) - => Maybe (DocId a, Document a) - -- ^ 'Just', if document exists already; 'Nothing' otherwise. - -> Object a - -> m () -createVersion mDoc newObj = case mDoc of - Nothing -> save (DocId @a $ UUID.encodeBase32 objectId) [] - Just (docid, oldDoc) -> do - let Document{value = oldObj, versions, isTouched = IsTouched isTouched} - = oldDoc - when (newObj /= oldObj || length versions /= 1 || isTouched) $ - save docid versions - where - Object{objectId, objectFrame} = newObj - - save docid oldVersions = do - newVersion <- UUID.encodeBase32 <$> getEventUuid - saveVersionContent docid newVersion (serializeStateFrame objectFrame) - for_ oldVersions $ deleteVersion docid - --- | Create document assuming it doesn't exist yet. -createDocument :: (Collection a, MonadStorage m) => Object a -> m () -createDocument = createVersion Nothing - -docIdFromUuid :: UUID -> DocId a -docIdFromUuid = DocId . UUID.encodeBase32 diff --git a/lib/RON/Storage/IO.hs b/lib/RON/Storage/IO.hs deleted file mode 100644 --- a/lib/RON/Storage/IO.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | A real-world file storage. --- --- Typical usage: --- --- @ --- import RON.Storage.IO as Storage --- --- main = do --- let dataDir = ".\/data\/" --- h <- Storage.'newHandle' dataDir --- 'runStorage' h $ do --- obj <- 'newObject' Note{active = True, text = "Write an example"} --- 'createDocument' obj --- @ -module RON.Storage.IO ( - module X, - -- * Handle - Handle, - OnDocumentChanged (..), - newHandle, - setOnDocumentChanged, - -- * Storage - Storage, - runStorage, -) where - -import Control.Exception (catch, throwIO) -import Control.Monad.Except (ExceptT (ExceptT), MonadError, - runExceptT, throwError) -import Control.Monad.Extra (filterM, unless, when, whenJust) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT (ReaderT), ask, runReaderT) -import Control.Monad.Trans (lift) -import Data.Bits (shiftL) -import qualified Data.ByteString.Lazy as BSL -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Word (Word64) -import Network.Info (MAC (MAC), getNetworkInterfaces, mac) -import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock) -import RON.Event (EpochTime, ReplicaClock, ReplicaId, advance, - applicationSpecific, getEvents, getPid) -import System.Directory (canonicalizePath, createDirectoryIfMissing, - doesDirectoryExist, doesPathExist, - listDirectory, removeFile, renameDirectory) -import System.FilePath (()) -import System.IO.Error (isDoesNotExistError) - -import RON.Storage as X - --- | Environment is the dataDir -newtype Storage a = Storage (ExceptT String (ReaderT Handle EpochClock) a) - deriving (Applicative, Functor, Monad, MonadError String, MonadIO) - --- | Run a 'Storage' action -runStorage :: Handle -> Storage a -> IO a -runStorage h@Handle{hReplica, hClock} (Storage action) = do - res <- - runEpochClock hReplica hClock $ - (`runReaderT` h) $ - runExceptT action - either fail pure res - -instance ReplicaClock Storage where - getPid = Storage . lift $ lift getPid - getEvents = Storage . lift . lift . getEvents - advance = Storage . lift . lift . advance - -instance MonadStorage Storage where - getCollections = Storage $ do - Handle{hDataDir} <- ask - liftIO $ - listDirectory hDataDir - >>= filterM (doesDirectoryExist . (hDataDir )) - - getDocuments :: forall doc. Collection doc => Storage [DocId doc] - getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc) - - getDocumentVersions = listDirectoryIfExists . docDir - - saveVersionContent docid version content = do - Storage $ do - Handle{hDataDir} <- ask - let docdir = hDataDir docDir docid - liftIO $ do - createDirectoryIfMissing True docdir - BSL.writeFile (docdir version) content - emitDocumentChanged docid - - loadVersionContent docid version = Storage $ do - Handle{hDataDir} <- ask - liftIO $ BSL.readFile $ hDataDir docDir docid version - - deleteVersion docid version = Storage $ do - Handle{hDataDir} <- ask - liftIO $ do - let file = hDataDir docDir docid version - removeFile file - `catch` \e -> - unless (isDoesNotExistError e) $ throwIO e - - changeDocId old new = do - renamed <- Storage $ do - Handle{hDataDir} <- ask - let oldPath = hDataDir docDir old - newPath = hDataDir docDir new - oldPathCanon <- liftIO $ canonicalizePath oldPath - newPathCanon <- liftIO $ canonicalizePath newPath - let pathsDiffer = newPathCanon /= oldPathCanon - when pathsDiffer $ do - newPathExists <- liftIO $ doesPathExist newPath - when newPathExists $ - throwError $ unwords - [ "changeDocId" - , show old, "[", oldPath, "->", oldPathCanon, "]" - , show new, "[", newPath, "->", newPathCanon, "]" - , ": internal error: new document id is already taken" - ] - liftIO $ renameDirectory oldPath newPath - pure pathsDiffer - when renamed $ emitDocumentChanged new - --- | Storage handle (uses the “Handle pattern”). -data Handle = Handle - { hClock :: IORef EpochTime - , hDataDir :: FilePath - , hReplica :: ReplicaId - , hOnDocumentChanged :: IORef (Maybe OnDocumentChanged) - } - --- | The handler is called as @onDocumentChanged docid@, where --- @docid@ is the changed document id. -newtype OnDocumentChanged = - OnDocumentChanged (forall a . Collection a => DocId a -> IO ()) - -emitDocumentChanged :: Collection a => DocId a -> Storage () -emitDocumentChanged docid = Storage $ do - Handle{hOnDocumentChanged} <- ask - liftIO $ do - mOnDocumentChanged <- readIORef hOnDocumentChanged - whenJust mOnDocumentChanged $ \(OnDocumentChanged onDocumentChanged) -> - onDocumentChanged docid - --- | Create new storage handle -newHandle :: FilePath -> IO Handle -newHandle hDataDir = do - time <- getCurrentEpochTime - hClock <- newIORef time - hReplica <- applicationSpecific <$> getMacAddress - hOnDocumentChanged <- newIORef Nothing - pure Handle{hDataDir, hClock, hReplica, hOnDocumentChanged} - -setOnDocumentChanged :: Handle -> OnDocumentChanged -> IO () -setOnDocumentChanged h handler = - writeIORef (hOnDocumentChanged h) $ Just handler - -listDirectoryIfExists :: FilePath -> Storage [FilePath] -listDirectoryIfExists relpath = Storage $ do - Handle{hDataDir} <- ask - let dir = hDataDir relpath - liftIO $ do - exists <- doesDirectoryExist dir - if exists then listDirectory dir else pure [] - -docDir :: forall a . Collection a => DocId a -> FilePath -docDir (DocId dir) = collectionName @a dir - --- MAC address - -getMacAddress :: IO Word64 -getMacAddress = decodeMac <$> getMac where - getMac - = fromMaybe - (error "Can't get any non-zero MAC address of this machine") - . listToMaybe - . filter (/= minBound) - . map mac - <$> getNetworkInterfaces - decodeMac (MAC b5 b4 b3 b2 b1 b0) - = fromIntegral b5 `shiftL` 40 - + fromIntegral b4 `shiftL` 32 - + fromIntegral b3 `shiftL` 24 - + fromIntegral b2 `shiftL` 16 - + fromIntegral b1 `shiftL` 8 - + fromIntegral b0 diff --git a/lib/RON/Storage/Test.hs b/lib/RON/Storage/Test.hs deleted file mode 100644 --- a/lib/RON/Storage/Test.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module RON.Storage.Test (TestDB, runStorageSim) where - -import Control.Monad.Except (ExceptT, MonadError, runExceptT) -import Control.Monad.State.Strict (StateT, get, gets, modify, - runStateT) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.Functor.Compose (Compose (Compose), getCompose) -import Data.Map.Strict (Map, (!), (!?)) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import RON.Event (ReplicaClock, applicationSpecific) -import RON.Event.Simulation (ReplicaSim, runNetworkSim, runReplicaSim) - -import RON.Storage (Collection, CollectionName, DocId (DocId), - DocVersion, MonadStorage, changeDocId, - collectionName, deleteVersion, getCollections, - getDocumentVersions, getDocuments, - loadVersionContent, saveVersionContent) - -type ByteStringL = BSL.ByteString - -type TestDB = Map CollectionName (Map DocumentId (Map DocVersion Document)) - -type Document = [ByteStringL] - -type DocumentId = FilePath - --- * Storage simulation - -newtype StorageSim a = StorageSim (StateT TestDB (ExceptT String ReplicaSim) a) - deriving (Applicative, Functor, Monad, MonadError String, ReplicaClock) - -runStorageSim :: TestDB -> StorageSim a -> Either String (a, TestDB) -runStorageSim db (StorageSim action) = - runNetworkSim $ runReplicaSim (applicationSpecific 34) $ - runExceptT $ runStateT action db - -instance MonadStorage StorageSim where - getCollections = StorageSim $ gets Map.keys - - getDocuments :: forall a . Collection a => StorageSim [DocId a] - getDocuments = StorageSim $ do - db <- get - pure $ map DocId $ Map.keys $ db !. collectionName @a - - getDocumentVersions (DocId doc :: DocId a) = StorageSim $ do - db <- get - pure $ Map.keys $ db !. collectionName @a !. doc - - saveVersionContent (DocId docid :: DocId a) version content = do - let document = BSLC.lines content - let insertDocumentVersion = - Just . Map.insertWith (<>) version document . fromMaybe mempty - let alterDocument - = Just - . Map.alter insertDocumentVersion docid - . fromMaybe mempty - let alterCollection = Map.alter alterDocument (collectionName @a) - StorageSim $ modify alterCollection - - loadVersionContent (DocId dir :: DocId a) version = StorageSim $ do - db <- get - pure $ BSLC.unlines $ db !. collectionName @a !. dir ! version - - deleteVersion (DocId doc :: DocId a) version - = StorageSim - . modify - . (`Map.adjust` collectionName @a) - . (`Map.adjust` doc) - $ Map.delete version - - changeDocId (DocId old :: DocId a) (DocId new :: DocId a) = StorageSim $ - modify $ (`Map.adjust` collectionName @a) $ \collection -> - maybe collection (uncurry $ Map.insert new) $ - mapTake old collection - -(!.) :: Ord a => Map a (Map b c) -> a -> Map b c -m !. a = fromMaybe Map.empty $ m !? a - -mapTake :: Ord k => k -> Map k a -> Maybe (a, Map k a) -mapTake k = getCompose . Map.alterF (Compose . f) k where - f = \case - Nothing -> Nothing - Just a -> Just (a, Nothing) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs --- a/lib/RON/Text/Parse.hs +++ b/lib/RON/Text/Parse.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} @@ -20,7 +21,6 @@ ) where import Prelude hiding (takeWhile) -import RON.Internal.Prelude import Attoparsec.Extra (Parser, char, endOfInputEx, isSuccessful, label, manyTill, parseOnlyL, satisfy, (<+>), @@ -32,17 +32,17 @@ 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 Data.Maybe (isJust, isNothing) import qualified RON.Base64 as Base64 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 (..)) + ClosedOp (..), Object (Object), Op (..), + OpTerm (TClosed, THeader, TQuery, TReduced), + StateChunk (..), StateFrame, UUID (UUID), + WireChunk (Closed, Query, Value), WireFrame, + WireReducedChunk (..)) +import RON.Util (ByteStringL) import RON.Util.Word (Word2, Word4, Word60, b00, b0000, b01, b10, b11, ls60, safeCast) import RON.UUID (UuidFields (..)) @@ -65,24 +65,24 @@ (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 +pChunk :: ClosedOp -> Parser (WireChunk, ClosedOp) +pChunk prev = label "WireChunk" $ wireStateChunk prev <+> chunkClosed prev -chunkRaw :: RawOp -> Parser (WireChunk, RawOp) -chunkRaw prev = label "WireChunk-raw" $ do +chunkClosed :: ClosedOp -> Parser (WireChunk, ClosedOp) +chunkClosed prev = label "WireChunk-closed" $ do skipSpace - (_, x) <- rawOp prev + (_, x) <- closedOp prev skipSpace void $ char ';' - pure (Raw x, x) + pure (Closed x, x) --- | Returns a chunk and the last op (converted to raw) in it -wireStateChunk :: RawOp -> Parser (WireChunk, RawOp) +-- | Returns a chunk and the last op (converted to closed) in it +wireStateChunk :: ClosedOp -> Parser (WireChunk, ClosedOp) wireStateChunk prev = label "WireChunk-reduced" $ do (wrcHeader, isQuery) <- header prev let reducedOps y = do skipSpace - (isNotEmpty, x) <- reducedOp (opObject wrcHeader) y + (isNotEmpty, x) <- reducedOp (objectId wrcHeader) y t <- optional term unless (t == Just TReduced || isNothing t) $ fail "reduced op may end with `,` only" @@ -90,11 +90,9 @@ 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} + let lastOp = lastDef (op wrcHeader) wrcBody + wrap op = ClosedOp + {reducerId = reducerId wrcHeader, objectId = objectId wrcHeader, op} pure ((if isQuery then Query else Value) WireReducedChunk{..}, wrap lastOp) where stop = pure [] @@ -110,9 +108,9 @@ frameInStream = label "WireFrame-stream" $ chunksTill endOfFrame -- | Parse a single context-free op -parseOp :: ByteStringL -> Either String RawOp +parseOp :: ByteStringL -> Either String ClosedOp parseOp = parseOnlyL $ do - (_, x) <- rawOp opZero <* skipSpace <* endOfInputEx + (_, x) <- closedOp opZero <* skipSpace <* endOfInputEx pure x -- | Parse a single context-free UUID @@ -139,28 +137,28 @@ 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 +closedOp :: ClosedOp -> Parser (Bool, ClosedOp) +closedOp prev = label "ClosedOp-cont" $ do + (hasTyp, reducerId) <- key "reducer" '*' (reducerId prev) UUID.zero + (hasObj, objectId) <- key "object" '#' (objectId prev) reducerId + (hasEvt, opId) <- key "opId" '@' (opId prev') objectId + (hasLoc, refId) <- key "ref" ':' (refId prev') opId + payload <- payloadP objectId let op = Op{..} pure - ( hasTyp || hasObj || hasEvt || hasLoc || not (null opPayload) - , RawOp{..} + ( hasTyp || hasObj || hasEvt || hasLoc || not (null payload) + , ClosedOp{..} ) 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) + (hasEvt, opId) <- key "event" '@' (opId prev) opObject + (hasLoc, refId) <- key "ref" ':' (refId prev) opId + payload <- payloadP opObject + let op = Op{opId, refId, payload} + pure (hasEvt || hasLoc || not (null payload), op) key :: String -> Char -> UUID -> UUID -> Parser (Bool, UUID) key name keyChar prevOpSameKey sameOpPrevUuid = label name $ do @@ -302,8 +300,8 @@ '-' -> pure b11 _ -> fail "not a UUID-version" -payload :: UUID -> Parser [Atom] -payload = label "payload" . go +payloadP :: UUID -> Parser [Atom] +payloadP = label "payload" . go where go prevUuid = do ma <- optional $ atom prevUuid @@ -353,10 +351,10 @@ parseString :: ByteStringL -> Either String Text parseString = parseOnlyL $ string <* endOfInputEx --- | Return 'RawOp' and 'chunkIsQuery' -header :: RawOp -> Parser (RawOp, Bool) +-- | Return 'ClosedOp' and 'chunkIsQuery' +header :: ClosedOp -> Parser (ClosedOp, Bool) header prev = do - (_, x) <- rawOp prev + (_, x) <- closedOp prev t <- term case t of THeader -> pure (x, False) @@ -370,7 +368,7 @@ '!' -> pure THeader '?' -> pure TQuery ',' -> pure TReduced - ';' -> pure TRaw + ';' -> pure TClosed _ -> fail "not a term" -- | Parse a state frame @@ -386,16 +384,17 @@ findObjects = fmap Map.fromList . traverse loadBody where loadBody = \case Value WireReducedChunk{..} -> do - let RawOp{..} = wrcHeader - let Op{..} = op - let stateVersion = opEvent + let ClosedOp{reducerId, objectId, op} = wrcHeader + let Op{opId} = op + let stateVersion = opId let stateBody = wrcBody - pure ((opType, opObject), StateChunk{..}) + let stateType = reducerId + pure (objectId, StateChunk{..}) _ -> Left "expected reduced chunk" -opZero :: RawOp -opZero = RawOp - { opType = UUID.zero - , opObject = UUID.zero - , op = Op{opEvent = UUID.zero, opRef = UUID.zero, opPayload = []} +opZero :: ClosedOp +opZero = ClosedOp + { reducerId = UUID.zero + , objectId = UUID.zero + , op = Op{opId = UUID.zero, refId = UUID.zero, payload = []} } diff --git a/lib/RON/Text/Serialize.hs b/lib/RON/Text/Serialize.hs --- a/lib/RON/Text/Serialize.hs +++ b/lib/RON/Text/Serialize.hs @@ -17,29 +17,26 @@ , 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.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 (..)) + ClosedOp (..), Object (..), Op (..), + StateChunk (..), StateFrame, + WireChunk (Closed, Query, Value), WireFrame, + WireReducedChunk (..)) +import RON.Util (ByteStringL) import RON.UUID (UUID, zero) -- | Serialize a common frame serializeWireFrame :: WireFrame -> ByteStringL serializeWireFrame chunks = (`BSLC.snoc` '.') - . mconcat + . fold . (`evalState` opZero) $ traverse serializeChunk chunks @@ -48,50 +45,50 @@ serializeWireFrames = foldMap serializeWireFrame -- | Serialize a common chunk -serializeChunk :: WireChunk -> State RawOp ByteStringL +serializeChunk :: WireChunk -> State ClosedOp ByteStringL serializeChunk = \case - Raw op -> (<> " ;\n") <$> serializeRawOpZip op + Closed op -> (<> " ;\n") <$> serializeClosedOpZip op Value chunk -> serializeReducedChunk False chunk Query chunk -> serializeReducedChunk True chunk -- | Serialize a reduced chunk -serializeReducedChunk :: Bool -> WireReducedChunk -> State RawOp ByteStringL +serializeReducedChunk :: Bool -> WireReducedChunk -> State ClosedOp ByteStringL serializeReducedChunk isQuery WireReducedChunk{wrcHeader, wrcBody} = BSLC.unlines <$> liftA2 (:) serializeHeader serializeBody where serializeHeader = do - h <- serializeRawOpZip wrcHeader + h <- serializeClosedOpZip wrcHeader pure $ BSLC.unwords [h, if isQuery then "?" else "!"] - serializeBody = state $ \RawOp{op = opBefore, ..} -> let + serializeBody = state $ \ClosedOp{op = opBefore, ..} -> let (body, opAfter) = (`runState` opBefore) $ for wrcBody $ - fmap ("\t" <>) . serializeReducedOpZip opObject + fmap ("\t" <>) . serializeReducedOpZip objectId in ( body - , RawOp{op = opAfter, ..} + , ClosedOp{op = opAfter, ..} ) -- | Serialize a context-free raw op -serializeRawOp :: RawOp -> ByteStringL -serializeRawOp op = evalState (serializeRawOpZip op) opZero +serializeRawOp :: ClosedOp -> ByteStringL +serializeRawOp op = evalState (serializeClosedOpZip op) opZero -- | Serialize a raw op with compression in stream context -serializeRawOpZip :: RawOp -> State RawOp ByteStringL -serializeRawOpZip this = state $ \prev -> let +serializeClosedOpZip :: ClosedOp -> State ClosedOp ByteStringL +serializeClosedOpZip 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') + typ = serializeUuidKey (reducerId prev) zero (reducerId this) + obj = serializeUuidKey (objectId prev) (reducerId this) (objectId this) + evt = serializeUuidKey (opId prev') (objectId this) (opId this') + ref = serializeUuidKey (refId prev') (opId this') (refId this') + payloadAtoms = serializePayload (objectId this) (payload this') in ( BSLC.unwords $ key '*' typ ++ key '#' obj ++ key '@' evt ++ key ':' ref - ++ [payload | not $ BSL.null payload] + ++ [payloadAtoms | not $ BSL.null payloadAtoms] , this ) where @@ -104,15 +101,15 @@ -> 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) + evt = serializeUuidKey (opId prev) opObject (opId this) + ref = serializeUuidKey (refId prev) (opId this) (refId this) + payloadAtoms = serializePayload opObject (payload this) in ( BSLC.unwords $ (if BSL.null evt && BSL.null ref then ["@"] else key '@' evt ++ key ':' ref) - ++ [payload | not $ BSL.null payload] + ++ [payloadAtoms | not $ BSL.null payloadAtoms] , this ) where @@ -156,20 +153,26 @@ -- | Serialize a state frame serializeStateFrame :: StateFrame -> ByteStringL -serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs where - wrapChunk ((opType, opObject), StateChunk{..}) = Value WireReducedChunk{..} +serializeStateFrame = + serializeWireFrame . map wrapChunk . sortOn (stateType . snd) . Map.assocs + -- TODO(2019-01-28, cblp) remove sortOn type + where + wrapChunk (objectId, StateChunk{..}) = Value WireReducedChunk{..} where - wrcHeader = RawOp{op = Op{opRef = zero, opPayload = [], ..}, ..} + wrcHeader = ClosedOp + { reducerId = stateType + , objectId + , op = Op{opId = stateVersion, refId = zero, payload = []} + } 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 = []} +opZero :: ClosedOp +opZero = ClosedOp + { reducerId = zero + , objectId = zero + , op = Op{opId = zero, refId = zero, payload = []} } diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs --- a/lib/RON/Text/Serialize/UUID.hs +++ b/lib/RON/Text/Serialize/UUID.hs @@ -11,16 +11,13 @@ , 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.Util (ByteStringL) import RON.Util.Word (pattern B00, pattern B0000, pattern B01, pattern B10, pattern B11, Word2, Word60, ls60, safeCast) diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs --- a/lib/RON/Types.hs +++ b/lib/RON/Types.hs @@ -1,70 +1,77 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE PatternSynonyms #-} -- | RON model types -module RON.Types - ( Atom (..) - , Object (..) - , ObjectId - , ObjectPart (..) - , Op (..) - , OpTerm (..) - , RawOp (..) - , StateChunk (..) - , StateFrame - , UUID (..) - , WireChunk (..) - , WireFrame - , WireReducedChunk (..) - ) where - -import RON.Internal.Prelude +module RON.Types ( + pattern AckP, + pattern AnnotationDerivedP, + pattern AnnotationP, + pattern CreateP, + pattern DeleteP, + pattern RegularP, + pattern UndeleteP, + Atom (..), + ClosedOp (..), + Object (..), + ObjectPart (..), + Op (..), + OpPattern (..), + OpTerm (..), + StateChunk (..), + StateFrame, + UUID (..), + WireChunk (..), + WireFrame, + WireReducedChunk (..), + opPattern, +) where -import Data.Data (Data) -import Data.Text (Text) -import GHC.Generics (Generic) +import qualified Text.Show -import RON.UUID (UUID (..)) +import RON.Util.Word (pattern B00, pattern B10, pattern B11, Word2) +import RON.UUID (UUID (UUID), uuidVersion) +import qualified RON.UUID as UUID -- | Atom — a payload element data Atom = AFloat Double | AInteger Int64 | AString Text | AUuid UUID deriving (Data, Eq, Generic, Hashable, Show) --- | Raw op -data RawOp = RawOp - { opType :: UUID +-- | Closed op +data ClosedOp = ClosedOp + { reducerId :: UUID -- ^ type - , opObject :: UUID + , objectId :: UUID -- ^ object id - , op :: Op + , op :: Op -- ^ other keys and payload, that are common with reduced op } deriving (Data, Eq, Generic) --- | “Reduced” op (op from reduced chunk) +-- | Open op (operation) data Op = Op - { opEvent :: UUID + { opId :: UUID -- ^ event id (usually timestamp) - , opRef :: UUID + , refId :: UUID -- ^ reference to other op; actual semantics depends on the type - , opPayload :: [Atom] + , payload :: [Atom] -- ^ payload } deriving (Data, Eq, Generic, Hashable, Show) -instance Show RawOp where - show RawOp{opType, opObject, op = Op{opEvent, opRef, opPayload}} = +instance Show ClosedOp where + show ClosedOp{reducerId, objectId, op = Op{opId, refId, payload}} = unwords - [ "RawOp" - , insert '*' $ show opType - , insert '#' $ show opObject - , insert '@' $ show opEvent - , insert ':' $ show opRef - , show opPayload + [ "ClosedOp" + , insert '*' $ show reducerId + , insert '#' $ show objectId + , insert '@' $ show opId + , insert ':' $ show refId + , show payload ] where insert k = \case @@ -73,39 +80,71 @@ -- | Common reduced chunk data WireReducedChunk = WireReducedChunk - { wrcHeader :: RawOp + { wrcHeader :: ClosedOp , wrcBody :: [Op] } deriving (Data, Eq, Generic, Show) -- | Common chunk -data WireChunk = Raw RawOp | Value WireReducedChunk | Query WireReducedChunk +data WireChunk = + Closed ClosedOp | Value WireReducedChunk | Query WireReducedChunk deriving (Data, Eq, Generic, Show) -- | Common frame type WireFrame = [WireChunk] -- | Op terminator -data OpTerm = TRaw | TReduced | THeader | TQuery +data OpTerm = TClosed | 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 + { stateType :: UUID + , stateVersion :: UUID , stateBody :: [Op] } deriving (Eq, Show) -- | Frame containing only state chunks -type StateFrame = Map ObjectId StateChunk +type StateFrame = Map UUID StateChunk -- | Reference to an object inside a frame. -data Object a = Object{objectId :: UUID, objectFrame :: StateFrame} +data Object a = Object{id :: UUID, frame :: 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} + +data OpPattern = + Regular | Delete | Undelete | Create | Ack | Annotation | AnnotationDerived + +pattern AnnotationP :: (Word2, Word2) +pattern AnnotationP = (B00, B10) +pattern AnnotationDerivedP :: (Word2, Word2) +pattern AnnotationDerivedP = (B00, B11) +pattern CreateP :: (Word2, Word2) +pattern CreateP = (B10, B00) +pattern RegularP :: (Word2, Word2) +pattern RegularP = (B10, B10) +pattern AckP :: (Word2, Word2) +pattern AckP = (B10, B11) +pattern DeleteP :: (Word2, Word2) +pattern DeleteP = (B11, B10) +pattern UndeleteP :: (Word2, Word2) +pattern UndeleteP = (B11, B11) + +opPattern :: Op -> Maybe OpPattern +opPattern Op{opId, refId} = + case mapBoth (uuidVersion . UUID.split) (opId, refId) of + AnnotationP -> Just Annotation + AnnotationDerivedP -> Just AnnotationDerived + CreateP -> Just Create + RegularP -> Just Regular + AckP -> Just Ack + DeleteP -> Just Delete + UndeleteP -> Just Undelete + _ -> Nothing + +mapBoth :: (a -> b) -> (a, a) -> (b, b) +mapBoth f (x, y) = (f x, f y) diff --git a/lib/RON/UUID.hs b/lib/RON/UUID.hs --- a/lib/RON/UUID.hs +++ b/lib/RON/UUID.hs @@ -20,6 +20,7 @@ , pattern Zero -- * Name , getName + , liftName , mkName , mkScopedName -- * Base32 encoding, suitable for file names @@ -27,14 +28,10 @@ , encodeBase32 ) where -import RON.Internal.Prelude - 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 Language.Haskell.TH.Syntax (Exp, Q, liftData) +import qualified Text.Show import qualified RON.Base64 as Base64 import RON.Util.Word (pattern B00, pattern B0000, pattern B01, @@ -115,14 +112,19 @@ -- | Make an unscoped (unqualified) name mkName - :: Monad m + :: MonadFail m => ByteString -- ^ name, max 10 Base64 letters -> m UUID mkName nam = mkScopedName nam "" +-- | Contruct a UUID name in compile-time +liftName :: ByteString -> Q Exp +liftName = mkName >=> liftData +-- TODO(2019-01-11, cblp) typed splice + -- | Make a scoped (qualified) name mkScopedName - :: Monad m + :: MonadFail m => ByteString -- ^ scope, max 10 Base64 letters -> ByteString -- ^ local name, max 10 Base64 letters -> m UUID diff --git a/lib/RON/Util.hs b/lib/RON/Util.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Util.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} + +module RON.Util ( + ByteStringL, + Instance (Instance), +) where + +import qualified Data.ByteString.Lazy as BSL + +type ByteStringL = BSL.ByteString + +data Instance c = forall a . c a => Instance a diff --git a/lib/RON/Util/Word.hs b/lib/RON/Util/Word.hs --- a/lib/RON/Util/Word.hs +++ b/lib/RON/Util/Word.hs @@ -48,10 +48,8 @@ ) 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) +import Data.Hashable (hashUsing, hashWithSalt) newtype Word2 = W2 Word8 deriving (Eq, Ord, Show) diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs new file mode 100644 --- /dev/null +++ b/prelude/Prelude.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module Prelude ( + module X, + fmapL, + foldr1, + identity, + lastDef, + maximumDef, + maxOn, + minOn, + show, + whenJust, + (?:), +) where + +-- base +import Control.Applicative as X (Alternative, Applicative, liftA2, + many, optional, pure, some, (*>), + (<*), (<*>), (<|>)) +import Control.Exception as X (Exception, catch, evaluate, throwIO) +import Control.Monad as X (Monad, filterM, guard, unless, void, when, + (<=<), (=<<), (>=>), (>>=)) +import Control.Monad.Fail as X (MonadFail, fail) +import Control.Monad.IO.Class as X (MonadIO, liftIO) +import Data.Bifunctor as X (bimap) +import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||)) +import Data.Char as X (Char, chr, ord, toLower, toUpper) +import Data.Coerce as X (Coercible, coerce) +import Data.Data as X (Data) +import Data.Either as X (Either (Left, Right), either) +import Data.Eq as X (Eq, (/=), (==)) +import Data.Foldable as X (Foldable, and, asum, fold, foldMap, foldl', + foldr, for_, length, minimumBy, null, or, + toList, traverse_) +import Data.Function as X (const, flip, on, ($), (.)) +import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>)) +import Data.Functor.Identity as X (Identity) +import Data.Int as X (Int, Int16, Int32, Int64, Int8) +import Data.IORef as X (IORef, atomicModifyIORef', newIORef, + readIORef, writeIORef) +import Data.List as X (filter, genericLength, intercalate, isPrefixOf, + isSuffixOf, lookup, map, partition, repeat, + replicate, sortBy, sortOn, span, splitAt, take, + takeWhile, unlines, unwords, zip, (++)) +import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) +import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, + listToMaybe, maybe, maybeToList) +import Data.Monoid as X (Last (Last), Monoid, mempty) +import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT), + compare, comparing, max, min, (<), (<=), (>), + (>=)) +import Data.Ratio as X ((%)) +import Data.Semigroup as X (Semigroup, sconcat, (<>)) +import Data.String as X (String) +import Data.Traversable as X (for, sequence, sequenceA, traverse) +import Data.Tuple as X (fst, snd, uncurry) +import Data.Typeable as X (Typeable) +import Data.Word as X (Word, Word16, Word32, Word64, Word8) +import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound, + pred, succ, toEnum) +import GHC.Err as X (error, undefined) +import GHC.Exts as X (Double) +import GHC.Generics as X (Generic) +import GHC.Integer as X (Integer) +import GHC.Num as X (Num, negate, subtract, (*), (+), (-)) +import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round, + (^), (^^)) +import GHC.Stack as X (HasCallStack) +import System.IO as X (FilePath, IO) +import Text.Show as X (Show) + +#ifdef VERSION_bytestring +import Data.ByteString as X (ByteString) +#endif + +#ifdef VERSION_containers +import Data.Map.Strict as X (Map) +#endif + +#ifdef VERSION_deepseq +import Control.DeepSeq as X (NFData, force) +#endif + +#ifdef VERSION_filepath +import System.FilePath as X (()) +#endif + +#ifdef VERSION_hashable +import Data.Hashable as X (Hashable, hash) +#endif + +#ifdef VERSION_mtl +import Control.Monad.Except as X (ExceptT, MonadError, catchError, + liftEither, runExceptT, throwError) +import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader, + runReaderT) +import Control.Monad.State.Strict as X (MonadState, State, StateT, + evalState, evalStateT, + execStateT, get, gets, + modify', put, runState, + runStateT, state) +import Control.Monad.Trans as X (MonadTrans, lift) +import Control.Monad.Writer.Strict as X (MonadWriter, WriterT, + runWriterT, tell) +#endif + +#ifdef VERSION_text +import Data.Text as X (Text) +#endif + +#ifdef VERSION_time +import Data.Time as X (UTCTime) +#endif + +#ifdef VERSION_unordered_containers +import Data.HashMap.Strict as X (HashMap) +#endif + +-------------------------------------------------------------------------------- + +import qualified Data.Foldable +import Data.List (last, maximum) +import Data.String (IsString, fromString) +import qualified Text.Show + +fmapL :: (a -> b) -> Either a c -> Either b c +fmapL f = either (Left . f) Right + +foldr1 :: (a -> a -> a) -> NonEmpty a -> a +foldr1 = Data.Foldable.foldr1 + +identity :: a -> a +identity x = x + +lastDef :: a -> [a] -> a +lastDef def = list' def last + +list' :: b -> ([a] -> b) -> [a] -> b +list' onEmpty onNonEmpty = \case + [] -> onEmpty + xs -> onNonEmpty xs + +maximumDef :: Ord a => a -> [a] -> a +maximumDef def = list' def maximum + +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 + +show :: (Show a, IsString s) => a -> s +show = fromString . Text.Show.show + +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust m f = maybe (pure ()) f m + +-- | An infix form of 'fromMaybe' with arguments flipped. +(?:) :: Maybe a -> a -> a +maybeA ?: b = fromMaybe b maybeA +{-# INLINABLE (?:) #-} +infixr 0 ?: diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -1,16 +1,16 @@ cabal-version: 2.2 name: ron -version: 0.4 +version: 0.5 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database -copyright: 2018 Yuriy Syrovetskiy +copyright: 2018-2019 Yuriy Syrovetskiy homepage: https://github.com/ff-notes/ron license: BSD-3-Clause license-file: LICENSE maintainer: Yuriy Syrovetskiy -synopsis: RON, RON-RDT, and RON-Schema +synopsis: RON description: Replicated Object Notation (RON), data types (RDT), and RON-Schema @@ -42,10 +42,11 @@ build-type: Simple common language - build-depends: - base >= 4.10 && < 4.13, - default-extensions: StrictData - default-language: Haskell2010 + build-depends: base >= 4.10 && < 4.13, integer-gmp + default-extensions: MonadFailDesugaring StrictData + default-language: Haskell2010 + hs-source-dirs: prelude + other-modules: Prelude library import: language @@ -55,55 +56,33 @@ binary, bytestring, containers, - Diff, - directory, - errors, - extra, - filepath, hashable, - hedn, mtl, - network-info, - safe, template-haskell, text, time, - transformers, - unordered-containers, - vector, + unordered-containers exposed-modules: RON.Base64 RON.Binary RON.Binary.Parse RON.Binary.Serialize RON.Binary.Types - RON.Data - RON.Data.LWW - RON.Data.ORSet - RON.Data.RGA - RON.Data.Time - RON.Data.VersionVector RON.Epoch + RON.Error RON.Event RON.Event.Simulation - RON.Schema - RON.Schema.TH - RON.Storage - RON.Storage.IO - RON.Storage.Test RON.Text RON.Text.Parse RON.Text.Serialize RON.Text.Serialize.UUID RON.Types + RON.Util RON.Util.Word RON.UUID other-modules: Attoparsec.Extra Data.ZigZag - RON.Data.Internal - RON.Internal.Prelude - RON.Schema.EDN hs-source-dirs: lib benchmark bench @@ -113,7 +92,7 @@ criterion, deepseq, -- package - ron, + ron main-is: Main.hs hs-source-dirs: bench type: exitcode-stdio-1.0