{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

import           RON.Prelude

import           Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime,
                                        posixSecondsToUTCTime)

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 EpochClock a = EpochClock (ReaderT (Replica, IORef Word60) IO a)
    deriving (Functor EpochClock
a -> EpochClock a
Functor EpochClock
-> (forall a. a -> EpochClock a)
-> (forall a b.
    EpochClock (a -> b) -> EpochClock a -> EpochClock b)
-> (forall a b c.
    (a -> b -> c) -> EpochClock a -> EpochClock b -> EpochClock c)
-> (forall a b. EpochClock a -> EpochClock b -> EpochClock b)
-> (forall a b. EpochClock a -> EpochClock b -> EpochClock a)
-> Applicative EpochClock
EpochClock a -> EpochClock b -> EpochClock b
EpochClock a -> EpochClock b -> EpochClock a
EpochClock (a -> b) -> EpochClock a -> EpochClock b
(a -> b -> c) -> EpochClock a -> EpochClock b -> EpochClock c
forall a. a -> EpochClock a
forall a b. EpochClock a -> EpochClock b -> EpochClock a
forall a b. EpochClock a -> EpochClock b -> EpochClock b
forall a b. EpochClock (a -> b) -> EpochClock a -> EpochClock b
forall a b c.
(a -> b -> c) -> EpochClock a -> EpochClock b -> EpochClock c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EpochClock a -> EpochClock b -> EpochClock a
$c<* :: forall a b. EpochClock a -> EpochClock b -> EpochClock a
*> :: EpochClock a -> EpochClock b -> EpochClock b
$c*> :: forall a b. EpochClock a -> EpochClock b -> EpochClock b
liftA2 :: (a -> b -> c) -> EpochClock a -> EpochClock b -> EpochClock c
$cliftA2 :: forall a b c.
(a -> b -> c) -> EpochClock a -> EpochClock b -> EpochClock c
<*> :: EpochClock (a -> b) -> EpochClock a -> EpochClock b
$c<*> :: forall a b. EpochClock (a -> b) -> EpochClock a -> EpochClock b
pure :: a -> EpochClock a
$cpure :: forall a. a -> EpochClock a
$cp1Applicative :: Functor EpochClock
Applicative, a -> EpochClock b -> EpochClock a
(a -> b) -> EpochClock a -> EpochClock b
(forall a b. (a -> b) -> EpochClock a -> EpochClock b)
-> (forall a b. a -> EpochClock b -> EpochClock a)
-> Functor EpochClock
forall a b. a -> EpochClock b -> EpochClock a
forall a b. (a -> b) -> EpochClock a -> EpochClock b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EpochClock b -> EpochClock a
$c<$ :: forall a b. a -> EpochClock b -> EpochClock a
fmap :: (a -> b) -> EpochClock a -> EpochClock b
$cfmap :: forall a b. (a -> b) -> EpochClock a -> EpochClock b
Functor, Applicative EpochClock
a -> EpochClock a
Applicative EpochClock
-> (forall a b.
    EpochClock a -> (a -> EpochClock b) -> EpochClock b)
-> (forall a b. EpochClock a -> EpochClock b -> EpochClock b)
-> (forall a. a -> EpochClock a)
-> Monad EpochClock
EpochClock a -> (a -> EpochClock b) -> EpochClock b
EpochClock a -> EpochClock b -> EpochClock b
forall a. a -> EpochClock a
forall a b. EpochClock a -> EpochClock b -> EpochClock b
forall a b. EpochClock a -> (a -> EpochClock b) -> EpochClock b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EpochClock a
$creturn :: forall a. a -> EpochClock a
>> :: EpochClock a -> EpochClock b -> EpochClock b
$c>> :: forall a b. EpochClock a -> EpochClock b -> EpochClock b
>>= :: EpochClock a -> (a -> EpochClock b) -> EpochClock b
$c>>= :: forall a b. EpochClock a -> (a -> EpochClock b) -> EpochClock b
$cp1Monad :: Applicative EpochClock
Monad, Monad EpochClock
Monad EpochClock
-> (forall a. IO a -> EpochClock a) -> MonadIO EpochClock
IO a -> EpochClock a
forall a. IO a -> EpochClock a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> EpochClock a
$cliftIO :: forall a. IO a -> EpochClock a
$cp1MonadIO :: Monad EpochClock
MonadIO)

instance ReplicaClock EpochClock where
    getPid :: EpochClock Replica
getPid = ReaderT (Replica, IORef Word60) IO Replica -> EpochClock Replica
forall a. ReaderT (Replica, IORef Word60) IO a -> EpochClock a
EpochClock (ReaderT (Replica, IORef Word60) IO Replica -> EpochClock Replica)
-> ReaderT (Replica, IORef Word60) IO Replica -> EpochClock Replica
forall a b. (a -> b) -> a -> b
$ ((Replica, IORef Word60) -> Replica)
-> ReaderT (Replica, IORef Word60) IO Replica
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader (Replica, IORef Word60) -> Replica
forall a b. (a, b) -> a
fst

    advance :: Word60 -> EpochClock ()
advance Word60
theirTime = ReaderT (Replica, IORef Word60) IO () -> EpochClock ()
forall a. ReaderT (Replica, IORef Word60) IO a -> EpochClock a
EpochClock (ReaderT (Replica, IORef Word60) IO () -> EpochClock ())
-> ReaderT (Replica, IORef Word60) IO () -> EpochClock ()
forall a b. (a -> b) -> a -> b
$ ((Replica, IORef Word60) -> IO ())
-> ReaderT (Replica, IORef Word60) IO ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((Replica, IORef Word60) -> IO ())
 -> ReaderT (Replica, IORef Word60) IO ())
-> ((Replica, IORef Word60) -> IO ())
-> ReaderT (Replica, IORef Word60) IO ()
forall a b. (a -> b) -> a -> b
$ \(Replica
_pid, IORef Word60
timeVar) ->
        IORef Word60 -> (Word60 -> (Word60, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word60
timeVar ((Word60 -> (Word60, ())) -> IO ())
-> (Word60 -> (Word60, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Word60
ourTime -> (Word60 -> Word60 -> Word60
forall a. Ord a => a -> a -> a
max Word60
theirTime Word60
ourTime, ())

    getEvents :: Word60 -> EpochClock [Event]
getEvents Word60
n0 = ReaderT (Replica, IORef Word60) IO [Event] -> EpochClock [Event]
forall a. ReaderT (Replica, IORef Word60) IO a -> EpochClock a
EpochClock (ReaderT (Replica, IORef Word60) IO [Event] -> EpochClock [Event])
-> ReaderT (Replica, IORef Word60) IO [Event] -> EpochClock [Event]
forall a b. (a -> b) -> a -> b
$ ((Replica, IORef Word60) -> IO [Event])
-> ReaderT (Replica, IORef Word60) IO [Event]
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((Replica, IORef Word60) -> IO [Event])
 -> ReaderT (Replica, IORef Word60) IO [Event])
-> ((Replica, IORef Word60) -> IO [Event])
-> ReaderT (Replica, IORef Word60) IO [Event]
forall a b. (a -> b) -> a -> b
$ \(Replica
pid, IORef Word60
timeVar) -> do
        let n :: Word60
n = Word60 -> Word60 -> Word60
forall a. Ord a => a -> a -> a
max Word60
n0 Word60
1
        Word60
realTime <- IO Word60
getCurrentEpochTime
        (Word60
begin, Word60
end) <- IORef Word60
-> (Word60 -> (Word60, (Word60, Word60))) -> IO (Word60, Word60)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word60
timeVar ((Word60 -> (Word60, (Word60, Word60))) -> IO (Word60, Word60))
-> (Word60 -> (Word60, (Word60, Word60))) -> IO (Word60, Word60)
forall a b. (a -> b) -> a -> b
$ \Word60
timeCur -> let
            begin :: Word60
begin = Word60 -> Word60 -> Word60
forall a. Ord a => a -> a -> a
max Word60
realTime (Word60 -> Word60) -> Word60 -> Word60
forall a b. (a -> b) -> a -> b
$ Word60 -> Word60
forall a. Enum a => a -> a
succ Word60
timeCur
            end :: Word60
end   = Word60
begin Word60 -> Word60 -> Word60
forall a. Num a => a -> a -> a
+ Word60 -> Word60
forall a. Enum a => a -> a
pred Word60
n
            in (Word60
end, (Word60
begin, Word60
end))
        [Event] -> IO [Event]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Event :: Time -> Replica -> Event
Event{time :: Time
time = TimeVariety -> Word60 -> Time
mkTime TimeVariety
Epoch Word60
t, replica :: Replica
replica = Replica
pid} | Word60
t <- [Word60
begin .. Word60
end]]

-- | Run 'EpochClock' action with explicit time variable.
runEpochClock :: Replica -> IORef Word60 -> EpochClock a -> IO a
runEpochClock :: Replica -> IORef Word60 -> EpochClock a -> IO a
runEpochClock Replica
replicaId IORef Word60
timeVar (EpochClock ReaderT (Replica, IORef Word60) IO a
action) =
    ReaderT (Replica, IORef Word60) IO a
-> (Replica, IORef Word60) -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Replica, IORef Word60) IO a
action (Replica
replicaId, IORef Word60
timeVar)

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

-- | Get current time in 'Time' format (with 100 ns resolution).
-- Monotonicity is not guaranteed.
getCurrentEpochTime :: IO Word60
getCurrentEpochTime :: IO Word60
getCurrentEpochTime = POSIXTime -> Word60
encode (POSIXTime -> Word60) -> IO POSIXTime -> IO Word60
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime

-- | Convert unix time in hundreds of milliseconds to RFC 4122 time.
epochTimeFromUnix :: Word64 -> Word60
epochTimeFromUnix :: Word64 -> Word60
epochTimeFromUnix = Word64 -> Word60
forall integral. Integral integral => integral -> Word60
leastSignificant60 (Word64 -> Word60) -> (Word64 -> Word64) -> Word64 -> Word60
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
epochDiff)

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

-- | Decode date and time from UUID epoch timestamp
decode :: Word60 -> UTCTime
decode :: Word60 -> UTCTime
decode
    = POSIXTime -> UTCTime
posixSecondsToUTCTime
    (POSIXTime -> UTCTime)
-> (Word60 -> POSIXTime) -> Word60 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Word64 -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    (Ratio Word64 -> POSIXTime)
-> (Word60 -> Ratio Word64) -> Word60 -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64 -> Ratio Word64
forall a. Integral a => a -> a -> Ratio a
% Word64
10000000)
    (Word64 -> Ratio Word64)
-> (Word60 -> Word64) -> Word60 -> Ratio Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
subtract Word64
epochDiff
    (Word64 -> Word64) -> (Word60 -> Word64) -> Word60 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast

encode :: POSIXTime -> Word60
encode :: POSIXTime -> Word60
encode = Word64 -> Word60
epochTimeFromUnix (Word64 -> Word60) -> (POSIXTime -> Word64) -> POSIXTime -> Word60
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Word64)
-> (POSIXTime -> POSIXTime) -> POSIXTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
10000000)