diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lib/Attoparsec/Extra.hs b/lib/Attoparsec/Extra.hs --- a/lib/Attoparsec/Extra.hs +++ b/lib/Attoparsec/Extra.hs @@ -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 diff --git a/lib/Data/ZigZag.hs b/lib/Data/ZigZag.hs --- a/lib/Data/ZigZag.hs +++ b/lib/Data/ZigZag.hs @@ -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 diff --git a/lib/RON/Base64.hs b/lib/RON/Base64.hs --- a/lib/RON/Base64.hs +++ b/lib/RON/Base64.hs @@ -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) diff --git a/lib/RON/Binary/Parse.hs b/lib/RON/Binary/Parse.hs --- a/lib/RON/Binary/Parse.hs +++ b/lib/RON/Binary/Parse.hs @@ -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 diff --git a/lib/RON/Binary/Serialize.hs b/lib/RON/Binary/Serialize.hs --- a/lib/RON/Binary/Serialize.hs +++ b/lib/RON/Binary/Serialize.hs @@ -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 diff --git a/lib/RON/Epoch.hs b/lib/RON/Epoch.hs --- a/lib/RON/Epoch.hs +++ b/lib/RON/Epoch.hs @@ -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) diff --git a/lib/RON/Error.hs b/lib/RON/Error.hs --- a/lib/RON/Error.hs +++ b/lib/RON/Error.hs @@ -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))]} diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -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} 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 @@ -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 diff --git a/lib/RON/Prelude.hs b/lib/RON/Prelude.hs --- a/lib/RON/Prelude.hs +++ b/lib/RON/Prelude.hs @@ -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 diff --git a/lib/RON/Semilattice.hs b/lib/RON/Semilattice.hs --- a/lib/RON/Semilattice.hs +++ b/lib/RON/Semilattice.hs @@ -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 diff --git a/lib/RON/Text.hs b/lib/RON/Text.hs --- a/lib/RON/Text.hs +++ b/lib/RON/Text.hs @@ -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) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs --- a/lib/RON/Text/Parse.hs +++ b/lib/RON/Text/Parse.hs @@ -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 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 @@ -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 = []} + } diff --git a/lib/RON/Text/Serialize/Experimental.hs b/lib/RON/Text/Serialize/Experimental.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Text/Serialize/Experimental.hs @@ -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 diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs --- a/lib/RON/Text/Serialize/UUID.hs +++ b/lib/RON/Text/Serialize/UUID.hs @@ -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 diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs --- a/lib/RON/Types.hs +++ b/lib/RON/Types.hs @@ -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] diff --git a/lib/RON/UUID/Experimental.hs b/lib/RON/UUID/Experimental.hs new file mode 100644 --- /dev/null +++ b/lib/RON/UUID/Experimental.hs @@ -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 #-} diff --git a/lib/RON/Util.hs b/lib/RON/Util.hs --- a/lib/RON/Util.hs +++ b/lib/RON/Util.hs @@ -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 diff --git a/lib/RON/Util/Word.hs b/lib/RON/Util/Word.hs --- a/lib/RON/Util/Word.hs +++ b/lib/RON/Util/Word.hs @@ -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 diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -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