content: {-# LANGUAGE BinaryLiterals #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE NumericUnderscores #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module RON.Event (
      CalendarTime (..),
      Event (..),
      Time (..),
      TimeVariety (.., Calendar, Logical, Epoch, Unknown),
      OriginVariety (
          ..,
          TrieForked,
          CryptoForked,
          RecordForked,
          ApplicationSpecific
      ),
      ReplicaClock (..),
      Replica (..),
      advanceToUuid,
      decodeCalendar,
      decodeEvent,
      decodeReplica,
      encodeCalendar,
      encodeEvent,
      getEvent,
      getEventUuid,
      getEventUuids,
      isEventUuid,
      mkCalendarDate,
      mkCalendarDateTime,
      mkCalendarDateTimeNano,
      mkCalendarEvent,
      mkReplica,
      mkTime,
      timeValue,
      timeVariety,
      unsafeDecodeEvent,
  ) where
  
  import RON.Prelude
  
  import Data.Bits (shiftL, shiftR, (.&.), (.|.))
  import Data.ByteString.Char8 qualified as BSC
  import Data.Time (fromGregorianValid, makeTimeOfDayValid)
  import Text.Show qualified
  
  import RON.Base64 (encode60short)
  import RON.UUID (UUID (..), UuidFields (..))
  import RON.UUID qualified as UUID
  import RON.Util.Word (
      Word12,
      Word2,
      Word24,
      Word6,
      Word60,
      leastSignificant12,
      leastSignificant2,
      leastSignificant24,
      leastSignificant6,
      ls12,
      ls24,
      ls6,
      ls60,
      safeCast,
      pattern B00,
      pattern B01,
      pattern B10,
      pattern B11,
   )
  
  {- | Calendar format. See https://github.com/gritzko/ron/issues/19.
  Year range is 2010—2350.
  Precision is 100 ns.
  -}
  data CalendarTime = CalendarTime
      { months :: Word12
      , days :: Word6
      , hours :: Word6
      , minutes :: Word6
      , seconds :: Word6
      , nanosecHundreds :: Word24
      }
      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.
  -}
  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
  newtype Time = Time Word64
      deriving (Eq, Ord)
  
  instance Show Time where
      show t =
          show (timeVariety t) ++ '/' : BSC.unpack (encode60short $ timeValue t)
  
  timeVariety :: Time -> TimeVariety
  timeVariety (Time w64) = TimeVariety $ leastSignificant2 $ w64 `shiftR` 62
  
  timeValue :: Time -> Word60
  timeValue (Time w64) = ls60 w64
  
  -- | Replica id assignment style
  newtype OriginVariety = OriginVariety Word2
      deriving newtype (Eq, Hashable)
  
  pattern TrieForked :: OriginVariety
  pattern TrieForked = OriginVariety B00
  
  pattern CryptoForked :: OriginVariety
  pattern CryptoForked = OriginVariety B01
  
  pattern RecordForked :: OriginVariety
  pattern RecordForked = OriginVariety B10
  
  pattern ApplicationSpecific :: OriginVariety
  pattern ApplicationSpecific = OriginVariety B11
  
  {-# COMPLETE TrieForked, CryptoForked, RecordForked, ApplicationSpecific #-}
  
  instance Show OriginVariety where
      show = \case
          TrieForked -> "Trie"
          CryptoForked -> "Crypto"
          RecordForked -> "Record"
          ApplicationSpecific -> "App"
  
  {- | 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 Replica
  
      {- | Get sequential timestamps.
  
      Laws:
  
      1. @
      t <- getEvents n
      (t !! i) == head t + i
      @
  
      2. @
      t1 <- 'getEvent'
      t2 <- 'getEvent'
      t2 >= t1 + 1
      @
  
      3. @getEvents 0 == getEvents 1@
      -}
      getEvents ::
          -- | number of needed timestamps
          Word60 ->
          m [Event]
  
      -- | Make local time not less than this
      advance :: Word60 -> 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
  
  isEventUuid :: UUID -> Bool
  isEventUuid uuid =
      uuidVariant == B00 && (uuidVersion == B10 || uuidVersion == B11)
    where
      UuidFields{uuidVariant, uuidVersion} = UUID.split uuid
  
  -- | 'advance' variant for any UUID, but works only for event UUIDs
  advanceToUuid :: (ReplicaClock clock) => UUID -> clock ()
  advanceToUuid uuid = when (isEventUuid uuid) $ advance uuidValue
    where
      UuidFields{uuidValue} = UUID.split uuid
  
  -- | Get a single event
  getEvent :: (HasCallStack, ReplicaClock m) => m Event
  getEvent =
      getEvents 1 >>= \case
          e : _ -> pure e
          [] -> error "getEvents returned no events"
  
  -- | Get a single event as UUID
  getEventUuid :: (ReplicaClock m) => m UUID
  getEventUuid = encodeEvent <$> getEvent
  
  -- | Get event sequence as UUIDs
  getEventUuids :: (ReplicaClock m) => Word60 -> m [UUID]
  getEventUuids = fmap (map encodeEvent) . 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
  
  decodeTime :: Word64 -> Time
  decodeTime value = Time $ value .&. 0x_CFFF_FFFF_FFFF_FFFF
  
  encodeEvent :: Event -> UUID
  encodeEvent Event{time, replica} =
      UUID (varietyAndValue .|. originVariety) (eventVersion .|. origin)
    where
      Time varietyAndValue = time
      (originVariety, origin) = encodeReplicaId replica
      eventVersion = 0x_2000_0000_0000_0000
  
  -- | Assume UUID is event
  decodeEvent :: UUID -> Maybe Event
  decodeEvent u = guard (isEventUuid u) $> unsafeDecodeEvent u
  
  unsafeDecodeEvent :: UUID -> Event
  unsafeDecodeEvent u@(UUID x _) =
      Event{replica = decodeReplica u, time = decodeTime x}
  
  decodeReplica :: UUID -> Replica
  decodeReplica (UUID x y) =
      Replica $ (x .&. 0x_3000_0000_0000_0000) .|. (y .&. 0x_0FFF_FFFF_FFFF_FFFF)
  
  encodeReplicaId :: Replica -> (Word64, Word64)
  encodeReplicaId (Replica r) =
      ( r .&. 0x_3000_0000_0000_0000
      , r .&. 0x_0FFF_FFFF_FFFF_FFFF
      )
  
  -- | Make a calendar timestamp from a date
  mkCalendarDate ::
      -- | date as (year, month [1..12], day [1..])
      (Word16, Word16, Word8) ->
      Maybe CalendarTime
  mkCalendarDate ymd = mkCalendarDateTime ymd (0, 0, 0)
  
  -- | Make a calendar timestamp from a date and a day time
  mkCalendarDateTime ::
      -- | date as (year, month [1..12], day [1..])
      (Word16, Word16, Word8) ->
      -- | day time as (hours, minutes, seconds)
      (Word8, Word8, Word8) ->
      Maybe CalendarTime
  mkCalendarDateTime ymd hms = mkCalendarDateTimeNano ymd hms 0
  
  -- | Make a calendar timestamp from a date, a day time, and a second fraction
  mkCalendarDateTimeNano ::
      -- | date as (year, month [1..12], day [1..])
      (Word16, Word16, Word8) ->
      -- | day time as (hours, minutes, seconds)
      (Word8, Word8, Word8) ->
      -- | fraction of a second in hundreds of nanosecond
      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 < 10_000_000
      pure
          CalendarTime
              { months = ls12 months
              , days = ls6 $ d - 1
              , hours = ls6 hh
              , minutes = ls6 mm
              , seconds = ls6 ss
              , nanosecHundreds = ls24 hns
              }
  
  -- | 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}
  