ron 0.11 → 0.12
raw patch · 22 files changed
+562/−323 lines, 22 filesdep +vector
Dependencies added: vector
Files
- CHANGELOG.md +10/−1
- lib/Attoparsec/Extra.hs +10/−9
- lib/Data/ZigZag.hs +2/−1
- lib/RON/Base64.hs +0/−1
- lib/RON/Binary/Parse.hs +0/−1
- lib/RON/Binary/Serialize.hs +0/−1
- lib/RON/Epoch.hs +20/−24
- lib/RON/Error.hs +31/−9
- lib/RON/Event.hs +140/−132
- lib/RON/Event/Simulation.hs +16/−14
- lib/RON/Prelude.hs +13/−6
- lib/RON/Semilattice.hs +20/−7
- lib/RON/Text.hs +10/−3
- lib/RON/Text/Parse.hs +82/−26
- lib/RON/Text/Serialize.hs +62/−36
- lib/RON/Text/Serialize/Experimental.hs +17/−0
- lib/RON/Text/Serialize/UUID.hs +10/−1
- lib/RON/Types.hs +43/−38
- lib/RON/UUID/Experimental.hs +60/−0
- lib/RON/Util.hs +0/−5
- lib/RON/Util/Word.hs +10/−5
- ron.cabal +6/−3
CHANGELOG.md view
@@ -7,6 +7,13 @@ ## [Unreleased] +## [0.12] - 2021-07-15+### Added+- Support for GHC 8.10.++### Fixed+- Internal parser helper (<+>)+ ## [0.11] - 2020-06-14 ### Added - Support for GHC 8.8.@@ -151,7 +158,9 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.10...HEAD+[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.12...HEAD+[0.12]: https://github.com/ff-notes/ron/compare/ron-0.11...ron-0.12+[0.11]: https://github.com/ff-notes/ron/compare/ron-0.10...ron-0.11 [0.10]: https://github.com/ff-notes/ron/compare/ron-0.9...ron-0.10 [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
lib/Attoparsec/Extra.hs view
@@ -16,18 +16,19 @@ import RON.Prelude -import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, isDigit_w8, signed)+import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, isDigit_w8,+ signed)+import Data.Attoparsec.ByteString.Lazy as Attoparsec 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.ByteString.Lazy (fromStrict) import qualified Data.Scientific as Sci import GHC.Real (toInteger) -import RON.Util (ByteStringL)-+-- | TODO(2020-06-17, cblp) make parser lazy/incremental+-- TODO(2021-04-25, cblp) remove in favor of attoparsec-0.14 lazy version parseOnlyL :: Parser a -> ByteStringL -> Either String a-parseOnlyL p = parseOnly p . toStrict+parseOnlyL p = eitherResult . parse p -- | 'Attoparsec.take' adapter to 'ByteStringL' takeL :: Int -> Parser ByteStringL@@ -73,8 +74,8 @@ pos <- getPos guard (pos >= maxPos) <|> endOfInput -(??) :: Maybe a -> Parser a -> Parser a-(??) a alt = maybe alt pure a+(??) :: Applicative f => Maybe a -> f a -> f a+a ?? alt = maybe alt pure a -- | Apply parser and check it is applied successfully. -- Kinda opposite to 'guard'.@@ -124,7 +125,7 @@ (<+>) p1 p2 = Internal.Parser $ \t pos more lose suc -> let lose1 t' _pos more1 ctx1 msg1 = Internal.runParser p2 t' pos more1 lose2 suc where- lose2 _t _pos _more ctx2 msg2 = lose t pos more [] $ unwords+ lose2 t2 pos2 more2 ctx2 msg2 = lose t2 pos2 more2 [] $ unwords [ "Many fails:\n" , intercalate " > " ctx1, ":", msg1, "|\n" , intercalate " > " ctx2, ":", msg2
lib/Data/ZigZag.hs view
@@ -15,7 +15,8 @@ {-# SPECIALIZE INLINE zzEncode :: Int32 -> Word32 #-} {-# SPECIALIZE INLINE zzEncode :: Int64 -> Word64 #-} zzEncode :: (Num b, Integral a, FiniteBits a) => a -> b-zzEncode w = fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w -1)))+zzEncode w =+ fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w - 1))) {-# INLINE zzDecode #-} zzDecode :: (Num a, Integral a1, Bits a1) => a1 -> a
lib/RON/Base64.hs view
@@ -28,7 +28,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import RON.Util (ByteStringL) import RON.Util.Word (Word4, Word6 (W6), Word60, leastSignificant4, leastSignificant6, leastSignificant60, safeCast)
lib/RON/Binary/Parse.hs view
@@ -33,7 +33,6 @@ Payload, UUID (UUID), WireChunk (Closed, Query, Value), WireFrame, WireReducedChunk (..))-import RON.Util (ByteStringL) import RON.Util.Word (safeCast) -- | 'Parser' for descriptor
lib/RON/Binary/Serialize.hs view
@@ -25,7 +25,6 @@ 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
lib/RON/Epoch.hs view
@@ -4,8 +4,8 @@ EpochClock, decode, encode,+ epochTimeFromUnix, getCurrentEpochTime,- localEpochTimeFromUnix, runEpochClock, runEpochClockFromCurrentTime, ) where@@ -15,50 +15,50 @@ import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) -import RON.Event (EpochEvent (EpochEvent), EpochTime,- LocalTime (TEpoch), ReplicaClock, ReplicaId,- advance, getEvents, getPid)-import RON.Util.Word (leastSignificant60, ls60, safeCast, word60add)+import RON.Event (Event (..), Replica, ReplicaClock,+ TimeVariety (Epoch), advance, getEvents, getPid,+ mkTime)+import RON.Util.Word (Word60, leastSignificant60, safeCast) -- | Real epoch clock. -- Uses kind of global variable to ensure strict monotonicity.-newtype EpochClock a = EpochClock (ReaderT (ReplicaId, IORef EpochTime) IO a)+newtype EpochClock a = EpochClock (ReaderT (Replica, IORef Word60) IO a) deriving (Applicative, Functor, Monad, MonadIO) instance ReplicaClock EpochClock where getPid = EpochClock $ reader fst - advance time = EpochClock $ ReaderT $ \(_pid, timeVar) ->- atomicModifyIORef' timeVar $ \t0 -> (max time t0, ())+ advance theirTime = EpochClock $ ReaderT $ \(_pid, timeVar) ->+ atomicModifyIORef' timeVar $ \ourTime -> (max theirTime ourTime, ()) getEvents n0 = EpochClock $ ReaderT $ \(pid, timeVar) -> do- let n = max n0 $ ls60 1+ let n = max n0 1 realTime <- getCurrentEpochTime (begin, end) <- atomicModifyIORef' timeVar $ \timeCur -> let begin = max realTime $ succ timeCur- end = begin `word60add` pred n+ end = begin + pred n in (end, (begin, end))- pure [EpochEvent t pid | t <- [begin .. end]]+ pure [Event{time = mkTime Epoch t, replica = pid} | t <- [begin .. end]] -- | Run 'EpochClock' action with explicit time variable.-runEpochClock :: ReplicaId -> IORef EpochTime -> EpochClock a -> IO a+runEpochClock :: Replica -> IORef Word60 -> EpochClock a -> IO a runEpochClock replicaId timeVar (EpochClock action) = runReaderT action (replicaId, timeVar) -- | Like 'runEpochClock', but initialize time variable with current wall time.-runEpochClockFromCurrentTime :: ReplicaId -> EpochClock a -> IO a+runEpochClockFromCurrentTime :: Replica -> EpochClock a -> IO a runEpochClockFromCurrentTime replicaId clock = do- time <- getCurrentEpochTime- timeVar <- newIORef time+ wallTime <- getCurrentEpochTime+ timeVar <- newIORef wallTime runEpochClock replicaId timeVar clock --- | Get current time in 'EpochTime' format (with 100 ns resolution).+-- | Get current time in 'Time' format (with 100 ns resolution). -- Monotonicity is not guaranteed.-getCurrentEpochTime :: IO EpochTime+getCurrentEpochTime :: IO Word60 getCurrentEpochTime = encode <$> getPOSIXTime -- | Convert unix time in hundreds of milliseconds to RFC 4122 time.-epochTimeFromUnix :: Word64 -> EpochTime+epochTimeFromUnix :: Word64 -> Word60 epochTimeFromUnix = leastSignificant60 . (+ epochDiff) -- The difference between Unix epoch and UUID epoch;@@ -66,12 +66,8 @@ epochDiff :: Word64 epochDiff = 0x01B21DD213814000 --- | Convert unix time in hundreds of milliseconds to RFC 4122 time.-localEpochTimeFromUnix :: Word64 -> LocalTime-localEpochTimeFromUnix = TEpoch . epochTimeFromUnix- -- | Decode date and time from UUID epoch timestamp-decode :: EpochTime -> UTCTime+decode :: Word60 -> UTCTime decode = posixSecondsToUTCTime . realToFrac@@ -79,5 +75,5 @@ . subtract epochDiff . safeCast -encode :: POSIXTime -> EpochTime+encode :: POSIXTime -> Word60 encode = epochTimeFromUnix . round . (* 10000000)
lib/RON/Error.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} module RON.Error ( Error (..),@@ -9,24 +11,30 @@ liftEither, liftEitherString, liftMaybe,+ throwError, throwErrorString, throwErrorText,+ tryIO, ) where import RON.Prelude +import Control.Exception (SomeException, try) import Data.String (IsString, fromString)+import qualified Data.Text as Text+import GHC.Stack (callStack, getCallStack, prettySrcLoc)+import qualified Text.Show -data Error = Error Text [Error]- deriving (Eq, Show)-{- TODO(2019-08-09, cblp)- data Error = Error- { context :: [Text]- , desc :: Text- , reasons :: [Error]- }--}+data Error = Error{description :: Text, reasons :: [Error]}+ deriving (Eq) +instance Show Error where+ show =+ unlines . go+ where+ go Error{description, reasons} =+ Text.unpack description : foldMap (map (" " ++) . go) reasons+ instance Exception Error instance IsString Error where@@ -55,3 +63,17 @@ `catchError` \_e -> -- TODO(2019-08-06, cblp) $logWarnSH e pure def++tryIO :: (MonadE m, MonadIO m, HasCallStack) => IO a -> m a+tryIO action = do+ e <- liftIO $ try action+ case e of+ Right a -> pure a+ Left exc -> do+ let+ description =+ case getCallStack callStack of+ [] -> "tryIO"+ (f, loc) : _ -> Text.pack $ f ++ ", called at " ++ prettySrcLoc loc+ throwError+ Error{description, reasons = [fromString (show (exc :: SomeException))]}
lib/RON/Event.hs view
@@ -1,50 +1,54 @@ {-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} module RON.Event (- CalendarTime (..),- CalendarEvent (..),- EpochEvent (..),- EpochTime,- Event (..),- LocalTime (..),- Naming (..),- ReplicaClock (..),- ReplicaId (..),- advanceToUuid,- applicationSpecific,- decodeEvent,- encodeEvent,- fromCalendarEvent,- fromEpochEvent,- getEvent,- getEventUuid,- getEventUuids,- mkCalendarDate,- mkCalendarDateTime,- mkCalendarDateTimeNano,- toEpochEvent,+ CalendarTime (..),+ Event (..),+ Time (..),+ TimeVariety (.., Calendar, Logical, Epoch, Unknown),+ OriginVariety+ (.., TrieForked, CryptoForked, RecordForked, ApplicationSpecific),+ ReplicaClock (..),+ Replica (..),+ advanceToUuid,+ decodeCalendar,+ decodeEvent,+ decodeReplica,+ encodeCalendar,+ encodeEvent,+ getEvent,+ getEventUuid,+ getEventUuids,+ mkCalendarDate,+ mkCalendarDateTime,+ mkCalendarDateTimeNano,+ mkCalendarEvent,+ mkReplica,+ mkTime,+ timeValue,+ timeVariety, ) where import RON.Prelude -import Data.Bits (shiftL, shiftR, (.|.))-import Data.Hashable (hashUsing, hashWithSalt)+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString.Char8 as BSC import Data.Time (fromGregorianValid, makeTimeOfDayValid)+import qualified Text.Show +import RON.Base64 (encode60short) import RON.Util.Word (pattern B00, pattern B01, pattern B10, pattern B11, Word12, Word2, Word24, Word6, Word60, leastSignificant12, leastSignificant2,- leastSignificant24, leastSignificant4,- leastSignificant6, ls12, ls24, ls6, ls60,- safeCast)-import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin, uuidValue,- uuidVariant, uuidVariety, uuidVersion)+ leastSignificant24, leastSignificant6, ls12,+ ls24, ls6, ls60, safeCast)+import RON.UUID (UUID (..), UuidFields (..)) import qualified RON.UUID as UUID -- | Calendar format. See https://github.com/gritzko/ron/issues/19.@@ -60,77 +64,93 @@ } deriving (Eq, Ord, Show) +newtype TimeVariety = TimeVariety Word2++pattern Calendar :: TimeVariety+pattern Calendar = TimeVariety B00++pattern Logical :: TimeVariety+pattern Logical = TimeVariety B01+ -- | RFC 4122 epoch, hundreds of nanoseconds since 1582. -- Year range is 1582—5235.-type EpochTime = Word60+pattern Epoch :: TimeVariety+pattern Epoch = TimeVariety B10 +pattern Unknown :: TimeVariety+pattern Unknown = TimeVariety B11++{-# COMPLETE Calendar, Logical, Epoch, Unknown #-}++instance Show TimeVariety where+ show = \case+ Calendar -> "Calendar"+ Logical -> "Logical"+ Epoch -> "Epoch"+ Unknown -> "Unknown"+ -- | Clock type is encoded in 2 higher bits of variety, value in uuidValue-data LocalTime- = TCalendar !CalendarTime- | TLogical !Word60- -- ^ https://en.wikipedia.org/wiki/Logical_clock- | TEpoch !EpochTime- | TUnknown !Word60- deriving (Eq, Show)+newtype Time = Time Word64+ deriving (Eq, Ord) --- | Replica id assignment style-data Naming- = TrieForked- | CryptoForked- | RecordForked- | ApplicationSpecific- deriving (Bounded, Enum, Eq, Show)+instance Show Time where+ show t =+ show (timeVariety t) ++ '/' : BSC.unpack (encode60short $ timeValue t) -instance Hashable Naming where- hashWithSalt = hashUsing fromEnum+timeVariety :: Time -> TimeVariety+timeVariety (Time w64) = TimeVariety $ leastSignificant2 $ w64 `shiftR` 62 --- | Replica identifier-data ReplicaId = ReplicaId !Naming !Word60- deriving (Eq, Show, Generic, Hashable)+timeValue :: Time -> Word60+timeValue (Time w64) = ls60 w64 --- | Generic Lamport time event.--- Cannot be 'Ord' because we can't compare different types of clocks.--- If you want comparable events, use specific 'EpochEvent'.-data Event = Event !LocalTime !ReplicaId- deriving (Eq, Show)+-- | Replica id assignment style+newtype OriginVariety = OriginVariety Word2+ deriving newtype (Hashable) --- | Calendar-based Lamport time event, specific case of 'Event'.-data CalendarEvent = CalendarEvent !CalendarTime !ReplicaId- deriving (Eq, Show)+pattern TrieForked :: OriginVariety+pattern TrieForked = OriginVariety B00 -instance Ord CalendarEvent where- compare (CalendarEvent t1 (ReplicaId n1 r1))- (CalendarEvent t2 (ReplicaId n2 r2))- = compare- (t1, fromEnum n1, r1)- (t2, fromEnum n2, r2)+pattern CryptoForked :: OriginVariety+pattern CryptoForked = OriginVariety B01 -fromCalendarEvent :: CalendarEvent -> Event-fromCalendarEvent (CalendarEvent t r) = Event (TCalendar t) r+pattern RecordForked :: OriginVariety+pattern RecordForked = OriginVariety B10 --- | Epoch-based Lamport time event, specific case of 'Event'.-data EpochEvent = EpochEvent !EpochTime !ReplicaId- deriving (Eq, Show)+pattern ApplicationSpecific :: OriginVariety+pattern ApplicationSpecific = OriginVariety B11 -instance Ord EpochEvent where- compare (EpochEvent t1 (ReplicaId n1 r1))- (EpochEvent t2 (ReplicaId n2 r2))- = compare- (t1, fromEnum n1, r1)- (t2, fromEnum n2, r2)+{-# COMPLETE TrieForked, CryptoForked, RecordForked, ApplicationSpecific #-} -fromEpochEvent :: EpochEvent -> Event-fromEpochEvent (EpochEvent t r) = Event (TEpoch t) r+instance Show OriginVariety where+ show = \case+ TrieForked -> "Trie"+ CryptoForked -> "Crypto"+ RecordForked -> "Record"+ ApplicationSpecific -> "App" -toEpochEvent :: Event -> Maybe EpochEvent-toEpochEvent (Event t r) = case t of- TEpoch t' -> Just $ EpochEvent t' r- _ -> Nothing+-- | Replica identifier.+-- Implementation: naming (62-61) and origin (60-0 bits) fields from UUID+newtype Replica = Replica Word64+ deriving newtype (Eq, Hashable, Ord) +instance Show Replica where+ show (Replica w64) =+ show (OriginVariety $ leastSignificant2 $ w64 `shiftR` 60)+ ++ '/' : BSC.unpack (encode60short $ ls60 w64)++-- | Generic Lamport time event.+-- Cannot be 'Ord' because we can't compare different types of clocks.+-- If you want comparable events, use specific 'EpochEvent'.+data Event = Event+ { time :: !Time+ , replica :: !Replica+ }+ deriving (Eq, Generic, Show)+ class Monad m => ReplicaClock m where -- | Get current replica id- getPid :: m ReplicaId+ getPid :: m Replica -- | Get sequential timestamps. --@@ -149,11 +169,11 @@ -- -- 3. @getEvents 0 == getEvents 1@ getEvents- :: EpochTime -- ^ number of needed timestamps- -> m [EpochEvent]+ :: Word60 -- ^ number of needed timestamps+ -> m [Event] -- | Make local time not less than this- advance :: EpochTime -> m ()+ advance :: Word60 -> m () instance ReplicaClock m => ReplicaClock (ExceptT e m) where getPid = lift getPid@@ -177,21 +197,24 @@ -- | 'advance' variant for any UUID advanceToUuid :: ReplicaClock clock => UUID -> clock ()-advanceToUuid = advance . uuidValue . UUID.split+advanceToUuid uuid =+ when (uuidVariant == B00 && uuidVersion == B10) $ advance uuidValue+ where+ UuidFields{uuidValue, uuidVariant, uuidVersion} = UUID.split uuid -- | Get a single event-getEvent :: (HasCallStack, ReplicaClock m) => m EpochEvent+getEvent :: (HasCallStack, ReplicaClock m) => m Event getEvent = getEvents (ls60 1) >>= \case e:_ -> pure e [] -> error "getEvents returned no events" -- | Get a single event as UUID getEventUuid :: ReplicaClock m => m UUID-getEventUuid = encodeEvent . fromEpochEvent <$> getEvent+getEventUuid = encodeEvent <$> getEvent -- | Get event sequence as UUIDs getEventUuids :: ReplicaClock m => Word60 -> m [UUID]-getEventUuids = fmap (map $ encodeEvent . fromEpochEvent) . getEvents+getEventUuids = fmap (map encodeEvent) . getEvents encodeCalendar :: CalendarTime -> Word60 encodeCalendar CalendarTime{..} = ls60 $@@ -214,53 +237,29 @@ where v = safeCast w :: Word64 -encodeLocalTime :: LocalTime -> (Word2, Word60)-encodeLocalTime = \case- TCalendar t -> (B00, encodeCalendar t)- TLogical t -> (B01, t)- TEpoch t -> (B10, t)- TUnknown t -> (B11, t)--decodeLocalTime :: Word2 -> Word60 -> LocalTime-decodeLocalTime = \case- B00 -> TCalendar . decodeCalendar- B01 -> TLogical- B10 -> TEpoch- B11 -> TUnknown+decodeTime :: Word64 -> Time+decodeTime value = Time $ value .&. 0xCFFFFFFFFFFFFFFF encodeEvent :: Event -> UUID-encodeEvent (Event time replicaId) = UUID.build UuidFields- { uuidVariety- , uuidValue- , uuidVariant = B00- , uuidVersion = B10- , uuidOrigin- }+encodeEvent Event{time, replica} =+ UUID (varietyAndValue .|. originVariety) (eventVersion .|. origin) where- (varietyMS2, uuidValue) = encodeLocalTime time- (varietyLS2, uuidOrigin) = encodeReplicaId replicaId- uuidVariety = leastSignificant4 $- ((safeCast varietyMS2 :: Word8) `shiftL` 2) .|.- ( safeCast varietyLS2 :: Word8)+ Time varietyAndValue = time+ (originVariety, origin) = encodeReplicaId replica+ eventVersion = 0x2000000000000000 decodeEvent :: UUID -> Event-decodeEvent uuid = Event- (decodeLocalTime- (leastSignificant2 (safeCast uuidVariety `shiftR` 2 :: Word8))- uuidValue)- (decodeReplicaId- (leastSignificant2 (safeCast uuidVariety :: Word8)) uuidOrigin)- where- UuidFields{uuidVariety, uuidValue, uuidOrigin} = UUID.split uuid+decodeEvent u@(UUID x _) = Event{replica = decodeReplica u, time = decodeTime x} -decodeReplicaId :: Word2 -> Word60 -> ReplicaId-decodeReplicaId varietyLS2 = ReplicaId $ toEnum $ safeCast varietyLS2+decodeReplica :: UUID -> Replica+decodeReplica (UUID x y) =+ Replica $ (x .&. 0x3000000000000000) .|. (y .&. 0x0FFFFFFFFFFFFFFF) -encodeReplicaId :: ReplicaId -> (Word2, Word60)-encodeReplicaId (ReplicaId naming origin) =- ( leastSignificant2 $ fromEnum naming- , origin- )+encodeReplicaId :: Replica -> (Word64, Word64)+encodeReplicaId (Replica r) =+ ( r .&. 0x3000000000000000+ , r .&. 0x0FFFFFFFFFFFFFFF+ ) -- | Make a calendar timestamp from a date mkCalendarDate@@ -299,6 +298,15 @@ , nanosecHundreds = ls24 hns } --- | Make an 'ApplicationSpecific' replica id from arbitrary number-applicationSpecific :: Word64 -> ReplicaId-applicationSpecific = ReplicaId ApplicationSpecific . ls60+-- | Make a replica id from 'OriginVariety' and arbitrary number+mkReplica :: OriginVariety -> Word60 -> Replica+mkReplica (OriginVariety variety) origin =+ Replica $ (safeCast variety `shiftL` 60) .|. safeCast origin++mkTime :: TimeVariety -> Word60 -> Time+mkTime (TimeVariety variety) value =+ Time $ (safeCast variety `shiftL` 62) .|. safeCast value++mkCalendarEvent :: CalendarTime -> Replica -> Event+mkCalendarEvent time replica =+ Event{time = mkTime Calendar $ encodeCalendar time, replica}
lib/RON/Event/Simulation.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} -- | Lamport clock network simulation. -- 'ReplicaSim' provides 'Replica' and 'Clock' instances,@@ -16,20 +17,21 @@ import Control.Monad.State.Strict (state) import qualified Data.HashMap.Strict as HM -import RON.Event (EpochEvent (EpochEvent), ReplicaClock,- ReplicaId (ReplicaId), advance, getEvents, getPid)-import RON.Util.Word (Word60, ls60, word60add)+import RON.Event (Event (..), Replica (Replica), ReplicaClock,+ TimeVariety (Logical), advance, getEvents, getPid,+ mkTime)+import RON.Util.Word (Word60, ls60) --- | Lamport clock simulation. Key is 'ReplicaId'.+-- | Lamport clock simulation. Key is 'Replica'. -- Non-present value is equivalent to (0, initial).-newtype NetworkSimT m a = NetworkSim (StateT (HashMap ReplicaId Word60) m a)+newtype NetworkSimT m a = NetworkSim (StateT (HashMap Replica Word60) m a) deriving (Applicative, Functor, Monad, MonadError e) instance MonadTrans NetworkSimT where lift = NetworkSim . lift -- | ReplicaSim inside Lamport clock simulation.-newtype ReplicaSimT m a = ReplicaSim (ReaderT ReplicaId (NetworkSimT m) a)+newtype ReplicaSimT m a = ReplicaSim (ReaderT Replica (NetworkSimT m) a) deriving (Applicative, Functor, Monad, MonadError e) instance MonadTrans ReplicaSimT where@@ -39,17 +41,17 @@ getPid = ReplicaSim ask getEvents n' = ReplicaSim $ do- rid <- ask+ replica <- ask (t0, t1) <- lift $ NetworkSim $ state $ \replicaStates -> let- t0orig = HM.lookupDefault (ls60 0) rid replicaStates- ReplicaId _ r = rid+ t0orig = HM.lookupDefault (ls60 0) replica replicaStates+ Replica r = replica randomLeap = ls60 . fromIntegral $ hash (t0orig, n, r) `mod` 0x10000- t0 = t0orig `word60add` randomLeap- t1 = t0 `word60add` n- in ((t0, t1), HM.insert rid t1 replicaStates)- pure [EpochEvent t rid | t <- [succ t0 .. t1]]+ t0 = t0orig + randomLeap+ t1 = t0 + n+ in ((t0, t1), HM.insert replica t1 replicaStates)+ pure [Event{time = mkTime Logical t, replica} | t <- [succ t0 .. t1]] where n = max n' (ls60 1) @@ -82,5 +84,5 @@ runNetworkSimT :: Monad m => NetworkSimT m a -> m a runNetworkSimT (NetworkSim action) = evalStateT action mempty -runReplicaSimT :: ReplicaId -> ReplicaSimT m a -> NetworkSimT m a+runReplicaSimT :: Replica -> ReplicaSimT m a -> NetworkSimT m a runReplicaSimT rid (ReplicaSim action) = runReaderT action rid
lib/RON/Prelude.hs view
@@ -2,6 +2,7 @@ module RON.Prelude ( module X,+ ByteStringL, fmapL, foldr1, headMay,@@ -24,7 +25,7 @@ ) where -- TODO import RON.Prelude.Writer as X-import Control.Monad.Writer.Strict as X (WriterT, runWriterT, tell)+import Control.Monad.Writer.Strict as X (WriterT, runWriterT, tell) -- base import Control.Applicative as X (Alternative, Applicative, liftA2,@@ -39,7 +40,7 @@ import Control.Monad.Fail as X (MonadFail, fail) import Control.Monad.IO.Class as X (MonadIO, liftIO) import Control.Monad.Reader as X (MonadReader, ReaderT (ReaderT), ask,- reader, runReaderT)+ asks, reader, runReaderT) import Control.Monad.State.Strict as X (MonadState, State, StateT, evalState, evalStateT, execStateT, get, gets,@@ -54,9 +55,9 @@ 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, elem, fold, foldMap,- foldl', foldr, for_, length, null, or,- toList, traverse_)+import Data.Foldable as X (Foldable, all, and, any, 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)@@ -67,7 +68,7 @@ readIORef, writeIORef) import Data.List as X (drop, filter, genericLength, intercalate, isPrefixOf, isSuffixOf, lookup, map, partition,- repeat, replicate, sortBy, sortOn, span,+ repeat, replicate, sort, sortBy, sortOn, span, splitAt, take, takeWhile, unlines, unwords, zip, zipWith, (++)) import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)@@ -81,12 +82,15 @@ import Data.Proxy as X (Proxy (Proxy)) import Data.Ratio as X ((%)) import Data.Semigroup as X (Semigroup, sconcat, (<>))+import Data.Sequence as X (Seq)+import Data.Set as X (Set) import Data.String as X (String) import Data.Text as X (Text) import Data.Time as X (UTCTime) 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.Vector as X (Vector) import Data.Word as X (Word, Word16, Word32, Word64, Word8) import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound, pred, succ, toEnum)@@ -104,10 +108,13 @@ -------------------------------------------------------------------------------- +import qualified Data.ByteString.Lazy as BSL import qualified Data.Foldable import Data.List (last, maximum, maximumBy, minimum, minimumBy) import Data.String (IsString, fromString) import qualified Text.Show++type ByteStringL = BSL.ByteString fmapL :: (a -> b) -> Either a c -> Either b c fmapL f = either (Left . f) Right
lib/RON/Semilattice.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-} module RON.Semilattice (- Semilattice,+ Semilattice (..), BoundedSemilattice, ) where -import Data.Maybe (Maybe)-import Data.Monoid (Monoid)-import Data.Ord (Ord)-import Data.Semigroup (Max, Semigroup)+import Prelude++import Data.Semigroup (Max) import Data.Set (Set) {- |@@ -27,9 +27,19 @@ [idempotency] @x '<>' x == x@++[relation-operation equivalence]++ @x '≼' y == (x '<>' y == y)@+ @x '<>' y == minimum \z -> x '≼' z && y '≼' z@ -}-class Semigroup a => Semilattice a+class Semigroup a => Semilattice a where + -- | Semilattice relation.+ (≼) :: a -> a -> Bool+ default (≼) :: Eq a => a -> a -> Bool+ a ≼ b = a <> b == b+ {- | A bounded semilattice. @@ -44,4 +54,7 @@ instance Ord a => Semilattice (Set a) -instance Semilattice a => Semilattice (Maybe a)+instance Semilattice a => Semilattice (Maybe a) where+ Nothing ≼ _ = True+ _ ≼ Nothing = False+ Just a ≼ Just b = a ≼ b
lib/RON/Text.hs view
@@ -1,6 +1,7 @@ -- | RON-Text wire format module RON.Text ( parseObject,+ parseStateChunk, parseStateFrame, parseWireFrame, parseWireFrames,@@ -8,9 +9,15 @@ serializeStateFrame, serializeWireFrame, serializeWireFrames,+ uuidFromString,+ uuidFromText,+ uuidToString,+ uuidToText, ) where -import RON.Text.Parse (parseObject, parseStateFrame, parseWireFrame,- parseWireFrames)+import RON.Text.Parse (parseObject, parseStateChunk, parseStateFrame,+ parseWireFrame, parseWireFrames,+ uuidFromString, uuidFromText) import RON.Text.Serialize (serializeObject, serializeStateFrame,- serializeWireFrame, serializeWireFrames)+ serializeWireFrame, serializeWireFrames,+ uuidToString, uuidToText)
lib/RON/Text/Parse.hs view
@@ -10,6 +10,9 @@ parseAtom, parseObject, parseOp,+ parseOpenFrame,+ parseOpenOp,+ parseStateChunk, parseStateFrame, parseString, parseUuid,@@ -17,6 +20,8 @@ parseUuidAtom, parseWireFrame, parseWireFrames,+ uuidFromString,+ uuidFromText, ) where import RON.Prelude hiding (takeWhile)@@ -31,8 +36,11 @@ import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL import qualified Data.Map.Strict as Map import Data.Maybe (isJust, isNothing)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import qualified RON.Base64 as Base64 import RON.Types (Atom (AFloat, AInteger, AString, AUuid),@@ -41,7 +49,6 @@ Payload, StateFrame, UUID (UUID), WireChunk (Closed, Query, Value), WireFrame, WireReducedChunk (..), WireStateChunk (..))-import RON.Util (ByteStringL) import RON.Util.Word (Word2, Word4, Word60, b00, b0000, b01, b10, b11, ls60, safeCast) import RON.UUID (UuidFields (..))@@ -52,7 +59,7 @@ parseWireFrame = parseOnlyL frame chunksTill :: Parser () -> Parser [WireChunk]-chunksTill end = label "[WireChunk]" $ go opZero+chunksTill end = label "[WireChunk]" $ go closedOpZero where go prev = do skipSpace@@ -65,7 +72,7 @@ -- | Returns a chunk and the last op in it pChunk :: ClosedOp -> Parser (WireChunk, ClosedOp)-pChunk prev = label "WireChunk" $ wireStateChunk prev <+> chunkClosed prev+pChunk prev = label "WireChunk" $ wireReducedChunk prev <+> chunkClosed prev chunkClosed :: ClosedOp -> Parser (WireChunk, ClosedOp) chunkClosed prev = label "WireChunk-closed" $ do@@ -76,8 +83,8 @@ pure (Closed x, x) -- | Returns a chunk and the last op (converted to closed) in it-wireStateChunk :: ClosedOp -> Parser (WireChunk, ClosedOp)-wireStateChunk prev = label "WireChunk-reduced" $ do+wireReducedChunk :: ClosedOp -> Parser (WireChunk, ClosedOp)+wireReducedChunk prev = label "WireChunk-reduced" $ do (wrcHeader, isQuery) <- header prev let reducedOps y = do skipSpace@@ -96,6 +103,14 @@ where stop = pure [] +parseStateChunk :: ByteStringL -> Either String WireStateChunk+parseStateChunk = parseOnlyL $ do+ (Value value, _) <- wireReducedChunk closedOpZero+ let+ WireReducedChunk{wrcHeader, wrcBody} = value+ ClosedOp{reducerId} = wrcHeader+ pure WireStateChunk{stateType = reducerId, stateBody = wrcBody}+ frame :: Parser WireFrame frame = label "WireFrame" $ chunksTill (endOfFrame <|> endOfInputEx) @@ -109,7 +124,7 @@ -- | Parse a single context-free op parseOp :: ByteStringL -> Either String ClosedOp parseOp = parseOnlyL $ do- (_, x) <- closedOp opZero <* skipSpace <* endOfInputEx+ (_, x) <- closedOp closedOpZero <* skipSpace <* endOfInputEx pure x -- | Parse a single context-free UUID@@ -117,6 +132,12 @@ parseUuid = parseOnlyL $ uuid UUID.zero UUID.zero PrevOpSameKey <* skipSpace <* endOfInputEx +uuidFromText :: Text -> Either String UUID+uuidFromText = parseUuid . BSL.fromStrict . Text.encodeUtf8++uuidFromString :: String -> Either String UUID+uuidFromString = uuidFromText . Text.pack+ -- | Parse a UUID in key position parseUuidKey :: UUID -- ^ same key in the previous op (default is 'UUID.zero')@@ -141,35 +162,53 @@ (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+ (hasRef, refId) <- key "ref" ':' (refId prev') opId+ payload <- pPayload objectId let op = Op{..} pure- ( hasTyp || hasObj || hasEvt || hasLoc || not (null payload)+ ( hasTyp || hasObj || hasEvt || hasRef || not (null payload) , ClosedOp{..} ) where prev' = op prev reducedOp :: UUID -> Op -> Parser (Bool, Op)-reducedOp opObject prev = label "Op-cont" $ do+reducedOp opObject prev = label "Op-reduced-cont" $ do (hasEvt, opId) <- key "event" '@' (opId prev) opObject- (hasLoc, refId) <- key "ref" ':' (refId prev) opId- payload <- payloadP opObject+ (hasRef, refId) <- key "ref" ':' (refId prev) opId+ payload <- pPayload opObject let op = Op{opId, refId, payload}- pure (hasEvt || hasLoc || not (null payload), op)+ pure (hasEvt || hasRef || not (null payload), op) +openOp :: UUID -> Parser Op+openOp prev =+ label "Op-open-cont" $ do+ opId <- openKey "event" '@' <|> pure (UUID.succValue prev)+ refId <- openKey "ref" ':' <|> pure prev+ payload <- pPayload opId+ t <- term+ guard $ t == TReduced || t == TClosed+ pure Op{opId, refId, payload}+ key :: String -> Char -> UUID -> UUID -> Parser (Bool, UUID)-key name keyChar prevOpSameKey sameOpPrevUuid = label name $ do+key name keyChar prevOpSameKey sameOpPrevUuid =+ label name $ do skipSpace isKeyPresent <- isSuccessful $ char keyChar if isKeyPresent then do- u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey- pure (True, u)+ u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey+ pure (True, u) else- -- no key => use previous key- pure (False, prevOpSameKey)+ -- no key => use previous key+ pure (False, prevOpSameKey) +openKey :: String -> Char -> Parser UUID+openKey name keyChar =+ label name $ do+ skipSpace+ _ <- char keyChar+ uuid UUID.zero UUID.zero PrevOpSameKey+ uuid :: UUID -> UUID -> UuidZipBase -> Parser UUID uuid prevOpSameKey sameOpPrevUuid defaultZipBase = label "UUID" $ uuid22 <+> uuid11 <+> uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase@@ -313,8 +352,8 @@ '-' -> pure b11 _ -> fail "not a UUID-version" -payloadP :: UUID -> Parser Payload-payloadP = label "payload" . go+pPayload :: UUID -> Parser Payload+pPayload = label "payload" . go where go prevUuid = do ma <- optional $ atom prevUuid@@ -395,6 +434,7 @@ _ -> fail "not a term" -- | Parse a state frame+-- TODO deprecate multi-object states parseStateFrame :: ByteStringL -> Either String StateFrame parseStateFrame = parseWireFrame >=> findObjects @@ -403,6 +443,7 @@ parseObject oid bytes = ObjectFrame oid <$> parseStateFrame bytes -- | Extract object states from a common frame+-- TODO deprecate multi-object states findObjects :: WireFrame -> Either String StateFrame findObjects = fmap Map.fromList . traverse loadBody where loadBody = \case@@ -414,9 +455,24 @@ ) _ -> Left "expected reduced chunk" -opZero :: ClosedOp-opZero = ClosedOp- { reducerId = UUID.zero- , objectId = UUID.zero- , op = Op{opId = UUID.zero, refId = UUID.zero, payload = []}- }+closedOpZero :: ClosedOp+closedOpZero =+ ClosedOp{reducerId = UUID.zero, objectId = UUID.zero, op = opZero}++opZero :: Op+opZero = Op{opId = UUID.zero, refId = UUID.zero, payload = []}++parseOpenFrame :: ByteStringL -> Either String [Op]+parseOpenFrame =+ parseOnlyL $ go UUID.zero <* skipSpace <* endOfInputEx+ where+ go :: UUID -> Parser [Op]+ go prev =+ do+ op@Op{opId} <- openOp prev+ (op :) <$> go opId+ <|>+ pure []++parseOpenOp :: ByteStringL -> Either String Op+parseOpenOp = parseOnlyL $ openOp UUID.zero <* skipSpace <* endOfInputEx
lib/RON/Text/Serialize.hs view
@@ -5,44 +5,41 @@ {-# LANGUAGE RecordWildCards #-} -- | RON-Text serialization-module RON.Text.Serialize- ( serializeAtom,+module RON.Text.Serialize (+ serializeAtom, serializeObject,+ serializeOp,+ serializeOpenOp,+ serializePayload, serializeRawOp, serializeStateFrame, serializeString, serializeUuid, serializeWireFrame,- serializeWireFrames- )-where+ serializeWireFrames,+ uuidToString,+ uuidToText,+ ) where -import Control.Monad.State.Strict (state)+import RON.Prelude hiding (elem)++import Control.Monad.State.Strict (state) import qualified Data.Aeson as Json+import Data.ByteString.Lazy.Char8 (cons, elem, snoc) 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.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) +import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom,+ serializeUuidKey, uuidToString,+ uuidToText)+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 qualified RON.UUID as UUID+ -- | Serialize a common frame serializeWireFrame :: WireFrame -> ByteStringL serializeWireFrame =@@ -87,9 +84,9 @@ 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')+ payloadAtoms = serializePayloadZip (objectId this) (payload this') in ( BSL.intercalate "\t"- $ key '*' typ+ $ key '*' typ ++ key '#' obj ++ key '@' evt ++ key ':' ref@@ -108,7 +105,7 @@ 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)+ payloadAtoms = serializePayloadZip opObject (payload this) keys | BSL.null evt && BSL.null ref = ["@"] | otherwise = key '@' evt ++ key ':' ref@@ -117,6 +114,31 @@ where key c u = [c `cons` u | not $ BSL.null u] +serializeOp :: Op -> ByteStringL+serializeOp Op{opId, refId, payload} =+ BSL.intercalate "\t"+ [ '@' `cons` serializeUuid opId+ , ':' `cons` serializeUuid refId+ , serializePayloadZip opId payload+ ]++serializeOpenOp ::+ -- | Previous op id+ UUID ->+ -- | Current op+ Op ->+ ByteStringL+serializeOpenOp prevId Op{opId, refId, payload} =+ BSL.intercalate "\t" $ idS : refS : payloadS+ where+ idS+ | opId /= UUID.succValue prevId = '@' `cons` serializeUuid opId+ | otherwise = ""+ refS+ | refId /= prevId = ':' `cons` serializeUuid refId+ | otherwise = ""+ payloadS = [serializePayloadZip opId payload | not $ null payload]+ -- | Serialize a context-free atom serializeAtom :: Atom -> ByteStringL serializeAtom a = evalState (serializeAtomZip a) zero@@ -164,13 +186,17 @@ state $ \prev -> (cons '>' $ serializeUuidAtom prev u, u) -- | Serialize a payload in stream context-serializePayload+serializePayloadZip :: UUID -- ^ previous UUID (default is 'zero') -> Payload -> ByteStringL-serializePayload prev =+serializePayloadZip prev = BSL.unwords . (`evalState` prev) . traverse serializeAtomZip +-- | Serialize an abstract payload+serializePayload :: Payload -> ByteStringL+serializePayload = serializePayloadZip UUID.zero+ -- | Serialize a state frame serializeStateFrame :: StateFrame -> ByteStringL serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs@@ -187,7 +213,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/Text/Serialize/Experimental.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module RON.Text.Serialize.Experimental (serializeOpenFrame) where++import RON.Prelude++import qualified Data.ByteString.Lazy.Char8 as BSLC++import RON.Text.Serialize (serializeOpenOp)+import RON.Types (Op (opId), OpenFrame)+import qualified RON.UUID as UUID++serializeOpenFrame :: OpenFrame -> ByteStringL+serializeOpenFrame ops =+ BSLC.intercalate ",\n" opsSerialized <> ";\n"+ where+ opsSerialized = zipWith serializeOpenOp (UUID.zero : map opId ops) ops
lib/RON/Text/Serialize/UUID.hs view
@@ -9,6 +9,8 @@ serializeUuid, serializeUuidAtom, serializeUuidKey,+ uuidToString,+ uuidToText, ) where import RON.Prelude@@ -17,10 +19,11 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Foldable (minimumBy)+import qualified Data.Text as Text 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)@@ -34,6 +37,12 @@ _ -> serializeUuidGeneric this where thisFields@UuidFields{..} = split this++uuidToString :: UUID -> String+uuidToString = BSLC.unpack . serializeUuid++uuidToText :: UUID -> Text+uuidToText = Text.pack . uuidToString -- | Serialize UUID in op key context serializeUuidKey
lib/RON/Types.hs view
@@ -17,6 +17,7 @@ ObjectRef (..), ObjectFrame (..), Op (..),+ OpenFrame, OpTerm (..), Payload, StateChunk (..),@@ -40,42 +41,45 @@ ) where -import Data.Typeable (typeRep)-import RON.Prelude-import RON.UUID (UUID (UUID), uuidVersion)-import qualified RON.UUID as UUID-import RON.Util.Word (Word2, pattern B00, pattern B10, pattern B11)-import Text.Show (showParen, showString, showsPrec)+import RON.Prelude++import Data.String (IsString, fromString)+import Data.Typeable (typeRep)+import Text.Show (showParen, showString, showsPrec) import qualified Text.Show +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) +instance IsString Atom where+ fromString = AString . fromString+ -- | Closed op-data ClosedOp- = ClosedOp- { -- | type- reducerId :: UUID,- -- | object id- objectId :: UUID,- -- | other keys and payload, that are common with reduced op- op :: Op- }+data ClosedOp = ClosedOp {+ -- | type+ reducerId :: UUID,+ -- | object id+ objectId :: UUID,+ -- | other keys and payload, that are common with reduced op+ op :: Op+ } deriving (Data, Eq, Generic) type Payload = [Atom] -- | Open op (operation)-data Op- = Op- { -- | event id (usually timestamp)- opId :: UUID,- -- | reference to other op; actual semantics depends on the type- refId :: UUID,- -- | payload- payload :: Payload- }+data Op = Op+ { opId :: UUID+ -- ^ event id (usually timestamp)+ , refId :: UUID+ -- ^ reference to other op; actual semantics depends on the type+ , payload :: Payload+ } deriving (Data, Eq, Generic, Hashable, Show) instance Show ClosedOp where@@ -94,11 +98,10 @@ c : cs -> c : k : cs -- | Common reduced chunk-data WireReducedChunk- = WireReducedChunk- { wrcHeader :: ClosedOp,- wrcBody :: [Op]- }+data WireReducedChunk = WireReducedChunk+ { wrcHeader :: ClosedOp+ , wrcBody :: [Op]+ } deriving (Data, Eq, Generic, Show) -- | Common chunk@@ -116,11 +119,10 @@ deriving (Eq, Show) -- | Reduced chunk representing an object state (i. e. high-level value)-data WireStateChunk- = WireStateChunk- { stateType :: UUID,- stateBody :: [Op]- }+data WireStateChunk = WireStateChunk+ { stateType :: UUID+ , stateBody :: [Op]+ } deriving (Eq, Show) -- | Type-tagged version of 'WireStateChunk'@@ -132,6 +134,7 @@ type StateFrame = Map UUID WireStateChunk -- | Reference to an object+-- TODO hide data constructor in Internal module newtype ObjectRef a = ObjectRef UUID deriving newtype (Eq, Hashable) deriving stock (Generic)@@ -139,10 +142,10 @@ instance Typeable a => Show (ObjectRef a) where showsPrec a (ObjectRef b) = showParen (a >= 11) $- showString "ObjectRef @"- . showsPrec 11 (typeRep $ Proxy @a)- . showString " "- . showsPrec 11 b+ showString "ObjectRef @"+ . showsPrec 11 (typeRep $ Proxy @a)+ . showString " "+ . showsPrec 11 b -- | Object reference accompanied with a frame data ObjectFrame a = ObjectFrame {uuid :: UUID, frame :: StateFrame}@@ -192,3 +195,5 @@ mapBoth :: (a -> b) -> (a, a) -> (b, b) mapBoth f (x, y) = (f x, f y)++type OpenFrame = [Op]
+ lib/RON/UUID/Experimental.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RankNTypes #-}++module RON.UUID.Experimental (variety, value, variant, version, origin) where++import RON.Prelude++import Data.Bits (shiftL, shiftR, (.&.), (.|.))++import RON.UUID (UUID (..))+import RON.Util.Word (Word2, Word4, Word60, leastSignificant2,+ leastSignificant4, leastSignificant60, safeCast)++-- data UuidFields = UuidFields+-- { uuidVariety :: !Word4+-- , uuidValue :: !Word60+-- , uuidVariant :: !Word2+-- , uuidVersion :: !Word2+-- , uuidOrigin :: !Word60+-- }++variety :: Lens' UUID Word4+variety =+ lens+ (\(UUID x _) -> leastSignificant4 $ x `shiftR` 60)+ (\(UUID x y) v ->+ UUID (x .&. 0x0FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) y)++value :: Lens' UUID Word60+value =+ lens+ (\(UUID x _) -> leastSignificant60 x)+ (\(UUID x y) v -> UUID (x .&. 0xF000000000000000 .|. safeCast v) y)++variant :: Lens' UUID Word2+variant =+ lens+ (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 62)+ (\(UUID x y) v ->+ UUID x (y .&. 0x3FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 62)))++version :: Lens' UUID Word2+version =+ lens+ (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 60)+ (\(UUID x y) v ->+ UUID x (y .&. 0xCFFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)))++origin :: Lens' UUID Word60+origin =+ lens+ (\(UUID _ y) -> leastSignificant60 y)+ (\(UUID x y) v -> UUID x (y .&. 0xF000000000000000 .|. safeCast v))++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a++lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE lens #-}
lib/RON/Util.hs view
@@ -2,12 +2,7 @@ {-# 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
@@ -39,7 +39,6 @@ leastSignificant60, ls60, toWord60,- word60add, -- * Word64 Word64, -- * SafeCast@@ -51,9 +50,10 @@ import Data.Bits ((.&.)) import Data.Fixed (Fixed, HasResolution) import Data.Hashable (hashUsing, hashWithSalt)+import GHC.Num (abs, fromInteger, signum) newtype Word2 = W2 Word8- deriving (Eq, Ord, Show)+ deriving (Eq, Hashable, Ord, Show) b00, b01, b10, b11 :: Word2 b00 = W2 0b00@@ -140,6 +140,14 @@ newtype Word60 = W60 Word64 deriving (Enum, Eq, Ord, Show) +instance Num Word60 where+ W60 x + W60 y = ls60 $ x + y+ W60 x * W60 y = ls60 $ x * y+ abs = id+ signum (W60 x) = W60 $ signum x+ fromInteger = leastSignificant60+ negate (W60 x) = W60 $ 0x1000000000000000 - x+ instance Bounded Word60 where minBound = W60 0 maxBound = W60 0xFFFFFFFFFFFFFFF@@ -160,9 +168,6 @@ toWord60 w | w < 0x1000000000000000 = Just $ W60 w | otherwise = Nothing--word60add :: Word60 -> Word60 -> Word60-word60add (W60 a) (W60 b) = leastSignificant60 $ a + b class SafeCast v w where safeCast :: v -> w
ron.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 name: ron-version: 0.11+version: 0.12 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database-copyright: 2018-2019 Yuriy Syrovetskiy+copyright: 2018-2021 Yuriy Syrovetskiy homepage: https://github.com/ff-notes/ron license: BSD-3-Clause license-file: LICENSE@@ -43,7 +43,8 @@ time, -- transformers >= 0.5.6.0, -- ^ TODO Writer.CPS- unordered-containers+ unordered-containers,+ vector, exposed-modules: RON.Base64 RON.Binary@@ -59,11 +60,13 @@ RON.Text RON.Text.Parse RON.Text.Serialize+ RON.Text.Serialize.Experimental RON.Text.Serialize.UUID RON.Types RON.Util RON.Util.Word RON.UUID+ RON.UUID.Experimental other-modules: Attoparsec.Extra Data.ZigZag