ron 0.8 → 0.9
raw patch · 8 files changed
+166/−146 lines, 8 filesdep +transformers
Dependencies added: transformers
Files
- CHANGELOG.md +12/−1
- lib/RON/Event.hs +1/−1
- lib/RON/Event/Simulation.hs +5/−19
- lib/RON/Prelude.hs +7/−7
- lib/RON/Prelude/Writer.hs +23/−0
- lib/RON/Text/Serialize.hs +108/−111
- lib/RON/Types.hs +6/−6
- ron.cabal +4/−1
CHANGELOG.md view
@@ -7,8 +7,18 @@ ## [Unreleased] +## [0.9] - 2019-09-06+### Changed+- Renamed `Object` to `ObjectRef`++### Removed+- Types `NetworkSim`, `ReplicaSim`, functions `runNetworkSim`, `runReplicaSim`.+ Use `NetworkSimT`, `ReplicaSimT`, functions `runNetworkSimT`, `runReplicaSimT`+ instead.+ ## [0.8] - 2019-08-10 ### Added+- Type alias `Payload = [Atom]` - Associated type `ReplicatedAsObject.Rep` - Function `correct` @@ -130,7 +140,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.8...HEAD+[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.9...HEAD+[0.9]: https://github.com/ff-notes/ron/compare/ron-0.8...ron-0.9 [0.8]: https://github.com/ff-notes/ron/compare/ron-0.7...ron-0.8 [0.7]: https://github.com/ff-notes/ron/compare/ron-0.6...ron-0.7 [0.6]: https://github.com/ff-notes/ron/compare/v0.5...ron-0.6
lib/RON/Event.hs view
@@ -171,7 +171,7 @@ getEvents = lift . getEvents advance = lift . advance -instance (ReplicaClock m, Monoid s) => ReplicaClock (WriterT s m) where+instance ReplicaClock m => ReplicaClock (WriterT s m) where getPid = lift getPid getEvents = lift . getEvents advance = lift . advance
lib/RON/Event/Simulation.hs view
@@ -5,13 +5,9 @@ -- 'ReplicaSim' provides 'Replica' and 'Clock' instances, -- replicas may interchange data while they are connected in a 'NetworkSim'. module RON.Event.Simulation (- NetworkSim, NetworkSimT,- ReplicaSim, ReplicaSimT,- runNetworkSim, runNetworkSimT,- runReplicaSim, runReplicaSimT, ) where @@ -32,14 +28,10 @@ instance MonadTrans NetworkSimT where lift = NetworkSim . lift -type NetworkSim = NetworkSimT Identity- -- | ReplicaSim inside Lamport clock simulation. newtype ReplicaSimT m a = ReplicaSim (ReaderT ReplicaId (NetworkSimT m) a) deriving (Applicative, Functor, Monad, MonadError e) -type ReplicaSim = ReplicaSimT Identity- instance MonadTrans ReplicaSimT where lift = ReplicaSim . lift . lift @@ -77,24 +69,18 @@ -- Usage: -- -- @--- runNetworkSim $ do--- 'runReplicaSim' r1 $ do+-- 'runExceptT' . runNetworkSimT $ do+-- 'runReplicaSimT' r1 $ do -- actions...--- 'runReplicaSim' r2 $ do+-- 'runReplicaSimT' r2 $ do -- actions...--- 'runReplicaSim' r1 $ ...+-- 'runReplicaSimT' r1 $ ... -- @ ----- Each 'runNetworkSim' starts its own networks.+-- Each 'runNetworkSimT' starts its own networks. -- One shouldn't use in one network events generated in another.-runNetworkSim :: NetworkSim a -> a-runNetworkSim (NetworkSim action) = evalState action mempty- runNetworkSimT :: Monad m => NetworkSimT m a -> m a runNetworkSimT (NetworkSim action) = evalStateT action mempty--runReplicaSim :: ReplicaId -> ReplicaSim a -> NetworkSim a-runReplicaSim rid (ReplicaSim action) = runReaderT action rid runReplicaSimT :: ReplicaId -> ReplicaSimT m a -> NetworkSimT m a runReplicaSimT rid (ReplicaSim action) = runReaderT action rid
lib/RON/Prelude.hs view
@@ -23,6 +23,8 @@ (?:), ) where +import RON.Prelude.Writer as X+ -- base import Control.Applicative as X (Alternative, Applicative, liftA2, many, optional, pure, some, (*>),@@ -43,8 +45,6 @@ modify', put, runState, runStateT) import Control.Monad.Trans as X (MonadTrans, lift)-import Control.Monad.Writer.Strict as X (MonadWriter, WriterT,- runWriterT, tell) import Data.Bifunctor as X (bimap) import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||)) import Data.ByteString as X (ByteString)@@ -53,10 +53,10 @@ 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, null, or, toList,- traverse_)-import Data.Function as X (const, flip, id, on, ($), (.))+import Data.Foldable as X (Foldable, and, asum, elem, fold, foldMap,+ foldl', foldr, for_, length, null, or,+ toList, traverse_)+import Data.Function as X (const, flip, id, on, ($), (&), (.)) import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>), (<&>)) import Data.Functor.Identity as X (Identity) import Data.Hashable as X (Hashable, hash)@@ -95,7 +95,7 @@ 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.Read as X (readMaybe)
+ lib/RON/Prelude/Writer.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module RON.Prelude.Writer+ ( module X+ )+where++import Control.Monad.Trans.Writer.CPS as X (WriterT, execWriterT, runWriterT)+import qualified Control.Monad.Trans.Writer.CPS as CPS+import Control.Monad.Writer.Class as X (MonadWriter, listen, pass, tell, writer)+import Prelude (Monad, Monoid)++instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where++ listen = CPS.listen++ pass = CPS.pass++ tell = CPS.tell++ writer = CPS.writer
lib/RON/Text/Serialize.hs view
@@ -6,43 +6,48 @@ {-# LANGUAGE RecordWildCards #-} -- | RON-Text serialization-module RON.Text.Serialize (- serializeAtom,+module RON.Text.Serialize+ ( serializeAtom, serializeObject, serializeRawOp, serializeStateFrame, serializeString, serializeUuid, serializeWireFrame,- serializeWireFrames,-) where--import RON.Prelude+ serializeWireFrames+ )+where -import Control.Monad.State.Strict (state)+import Control.Monad.State.Strict (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.List as List+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.ByteString.Lazy.Char8 (cons, snoc, elem) import qualified Data.Map.Strict as Map--import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom,- serializeUuidKey)-import RON.Types (Atom (AFloat, AInteger, AString, AUuid),- ClosedOp (..), ObjectFrame (..), Op (..), Payload,- StateFrame, WireChunk (Closed, Query, Value),- WireFrame, WireReducedChunk (..),- WireStateChunk (..))-import RON.Util (ByteStringL)-import RON.UUID (UUID, zero)+import RON.Prelude hiding (elem)+import RON.Text.Serialize.UUID+ ( serializeUuid,+ serializeUuidAtom,+ serializeUuidKey+ )+import RON.Types+ ( Atom (AFloat, AInteger, AString, AUuid),+ ClosedOp (..),+ ObjectFrame (..),+ Op (..),+ Payload,+ StateFrame,+ WireChunk (Closed, Query, Value),+ WireFrame,+ WireReducedChunk (..),+ WireStateChunk (..)+ )+import RON.UUID (UUID, zero)+import RON.Util (ByteStringL) -- | Serialize a common frame serializeWireFrame :: WireFrame -> ByteStringL-serializeWireFrame chunks- = (`BSLC.snoc` '.')- . fold- . (`evalState` opZero)- $ traverse serializeChunk chunks+serializeWireFrame =+ (`snoc` '.') . fold . (`evalState` opZero) . traverse serializeChunk -- | Serialize a sequence of common frames serializeWireFrames :: [WireFrame] -> ByteStringL@@ -51,27 +56,25 @@ -- | Serialize a common chunk serializeChunk :: WireChunk -> State ClosedOp ByteStringL serializeChunk = \case- Closed op -> (<> " ;\n") <$> serializeClosedOpZip op- Value chunk -> serializeReducedChunk False chunk- Query chunk -> serializeReducedChunk True chunk+ Closed op -> (<> " ;\n") <$> serializeClosedOpZip op+ Value chunk -> serializeReducedChunk False chunk+ Query chunk -> serializeReducedChunk True chunk -- | Serialize a reduced chunk serializeReducedChunk :: Bool -> WireReducedChunk -> State ClosedOp ByteStringL-serializeReducedChunk isQuery WireReducedChunk{wrcHeader, wrcBody} =- BSLC.unlines <$> liftA2 (:) serializeHeader serializeBody+serializeReducedChunk isQuery WireReducedChunk {wrcHeader, wrcBody} =+ BSL.unlines <$> liftA2 (:) serializeHeader serializeBody where serializeHeader = do- h <- serializeClosedOpZip wrcHeader- pure $ BSLC.unwords [h, if isQuery then "?" else "!"]- serializeBody = state $ \ClosedOp{op = opBefore, ..} -> let- (body, opAfter) =- (`runState` opBefore) $- for wrcBody $- fmap ("\t" <>) . serializeReducedOpZip objectId- in- ( body- , ClosedOp{op = opAfter, ..}- )+ h <- serializeClosedOpZip wrcHeader+ pure $ BSL.intercalate "\t" [h, if isQuery then "?" else "!"]+ serializeBody = state $ \ClosedOp {op = opBefore, ..} ->+ let (body, opAfter) =+ (`runState` opBefore)+ $ for wrcBody+ $ fmap ("\t" <>)+ . serializeReducedOpZip objectId+ in (body, ClosedOp {op = opAfter, ..}) -- | Serialize a context-free raw op serializeRawOp :: ClosedOp -> ByteStringL@@ -79,45 +82,41 @@ -- | Serialize a raw op with compression in stream context serializeClosedOpZip :: ClosedOp -> State ClosedOp ByteStringL-serializeClosedOpZip this = state $ \prev -> let- prev' = op prev- 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- ++ [payloadAtoms | not $ BSL.null payloadAtoms]- , this- )+serializeClosedOpZip this = state $ \prev ->+ let prev' = op prev+ 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 ( BSL.intercalate "\t"+ $ key '*' typ+ ++ key '#' obj+ ++ key '@' evt+ ++ key ':' ref+ ++ [payloadAtoms | not $ BSL.null payloadAtoms],+ this+ ) where this' = op this- key c u = [BSLC.cons c u | not $ BSL.null u]+ key c u = [c `cons` u | not $ BSL.null u] -- | Serialize a reduced op with compression in stream context serializeReducedOpZip- :: UUID -- ^ enclosing object- -> Op- -> State Op ByteStringL-serializeReducedOpZip opObject this = state $ \prev -> let- evt = serializeUuidKey (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)- ++ [payloadAtoms | not $ BSL.null payloadAtoms]- , this- )+ :: UUID -- ^ enclosing object+ -> Op+ -> State Op ByteStringL+serializeReducedOpZip opObject this = state $ \prev ->+ let evt = serializeUuidKey (opId prev) opObject (opId this)+ ref = serializeUuidKey (refId prev) (opId this) (refId this)+ payloadAtoms = serializePayload opObject (payload this)+ keys+ | BSL.null evt && BSL.null ref = ["@"]+ | otherwise = key '@' evt ++ key ':' ref+ op = keys ++ [payloadAtoms | not $ BSL.null payloadAtoms]+ in (BSL.intercalate "\t" op, this) where- key c u = [BSLC.cons c u | not $ BSL.null u]+ key c u = [c `cons` u | not $ BSL.null u] -- | Serialize a context-free atom serializeAtom :: Atom -> ByteStringL@@ -126,64 +125,62 @@ -- | Serialize an atom with compression for UUID in stream context serializeAtomZip :: Atom -> State UUID ByteStringL serializeAtomZip = \case- AFloat f -> pure $ serializeFloatAtom f- AInteger i -> pure $ serializeIntegerAtom i- AString s -> pure $ serializeString s- AUuid u -> serializeUuidAtom' u+ AFloat f -> pure $ serializeFloatAtom f+ AInteger i -> pure $ serializeIntegerAtom i+ AString s -> pure $ serializeString s+ AUuid u -> serializeUuidAtom' u -- | Serialize a float atom. -- If unambiguous, i.e. contains a '.' or an 'e'/'E', the prefix '^' is skipped. serializeFloatAtom :: Double -> ByteStringL-serializeFloatAtom f = let- s = show f- p = ('.' `List.elem` s || 'e' `List.elem` s || 'E' `List.elem` s)- b = BSLC.pack s- in if p then b- else BSLC.cons '^' b+serializeFloatAtom float+ | isDistinguishableFromUuid = bs+ | otherwise = '^' `cons` bs+ where+ isDistinguishableFromUuid = '.' `elem` bs || 'e' `elem` bs || 'E' `elem` bs+ bs = BSL.pack $ show float -- | Serialize an integer atom. -- Since integers are always unambiguous, the prefix '=' is always skipped. serializeIntegerAtom :: Int64 -> ByteStringL-serializeIntegerAtom i =- BSLC.pack (show i)+serializeIntegerAtom = BSL.pack . show -- | Serialize a string atom serializeString :: Text -> ByteStringL serializeString =- wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode+ wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode where- wrapSingleQuotes = (`BSLC.snoc` '\'') . BSLC.cons '\''+ wrapSingleQuotes = (`snoc` '\'') . cons '\'' stripDoubleQuotes = BSL.init . BSL.tail- escapeApostrophe s = let- (s1, s2) = BSLC.break (== '\'') s- in- if BSL.null s2 then- s1- else- s1 <> "\\'" <> escapeApostrophe (BSL.tail s2)+ escapeApostrophe s+ | BSL.null s2 = s1+ | otherwise = s1 <> "\\'" <> escapeApostrophe (BSL.tail s2)+ where+ (s1, s2) = BSL.break (== '\'') s serializeUuidAtom' :: UUID -> State UUID ByteStringL serializeUuidAtom' u =- -- FIXME: Check if uuid can be unambiguously serialized and if so, skip the prefix.- state $ \prev -> (BSLC.cons '>' $ serializeUuidAtom prev u, u)+ -- TODO(2019-08-19, cblp): Check if uuid can be unambiguously serialized and+ -- if so, skip the prefix.+ state $ \prev -> (cons '>' $ serializeUuidAtom prev u, u) -- | Serialize a payload in stream context serializePayload- :: UUID -- ^ previous UUID (default is 'zero')- -> Payload- -> ByteStringL+ :: UUID -- ^ previous UUID (default is 'zero')+ -> Payload+ -> ByteStringL serializePayload prev =- BSLC.unwords . (`evalState` prev) . traverse serializeAtomZip+ BSL.unwords . (`evalState` prev) . traverse serializeAtomZip -- | Serialize a state frame serializeStateFrame :: StateFrame -> ByteStringL-serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs where- wrapChunk (objectId, WireStateChunk{stateType, stateBody}) =- Value- WireReducedChunk- { wrcHeader = opZero{reducerId = stateType, objectId}- , wrcBody = stateBody- }+serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs+ where+ wrapChunk (objectId, WireStateChunk {stateType, stateBody}) =+ Value WireReducedChunk+ { wrcHeader = opZero {reducerId = stateType, objectId},+ wrcBody = stateBody+ } -- | Serialize an object. Return object id that must be stored separately. serializeObject :: ObjectFrame a -> (UUID, ByteStringL)@@ -191,7 +188,7 @@ opZero :: ClosedOp opZero = ClosedOp- { reducerId = zero- , objectId = zero- , op = Op{opId = zero, refId = zero, payload = []}+ { reducerId = zero,+ objectId = zero,+ op = Op {opId = zero, refId = zero, payload = []} }
lib/RON/Types.hs view
@@ -12,7 +12,7 @@ module RON.Types ( Atom (..), ClosedOp (..),- Object (..),+ ObjectRef (..), ObjectFrame (..), Op (..), OpTerm (..),@@ -124,18 +124,18 @@ type StateFrame = Map UUID WireStateChunk -- | Reference to an object-newtype Object a = Object UUID+newtype ObjectRef a = ObjectRef UUID deriving (Eq) -instance Typeable a => Show (Object a) where- showsPrec a (Object b) =+instance Typeable a => Show (ObjectRef a) where+ showsPrec a (ObjectRef b) = showParen (a >= 11)- $ showString "Object @"+ $ showString "ObjectRef @" . showsPrec 11 (typeRep $ Proxy @a) . showString " " . showsPrec 11 b --- | Object accompanied with a frame+-- | Object reference accompanied with a frame data ObjectFrame a = ObjectFrame{uuid :: UUID, frame :: StateFrame} deriving (Eq, Show)
ron.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-version: 0.8+version: 0.9 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -41,6 +41,8 @@ template-haskell, text, time,+ transformers >= 0.5.6.0,+ -- ^ Writer.CPS unordered-containers exposed-modules: RON.Base64@@ -65,6 +67,7 @@ other-modules: Attoparsec.Extra Data.ZigZag+ RON.Prelude.Writer hs-source-dirs: lib benchmark bench