{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Legion.Propagation (
PropState,
PropPowerState,
merge,
mergeMaybe,
mergeEither,
heartbeat,
delta,
actions,
new,
initProp,
getPowerState,
ask,
participate,
disassociate,
getSelf,
divergences,
participating,
allParticipants,
projParticipants,
projected,
infimum,
idle,
) where
import Prelude hiding (lookup)
import Data.Aeson (ToJSON, object, (.=), toJSON)
import Data.Binary (Binary)
import Data.Default.Class (Default)
import Data.Map (Map, lookup)
import Data.Maybe (fromMaybe)
import Data.Set (member, Set)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime)
import Data.Time.Format ()
import Network.Legion.PowerState (PowerState, divergent, ApplyDelta,
acknowledge, projectedValue, StateId)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Network.Legion.PowerState as PS
type Time = Maybe UTCTime
data PropState o s p d r = PropState {
powerState :: PowerState o s p d r,
peerStates :: Map p PeerStatus,
self :: p,
now :: Time
} deriving (Eq, Show)
instance (Show o, Show s, Show p, Show d) => ToJSON (PropState o s p d r) where
toJSON PropState {powerState, peerStates, self, now} = object [
"powerState" .= powerState,
"peerStates" .= Map.fromList [
(show p, show s)
| (p, s) <- Map.toList peerStates
],
"self" .= show self,
"now" .= show now
]
newtype PropPowerState o s p d r = PropPowerState {
unPowerState :: PowerState o s p d r
} deriving (Show, Binary)
ask :: (ApplyDelta d r s) => PropState o s p d r -> s
ask = projectedValue . powerState
initProp :: (ApplyDelta d r s, Ord p)
=> p
-> PropPowerState o s p d r
-> PropState o s p d r
initProp self ps =
let powerState = acknowledge self (unPowerState ps)
in PropState {
powerState = powerState,
peerStates = Map.fromAscList [
(p, NeedsSendAt Nothing)
| p <- Set.toAscList (divergent powerState)
],
self,
now = Nothing
}
getPowerState :: PropState o s p d r -> PropPowerState o s p d r
getPowerState = PropPowerState . powerState
data PeerStatus
= NeedsSendAt Time
| NeedsAck
deriving (Show, Eq)
new :: (Default s) => o -> p -> Set p -> PropState o s p d r
new origin self participants =
PropState {
powerState = PS.new origin participants,
peerStates = Map.empty,
self,
now = Nothing
}
mergeEither :: (Eq o, Ord p, Show o, Show s, Show p, Show d, ApplyDelta d r s)
=> p
-> PropPowerState o s p d r
-> PropState o s p d r
-> Either String (PropState o s p d r)
mergeEither source kernel (prop@PropState {powerState, peerStates, self, now}) =
let ps = unPowerState kernel
in case acknowledge self <$> PS.mergeEither ps powerState of
Left err -> Left err
Right merged -> Right prop {
powerState = merged,
peerStates =
Map.fromList $ [
(p, ns)
| p <- Set.toList (divergent merged)
, let ns = fromMaybe (NeedsSendAt now) (lookup p peerStates)
]
++
[(source, NeedsAck) | self `member` divergent ps]
}
mergeMaybe :: (Eq o, Ord p, Show o, Show s, Show p, Show d, ApplyDelta d r s)
=> p
-> PropPowerState o s p d r
-> PropState o s p d r
-> Maybe (PropState o s p d r)
mergeMaybe source ps prop =
case mergeEither source ps prop of
Left _ -> Nothing
Right v -> Just v
merge :: (Eq o, Ord p, Show o, Show s, Show p, Show d, ApplyDelta d r s)
=> p
-> PropPowerState o s p d r
-> PropState o s p d r
-> PropState o s p d r
merge source ps prop =
case mergeEither source ps prop of
Left err -> error err
Right v -> v
heartbeat :: UTCTime -> PropState o s p d r -> PropState o s p d r
heartbeat newNow prop = prop {now = max (now prop) (Just newNow)}
delta :: (Ord p, ApplyDelta d r s)
=> d
-> PropState o s p d r
-> PropState o s p d r
delta d prop@PropState {self, powerState, now} =
let newPowerState = PS.delta self d powerState
in prop {
powerState = newPowerState,
peerStates = Map.fromAscList [
(p, NeedsSendAt now)
| p <- Set.toAscList (divergent newPowerState)
]
}
actions :: (Eq p)
=> PropState o s p d r
-> (Set p, PropPowerState o s p d r, PropState o s p d r)
actions prop@PropState {powerState, peerStates, now} =
(outOfDatePeers, PropPowerState powerState, newPropState)
where
outOfDatePeers = Set.fromAscList [
p
| (p, status) <- Map.toAscList peerStates
, shouldSendNow status
]
shouldSendNow NeedsAck = True
shouldSendNow (NeedsSendAt time) = now > time
newPropState = prop {
peerStates = Map.fromAscList [
(p, ns)
| (p, NeedsSendAt time) <- Map.toAscList peerStates
, let ns = NeedsSendAt (nextTime time)
]
}
nextTime :: Time -> Time
nextTime time =
if now > time
then addUTCTime gracePeriod <$> now
else time
gracePeriod :: NominalDiffTime
gracePeriod = oneMinute
where
oneMinute = 60
participate :: (Ord p, ApplyDelta d r s)
=> p
-> PropState o s p d r
-> PropState o s p d r
participate peer prop@PropState {powerState, now} =
let newPowerState = PS.participate peer powerState
in prop {
powerState = newPowerState,
peerStates = Map.fromAscList [
(p, NeedsSendAt now)
| p <- Set.toAscList (divergent newPowerState)
]
}
disassociate :: (Ord p, ApplyDelta d r s)
=> p
-> PropState o s p d r
-> PropState o s p d r
disassociate peer prop@PropState {powerState, now} =
let newPowerState = PS.disassociate peer powerState
in prop {
powerState = newPowerState,
peerStates = Map.fromAscList [
(p, NeedsSendAt now)
| p <- Set.toAscList (divergent newPowerState)
]
}
divergences :: (Ord p) => p -> PropState o s p d r -> Map (StateId p) d
divergences peer = PS.divergences peer . powerState
getSelf :: PropState o s p d r -> p
getSelf = self
participating :: (Ord p) => PropState o s p d r -> Bool
participating PropState{self, powerState} =
self `member` PS.allParticipants powerState
allParticipants :: (Ord p) => PropState o s p d r -> Set p
allParticipants = PS.allParticipants . powerState
projParticipants :: (Ord p) => PropState o s p d r -> Set p
projParticipants = PS.projParticipants . powerState
projected :: (ApplyDelta d r s) => PropPowerState o s p d r -> s
projected = PS.projectedValue . unPowerState
infimum :: PropPowerState o s p d r -> s
infimum = PS.infimumValue . unPowerState
idle :: (Ord p) => PropState o s p d r -> Bool
idle PropState {powerState, peerStates} =
Map.null peerStates && Set.null (divergent powerState)