{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module CRDT.LamportClock
( Pid (..)
, Clock (..)
, LamportTime (..)
, getTime
, LocalTime
, Process (..)
, LamportClock
, runLamportClock
, 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)
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
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
getTimes
:: Natural
-> m LamportTime
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