{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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,
) where
import RON.Prelude
import Data.Bits (shiftL, shiftR, (.|.))
import Data.Hashable (hashUsing, hashWithSalt)
import Data.Time (fromGregorianValid, makeTimeOfDayValid)
import RON.Util.Word (pattern B00, pattern B01, pattern B10,
pattern B11, Word12, Word16, Word2, Word24,
Word32, Word6, Word60, Word64, Word8,
leastSignificant12, leastSignificant2,
leastSignificant24, leastSignificant4,
leastSignificant6, ls12, ls24, ls6, ls60,
safeCast)
import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin, uuidValue,
uuidVariant, uuidVariety, uuidVersion)
import qualified RON.UUID as UUID
data CalendarTime = CalendarTime
{ months :: Word12
, days :: Word6
, hours :: Word6
, minutes :: Word6
, seconds :: Word6
, nanosecHundreds :: Word24
}
deriving (Eq, Ord, Show)
type EpochTime = Word60
data LocalTime
= TCalendar !CalendarTime
| TLogical !Word60
| TEpoch !EpochTime
| TUnknown !Word60
deriving (Eq, Show)
data Naming
= TrieForked
| CryptoForked
| RecordForked
| ApplicationSpecific
deriving (Bounded, Enum, Eq, Show)
instance Hashable Naming where
hashWithSalt = hashUsing fromEnum
data ReplicaId = ReplicaId !Naming !Word60
deriving (Eq, Show, Generic, Hashable)
data Event = Event !LocalTime !ReplicaId
deriving (Eq, Show)
data CalendarEvent = CalendarEvent !CalendarTime !ReplicaId
deriving (Eq, Show)
instance Ord CalendarEvent where
compare (CalendarEvent t1 (ReplicaId n1 r1))
(CalendarEvent t2 (ReplicaId n2 r2))
= compare
(t1, fromEnum n1, r1)
(t2, fromEnum n2, r2)
fromCalendarEvent :: CalendarEvent -> Event
fromCalendarEvent (CalendarEvent t r) = Event (TCalendar t) r
data EpochEvent = EpochEvent !EpochTime !ReplicaId
deriving (Eq, Show)
instance Ord EpochEvent where
compare (EpochEvent t1 (ReplicaId n1 r1))
(EpochEvent t2 (ReplicaId n2 r2))
= compare
(t1, fromEnum n1, r1)
(t2, fromEnum n2, r2)
fromEpochEvent :: EpochEvent -> Event
fromEpochEvent (EpochEvent t r) = Event (TEpoch t) r
toEpochEvent :: Event -> Maybe EpochEvent
toEpochEvent (Event t r) = case t of
TEpoch t' -> Just $ EpochEvent t' r
_ -> Nothing
class Monad m => ReplicaClock m where
getPid :: m ReplicaId
getEvents
:: EpochTime
-> m [EpochEvent]
advance :: EpochTime -> m ()
instance ReplicaClock m => ReplicaClock (ExceptT e m) where
getPid = lift getPid
getEvents = lift . getEvents
advance = lift . advance
instance ReplicaClock m => ReplicaClock (ReaderT r m) where
getPid = lift getPid
getEvents = lift . getEvents
advance = lift . advance
instance ReplicaClock m => ReplicaClock (StateT s m) where
getPid = lift getPid
getEvents = lift . getEvents
advance = lift . advance
instance (Monoid s, ReplicaClock m) => ReplicaClock (WriterT s m) where
getPid = lift getPid
getEvents = lift . getEvents
advance = lift . advance
advanceToUuid :: ReplicaClock clock => UUID -> clock ()
advanceToUuid = advance . uuidValue . UUID.split
getEvent :: (HasCallStack, ReplicaClock m) => m EpochEvent
getEvent = getEvents (ls60 1) >>= \case
e:_ -> pure e
[] -> error "getEvents returned no events"
getEventUuid :: ReplicaClock m => m UUID
getEventUuid = encodeEvent . fromEpochEvent <$> getEvent
getEventUuids :: ReplicaClock m => Word60 -> m [UUID]
getEventUuids = fmap (map $ encodeEvent . fromEpochEvent) . getEvents
encodeCalendar :: CalendarTime -> Word60
encodeCalendar CalendarTime{..} = ls60 $
(safeCast months `shiftL` 48) .|.
(safeCast days `shiftL` 42) .|.
(safeCast hours `shiftL` 36) .|.
(safeCast minutes `shiftL` 30) .|.
(safeCast seconds `shiftL` 24) .|.
safeCast nanosecHundreds
decodeCalendar :: Word60 -> CalendarTime
decodeCalendar w = CalendarTime
{ months = leastSignificant12 $ v `shiftR` 48
, days = leastSignificant6 $ v `shiftR` 42
, hours = leastSignificant6 $ v `shiftR` 36
, minutes = leastSignificant6 $ v `shiftR` 30
, seconds = leastSignificant6 $ v `shiftR` 24
, nanosecHundreds = leastSignificant24 v
}
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
encodeEvent :: Event -> UUID
encodeEvent (Event time replicaId) = UUID.build UuidFields
{ uuidVariety
, uuidValue
, uuidVariant = B00
, uuidVersion = B10
, uuidOrigin
}
where
(varietyMS2, uuidValue) = encodeLocalTime time
(varietyLS2, uuidOrigin) = encodeReplicaId replicaId
uuidVariety = leastSignificant4 $
((safeCast varietyMS2 :: Word8) `shiftL` 2) .|.
( safeCast varietyLS2 :: Word8)
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
decodeReplicaId :: Word2 -> Word60 -> ReplicaId
decodeReplicaId varietyLS2 = ReplicaId $ toEnum $ safeCast varietyLS2
encodeReplicaId :: ReplicaId -> (Word2, Word60)
encodeReplicaId (ReplicaId naming origin) =
( leastSignificant2 $ fromEnum naming
, origin
)
mkCalendarDate
:: (Word16, Word16, Word8)
-> Maybe CalendarTime
mkCalendarDate ymd = mkCalendarDateTime ymd (0, 0, 0)
mkCalendarDateTime
:: (Word16, Word16, Word8)
-> (Word8, Word8, Word8)
-> Maybe CalendarTime
mkCalendarDateTime ymd hms = mkCalendarDateTimeNano ymd hms 0
mkCalendarDateTimeNano
:: (Word16, Word16, Word8)
-> (Word8, Word8, Word8)
-> Word32
-> Maybe CalendarTime
mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) hns = do
guard $ y >= 2010
let months = (y - 2010) * 12 + m - 1
guard $ months < 4096
_ <- fromGregorianValid (fromIntegral y) (fromIntegral m) (fromIntegral d)
_ <-
makeTimeOfDayValid (fromIntegral hh) (fromIntegral mm) (fromIntegral ss)
guard $ hns < 10000000
pure CalendarTime
{ months = ls12 months
, days = ls6 $ d - 1
, hours = ls6 hh
, minutes = ls6 mm
, seconds = ls6 ss
, nanosecHundreds = ls24 hns
}
applicationSpecific :: Word64 -> ReplicaId
applicationSpecific = ReplicaId ApplicationSpecific . ls60