{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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,
  mkCalendarDate,
  mkCalendarDateTime,
  mkCalendarDateTimeNano,
  mkCalendarEvent,
  mkReplica,
  mkTime,
  timeValue,
  timeVariety,
) where

import           RON.Prelude

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, 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.
-- Year range is 2010—2350.
-- Precision is 100 ns.
data CalendarTime = CalendarTime
    { CalendarTime -> Word12
months          :: Word12
    , CalendarTime -> Word6
days            :: Word6
    , CalendarTime -> Word6
hours           :: Word6
    , CalendarTime -> Word6
minutes         :: Word6
    , CalendarTime -> Word6
seconds         :: Word6
    , CalendarTime -> Word24
nanosecHundreds :: Word24
    }
    deriving (CalendarTime -> CalendarTime -> Bool
(CalendarTime -> CalendarTime -> Bool)
-> (CalendarTime -> CalendarTime -> Bool) -> Eq CalendarTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CalendarTime -> CalendarTime -> Bool
$c/= :: CalendarTime -> CalendarTime -> Bool
== :: CalendarTime -> CalendarTime -> Bool
$c== :: CalendarTime -> CalendarTime -> Bool
Eq, Eq CalendarTime
Eq CalendarTime
-> (CalendarTime -> CalendarTime -> Ordering)
-> (CalendarTime -> CalendarTime -> Bool)
-> (CalendarTime -> CalendarTime -> Bool)
-> (CalendarTime -> CalendarTime -> Bool)
-> (CalendarTime -> CalendarTime -> Bool)
-> (CalendarTime -> CalendarTime -> CalendarTime)
-> (CalendarTime -> CalendarTime -> CalendarTime)
-> Ord CalendarTime
CalendarTime -> CalendarTime -> Bool
CalendarTime -> CalendarTime -> Ordering
CalendarTime -> CalendarTime -> CalendarTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CalendarTime -> CalendarTime -> CalendarTime
$cmin :: CalendarTime -> CalendarTime -> CalendarTime
max :: CalendarTime -> CalendarTime -> CalendarTime
$cmax :: CalendarTime -> CalendarTime -> CalendarTime
>= :: CalendarTime -> CalendarTime -> Bool
$c>= :: CalendarTime -> CalendarTime -> Bool
> :: CalendarTime -> CalendarTime -> Bool
$c> :: CalendarTime -> CalendarTime -> Bool
<= :: CalendarTime -> CalendarTime -> Bool
$c<= :: CalendarTime -> CalendarTime -> Bool
< :: CalendarTime -> CalendarTime -> Bool
$c< :: CalendarTime -> CalendarTime -> Bool
compare :: CalendarTime -> CalendarTime -> Ordering
$ccompare :: CalendarTime -> CalendarTime -> Ordering
$cp1Ord :: Eq CalendarTime
Ord, Int -> CalendarTime -> ShowS
[CalendarTime] -> ShowS
CalendarTime -> String
(Int -> CalendarTime -> ShowS)
-> (CalendarTime -> String)
-> ([CalendarTime] -> ShowS)
-> Show CalendarTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CalendarTime] -> ShowS
$cshowList :: [CalendarTime] -> ShowS
show :: CalendarTime -> String
$cshow :: CalendarTime -> String
showsPrec :: Int -> CalendarTime -> ShowS
$cshowsPrec :: Int -> CalendarTime -> ShowS
Show)

newtype TimeVariety = TimeVariety Word2

pattern Calendar :: TimeVariety
pattern $bCalendar :: TimeVariety
$mCalendar :: forall r. TimeVariety -> (Void# -> r) -> (Void# -> r) -> r
Calendar = TimeVariety B00

pattern Logical :: TimeVariety
pattern $bLogical :: TimeVariety
$mLogical :: forall r. TimeVariety -> (Void# -> r) -> (Void# -> r) -> r
Logical = TimeVariety B01

-- | RFC 4122 epoch, hundreds of nanoseconds since 1582.
-- Year range is 1582—5235.
pattern Epoch :: TimeVariety
pattern $bEpoch :: TimeVariety
$mEpoch :: forall r. TimeVariety -> (Void# -> r) -> (Void# -> r) -> r
Epoch = TimeVariety B10

pattern Unknown :: TimeVariety
pattern $bUnknown :: TimeVariety
$mUnknown :: forall r. TimeVariety -> (Void# -> r) -> (Void# -> r) -> r
Unknown = TimeVariety B11

{-# COMPLETE Calendar, Logical, Epoch, Unknown #-}

instance Show TimeVariety where
  show :: TimeVariety -> String
show = \case
    TimeVariety
Calendar -> String
"Calendar"
    TimeVariety
Logical  -> String
"Logical"
    TimeVariety
Epoch    -> String
"Epoch"
    TimeVariety
Unknown  -> String
"Unknown"

-- | Clock type is encoded in 2 higher bits of variety, value in uuidValue
newtype Time = Time Word64
  deriving (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Eq Time
Eq Time
-> (Time -> Time -> Ordering)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> Ord Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c< :: Time -> Time -> Bool
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
$cp1Ord :: Eq Time
Ord)

instance Show Time where
  show :: Time -> String
show Time
t =
    TimeVariety -> String
forall a s. (Show a, IsString s) => a -> s
show (Time -> TimeVariety
timeVariety Time
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: ByteString -> String
BSC.unpack (Word60 -> ByteString
encode60short (Word60 -> ByteString) -> Word60 -> ByteString
forall a b. (a -> b) -> a -> b
$ Time -> Word60
timeValue Time
t)

timeVariety :: Time -> TimeVariety
timeVariety :: Time -> TimeVariety
timeVariety (Time Word64
w64) = Word2 -> TimeVariety
TimeVariety (Word2 -> TimeVariety) -> Word2 -> TimeVariety
forall a b. (a -> b) -> a -> b
$ Word64 -> Word2
forall integral. Integral integral => integral -> Word2
leastSignificant2 (Word64 -> Word2) -> Word64 -> Word2
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
62

timeValue :: Time -> Word60
timeValue :: Time -> Word60
timeValue (Time Word64
w64) = Word64 -> Word60
ls60 Word64
w64

-- | Replica id assignment style
newtype OriginVariety = OriginVariety Word2
  deriving newtype (Int -> OriginVariety -> Int
OriginVariety -> Int
(Int -> OriginVariety -> Int)
-> (OriginVariety -> Int) -> Hashable OriginVariety
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: OriginVariety -> Int
$chash :: OriginVariety -> Int
hashWithSalt :: Int -> OriginVariety -> Int
$chashWithSalt :: Int -> OriginVariety -> Int
Hashable)

pattern TrieForked :: OriginVariety
pattern $bTrieForked :: OriginVariety
$mTrieForked :: forall r. OriginVariety -> (Void# -> r) -> (Void# -> r) -> r
TrieForked = OriginVariety B00

pattern CryptoForked :: OriginVariety
pattern $bCryptoForked :: OriginVariety
$mCryptoForked :: forall r. OriginVariety -> (Void# -> r) -> (Void# -> r) -> r
CryptoForked = OriginVariety B01

pattern RecordForked :: OriginVariety
pattern $bRecordForked :: OriginVariety
$mRecordForked :: forall r. OriginVariety -> (Void# -> r) -> (Void# -> r) -> r
RecordForked = OriginVariety B10

pattern ApplicationSpecific :: OriginVariety
pattern $bApplicationSpecific :: OriginVariety
$mApplicationSpecific :: forall r. OriginVariety -> (Void# -> r) -> (Void# -> r) -> r
ApplicationSpecific = OriginVariety B11

{-# COMPLETE TrieForked, CryptoForked, RecordForked, ApplicationSpecific #-}

instance Show OriginVariety where
  show :: OriginVariety -> String
show = \case
    OriginVariety
TrieForked          -> String
"Trie"
    OriginVariety
CryptoForked        -> String
"Crypto"
    OriginVariety
RecordForked        -> String
"Record"
    OriginVariety
ApplicationSpecific -> String
"App"

-- | Replica identifier.
-- Implementation: naming (62-61) and origin (60-0 bits) fields from UUID
newtype Replica = Replica Word64
  deriving newtype (Replica -> Replica -> Bool
(Replica -> Replica -> Bool)
-> (Replica -> Replica -> Bool) -> Eq Replica
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Replica -> Replica -> Bool
$c/= :: Replica -> Replica -> Bool
== :: Replica -> Replica -> Bool
$c== :: Replica -> Replica -> Bool
Eq, Int -> Replica -> Int
Replica -> Int
(Int -> Replica -> Int) -> (Replica -> Int) -> Hashable Replica
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Replica -> Int
$chash :: Replica -> Int
hashWithSalt :: Int -> Replica -> Int
$chashWithSalt :: Int -> Replica -> Int
Hashable, Eq Replica
Eq Replica
-> (Replica -> Replica -> Ordering)
-> (Replica -> Replica -> Bool)
-> (Replica -> Replica -> Bool)
-> (Replica -> Replica -> Bool)
-> (Replica -> Replica -> Bool)
-> (Replica -> Replica -> Replica)
-> (Replica -> Replica -> Replica)
-> Ord Replica
Replica -> Replica -> Bool
Replica -> Replica -> Ordering
Replica -> Replica -> Replica
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Replica -> Replica -> Replica
$cmin :: Replica -> Replica -> Replica
max :: Replica -> Replica -> Replica
$cmax :: Replica -> Replica -> Replica
>= :: Replica -> Replica -> Bool
$c>= :: Replica -> Replica -> Bool
> :: Replica -> Replica -> Bool
$c> :: Replica -> Replica -> Bool
<= :: Replica -> Replica -> Bool
$c<= :: Replica -> Replica -> Bool
< :: Replica -> Replica -> Bool
$c< :: Replica -> Replica -> Bool
compare :: Replica -> Replica -> Ordering
$ccompare :: Replica -> Replica -> Ordering
$cp1Ord :: Eq Replica
Ord)

instance Show Replica where
  show :: Replica -> String
show (Replica Word64
w64) =
    OriginVariety -> String
forall a s. (Show a, IsString s) => a -> s
show (Word2 -> OriginVariety
OriginVariety (Word2 -> OriginVariety) -> Word2 -> OriginVariety
forall a b. (a -> b) -> a -> b
$ Word64 -> Word2
forall integral. Integral integral => integral -> Word2
leastSignificant2 (Word64 -> Word2) -> Word64 -> Word2
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
60)
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: ByteString -> String
BSC.unpack (Word60 -> ByteString
encode60short (Word60 -> ByteString) -> Word60 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Word60
ls60 Word64
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
  { Event -> Time
time    :: !Time
  , Event -> Replica
replica :: !Replica
  }
  deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, (forall x. Event -> Rep Event x)
-> (forall x. Rep Event x -> Event) -> Generic Event
forall x. Rep Event x -> Event
forall x. Event -> Rep Event x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Event x -> Event
$cfrom :: forall x. Event -> Rep Event x
Generic, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
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
        :: Word60 -- ^ number of needed timestamps
        -> m [Event]

    -- | Make local time not less than this
    advance :: Word60 -> m ()

instance ReplicaClock m => ReplicaClock (ExceptT e m) where
    getPid :: ExceptT e m Replica
getPid    = m Replica -> ExceptT e m Replica
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift   m Replica
forall (m :: * -> *). ReplicaClock m => m Replica
getPid
    getEvents :: Word60 -> ExceptT e m [Event]
getEvents = m [Event] -> ExceptT e m [Event]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Event] -> ExceptT e m [Event])
-> (Word60 -> m [Event]) -> Word60 -> ExceptT e m [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents
    advance :: Word60 -> ExceptT e m ()
advance   = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> (Word60 -> m ()) -> Word60 -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m ()
forall (m :: * -> *). ReplicaClock m => Word60 -> m ()
advance

instance ReplicaClock m => ReplicaClock (ReaderT r m) where
    getPid :: ReaderT r m Replica
getPid    = m Replica -> ReaderT r m Replica
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift   m Replica
forall (m :: * -> *). ReplicaClock m => m Replica
getPid
    getEvents :: Word60 -> ReaderT r m [Event]
getEvents = m [Event] -> ReaderT r m [Event]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Event] -> ReaderT r m [Event])
-> (Word60 -> m [Event]) -> Word60 -> ReaderT r m [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents
    advance :: Word60 -> ReaderT r m ()
advance   = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> (Word60 -> m ()) -> Word60 -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m ()
forall (m :: * -> *). ReplicaClock m => Word60 -> m ()
advance

instance ReplicaClock m => ReplicaClock (StateT s m) where
    getPid :: StateT s m Replica
getPid    = m Replica -> StateT s m Replica
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift   m Replica
forall (m :: * -> *). ReplicaClock m => m Replica
getPid
    getEvents :: Word60 -> StateT s m [Event]
getEvents = m [Event] -> StateT s m [Event]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Event] -> StateT s m [Event])
-> (Word60 -> m [Event]) -> Word60 -> StateT s m [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents
    advance :: Word60 -> StateT s m ()
advance   = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (Word60 -> m ()) -> Word60 -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m ()
forall (m :: * -> *). ReplicaClock m => Word60 -> m ()
advance

instance (Monoid s, ReplicaClock m) => ReplicaClock (WriterT s m) where
    getPid :: WriterT s m Replica
getPid    = m Replica -> WriterT s m Replica
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift   m Replica
forall (m :: * -> *). ReplicaClock m => m Replica
getPid
    getEvents :: Word60 -> WriterT s m [Event]
getEvents = m [Event] -> WriterT s m [Event]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Event] -> WriterT s m [Event])
-> (Word60 -> m [Event]) -> Word60 -> WriterT s m [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents
    advance :: Word60 -> WriterT s m ()
advance   = m () -> WriterT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT s m ())
-> (Word60 -> m ()) -> Word60 -> WriterT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m ()
forall (m :: * -> *). ReplicaClock m => Word60 -> m ()
advance

-- | 'advance' variant for any UUID
advanceToUuid :: ReplicaClock clock => UUID -> clock ()
advanceToUuid :: UUID -> clock ()
advanceToUuid UUID
uuid =
  Bool -> clock () -> clock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word2
uuidVariant Word2 -> Word2 -> Bool
forall a. Eq a => a -> a -> Bool
== Word2
B00 Bool -> Bool -> Bool
&& Word2
uuidVersion Word2 -> Word2 -> Bool
forall a. Eq a => a -> a -> Bool
== Word2
B10) (clock () -> clock ()) -> clock () -> clock ()
forall a b. (a -> b) -> a -> b
$ Word60 -> clock ()
forall (m :: * -> *). ReplicaClock m => Word60 -> m ()
advance Word60
uuidValue
  where
    UuidFields{Word60
uuidValue :: UuidFields -> Word60
uuidValue :: Word60
uuidValue, Word2
uuidVariant :: UuidFields -> Word2
uuidVariant :: Word2
uuidVariant, Word2
uuidVersion :: UuidFields -> Word2
uuidVersion :: Word2
uuidVersion} = UUID -> UuidFields
UUID.split UUID
uuid

-- | Get a single event
getEvent :: (HasCallStack, ReplicaClock m) => m Event
getEvent :: m Event
getEvent = Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents (Word64 -> Word60
ls60 Word64
1) m [Event] -> ([Event] -> m Event) -> m Event
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Event
e:[Event]
_ -> Event -> m Event
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event
e
    []  -> String -> m Event
forall a. HasCallStack => String -> a
error String
"getEvents returned no events"

-- | Get a single event as UUID
getEventUuid :: ReplicaClock m => m UUID
getEventUuid :: m UUID
getEventUuid = Event -> UUID
encodeEvent (Event -> UUID) -> m Event -> m UUID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Event
forall (m :: * -> *). (HasCallStack, ReplicaClock m) => m Event
getEvent

-- | Get event sequence as UUIDs
getEventUuids :: ReplicaClock m => Word60 -> m [UUID]
getEventUuids :: Word60 -> m [UUID]
getEventUuids = ([Event] -> [UUID]) -> m [Event] -> m [UUID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Event -> UUID) -> [Event] -> [UUID]
forall a b. (a -> b) -> [a] -> [b]
map Event -> UUID
encodeEvent) (m [Event] -> m [UUID])
-> (Word60 -> m [Event]) -> Word60 -> m [UUID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> m [Event]
forall (m :: * -> *). ReplicaClock m => Word60 -> m [Event]
getEvents

encodeCalendar :: CalendarTime -> Word60
encodeCalendar :: CalendarTime -> Word60
encodeCalendar CalendarTime{Word24
Word12
Word6
nanosecHundreds :: Word24
seconds :: Word6
minutes :: Word6
hours :: Word6
days :: Word6
months :: Word12
nanosecHundreds :: CalendarTime -> Word24
seconds :: CalendarTime -> Word6
minutes :: CalendarTime -> Word6
hours :: CalendarTime -> Word6
days :: CalendarTime -> Word6
months :: CalendarTime -> Word12
..} = Word64 -> Word60
ls60 (Word64 -> Word60) -> Word64 -> Word60
forall a b. (a -> b) -> a -> b
$
    (Word12 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word12
months     Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (Word6 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word6
days       Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
42) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (Word6 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word6
hours      Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
36) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (Word6 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word6
minutes    Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
30) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    (Word6 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word6
seconds    Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
    Word24 -> Word64
forall v w. SafeCast v w => v -> w
safeCast  Word24
nanosecHundreds

decodeCalendar :: Word60 -> CalendarTime
decodeCalendar :: Word60 -> CalendarTime
decodeCalendar Word60
w = CalendarTime :: Word12
-> Word6 -> Word6 -> Word6 -> Word6 -> Word24 -> CalendarTime
CalendarTime
    { months :: Word12
months          = Word64 -> Word12
forall integral. Integral integral => integral -> Word12
leastSignificant12 (Word64 -> Word12) -> Word64 -> Word12
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48
    , days :: Word6
days            = Word64 -> Word6
forall integral. Integral integral => integral -> Word6
leastSignificant6  (Word64 -> Word6) -> Word64 -> Word6
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
42
    , hours :: Word6
hours           = Word64 -> Word6
forall integral. Integral integral => integral -> Word6
leastSignificant6  (Word64 -> Word6) -> Word64 -> Word6
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
36
    , minutes :: Word6
minutes         = Word64 -> Word6
forall integral. Integral integral => integral -> Word6
leastSignificant6  (Word64 -> Word6) -> Word64 -> Word6
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
30
    , seconds :: Word6
seconds         = Word64 -> Word6
forall integral. Integral integral => integral -> Word6
leastSignificant6  (Word64 -> Word6) -> Word64 -> Word6
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
24
    , nanosecHundreds :: Word24
nanosecHundreds = Word64 -> Word24
forall integral. Integral integral => integral -> Word24
leastSignificant24   Word64
v
    }
  where
    v :: Word64
v = Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
w :: Word64

decodeTime :: Word64 -> Time
decodeTime :: Word64 -> Time
decodeTime Word64
value = Word64 -> Time
Time (Word64 -> Time) -> Word64 -> Time
forall a b. (a -> b) -> a -> b
$ Word64
value Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xCFFFFFFFFFFFFFFF

encodeEvent :: Event -> UUID
encodeEvent :: Event -> UUID
encodeEvent Event{Time
time :: Time
time :: Event -> Time
time, Replica
replica :: Replica
replica :: Event -> Replica
replica} =
  Word64 -> Word64 -> UUID
UUID (Word64
varietyAndValue Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
originVariety) (Word64
eventVersion Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
origin)
  where
    Time Word64
varietyAndValue = Time
time
    (Word64
originVariety, Word64
origin) = Replica -> (Word64, Word64)
encodeReplicaId Replica
replica
    eventVersion :: Word64
eventVersion = Word64
0x2000000000000000

decodeEvent :: UUID -> Event
decodeEvent :: UUID -> Event
decodeEvent u :: UUID
u@(UUID Word64
x Word64
_) = Event :: Time -> Replica -> Event
Event{replica :: Replica
replica = UUID -> Replica
decodeReplica UUID
u, time :: Time
time = Word64 -> Time
decodeTime Word64
x}

decodeReplica :: UUID -> Replica
decodeReplica :: UUID -> Replica
decodeReplica (UUID Word64
x Word64
y) =
  Word64 -> Replica
Replica (Word64 -> Replica) -> Word64 -> Replica
forall a b. (a -> b) -> a -> b
$ (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x3000000000000000) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
y Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0FFFFFFFFFFFFFFF)

encodeReplicaId :: Replica -> (Word64, Word64)
encodeReplicaId :: Replica -> (Word64, Word64)
encodeReplicaId (Replica Word64
r) =
  ( Word64
r Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x3000000000000000
  , Word64
r Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0FFFFFFFFFFFFFFF
  )

-- | Make a calendar timestamp from a date
mkCalendarDate
    :: (Word16, Word16, Word8)  -- ^ date as (year, month [1..12], day [1..])
    -> Maybe CalendarTime
mkCalendarDate :: (Word16, Word16, Word8) -> Maybe CalendarTime
mkCalendarDate (Word16, Word16, Word8)
ymd = (Word16, Word16, Word8)
-> (Word8, Word8, Word8) -> Maybe CalendarTime
mkCalendarDateTime (Word16, Word16, Word8)
ymd (Word8
0, Word8
0, Word8
0)

-- | Make a calendar timestamp from a date and a day time
mkCalendarDateTime
    :: (Word16, Word16, Word8)  -- ^ date as (year, month [1..12], day [1..])
    -> (Word8, Word8, Word8)    -- ^ day time as (hours, minutes, seconds)
    -> Maybe CalendarTime
mkCalendarDateTime :: (Word16, Word16, Word8)
-> (Word8, Word8, Word8) -> Maybe CalendarTime
mkCalendarDateTime (Word16, Word16, Word8)
ymd (Word8, Word8, Word8)
hms = (Word16, Word16, Word8)
-> (Word8, Word8, Word8) -> Word32 -> Maybe CalendarTime
mkCalendarDateTimeNano (Word16, Word16, Word8)
ymd (Word8, Word8, Word8)
hms Word32
0

-- | Make a calendar timestamp from a date, a day time, and a second fraction
mkCalendarDateTimeNano
    :: (Word16, Word16, Word8)  -- ^ date as (year, month [1..12], day [1..])
    -> (Word8, Word8, Word8)    -- ^ day time as (hours, minutes, seconds)
    -> Word32                   -- ^ fraction of a second in hundreds of
                                -- nanosecond
    -> Maybe CalendarTime
mkCalendarDateTimeNano :: (Word16, Word16, Word8)
-> (Word8, Word8, Word8) -> Word32 -> Maybe CalendarTime
mkCalendarDateTimeNano (Word16
y, Word16
m, Word8
d) (Word8
hh, Word8
mm, Word8
ss) Word32
hns = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word16
y Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word16
2010
    let months :: Word16
months = (Word16
y Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
2010) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
12 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
m Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word16
months Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
4096
    Day
_ <- Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
y) (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
m) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d)
    TimeOfDay
_ <-
        Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hh) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
mm) (Word8 -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ss)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word32
hns Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
10000000
    CalendarTime -> Maybe CalendarTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure CalendarTime :: Word12
-> Word6 -> Word6 -> Word6 -> Word6 -> Word24 -> CalendarTime
CalendarTime
        { months :: Word12
months          = Word16 -> Word12
ls12 Word16
months
        , days :: Word6
days            = Word8 -> Word6
ls6  (Word8 -> Word6) -> Word8 -> Word6
forall a b. (a -> b) -> a -> b
$ Word8
d Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1
        , hours :: Word6
hours           = Word8 -> Word6
ls6  Word8
hh
        , minutes :: Word6
minutes         = Word8 -> Word6
ls6  Word8
mm
        , seconds :: Word6
seconds         = Word8 -> Word6
ls6  Word8
ss
        , nanosecHundreds :: Word24
nanosecHundreds = Word32 -> Word24
ls24 Word32
hns
        }

-- | Make a replica id from 'OriginVariety' and arbitrary number
mkReplica :: OriginVariety -> Word60 -> Replica
mkReplica :: OriginVariety -> Word60 -> Replica
mkReplica (OriginVariety Word2
variety) Word60
origin =
  Word64 -> Replica
Replica (Word64 -> Replica) -> Word64 -> Replica
forall a b. (a -> b) -> a -> b
$ (Word2 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word2
variety Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
60) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
origin

mkTime :: TimeVariety -> Word60 -> Time
mkTime :: TimeVariety -> Word60 -> Time
mkTime (TimeVariety Word2
variety) Word60
value =
  Word64 -> Time
Time (Word64 -> Time) -> Word64 -> Time
forall a b. (a -> b) -> a -> b
$ (Word2 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word2
variety Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
62) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
value

mkCalendarEvent :: CalendarTime -> Replica -> Event
mkCalendarEvent :: CalendarTime -> Replica -> Event
mkCalendarEvent CalendarTime
time Replica
replica =
  Event :: Time -> Replica -> Event
Event{time :: Time
time = TimeVariety -> Word60 -> Time
mkTime TimeVariety
Calendar (Word60 -> Time) -> Word60 -> Time
forall a b. (a -> b) -> a -> b
$ CalendarTime -> Word60
encodeCalendar CalendarTime
time, Replica
replica :: Replica
replica :: Replica
replica}