Epoch.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module RON.Epoch (
    EpochClock,
    EpochClockT,
    decode,
    encode,
    epochTimeFromUnix,
    getCurrentEpochTime,
    runEpochClock,
    runEpochClockFromCurrentTime,
) where

import RON.Prelude

import Data.IORef (atomicModifyIORef', newIORef)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
import UnliftIO (MonadUnliftIO)

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 EpochClockT m a = EpochClock (ReaderT (Replica, IORef Word60) m a)
    deriving (Applicative, Functor, Monad, MonadIO, MonadTrans, MonadUnliftIO)

type EpochClock = EpochClockT IO

instance (MonadIO m) => ReplicaClock (EpochClockT m) where
    getPid = EpochClock $ reader fst

    advance theirTime =
        EpochClock $
            ReaderT $ \(_pid, timeVar) ->
                liftIO $
                    atomicModifyIORef' timeVar $
                        \ourTime -> (max theirTime ourTime, ())

    getEvents n0 =
        EpochClock $
            ReaderT $ \(pid, timeVar) -> do
                let n = max n0 1
                realTime <- liftIO getCurrentEpochTime
                (begin, end) <-
                    liftIO $
                        atomicModifyIORef' timeVar $ \timeCur ->
                            let
                                begin = max realTime $ succ timeCur
                                end = begin + pred n
                            in
                                (end, (begin, end))
                pure
                    [ Event{time = mkTime Epoch t, replica = pid}
                    | t <- [begin .. end]
                    ]

-- | Run 'EpochClock'/'EpochClockT' action with explicit time variable.
runEpochClock :: Replica -> IORef Word60 -> EpochClockT m a -> m a
runEpochClock replicaId timeVar (EpochClock action) =
    runReaderT action (replicaId, timeVar)

-- | Like 'runEpochClock', but initialize time variable with current wall time.
runEpochClockFromCurrentTime :: Replica -> EpochClock a -> IO a
runEpochClockFromCurrentTime replicaId clock = do
    wallTime <- getCurrentEpochTime
    timeVar <- newIORef wallTime
    runEpochClock replicaId timeVar clock

{- | Get current time in 'Time' format (with 100 ns resolution).
Monotonicity is not guaranteed.
-}
getCurrentEpochTime :: (MonadIO m) => m Word60
getCurrentEpochTime = liftIO $ encode <$> getPOSIXTime

-- | Convert unix time in hundreds of milliseconds to RFC 4122 time.
epochTimeFromUnix :: Word64 -> Word60
epochTimeFromUnix = leastSignificant60 . (+ epochDiff)

-- The difference between Unix epoch and UUID epoch;
-- the constant is taken from RFC 4122
epochDiff :: Word64
epochDiff = 0x01B21DD213814000

-- | Decode date and time from UUID epoch timestamp
decode :: Word60 -> UTCTime
decode =
    posixSecondsToUTCTime
        . realToFrac
        . (% 10000000)
        . subtract epochDiff
        . safeCast

encode :: POSIXTime -> Word60
encode = epochTimeFromUnix . round . (* 10000000)