diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -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 diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs --- a/lib/RON/Event/Simulation.hs +++ b/lib/RON/Event/Simulation.hs @@ -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 diff --git a/lib/RON/Prelude.hs b/lib/RON/Prelude.hs --- a/lib/RON/Prelude.hs +++ b/lib/RON/Prelude.hs @@ -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) diff --git a/lib/RON/Prelude/Writer.hs b/lib/RON/Prelude/Writer.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Prelude/Writer.hs @@ -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 diff --git a/lib/RON/Text/Serialize.hs b/lib/RON/Text/Serialize.hs --- a/lib/RON/Text/Serialize.hs +++ b/lib/RON/Text/Serialize.hs @@ -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 = []} } diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs --- a/lib/RON/Types.hs +++ b/lib/RON/Types.hs @@ -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) diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -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