ron 0.4 → 0.5
raw patch · 34 files changed
+510/−2843 lines, 34 filesdep +integer-gmpdep −Diffdep −directorydep −errors
Dependencies added: integer-gmp
Dependencies removed: Diff, directory, errors, extra, filepath, hedn, network-info, safe, transformers, vector
Files
- bench/Main.hs +6/−9
- lib/Attoparsec/Extra.hs +6/−9
- lib/Data/ZigZag.hs +2/−53
- lib/RON/Base64.hs +1/−3
- lib/RON/Binary/Parse.hs +34/−36
- lib/RON/Binary/Serialize.hs +25/−26
- lib/RON/Binary/Types.hs +5/−7
- lib/RON/Data.hs +0/−180
- lib/RON/Data/Internal.hs +0/−264
- lib/RON/Data/LWW.hs +0/−149
- lib/RON/Data/ORSet.hs +0/−169
- lib/RON/Data/RGA.hs +0/−408
- lib/RON/Data/Time.hs +0/−31
- lib/RON/Data/VersionVector.hs +0/−70
- lib/RON/Epoch.hs +0/−6
- lib/RON/Error.hs +36/−0
- lib/RON/Event.hs +8/−9
- lib/RON/Event/Simulation.hs +5/−11
- lib/RON/Internal/Prelude.hs +0/−63
- lib/RON/Schema.hs +0/−100
- lib/RON/Schema/EDN.hs +0/−249
- lib/RON/Schema/TH.hs +0/−302
- lib/RON/Storage.hs +0/−215
- lib/RON/Storage/IO.hs +0/−194
- lib/RON/Storage/Test.hs +0/−92
- lib/RON/Text/Parse.hs +52/−53
- lib/RON/Text/Serialize.hs +42/−39
- lib/RON/Text/Serialize/UUID.hs +1/−4
- lib/RON/Types.hs +87/−48
- lib/RON/UUID.hs +10/−8
- lib/RON/Util.hs +13/−0
- lib/RON/Util/Word.hs +1/−3
- prelude/Prelude.hs +164/−0
- ron.cabal +12/−33
bench/Main.hs view
@@ -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)
lib/Attoparsec/Extra.hs view
@@ -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 ()
lib/Data/ZigZag.hs view
@@ -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
lib/RON/Base64.hs view
@@ -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)
lib/RON/Binary/Parse.hs view
@@ -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
lib/RON/Binary/Serialize.hs view
@@ -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
lib/RON/Binary/Types.hs view
@@ -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
− lib/RON/Data.hs
@@ -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
− lib/RON/Data/Internal.hs
@@ -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"
− lib/RON/Data/LWW.hs
@@ -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
− lib/RON/Data/ORSet.hs
@@ -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
− lib/RON/Data/RGA.hs
@@ -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
− lib/RON/Data/Time.hs
@@ -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"
− lib/RON/Data/VersionVector.hs
@@ -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
lib/RON/Epoch.hs view
@@ -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,
+ lib/RON/Error.hs view
@@ -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
lib/RON/Event.hs view
@@ -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
lib/RON/Event/Simulation.hs view
@@ -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
− lib/RON/Internal/Prelude.hs
@@ -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 -:
− lib/RON/Schema.hs
@@ -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
− lib/RON/Schema/EDN.hs
@@ -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 <name:symbol> <item:symbol>...)"- 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 <kind:symbol> <name:symbol> <annotations>...)"- 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 <name:symbol> <annotations>... <fields>...)"- 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
− lib/RON/Schema/TH.hs
@@ -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) []
− lib/RON/Storage.hs
@@ -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
− lib/RON/Storage/IO.hs
@@ -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
− lib/RON/Storage/Test.hs
@@ -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)
lib/RON/Text/Parse.hs view
@@ -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 = []} }
lib/RON/Text/Serialize.hs view
@@ -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 = []} }
lib/RON/Text/Serialize/UUID.hs view
@@ -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)
lib/RON/Types.hs view
@@ -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)
lib/RON/UUID.hs view
@@ -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
+ lib/RON/Util.hs view
@@ -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
lib/RON/Util/Word.hs view
@@ -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)
+ prelude/Prelude.hs view
@@ -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 ?:
ron.cabal view
@@ -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 <haskell@cblp.su>-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