{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module CRDT.LamportClock
    ( Pid (..)
    -- * Lamport timestamp (for a single process)
    , Clock (..)
    , LamportTime (..)
    , getTime
    , LocalTime
    , Process (..)
    -- * Real Lamport clock
    , LamportClock
    , runLamportClock
    -- * Helpers
    , getRealLocalTime
    , getMacAddress
    ) where

import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader (ReaderT (..))
import           Control.Monad.State.Strict (StateT)
import           Control.Monad.Trans (lift)
import           Data.IORef (IORef, atomicModifyIORef')
import           Data.Time.Clock.POSIX (getPOSIXTime)
import           Data.Word (Word64)
import           Numeric.Natural (Natural)

import           MacAddress (getMacAddress)

-- | Unix time in 10^{-7} seconds (100 ns), as in RFC 4122 and Swarm RON.
type LocalTime = Natural

data LamportTime = LamportTime LocalTime Pid
    deriving (LamportTime -> LamportTime -> Bool
(LamportTime -> LamportTime -> Bool)
-> (LamportTime -> LamportTime -> Bool) -> Eq LamportTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LamportTime -> LamportTime -> Bool
$c/= :: LamportTime -> LamportTime -> Bool
== :: LamportTime -> LamportTime -> Bool
$c== :: LamportTime -> LamportTime -> Bool
Eq, Eq LamportTime
Eq LamportTime
-> (LamportTime -> LamportTime -> Ordering)
-> (LamportTime -> LamportTime -> Bool)
-> (LamportTime -> LamportTime -> Bool)
-> (LamportTime -> LamportTime -> Bool)
-> (LamportTime -> LamportTime -> Bool)
-> (LamportTime -> LamportTime -> LamportTime)
-> (LamportTime -> LamportTime -> LamportTime)
-> Ord LamportTime
LamportTime -> LamportTime -> Bool
LamportTime -> LamportTime -> Ordering
LamportTime -> LamportTime -> LamportTime
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 :: LamportTime -> LamportTime -> LamportTime
$cmin :: LamportTime -> LamportTime -> LamportTime
max :: LamportTime -> LamportTime -> LamportTime
$cmax :: LamportTime -> LamportTime -> LamportTime
>= :: LamportTime -> LamportTime -> Bool
$c>= :: LamportTime -> LamportTime -> Bool
> :: LamportTime -> LamportTime -> Bool
$c> :: LamportTime -> LamportTime -> Bool
<= :: LamportTime -> LamportTime -> Bool
$c<= :: LamportTime -> LamportTime -> Bool
< :: LamportTime -> LamportTime -> Bool
$c< :: LamportTime -> LamportTime -> Bool
compare :: LamportTime -> LamportTime -> Ordering
$ccompare :: LamportTime -> LamportTime -> Ordering
$cp1Ord :: Eq LamportTime
Ord)

instance Show LamportTime where
    show :: LamportTime -> String
show (LamportTime LocalTime
time (Pid Word64
pid)) = LocalTime -> String
forall a. Show a => a -> String
show LocalTime
time String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word64 -> String
forall a. Show a => a -> String
show Word64
pid

-- | Unique process identifier
newtype Pid = Pid Word64
    deriving (Pid -> Pid -> Bool
(Pid -> Pid -> Bool) -> (Pid -> Pid -> Bool) -> Eq Pid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pid -> Pid -> Bool
$c/= :: Pid -> Pid -> Bool
== :: Pid -> Pid -> Bool
$c== :: Pid -> Pid -> Bool
Eq, Eq Pid
Eq Pid
-> (Pid -> Pid -> Ordering)
-> (Pid -> Pid -> Bool)
-> (Pid -> Pid -> Bool)
-> (Pid -> Pid -> Bool)
-> (Pid -> Pid -> Bool)
-> (Pid -> Pid -> Pid)
-> (Pid -> Pid -> Pid)
-> Ord Pid
Pid -> Pid -> Bool
Pid -> Pid -> Ordering
Pid -> Pid -> Pid
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 :: Pid -> Pid -> Pid
$cmin :: Pid -> Pid -> Pid
max :: Pid -> Pid -> Pid
$cmax :: Pid -> Pid -> Pid
>= :: Pid -> Pid -> Bool
$c>= :: Pid -> Pid -> Bool
> :: Pid -> Pid -> Bool
$c> :: Pid -> Pid -> Bool
<= :: Pid -> Pid -> Bool
$c<= :: Pid -> Pid -> Bool
< :: Pid -> Pid -> Bool
$c< :: Pid -> Pid -> Bool
compare :: Pid -> Pid -> Ordering
$ccompare :: Pid -> Pid -> Ordering
$cp1Ord :: Eq Pid
Ord, Int -> Pid -> ShowS
[Pid] -> ShowS
Pid -> String
(Int -> Pid -> ShowS)
-> (Pid -> String) -> ([Pid] -> ShowS) -> Show Pid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pid] -> ShowS
$cshowList :: [Pid] -> ShowS
show :: Pid -> String
$cshow :: Pid -> String
showsPrec :: Int -> Pid -> ShowS
$cshowsPrec :: Int -> Pid -> ShowS
Show)

class Monad m => Process m where
    getPid :: m Pid

getRealLocalTime :: IO LocalTime
getRealLocalTime :: IO LocalTime
getRealLocalTime = POSIXTime -> LocalTime
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> LocalTime)
-> (POSIXTime -> POSIXTime) -> POSIXTime -> LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
10000000) (POSIXTime -> LocalTime) -> IO POSIXTime -> IO LocalTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime

class Process m => Clock m where
    -- | Get sequential timestamps.
    --
    -- Laws:
    --    1.  t1 <- getTimes n
    --        t2 <- getTime
    --        t2 >= t1 + n
    --
    --    2. getTimes 0 == getTimes 1
    getTimes
        :: Natural -- ^ number of needed timestamps
        -> m LamportTime
        -- ^ Starting value of the range.
        -- So return value @t@ means range @[t .. t + n - 1]@.

    advance :: LocalTime -> m ()

getTime :: Clock m => m LamportTime
getTime :: m LamportTime
getTime = LocalTime -> m LamportTime
forall (m :: * -> *). Clock m => LocalTime -> m LamportTime
getTimes LocalTime
1

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

runLamportClock :: IORef LocalTime -> LamportClock a -> IO a
runLamportClock :: IORef LocalTime -> LamportClock a -> IO a
runLamportClock IORef LocalTime
var (LamportClock ReaderT (IORef LocalTime) IO a
action) = ReaderT (IORef LocalTime) IO a -> IORef LocalTime -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IORef LocalTime) IO a
action IORef LocalTime
var

instance Process LamportClock where
    getPid :: LamportClock Pid
getPid = Word64 -> Pid
Pid (Word64 -> Pid) -> LamportClock Word64 -> LamportClock Pid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word64 -> LamportClock Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMacAddress

instance Clock LamportClock where
    advance :: LocalTime -> LamportClock ()
advance LocalTime
time = ReaderT (IORef LocalTime) IO () -> LamportClock ()
forall a. ReaderT (IORef LocalTime) IO a -> LamportClock a
LamportClock (ReaderT (IORef LocalTime) IO () -> LamportClock ())
-> ReaderT (IORef LocalTime) IO () -> LamportClock ()
forall a b. (a -> b) -> a -> b
$ (IORef LocalTime -> IO ()) -> ReaderT (IORef LocalTime) IO ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef LocalTime -> IO ()) -> ReaderT (IORef LocalTime) IO ())
-> (IORef LocalTime -> IO ()) -> ReaderT (IORef LocalTime) IO ()
forall a b. (a -> b) -> a -> b
$ \IORef LocalTime
timeVar ->
        IORef LocalTime -> (LocalTime -> (LocalTime, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LocalTime
timeVar ((LocalTime -> (LocalTime, ())) -> IO ())
-> (LocalTime -> (LocalTime, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LocalTime
t0 -> (LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
time LocalTime
t0, ())

    getTimes :: LocalTime -> LamportClock LamportTime
getTimes LocalTime
n' = LocalTime -> Pid -> LamportTime
LamportTime (LocalTime -> Pid -> LamportTime)
-> LamportClock LocalTime -> LamportClock (Pid -> LamportTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LamportClock LocalTime
getTimes' LamportClock (Pid -> LamportTime)
-> LamportClock Pid -> LamportClock LamportTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LamportClock Pid
forall (m :: * -> *). Process m => m Pid
getPid
      where
        n :: LocalTime
n = LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
n' LocalTime
1
        getTimes' :: LamportClock LocalTime
getTimes' = ReaderT (IORef LocalTime) IO LocalTime -> LamportClock LocalTime
forall a. ReaderT (IORef LocalTime) IO a -> LamportClock a
LamportClock (ReaderT (IORef LocalTime) IO LocalTime -> LamportClock LocalTime)
-> ReaderT (IORef LocalTime) IO LocalTime -> LamportClock LocalTime
forall a b. (a -> b) -> a -> b
$ (IORef LocalTime -> IO LocalTime)
-> ReaderT (IORef LocalTime) IO LocalTime
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef LocalTime -> IO LocalTime)
 -> ReaderT (IORef LocalTime) IO LocalTime)
-> (IORef LocalTime -> IO LocalTime)
-> ReaderT (IORef LocalTime) IO LocalTime
forall a b. (a -> b) -> a -> b
$ \IORef LocalTime
timeVar -> do
            LocalTime
realTime <- IO LocalTime
getRealLocalTime
            IORef LocalTime
-> (LocalTime -> (LocalTime, LocalTime)) -> IO LocalTime
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LocalTime
timeVar ((LocalTime -> (LocalTime, LocalTime)) -> IO LocalTime)
-> (LocalTime -> (LocalTime, LocalTime)) -> IO LocalTime
forall a b. (a -> b) -> a -> b
$ \LocalTime
timeCur ->
                let timeRangeStart :: LocalTime
timeRangeStart = LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
realTime (LocalTime
timeCur LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
+ LocalTime
1)
                in (LocalTime
timeRangeStart LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
+ LocalTime
n LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
- LocalTime
1, LocalTime
timeRangeStart)

instance Process m => Process (ReaderT r m) where
    getPid :: ReaderT r m Pid
getPid = m Pid -> ReaderT r m Pid
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Pid
forall (m :: * -> *). Process m => m Pid
getPid

instance Process m => Process (StateT s m) where
    getPid :: StateT s m Pid
getPid = m Pid -> StateT s m Pid
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Pid
forall (m :: * -> *). Process m => m Pid
getPid

instance Clock m => Clock (ReaderT r m) where
    advance :: LocalTime -> 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 ())
-> (LocalTime -> m ()) -> LocalTime -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> m ()
forall (m :: * -> *). Clock m => LocalTime -> m ()
advance
    getTimes :: LocalTime -> ReaderT r m LamportTime
getTimes = m LamportTime -> ReaderT r m LamportTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m LamportTime -> ReaderT r m LamportTime)
-> (LocalTime -> m LamportTime)
-> LocalTime
-> ReaderT r m LamportTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> m LamportTime
forall (m :: * -> *). Clock m => LocalTime -> m LamportTime
getTimes

instance Clock m => Clock (StateT s m) where
    advance :: LocalTime -> 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 ())
-> (LocalTime -> m ()) -> LocalTime -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> m ()
forall (m :: * -> *). Clock m => LocalTime -> m ()
advance
    getTimes :: LocalTime -> StateT s m LamportTime
getTimes = m LamportTime -> StateT s m LamportTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m LamportTime -> StateT s m LamportTime)
-> (LocalTime -> m LamportTime)
-> LocalTime
-> StateT s m LamportTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> m LamportTime
forall (m :: * -> *). Clock m => LocalTime -> m LamportTime
getTimes