{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Network.ZRE.Types where

import Control.Monad.Reader
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Concurrent.Async
import Control.Concurrent.STM
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.UUID
import Data.Time.Clock
import Data.Default

import Data.ZRE hiding (Shout, Whisper) -- (Name, Seq, Group, Groups, GroupSeq, Headers, Content, ZRECmd, ZREMsg)
import System.ZMQ4.Endpoint

import qualified Control.Monad

isec :: (Num a) => a -> a
isec :: forall a. Num a => a -> a
isec  = (forall a. Num a => a -> a -> a
*a
1000000)
sec  :: (RealFrac a) => a -> Int
sec :: forall a. RealFrac a => a -> Int
sec  = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
isec
msec :: (RealFrac a) => a -> Int
msec :: forall a. RealFrac a => a -> Int
msec = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*a
1000)

data ZRECfg = ZRECfg {
    ZRECfg -> ByteString
zreNamed         :: ByteString
  , ZRECfg -> Float
zreQuietPeriod   :: Float
  , ZRECfg -> Float
zreQuietPingRate :: Float
  , ZRECfg -> Float
zreDeadPeriod    :: Float
  , ZRECfg -> Float
zreBeaconPeriod  :: Float
  , ZRECfg -> [ByteString]
zreInterfaces    :: [ByteString]
  , ZRECfg -> Endpoint
zreMCast         :: Endpoint
  , ZRECfg -> Maybe Endpoint
zreZGossip       :: Maybe Endpoint
  , ZRECfg -> Bool
zreDbg           :: Bool
  } deriving (Int -> ZRECfg -> ShowS
[ZRECfg] -> ShowS
ZRECfg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ZRECfg] -> ShowS
$cshowList :: [ZRECfg] -> ShowS
show :: ZRECfg -> String
$cshow :: ZRECfg -> String
showsPrec :: Int -> ZRECfg -> ShowS
$cshowsPrec :: Int -> ZRECfg -> ShowS
Show)

defMCastEndpoint :: Endpoint
defMCastEndpoint :: Endpoint
defMCastEndpoint = ByteString -> Int -> Endpoint
newUDPEndpoint ByteString
"225.25.25.25" Int
5670

defaultConf :: ZRECfg
defaultConf :: ZRECfg
defaultConf = ZRECfg {
    zreNamed :: ByteString
zreNamed         = ByteString
"zre"
  , zreQuietPeriod :: Float
zreQuietPeriod   = Float
1.0
  , zreQuietPingRate :: Float
zreQuietPingRate = Float
1.0
  , zreDeadPeriod :: Float
zreDeadPeriod    = Float
5.0
  , zreBeaconPeriod :: Float
zreBeaconPeriod  = Float
0.9
  , zreInterfaces :: [ByteString]
zreInterfaces    = []
  , zreZGossip :: Maybe Endpoint
zreZGossip       = forall a. Maybe a
Nothing
  , zreMCast :: Endpoint
zreMCast         = Endpoint
defMCastEndpoint
  , zreDbg :: Bool
zreDbg           = Bool
False
  }

instance Default ZRECfg where
  def :: ZRECfg
def = ZRECfg
defaultConf

data Event =
    New UUID (Maybe Name) Groups Headers Endpoint
  | Ready UUID Name Groups Headers Endpoint
  | GroupJoin UUID Group
  | GroupLeave UUID Group
  | Quit UUID (Maybe Name)
  | Message ZREMsg
  | Shout UUID Group Content UTCTime
  | Whisper UUID Content UTCTime
  | Debug ByteString
  deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)

data API =
    DoJoin Group
  | DoLeave Group
  | DoShout Group ByteString
  | DoShoutMulti Group [ByteString]
  | DoWhisper UUID ByteString
  | DoDiscover UUID Endpoint
  | DoDebug Bool
  | DoQuit
  deriving (Int -> API -> ShowS
[API] -> ShowS
API -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [API] -> ShowS
$cshowList :: [API] -> ShowS
show :: API -> String
$cshow :: API -> String
showsPrec :: Int -> API -> ShowS
$cshowsPrec :: Int -> API -> ShowS
Show)

type Peers = Map UUID (TVar Peer)
type PeerGroups = Map Group Peers

type EventQueue = TBQueue Event
type APIQueue = TBQueue API


data ZREState = ZREState {
    ZREState -> UUID
zreUUID       :: UUID
  , ZREState -> Peers
zrePeers      :: Peers
  , ZREState -> PeerGroups
zrePeerGroups :: PeerGroups
  , ZREState -> Endpoint
zreEndpoint   :: Endpoint
  , ZREState -> Groups
zreGroups     :: Groups
  , ZREState -> Int
zreGroupSeq   :: GroupSeq
  , ZREState -> ByteString
zreName       :: Name
  , ZREState -> Headers
zreHeaders    :: Headers
  , ZREState -> Bool
zreDebug      :: Bool
  , ZREState -> EventQueue
zreIn         :: EventQueue
  , ZREState -> APIQueue
zreOut        :: APIQueue
  , ZREState -> Map ByteString [Async ()]
zreIfaces     :: Map ByteString [Async ()]
  , ZREState -> ZRECfg
zreCfg        :: ZRECfg
  }

data Peer = Peer {
    Peer -> Endpoint
peerEndpoint  :: Endpoint
  , Peer -> UUID
peerUUID      :: UUID
  , Peer -> Int
peerSeq       :: Seq
  , Peer -> Groups
peerGroups    :: Groups
  , Peer -> Int
peerGroupSeq  :: GroupSeq
  , Peer -> Maybe ByteString
peerName      :: Maybe Name
  , Peer -> Headers
peerHeaders   :: Headers
  , Peer -> Maybe (Async ())
peerAsync     :: Maybe (Async ())
  , Peer -> Maybe (Async ())
peerAsyncPing :: Maybe (Async ())
  , Peer -> TBQueue ZRECmd
peerQueue     :: TBQueue ZRECmd
  , Peer -> UTCTime
peerLastHeard :: UTCTime
  }
  deriving (Int -> Peer -> ShowS
[Peer] -> ShowS
Peer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Peer] -> ShowS
$cshowList :: [Peer] -> ShowS
show :: Peer -> String
$cshow :: Peer -> String
showsPrec :: Int -> Peer -> ShowS
$cshowsPrec :: Int -> Peer -> ShowS
Show)

instance Show a => Show (TBQueue a) where
  show :: TBQueue a -> String
show = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"TBQueue"

instance Show a => Show (Async a) where
  show :: Async a -> String
show = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Async"

newtype ZRE a = Z {
  forall a. ZRE a -> ReaderT (EventQueue, APIQueue) IO a
runZ' :: ReaderT (EventQueue, APIQueue) IO a
  } deriving (
      forall a b. a -> ZRE b -> ZRE a
forall a b. (a -> b) -> ZRE a -> ZRE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ZRE b -> ZRE a
$c<$ :: forall a b. a -> ZRE b -> ZRE a
fmap :: forall a b. (a -> b) -> ZRE a -> ZRE b
$cfmap :: forall a b. (a -> b) -> ZRE a -> ZRE b
Functor
    , Functor ZRE
forall a. a -> ZRE a
forall a b. ZRE a -> ZRE b -> ZRE a
forall a b. ZRE a -> ZRE b -> ZRE b
forall a b. ZRE (a -> b) -> ZRE a -> ZRE b
forall a b c. (a -> b -> c) -> ZRE a -> ZRE b -> ZRE 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
<* :: forall a b. ZRE a -> ZRE b -> ZRE a
$c<* :: forall a b. ZRE a -> ZRE b -> ZRE a
*> :: forall a b. ZRE a -> ZRE b -> ZRE b
$c*> :: forall a b. ZRE a -> ZRE b -> ZRE b
liftA2 :: forall a b c. (a -> b -> c) -> ZRE a -> ZRE b -> ZRE c
$cliftA2 :: forall a b c. (a -> b -> c) -> ZRE a -> ZRE b -> ZRE c
<*> :: forall a b. ZRE (a -> b) -> ZRE a -> ZRE b
$c<*> :: forall a b. ZRE (a -> b) -> ZRE a -> ZRE b
pure :: forall a. a -> ZRE a
$cpure :: forall a. a -> ZRE a
Applicative
    , Applicative ZRE
forall a. a -> ZRE a
forall a b. ZRE a -> ZRE b -> ZRE b
forall a b. ZRE a -> (a -> ZRE b) -> ZRE 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 :: forall a. a -> ZRE a
$creturn :: forall a. a -> ZRE a
>> :: forall a b. ZRE a -> ZRE b -> ZRE b
$c>> :: forall a b. ZRE a -> ZRE b -> ZRE b
>>= :: forall a b. ZRE a -> (a -> ZRE b) -> ZRE b
$c>>= :: forall a b. ZRE a -> (a -> ZRE b) -> ZRE b
Monad
    , Monad ZRE
forall a. IO a -> ZRE a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ZRE a
$cliftIO :: forall a. IO a -> ZRE a
MonadIO
    , MonadBase IO
    , MonadReader (EventQueue, APIQueue))

instance MonadBaseControl IO ZRE where
  type StM ZRE a = a
  liftBaseWith :: forall a. (RunInBase ZRE IO -> IO a) -> ZRE a
liftBaseWith RunInBase ZRE IO -> IO a
f = forall a. ReaderT (EventQueue, APIQueue) IO a -> ZRE a
Z forall a b. (a -> b) -> a -> b
$ forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase (ReaderT (EventQueue, APIQueue) IO) IO
q -> RunInBase ZRE IO -> IO a
f (RunInBase (ReaderT (EventQueue, APIQueue) IO) IO
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ZRE a -> ReaderT (EventQueue, APIQueue) IO a
runZ')
  restoreM :: forall a. StM ZRE a -> ZRE a
restoreM = forall a. ReaderT (EventQueue, APIQueue) IO a -> ZRE a
Z forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM

runZ :: ZRE a -> EventQueue -> APIQueue -> IO a
runZ :: forall a. ZRE a -> EventQueue -> APIQueue -> IO a
runZ ZRE a
app EventQueue
events APIQueue
api = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. ZRE a -> ReaderT (EventQueue, APIQueue) IO a
runZ' ZRE a
app) (EventQueue
events, APIQueue
api)

readZ :: ZRE (Event)
readZ :: ZRE Event
readZ = do
  (EventQueue
e, APIQueue
_) <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Event
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM a
readTBQueue EventQueue
e
  forall (m :: * -> *) a. Monad m => a -> m a
return Event
v

unReadZ :: Event -> ZRE ()
unReadZ :: Event -> ZRE ()
unReadZ Event
x = do
  (EventQueue
e, APIQueue
_) <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically
    forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> a -> STM ()
unGetTBQueue EventQueue
e Event
x

writeZ :: API -> ZRE ()
writeZ :: API -> ZRE ()
writeZ API
x = do
  (EventQueue
_, APIQueue
a) <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> a -> STM ()
writeTBQueue APIQueue
a API
x

getEventQueue :: ZRE (EventQueue)
getEventQueue :: ZRE EventQueue
getEventQueue = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
getApiQueue :: ZRE (APIQueue)
getApiQueue :: ZRE APIQueue
getApiQueue = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

zjoin :: Group -> ZRE ()
zjoin :: Group -> ZRE ()
zjoin = API -> ZRE ()
writeZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group -> API
DoJoin

zleave :: Group -> ZRE ()
zleave :: Group -> ZRE ()
zleave = API -> ZRE ()
writeZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group -> API
DoLeave

zshout :: Group -> ByteString -> ZRE ()
zshout :: Group -> ByteString -> ZRE ()
zshout Group
group ByteString
msg = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ Group -> ByteString -> API
DoShout Group
group ByteString
msg

zshout' :: Group -> [ByteString] -> ZRE ()
zshout' :: Group -> [ByteString] -> ZRE ()
zshout' Group
group [ByteString]
msgs = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ Group -> [ByteString] -> API
DoShoutMulti Group
group [ByteString]
msgs

zwhisper :: UUID -> ByteString -> ZRE ()
zwhisper :: UUID -> ByteString -> ZRE ()
zwhisper UUID
uuid ByteString
msg = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ UUID -> ByteString -> API
DoWhisper UUID
uuid ByteString
msg

zdebug :: ZRE ()
zdebug :: ZRE ()
zdebug = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ Bool -> API
DoDebug Bool
True

znodebug :: ZRE ()
znodebug :: ZRE ()
znodebug = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ Bool -> API
DoDebug Bool
False

zquit :: ZRE ()
zquit :: ZRE ()
zquit = API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ API
DoQuit

zfail :: String -> ZRE a
zfail :: forall a. String -> ZRE a
zfail String
errorMsg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
errorMsg
  API -> ZRE ()
writeZ forall a b. (a -> b) -> a -> b
$ API
DoQuit
  forall a. HasCallStack => String -> a
error String
errorMsg

zrecv :: ZRE (Event)
zrecv :: ZRE Event
zrecv = ZRE Event
readZ

maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM :: forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM m b
err a -> m b
f m (Maybe a)
value = m (Maybe a)
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
err a -> m b
f

newZREState :: Name
            -> Endpoint
            -> UUID
            -> EventQueue
            -> APIQueue
            -> Bool
            -> ZRECfg
            -> IO (TVar ZREState)
newZREState :: ByteString
-> Endpoint
-> UUID
-> EventQueue
-> APIQueue
-> Bool
-> ZRECfg
-> IO (TVar ZREState)
newZREState ByteString
name Endpoint
endpoint UUID
u EventQueue
inQ APIQueue
outQ Bool
dbg ZRECfg
cfg = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$
  ZREState {
    zreUUID :: UUID
zreUUID = UUID
u
    , zrePeers :: Peers
zrePeers = forall a. Monoid a => a
mempty
    , zrePeerGroups :: PeerGroups
zrePeerGroups = forall a. Monoid a => a
mempty
    , zreEndpoint :: Endpoint
zreEndpoint = Endpoint
endpoint
    , zreGroups :: Groups
zreGroups = forall a. Monoid a => a
mempty
    , zreGroupSeq :: Int
zreGroupSeq = Int
0
    , zreName :: ByteString
zreName = ByteString
name
    , zreHeaders :: Headers
zreHeaders = forall a. Monoid a => a
mempty
    , zreDebug :: Bool
zreDebug = Bool
dbg
    , zreIn :: EventQueue
zreIn = EventQueue
inQ
    , zreOut :: APIQueue
zreOut = APIQueue
outQ
    , zreIfaces :: Map ByteString [Async ()]
zreIfaces = forall a. Monoid a => a
mempty
    , zreCfg :: ZRECfg
zreCfg = ZRECfg
cfg
    }