{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RON.Epoch (
EpochClock,
decode,
encode,
getCurrentEpochTime,
localEpochTimeFromUnix,
runEpochClock,
runEpochClockFromCurrentTime,
) where
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ReaderT (ReaderT), reader, runReaderT)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Ratio ((%))
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime,
posixSecondsToUTCTime)
import Data.Word (Word64)
import RON.Event (EpochEvent (EpochEvent), EpochTime,
LocalTime (TEpoch), ReplicaClock, ReplicaId,
advance, getEvents, getPid)
import RON.Util.Word (leastSignificant60, ls60, safeCast, word60add)
newtype EpochClock a = EpochClock (ReaderT (ReplicaId, IORef EpochTime) 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, ())
getEvents n0 = EpochClock $ ReaderT $ \(pid, timeVar) -> do
let n = max n0 $ ls60 1
realTime <- getCurrentEpochTime
(begin, end) <- atomicModifyIORef' timeVar $ \timeCur -> let
begin = max realTime $ succ timeCur
end = begin `word60add` pred n
in (end, (begin, end))
pure [EpochEvent t pid | t <- [begin .. end]]
runEpochClock :: ReplicaId -> IORef EpochTime -> EpochClock a -> IO a
runEpochClock replicaId timeVar (EpochClock action) =
runReaderT action (replicaId, timeVar)
runEpochClockFromCurrentTime :: ReplicaId -> EpochClock a -> IO a
runEpochClockFromCurrentTime replicaId clock = do
time <- getCurrentEpochTime
timeVar <- newIORef time
runEpochClock replicaId timeVar clock
getCurrentEpochTime :: IO EpochTime
getCurrentEpochTime = encode <$> getPOSIXTime
epochTimeFromUnix :: Word64 -> EpochTime
epochTimeFromUnix = leastSignificant60 . (+ epochDiff)
epochDiff :: Word64
epochDiff = 0x01B21DD213814000
localEpochTimeFromUnix :: Word64 -> LocalTime
localEpochTimeFromUnix = TEpoch . epochTimeFromUnix
decode :: EpochTime -> UTCTime
decode
= posixSecondsToUTCTime
. realToFrac
. (% 10000000)
. subtract epochDiff
. safeCast
encode :: POSIXTime -> EpochTime
encode = epochTimeFromUnix . round . (* 10000000)