{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
module Haskoin.Node.Manager
    ( PeerManagerConfig (..)
    , PeerEvent (..)
    , OnlinePeer (..)
    , PeerManager
    , withPeerManager
    , managerBest
    , managerVersion
    , managerPing
    , managerPong
    , managerAddrs
    , managerVerAck
    , managerTickle
    , getPeers
    , getOnlinePeer
    , buildVersion
    , myVersion
    , toSockAddr
    , toHostService
    ) where

import           Control.Arrow
import           Control.Monad             (forM_, forever, guard, void, when,
                                            (<=<))
import           Control.Monad.Except      (ExceptT (..), runExceptT,
                                            throwError)
import           Control.Monad.Logger      (MonadLogger, MonadLoggerIO,
                                            logDebugS, logErrorS, logInfoS,
                                            logWarnS)
import           Control.Monad.Reader      (MonadReader, ReaderT (ReaderT), ask,
                                            asks, runReaderT)
import           Control.Monad.Trans       (lift)
import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import           Data.Bits                 ((.&.))
import           Data.Function             (on)
import           Data.List                 (find, nub, sort, dropWhileEnd, elemIndex)
import           Data.Maybe                (fromMaybe, isJust)
import           Data.Set                  (Set)
import qualified Data.Set                  as Set
import           Data.String.Conversions   (cs)
import           Data.Time.Clock           (NominalDiffTime, UTCTime,
                                            addUTCTime, diffUTCTime,
                                            getCurrentTime)
import           Data.Time.Clock.POSIX     (utcTimeToPOSIXSeconds)
import           Data.Word                 (Word32, Word64)
import           Haskoin                   (BlockHeight, Message (..),
                                            Network (..), NetworkAddress (..),
                                            Ping (..), Pong (..),
                                            VarString (..), Version (..),
                                            hostToSockAddr, nodeNetwork,
                                            sockToHostAddress)
import           Haskoin.Node.Peer
import           NQE                       (Child, Inbox, Mailbox, Publisher,
                                            Strategy (..), Supervisor, addChild,
                                            inboxToMailbox, newInbox,
                                            newMailbox, publish, receive,
                                            receiveMatch, send, sendSTM,
                                            withSupervisor)
import           Network.Socket            (AddrInfo (..), AddrInfoFlag (..),
                                            Family (..), SockAddr (..),
                                            SocketType (..), defaultHints,
                                            getAddrInfo)
import           System.Random             (randomIO, randomRIO)
import           UnliftIO                  (Async, MonadIO, MonadUnliftIO, STM,
                                            SomeException, TVar, atomically,
                                            catch, liftIO, link, modifyTVar,
                                            newTVarIO, readTVar, readTVarIO,
                                            withAsync, withRunInIO, writeTVar)
import           UnliftIO.Concurrent       (threadDelay)
import Control.Applicative ((<|>))

type MonadManager m = (MonadIO m, MonadReader PeerManager m)

data PeerEvent
    = PeerConnected !Peer
    | PeerDisconnected !Peer
    deriving PeerEvent -> PeerEvent -> Bool
(PeerEvent -> PeerEvent -> Bool)
-> (PeerEvent -> PeerEvent -> Bool) -> Eq PeerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeerEvent -> PeerEvent -> Bool
$c/= :: PeerEvent -> PeerEvent -> Bool
== :: PeerEvent -> PeerEvent -> Bool
$c== :: PeerEvent -> PeerEvent -> Bool
Eq

data PeerManagerConfig =
    PeerManagerConfig
        { PeerManagerConfig -> Int
peerManagerMaxPeers :: !Int
        , PeerManagerConfig -> [String]
peerManagerPeers    :: ![String]
        , PeerManagerConfig -> Bool
peerManagerDiscover :: !Bool
        , PeerManagerConfig -> NetworkAddress
peerManagerNetAddr  :: !NetworkAddress
        , PeerManagerConfig -> Network
peerManagerNetwork  :: !Network
        , PeerManagerConfig -> Publisher PeerEvent
peerManagerEvents   :: !(Publisher PeerEvent)
        , PeerManagerConfig -> NominalDiffTime
peerManagerTimeout  :: !NominalDiffTime
        , PeerManagerConfig -> NominalDiffTime
peerManagerMaxLife  :: !NominalDiffTime
        , PeerManagerConfig -> SockAddr -> WithConnection
peerManagerConnect  :: !(SockAddr -> WithConnection)
        , PeerManagerConfig -> Publisher (Peer, Message)
peerManagerPub      :: !(Publisher (Peer, Message))
        }

data PeerManager =
    PeerManager
        { PeerManager -> PeerManagerConfig
myConfig     :: !PeerManagerConfig
        , PeerManager -> Supervisor
mySupervisor :: !Supervisor
        , PeerManager -> Mailbox ManagerMessage
myMailbox    :: !(Mailbox ManagerMessage)
        , PeerManager -> TVar Word32
myBestBlock  :: !(TVar BlockHeight)
        , PeerManager -> TVar (Set SockAddr)
knownPeers   :: !(TVar (Set SockAddr))
        , PeerManager -> TVar [OnlinePeer]
onlinePeers  :: !(TVar [OnlinePeer])
        }

data ManagerMessage
    = Connect !SockAddr
    | CheckPeer !Peer
    | PeerDied !Child !(Maybe SomeException)
    | ManagerBest !BlockHeight
    | PeerVerAck !Peer
    | PeerVersion !Peer !Version
    | PeerPing !Peer !Word64
    | PeerPong !Peer !Word64
    | PeerAddrs !Peer ![NetworkAddress]
    | PeerTickle !Peer

-- | Data structure representing an online peer.
data OnlinePeer =
    OnlinePeer
        { OnlinePeer -> SockAddr
onlinePeerAddress     :: !SockAddr
        , OnlinePeer -> Bool
onlinePeerVerAck      :: !Bool
        , OnlinePeer -> Bool
onlinePeerConnected   :: !Bool
        , OnlinePeer -> Maybe Version
onlinePeerVersion     :: !(Maybe Version)
        , OnlinePeer -> Async ()
onlinePeerAsync       :: !(Async ())
        , OnlinePeer -> Peer
onlinePeerMailbox     :: !Peer
        , OnlinePeer -> Word64
onlinePeerNonce       :: !Word64
        , OnlinePeer -> Maybe (UTCTime, Word64)
onlinePeerPing        :: !(Maybe (UTCTime, Word64))
        , OnlinePeer -> [NominalDiffTime]
onlinePeerPings       :: ![NominalDiffTime]
        , OnlinePeer -> UTCTime
onlinePeerConnectTime :: !UTCTime
        , OnlinePeer -> UTCTime
onlinePeerTickled     :: !UTCTime
        , OnlinePeer -> UTCTime
onlinePeerDisconnect  :: !UTCTime
        }

instance Eq OnlinePeer where
    == :: OnlinePeer -> OnlinePeer -> Bool
(==) = Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Peer -> Peer -> Bool)
-> (OnlinePeer -> Peer) -> OnlinePeer -> OnlinePeer -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OnlinePeer -> Peer
f
      where
        f :: OnlinePeer -> Peer
f OnlinePeer {onlinePeerMailbox :: OnlinePeer -> Peer
onlinePeerMailbox = Peer
p} = Peer
p

instance Ord OnlinePeer where
    compare :: OnlinePeer -> OnlinePeer -> Ordering
compare = NominalDiffTime -> NominalDiffTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NominalDiffTime -> NominalDiffTime -> Ordering)
-> (OnlinePeer -> NominalDiffTime)
-> OnlinePeer
-> OnlinePeer
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OnlinePeer -> NominalDiffTime
f
      where
        f :: OnlinePeer -> NominalDiffTime
f OnlinePeer {onlinePeerPings :: OnlinePeer -> [NominalDiffTime]
onlinePeerPings = [NominalDiffTime]
pings} = NominalDiffTime -> Maybe NominalDiffTime -> NominalDiffTime
forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
60 ([NominalDiffTime] -> Maybe NominalDiffTime
forall a. (Ord a, Fractional a) => [a] -> Maybe a
median [NominalDiffTime]
pings)

withPeerManager :: (MonadUnliftIO m, MonadLoggerIO m)
                => PeerManagerConfig
                -> (PeerManager -> m a)
                -> m a
withPeerManager :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerManagerConfig -> (PeerManager -> m a) -> m a
withPeerManager PeerManagerConfig
cfg PeerManager -> m a
action = do
    Inbox ManagerMessage
inbox <- m (Inbox ManagerMessage)
forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
    let mgr :: Mailbox ManagerMessage
mgr = Inbox ManagerMessage -> Mailbox ManagerMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox ManagerMessage
inbox
    Strategy -> (Supervisor -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Strategy -> (Supervisor -> m a) -> m a
withSupervisor (Listen (Async (), Maybe SomeException) -> Strategy
Notify (Mailbox ManagerMessage -> Listen (Async (), Maybe SomeException)
forall {mbox :: * -> *}.
OutChan mbox =>
mbox ManagerMessage -> Listen (Async (), Maybe SomeException)
death Mailbox ManagerMessage
mgr)) ((Supervisor -> m a) -> m a) -> (Supervisor -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Supervisor
sup -> do
        TVar Word32
bb <- Word32 -> m (TVar Word32)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Word32
0
        TVar (Set SockAddr)
kp <- Set SockAddr -> m (TVar (Set SockAddr))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set SockAddr
forall a. Set a
Set.empty
        TVar [OnlinePeer]
ob <- [OnlinePeer] -> m (TVar [OnlinePeer])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        let rd :: PeerManager
rd = PeerManager :: PeerManagerConfig
-> Supervisor
-> Mailbox ManagerMessage
-> TVar Word32
-> TVar (Set SockAddr)
-> TVar [OnlinePeer]
-> PeerManager
PeerManager { myConfig :: PeerManagerConfig
myConfig = PeerManagerConfig
cfg
                             , mySupervisor :: Supervisor
mySupervisor = Supervisor
sup
                             , myMailbox :: Mailbox ManagerMessage
myMailbox = Mailbox ManagerMessage
mgr
                             , myBestBlock :: TVar Word32
myBestBlock = TVar Word32
bb
                             , knownPeers :: TVar (Set SockAddr)
knownPeers = TVar (Set SockAddr)
kp
                             , onlinePeers :: TVar [OnlinePeer]
onlinePeers = TVar [OnlinePeer]
ob
                             }
        Inbox ManagerMessage -> ReaderT PeerManager m a
go Inbox ManagerMessage
inbox ReaderT PeerManager m a -> PeerManager -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` PeerManager
rd
  where
    death :: mbox ManagerMessage -> Listen (Async (), Maybe SomeException)
death mbox ManagerMessage
mgr (Async ()
a, Maybe SomeException
ex) = Async () -> Maybe SomeException -> ManagerMessage
PeerDied Async ()
a Maybe SomeException
ex ManagerMessage -> mbox ManagerMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` mbox ManagerMessage
mgr
    go :: Inbox ManagerMessage -> ReaderT PeerManager m a
go Inbox ManagerMessage
inbox =
        ReaderT PeerManager m ()
-> (Async () -> ReaderT PeerManager m a) -> ReaderT PeerManager m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Inbox ManagerMessage -> ReaderT PeerManager m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
Inbox ManagerMessage -> m ()
peerManager Inbox ManagerMessage
inbox) ((Async () -> ReaderT PeerManager m a) -> ReaderT PeerManager m a)
-> (Async () -> ReaderT PeerManager m a) -> ReaderT PeerManager m a
forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
        ReaderT PeerManager m a -> ReaderT PeerManager m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadManager m) =>
m a -> m a
withConnectLoop (ReaderT PeerManager m a -> ReaderT PeerManager m a)
-> ReaderT PeerManager m a -> ReaderT PeerManager m a
forall a b. (a -> b) -> a -> b
$
        Async () -> ReaderT PeerManager m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a ReaderT PeerManager m ()
-> ReaderT PeerManager m a -> ReaderT PeerManager m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (PeerManager -> m a) -> ReaderT PeerManager m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT PeerManager -> m a
action

peerManager :: ( MonadUnliftIO m
               , MonadManager m
               , MonadLoggerIO m )
            => Inbox ManagerMessage
            -> m ()
peerManager :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
Inbox ManagerMessage -> m ()
peerManager Inbox ManagerMessage
inb = do
    $(logDebugS) Text
"PeerManager" Text
"Awaiting best block"
    Word32 -> m ()
forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock (Word32 -> m ())
-> ((ManagerMessage -> Maybe Word32) -> m Word32)
-> (ManagerMessage -> Maybe Word32)
-> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Inbox ManagerMessage
-> (ManagerMessage -> Maybe Word32) -> m Word32
forall (m :: * -> *) (mbox :: * -> *) msg a.
(MonadIO m, InChan mbox) =>
mbox msg -> (msg -> Maybe a) -> m a
receiveMatch Inbox ManagerMessage
inb ((ManagerMessage -> Maybe Word32) -> m ())
-> (ManagerMessage -> Maybe Word32) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
        ManagerBest Word32
b -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
b
        ManagerMessage
_             -> Maybe Word32
forall a. Maybe a
Nothing
    $(logDebugS) Text
"PeerManager" Text
"Starting peer manager actor"
    m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever m ()
loop
  where
    loop :: m ()
loop = do
        ManagerMessage
m <- Inbox ManagerMessage -> m ManagerMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox ManagerMessage
inb
        ManagerMessage -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
ManagerMessage -> m ()
managerMessage ManagerMessage
m

putBestBlock :: MonadManager m => BlockHeight -> m ()
putBestBlock :: forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock Word32
bb = do
    TVar Word32
b <- (PeerManager -> TVar Word32) -> m (TVar Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar Word32
myBestBlock
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Word32 -> Word32 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Word32
b Word32
bb

getBestBlock :: MonadManager m => m BlockHeight
getBestBlock :: forall (m :: * -> *). MonadManager m => m Word32
getBestBlock =
    (PeerManager -> TVar Word32) -> m (TVar Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar Word32
myBestBlock m (TVar Word32) -> (TVar Word32 -> m Word32) -> m Word32
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar Word32 -> m Word32
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO

getNetwork :: MonadManager m => m Network
getNetwork :: forall (m :: * -> *). MonadManager m => m Network
getNetwork =
    (PeerManager -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Network
peerManagerNetwork (PeerManagerConfig -> Network)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)

loadPeers :: (MonadUnliftIO m, MonadManager m) => m ()
loadPeers :: forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadPeers = do
    m ()
forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadStaticPeers
    m ()
forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadNetSeeds

loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m ()
loadStaticPeers :: forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadStaticPeers = do
    Network
net <- (PeerManager -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Network
peerManagerNetwork (PeerManagerConfig -> Network)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    [String]
xs <- (PeerManager -> [String]) -> m [String]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> [String]
peerManagerPeers (PeerManagerConfig -> [String])
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    (SockAddr -> m ()) -> [SockAddr] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SockAddr -> m ()
forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer ([SockAddr] -> m ())
-> ([[SockAddr]] -> [SockAddr]) -> [[SockAddr]] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[SockAddr]] -> [SockAddr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SockAddr]] -> m ()) -> m [[SockAddr]] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> m [SockAddr]) -> [String] -> m [[SockAddr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Network -> String -> m [SockAddr]
forall (m :: * -> *).
MonadUnliftIO m =>
Network -> String -> m [SockAddr]
toSockAddr Network
net) [String]
xs

loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m ()
loadNetSeeds :: forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadNetSeeds =
    (PeerManager -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Bool
peerManagerDiscover (PeerManagerConfig -> Bool)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
discover ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
discover (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Network
net <- m Network
forall (m :: * -> *). MonadManager m => m Network
getNetwork
            [SockAddr]
ss <- [[SockAddr]] -> [SockAddr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SockAddr]] -> [SockAddr]) -> m [[SockAddr]] -> m [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m [SockAddr]) -> [String] -> m [[SockAddr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Network -> String -> m [SockAddr]
forall (m :: * -> *).
MonadUnliftIO m =>
Network -> String -> m [SockAddr]
toSockAddr Network
net) (Network -> [String]
getSeeds Network
net)
            (SockAddr -> m ()) -> [SockAddr] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SockAddr -> m ()
forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer [SockAddr]
ss

logConnectedPeers :: (MonadManager m, MonadLoggerIO m) => m ()
logConnectedPeers :: forall (m :: * -> *). (MonadManager m, MonadLoggerIO m) => m ()
logConnectedPeers = do
    Int
m <- (PeerManager -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Int
peerManagerMaxPeers (PeerManagerConfig -> Int)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    Int
l <- [OnlinePeer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([OnlinePeer] -> Int) -> m [OnlinePeer] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [OnlinePeer]
forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getConnectedPeers
    $(logInfoS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Peers connected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
l) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
m)

getOnlinePeers :: MonadManager m => m [OnlinePeer]
getOnlinePeers :: forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getOnlinePeers =
    (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers m (TVar [OnlinePeer])
-> (TVar [OnlinePeer] -> m [OnlinePeer]) -> m [OnlinePeer]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar [OnlinePeer] -> m [OnlinePeer]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO

getConnectedPeers :: MonadManager m => m [OnlinePeer]
getConnectedPeers :: forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getConnectedPeers =
    (OnlinePeer -> Bool) -> [OnlinePeer] -> [OnlinePeer]
forall a. (a -> Bool) -> [a] -> [a]
filter OnlinePeer -> Bool
onlinePeerConnected ([OnlinePeer] -> [OnlinePeer]) -> m [OnlinePeer] -> m [OnlinePeer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [OnlinePeer]
forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getOnlinePeers

managerEvent :: MonadManager m => PeerEvent -> m ()
managerEvent :: forall (m :: * -> *). MonadManager m => PeerEvent -> m ()
managerEvent PeerEvent
e =
    PeerEvent -> Publisher PeerEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish PeerEvent
e (Publisher PeerEvent -> m ()) -> m (Publisher PeerEvent) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PeerManager -> Publisher PeerEvent) -> m (Publisher PeerEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Publisher PeerEvent
peerManagerEvents (PeerManagerConfig -> Publisher PeerEvent)
-> (PeerManager -> PeerManagerConfig)
-> PeerManager
-> Publisher PeerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)

managerMessage :: ( MonadUnliftIO m
                  , MonadManager m
                  , MonadLoggerIO m )
               => ManagerMessage
               -> m ()

managerMessage :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
ManagerMessage -> m ()
managerMessage (PeerVersion Peer
p Version
v) = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    Either PeerException ()
e <- ExceptT PeerException m () -> m (Either PeerException ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PeerException m () -> m (Either PeerException ()))
-> ExceptT PeerException m () -> m (Either PeerException ())
forall a b. (a -> b) -> a -> b
$ do
        OnlinePeer
o <- m (Either PeerException OnlinePeer)
-> ExceptT PeerException m OnlinePeer
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either PeerException OnlinePeer)
 -> ExceptT PeerException m OnlinePeer)
-> (STM (Either PeerException OnlinePeer)
    -> m (Either PeerException OnlinePeer))
-> STM (Either PeerException OnlinePeer)
-> ExceptT PeerException m OnlinePeer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either PeerException OnlinePeer)
-> m (Either PeerException OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either PeerException OnlinePeer)
 -> ExceptT PeerException m OnlinePeer)
-> STM (Either PeerException OnlinePeer)
-> ExceptT PeerException m OnlinePeer
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer]
-> Peer -> Version -> STM (Either PeerException OnlinePeer)
setPeerVersion TVar [OnlinePeer]
b Peer
p Version
v
        Bool -> ExceptT PeerException m () -> ExceptT PeerException m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OnlinePeer -> Bool
onlinePeerConnected OnlinePeer
o) (ExceptT PeerException m () -> ExceptT PeerException m ())
-> ExceptT PeerException m () -> ExceptT PeerException m ()
forall a b. (a -> b) -> a -> b
$ Peer -> ExceptT PeerException m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
announcePeer Peer
p
    case Either PeerException ()
e of
        Right () -> do
            $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Sending version ack to peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            Message
MVerAck Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
        Left PeerException
x -> do
            $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Version rejected for peer "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (PeerException -> String
forall a. Show a => a -> String
show PeerException
x)
            PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
x Peer
p

managerMessage (PeerVerAck Peer
p) = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
setPeerVerAck TVar [OnlinePeer]
b Peer
p) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just OnlinePeer
o -> do
            $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Received version ack from peer: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OnlinePeer -> Bool
onlinePeerConnected OnlinePeer
o) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                Peer -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
announcePeer Peer
p
        Maybe OnlinePeer
Nothing -> do
            $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Received verack from unknown peer: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
UnknownPeer Peer
p

managerMessage (PeerAddrs Peer
p [NetworkAddress]
nas) = do
    Bool
discover <- (PeerManager -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Bool
peerManagerDiscover (PeerManagerConfig -> Bool)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
discover (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let sas :: [SockAddr]
sas = (NetworkAddress -> SockAddr) -> [NetworkAddress] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map (HostAddress -> SockAddr
hostToSockAddr (HostAddress -> SockAddr)
-> (NetworkAddress -> HostAddress) -> NetworkAddress -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkAddress -> HostAddress
naAddress) [NetworkAddress]
nas
        [(Int, SockAddr)] -> ((Int, SockAddr) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [SockAddr] -> [(Int, SockAddr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [SockAddr]
sas) (((Int, SockAddr) -> m ()) -> m ())
-> ((Int, SockAddr) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, SockAddr
a) -> do
            $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Got peer address "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show ([SockAddr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
sas))
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (SockAddr -> String
forall a. Show a => a -> String
show SockAddr
a)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            SockAddr -> m ()
forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer SockAddr
a

managerMessage (PeerPong Peer
p Word64
n) = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Received pong "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word64 -> String
forall a. Show a => a -> String
show Word64
n)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
gotPong TVar [OnlinePeer]
b Word64
n UTCTime
now Peer
p)

managerMessage (PeerPing Peer
p Word64
n) = do
    $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Responding to ping "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word64 -> String
forall a. Show a => a -> String
show Word64
n)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Pong -> Message
MPong (Word64 -> Pong
Pong Word64
n) Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p

managerMessage (ManagerBest Word32
h) =
    Word32 -> m ()
forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock Word32
h

managerMessage (Connect SockAddr
sa) =
    SockAddr -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
SockAddr -> m ()
connectPeer SockAddr
sa

managerMessage (PeerDied Async ()
a Maybe SomeException
e) =
    Async () -> Maybe SomeException -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Async () -> Maybe SomeException -> m ()
processPeerOffline Async ()
a Maybe SomeException
e

managerMessage (CheckPeer Peer
p) =
    Peer -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
checkPeer Peer
p

managerMessage (PeerTickle Peer
p) = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> Peer -> (OnlinePeer -> OnlinePeer) -> STM ()
modifyPeer TVar [OnlinePeer]
b Peer
p ((OnlinePeer -> OnlinePeer) -> STM ())
-> (OnlinePeer -> OnlinePeer) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OnlinePeer
o ->
        OnlinePeer
o { onlinePeerTickled :: UTCTime
onlinePeerTickled = UTCTime
now }

checkPeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m ()
checkPeer :: forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
checkPeer Peer
p =
    Peer -> m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
getBusy Peer
p m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> do
            NominalDiffTime
to <- (PeerManager -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> NominalDiffTime
peerManagerTimeout (PeerManagerConfig -> NominalDiffTime)
-> (PeerManager -> PeerManagerConfig)
-> PeerManager
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
            STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe OnlinePeer
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just OnlinePeer
o -> do
                    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                    UTCTime -> OnlinePeer -> m ()
forall {f :: * -> *}. MonadIO f => UTCTime -> OnlinePeer -> f ()
check_conn UTCTime
now OnlinePeer
o
                    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime -> NominalDiffTime -> OnlinePeer -> Bool
check_tickle UTCTime
now NominalDiffTime
to OnlinePeer
o) (OnlinePeer -> m ()
forall {m :: * -> *}.
(MonadReader PeerManager m, MonadLoggerIO m) =>
OnlinePeer -> m ()
check_ping OnlinePeer
o)
  where
    check_tickle :: UTCTime -> NominalDiffTime -> OnlinePeer -> Bool
check_tickle UTCTime
now NominalDiffTime
to OnlinePeer
o =
        UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` OnlinePeer -> UTCTime
onlinePeerTickled OnlinePeer
o NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
to
    check_conn :: UTCTime -> OnlinePeer -> f ()
check_conn UTCTime
now OnlinePeer
o =
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` OnlinePeer -> UTCTime
onlinePeerDisconnect OnlinePeer
o NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        PeerException -> Peer -> f ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTooOld Peer
p
    check_ping :: OnlinePeer -> m ()
check_ping OnlinePeer
o =
        case OnlinePeer -> Maybe (UTCTime, Word64)
onlinePeerPing OnlinePeer
o of
            Maybe (UTCTime, Word64)
Nothing ->
                Peer -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
sendPing Peer
p
            Just (UTCTime, Word64)
_ -> do
                $(logWarnS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Peer ping timeout: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTimeout Peer
p

sendPing :: (MonadManager m, MonadLoggerIO m) => Peer -> m ()
sendPing :: forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
sendPing Peer
p = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing ->
            $(logWarnS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Will not ping unknown peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Just OnlinePeer
o
            | OnlinePeer -> Bool
onlinePeerConnected OnlinePeer
o -> do
                Word64
n <- IO Word64 -> m Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
                UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
setPeerPing TVar [OnlinePeer]
b Word64
n UTCTime
now Peer
p)
                $(logDebugS)Text
" PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Sending ping " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word64 -> String
forall a. Show a => a -> String
show Word64
n)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                Ping -> Message
MPing (Word64 -> Ping
Ping Word64
n) Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
            | Bool
otherwise -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

processPeerOffline :: (MonadManager m, MonadLoggerIO m)
                   => Child -> Maybe SomeException -> m ()
processPeerOffline :: forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Async () -> Maybe SomeException -> m ()
processPeerOffline Async ()
a Maybe SomeException
e = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Async () -> STM (Maybe OnlinePeer)
findPeerAsync TVar [OnlinePeer]
b Async ()
a) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> Maybe SomeException -> m ()
forall {m :: * -> *} {a}.
(MonadLogger m, Show a) =>
Maybe a -> m ()
log_unknown Maybe SomeException
e
        Just OnlinePeer
o -> do
            let p :: Peer
p = OnlinePeer -> Peer
onlinePeerMailbox OnlinePeer
o
            if OnlinePeer -> Bool
onlinePeerConnected OnlinePeer
o
                then do
                    Peer -> Maybe SomeException -> m ()
forall {m :: * -> *} {a}.
(MonadLogger m, Show a) =>
Peer -> Maybe a -> m ()
log_disconnected Peer
p Maybe SomeException
e
                    PeerEvent -> m ()
forall (m :: * -> *). MonadManager m => PeerEvent -> m ()
managerEvent (PeerEvent -> m ()) -> PeerEvent -> m ()
forall a b. (a -> b) -> a -> b
$ Peer -> PeerEvent
PeerDisconnected Peer
p
                else Peer -> Maybe SomeException -> m ()
forall {m :: * -> *} {a}.
(MonadLogger m, Show a) =>
Peer -> Maybe a -> m ()
log_not_connect Peer
p Maybe SomeException
e
            STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> Peer -> STM ()
removePeer TVar [OnlinePeer]
b Peer
p
            m ()
forall (m :: * -> *). (MonadManager m, MonadLoggerIO m) => m ()
logConnectedPeers
  where
    log_unknown :: Maybe a -> m ()
log_unknown Maybe a
Nothing =
        $(logErrorS) Text
"PeerManager"
        Text
"Disconnected unknown peer"
    log_unknown (Just a
x) =
        $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Unknown peer died: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
x)
    log_disconnected :: Peer -> Maybe a -> m ()
log_disconnected Peer
p Maybe a
Nothing =
        $(logWarnS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Disconnected peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    log_disconnected Peer
p (Just a
x) =
        $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" died: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
x)
    log_not_connect :: Peer -> Maybe a -> m ()
log_not_connect Peer
p Maybe a
Nothing =
        $(logWarnS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Could not connect to peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    log_not_connect Peer
p (Just a
x) =
        $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Could not connect to peer "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
x)

announcePeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m ()
announcePeer :: forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
announcePeer Peer
p = do
    TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just OnlinePeer {onlinePeerConnected :: OnlinePeer -> Bool
onlinePeerConnected = Bool
True} -> do
            $(logInfoS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Connected to peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            PeerEvent -> m ()
forall (m :: * -> *). MonadManager m => PeerEvent -> m ()
managerEvent (PeerEvent -> m ()) -> PeerEvent -> m ()
forall a b. (a -> b) -> a -> b
$ Peer -> PeerEvent
PeerConnected Peer
p
            m ()
forall (m :: * -> *). (MonadManager m, MonadLoggerIO m) => m ()
logConnectedPeers
        Just OnlinePeer {onlinePeerConnected :: OnlinePeer -> Bool
onlinePeerConnected = Bool
False} ->
            () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe OnlinePeer
Nothing ->
            $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Not announcing disconnected peer: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p

getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr)
getNewPeer :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m) =>
m (Maybe SockAddr)
getNewPeer =
    MaybeT m SockAddr -> m (Maybe SockAddr)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m SockAddr -> m (Maybe SockAddr))
-> MaybeT m SockAddr -> m (Maybe SockAddr)
forall a b. (a -> b) -> a -> b
$ m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadPeers MaybeT m () -> MaybeT m SockAddr -> MaybeT m SockAddr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MaybeT m SockAddr
go
  where
    go :: MaybeT m SockAddr
go = do
        TVar (Set SockAddr)
b <- (PeerManager -> TVar (Set SockAddr))
-> MaybeT m (TVar (Set SockAddr))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar (Set SockAddr)
knownPeers
        Set SockAddr
ks <- TVar (Set SockAddr) -> MaybeT m (Set SockAddr)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set SockAddr)
b
        Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> (Bool -> Bool) -> Bool -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Set SockAddr -> Bool
forall a. Set a -> Bool
Set.null Set SockAddr
ks
        let xs :: [SockAddr]
xs = Set SockAddr -> [SockAddr]
forall a. Set a -> [a]
Set.toList Set SockAddr
ks
        Int
a <- IO Int -> MaybeT m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> MaybeT m Int) -> IO Int -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$ CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, [SockAddr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        let p :: SockAddr
p = [SockAddr]
xs [SockAddr] -> Int -> SockAddr
forall a. [a] -> Int -> a
!! Int
a
        TVar [OnlinePeer]
o <- (PeerManager -> TVar [OnlinePeer]) -> MaybeT m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
        Maybe OnlinePeer
m <- STM (Maybe OnlinePeer) -> MaybeT m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe OnlinePeer) -> MaybeT m (Maybe OnlinePeer))
-> STM (Maybe OnlinePeer) -> MaybeT m (Maybe OnlinePeer)
forall a b. (a -> b) -> a -> b
$ do
            TVar (Set SockAddr) -> (Set SockAddr -> Set SockAddr) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SockAddr)
b ((Set SockAddr -> Set SockAddr) -> STM ())
-> (Set SockAddr -> Set SockAddr) -> STM ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> Set SockAddr -> Set SockAddr
forall a. Ord a => a -> Set a -> Set a
Set.delete SockAddr
p
            TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
o SockAddr
p
        MaybeT m SockAddr
-> (OnlinePeer -> MaybeT m SockAddr)
-> Maybe OnlinePeer
-> MaybeT m SockAddr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SockAddr -> MaybeT m SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
p) (MaybeT m SockAddr -> OnlinePeer -> MaybeT m SockAddr
forall a b. a -> b -> a
const MaybeT m SockAddr
go) Maybe OnlinePeer
m


connectPeer :: ( MonadUnliftIO m
               , MonadManager m
               , MonadLoggerIO m
               )
            => SockAddr
            -> m ()
connectPeer :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
SockAddr -> m ()
connectPeer SockAddr
sa = do
    TVar [OnlinePeer]
os <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
os SockAddr
sa) m (Maybe OnlinePeer) -> (Maybe OnlinePeer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just OnlinePeer
_ ->
            $(logErrorS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Attempted to connect to peer twice: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (SockAddr -> String
forall a. Show a => a -> String
show SockAddr
sa)
        Maybe OnlinePeer
Nothing -> do
            $(logInfoS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Connecting to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (SockAddr -> String
forall a. Show a => a -> String
show SockAddr
sa)
            PeerManagerConfig { peerManagerNetAddr :: PeerManagerConfig -> NetworkAddress
peerManagerNetAddr = NetworkAddress
ad
                              , peerManagerNetwork :: PeerManagerConfig -> Network
peerManagerNetwork = Network
net
                              } <- (PeerManager -> PeerManagerConfig) -> m PeerManagerConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> PeerManagerConfig
myConfig
            Supervisor
sup <- (PeerManager -> Supervisor) -> m Supervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> Supervisor
mySupervisor
            SockAddr -> WithConnection
conn <- (PeerManager -> SockAddr -> WithConnection)
-> m (SockAddr -> WithConnection)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> SockAddr -> WithConnection
peerManagerConnect (PeerManagerConfig -> SockAddr -> WithConnection)
-> (PeerManager -> PeerManagerConfig)
-> PeerManager
-> SockAddr
-> WithConnection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Publisher (Peer, Message)
pub <- (PeerManager -> Publisher (Peer, Message))
-> m (Publisher (Peer, Message))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Publisher (Peer, Message)
peerManagerPub (PeerManagerConfig -> Publisher (Peer, Message))
-> (PeerManager -> PeerManagerConfig)
-> PeerManager
-> Publisher (Peer, Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Word64
nonce <- IO Word64 -> m Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
            Word32
bb <- m Word32
forall (m :: * -> *). MonadManager m => m Word32
getBestBlock
            UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let rmt :: NetworkAddress
rmt = Word64 -> HostAddress -> NetworkAddress
NetworkAddress (Network -> Word64
forall {p}. Num p => Network -> p
srv Network
net) (SockAddr -> HostAddress
sockToHostAddress SockAddr
sa)
                unix :: Word64
unix = NominalDiffTime -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
now)
                ver :: Version
ver = Network
-> Word64
-> Word32
-> NetworkAddress
-> NetworkAddress
-> Word64
-> Version
buildVersion Network
net Word64
nonce Word32
bb NetworkAddress
ad NetworkAddress
rmt Word64
unix
                text :: Text
text = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (SockAddr -> String
forall a. Show a => a -> String
show SockAddr
sa)
            (Inbox PeerMessage
inbox, Mailbox PeerMessage
mailbox) <- m (Inbox PeerMessage, Mailbox PeerMessage)
forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
            let pc :: PeerConfig
pc = PeerConfig :: Publisher (Peer, Message)
-> Network -> Text -> WithConnection -> PeerConfig
PeerConfig { peerConfPub :: Publisher (Peer, Message)
peerConfPub = Publisher (Peer, Message)
pub
                                , peerConfNetwork :: Network
peerConfNetwork = Network
net
                                , peerConfText :: Text
peerConfText = Text
text
                                , peerConfConnect :: WithConnection
peerConfConnect = SockAddr -> WithConnection
conn SockAddr
sa
                                }
            TVar Bool
busy <- Bool -> m (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
            Peer
p <- PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
forall (m :: * -> *).
MonadIO m =>
PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer PeerConfig
pc TVar Bool
busy Mailbox PeerMessage
mailbox
            Async ()
a <- ((forall a. m a -> IO a) -> IO (Async ())) -> m (Async ())
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Async ())) -> m (Async ()))
-> ((forall a. m a -> IO a) -> IO (Async ())) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
io ->
                Supervisor
sup Supervisor -> ChildAction -> IO (Async ())
forall (m :: * -> *).
MonadIO m =>
Supervisor -> ChildAction -> m (Async ())
`addChild` m () -> ChildAction
forall a. m a -> IO a
io (PeerConfig -> TVar Bool -> Inbox PeerMessage -> Peer -> m ()
forall {m :: * -> *}.
(MonadReader PeerManager m, MonadUnliftIO m, MonadLoggerIO m) =>
PeerConfig -> TVar Bool -> Inbox PeerMessage -> Peer -> m ()
launch PeerConfig
pc TVar Bool
busy Inbox PeerMessage
inbox Peer
p)
            Version -> Message
MVersion Version
ver Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
            TVar [OnlinePeer]
b <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
            NominalDiffTime
max_life <- (PeerManager -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> NominalDiffTime
peerManagerMaxLife (PeerManagerConfig -> NominalDiffTime)
-> (PeerManager -> PeerManagerConfig)
-> PeerManager
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Rational
rand <- IO Rational -> m Rational
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Rational -> m Rational) -> IO Rational -> m Rational
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Rational) -> IO Double -> IO Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> IO Double
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Double
0.75 :: Double, Double
1.00)
            let life :: NominalDiffTime
life = NominalDiffTime
max_life NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational Rational
rand
            let dc :: UTCTime
dc = NominalDiffTime
life NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now
            OnlinePeer
_ <- STM OnlinePeer -> m OnlinePeer
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM OnlinePeer -> m OnlinePeer) -> STM OnlinePeer -> m OnlinePeer
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer]
-> SockAddr
-> Word64
-> Peer
-> Async ()
-> UTCTime
-> UTCTime
-> STM OnlinePeer
newOnlinePeer TVar [OnlinePeer]
b SockAddr
sa Word64
nonce Peer
p Async ()
a UTCTime
now UTCTime
dc
            () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    srv :: Network -> p
srv Network
net
        | Network -> Bool
getSegWit Network
net = p
8
        | Bool
otherwise = p
0
    launch :: PeerConfig -> TVar Bool -> Inbox PeerMessage -> Peer -> m ()
launch PeerConfig
pc TVar Bool
busy Inbox PeerMessage
inbox Peer
p =
        m PeerManager
forall r (m :: * -> *). MonadReader r m => m r
ask m PeerManager -> (PeerManager -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PeerManager
mgr ->
        SockAddr -> Peer -> PeerManager -> (Async () -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
SockAddr -> Peer -> PeerManager -> (Async a -> m a) -> m a
withPeerLoop SockAddr
sa Peer
p PeerManager
mgr ((Async () -> m ()) -> m ()) -> (Async () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
        Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PeerConfig -> TVar Bool -> Inbox PeerMessage -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerConfig -> TVar Bool -> Inbox PeerMessage -> m ()
peer PeerConfig
pc TVar Bool
busy Inbox PeerMessage
inbox

withPeerLoop ::
       (MonadUnliftIO m, MonadLogger m)
    => SockAddr
    -> Peer
    -> PeerManager
    -> (Async a -> m a)
    -> m a
withPeerLoop :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
SockAddr -> Peer -> PeerManager -> (Async a -> m a) -> m a
withPeerLoop SockAddr
_ Peer
p PeerManager
mgr =
    m a -> (Async a -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (m a -> (Async a -> m a) -> m a)
-> (m () -> m a) -> m () -> (Async a -> m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> (Async a -> m a) -> m a)
-> m () -> (Async a -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
        let x :: NominalDiffTime
x = PeerManagerConfig -> NominalDiffTime
peerManagerTimeout (PeerManager -> PeerManagerConfig
myConfig PeerManager
mgr)
            y :: Int
y = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime
x NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000000)
        Int
r <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4, Int
y)
        Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
r
        Peer -> PeerManager -> m ()
forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerCheck Peer
p PeerManager
mgr

withConnectLoop :: (MonadUnliftIO m, MonadManager m)
                => m a
                -> m a
withConnectLoop :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadManager m) =>
m a -> m a
withConnectLoop m a
act =
    m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync m Any
forall {b}. m b
go ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
    Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
act
  where
    go :: m b
go = m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
        Int
l <- [OnlinePeer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([OnlinePeer] -> Int) -> m [OnlinePeer] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [OnlinePeer]
forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getOnlinePeers
        Int
x <- (PeerManager -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Int
peerManagerMaxPeers (PeerManagerConfig -> Int)
-> (PeerManager -> PeerManagerConfig) -> PeerManager -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            m (Maybe SockAddr)
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m) =>
m (Maybe SockAddr)
getNewPeer m (Maybe SockAddr) -> (Maybe SockAddr -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SockAddr -> m ()) -> Maybe SockAddr -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\SockAddr
sa -> m PeerManager
forall r (m :: * -> *). MonadReader r m => m r
ask m PeerManager -> (PeerManager -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SockAddr -> PeerManager -> m ()
forall (m :: * -> *). MonadIO m => SockAddr -> PeerManager -> m ()
managerConnect SockAddr
sa)
        Int
delay <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
            CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO ( Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                      , Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
500 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 )
        Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay

newPeer :: (MonadIO m, MonadManager m) => SockAddr -> m ()
newPeer :: forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer SockAddr
sa = do
    TVar (Set SockAddr)
b <- (PeerManager -> TVar (Set SockAddr)) -> m (TVar (Set SockAddr))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar (Set SockAddr)
knownPeers
    TVar [OnlinePeer]
o <- (PeerManager -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
o SockAddr
sa STM (Maybe OnlinePeer) -> (Maybe OnlinePeer -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just OnlinePeer
_  -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe OnlinePeer
Nothing -> TVar (Set SockAddr) -> (Set SockAddr -> Set SockAddr) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SockAddr)
b ((Set SockAddr -> Set SockAddr) -> STM ())
-> (Set SockAddr -> Set SockAddr) -> STM ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> Set SockAddr -> Set SockAddr
forall a. Ord a => a -> Set a -> Set a
Set.insert SockAddr
sa

gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
gotPong TVar [OnlinePeer]
b Word64
nonce UTCTime
now Peer
p = STM (Maybe ()) -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM (Maybe ()) -> STM ())
-> (MaybeT STM () -> STM (Maybe ())) -> MaybeT STM () -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT STM () -> STM (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT STM () -> STM ()) -> MaybeT STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
    OnlinePeer
o <- STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer)
-> STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p
    (UTCTime
time, Word64
old_nonce) <- STM (Maybe (UTCTime, Word64)) -> MaybeT STM (UTCTime, Word64)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (STM (Maybe (UTCTime, Word64)) -> MaybeT STM (UTCTime, Word64))
-> (Maybe (UTCTime, Word64) -> STM (Maybe (UTCTime, Word64)))
-> Maybe (UTCTime, Word64)
-> MaybeT STM (UTCTime, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (UTCTime, Word64) -> STM (Maybe (UTCTime, Word64))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (UTCTime, Word64) -> MaybeT STM (UTCTime, Word64))
-> Maybe (UTCTime, Word64) -> MaybeT STM (UTCTime, Word64)
forall a b. (a -> b) -> a -> b
$ OnlinePeer -> Maybe (UTCTime, Word64)
onlinePeerPing OnlinePeer
o
    Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ Word64
nonce Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
old_nonce
    let diff :: NominalDiffTime
diff = UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
time
    STM () -> MaybeT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> MaybeT STM ()) -> STM () -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer
            TVar [OnlinePeer]
b
            OnlinePeer
o { onlinePeerPing :: Maybe (UTCTime, Word64)
onlinePeerPing = Maybe (UTCTime, Word64)
forall a. Maybe a
Nothing
              , onlinePeerPings :: [NominalDiffTime]
onlinePeerPings = [NominalDiffTime] -> [NominalDiffTime]
forall a. Ord a => [a] -> [a]
sort ([NominalDiffTime] -> [NominalDiffTime])
-> [NominalDiffTime] -> [NominalDiffTime]
forall a b. (a -> b) -> a -> b
$ Int -> [NominalDiffTime] -> [NominalDiffTime]
forall a. Int -> [a] -> [a]
take Int
11 ([NominalDiffTime] -> [NominalDiffTime])
-> [NominalDiffTime] -> [NominalDiffTime]
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
diff NominalDiffTime -> [NominalDiffTime] -> [NominalDiffTime]
forall a. a -> [a] -> [a]
: OnlinePeer -> [NominalDiffTime]
onlinePeerPings OnlinePeer
o
              }

setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM ()
setPeerPing TVar [OnlinePeer]
b Word64
nonce UTCTime
now Peer
p =
    TVar [OnlinePeer] -> Peer -> (OnlinePeer -> OnlinePeer) -> STM ()
modifyPeer TVar [OnlinePeer]
b Peer
p ((OnlinePeer -> OnlinePeer) -> STM ())
-> (OnlinePeer -> OnlinePeer) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OnlinePeer
o -> OnlinePeer
o {onlinePeerPing :: Maybe (UTCTime, Word64)
onlinePeerPing = (UTCTime, Word64) -> Maybe (UTCTime, Word64)
forall a. a -> Maybe a
Just (UTCTime
now, Word64
nonce)}

setPeerVersion ::
       TVar [OnlinePeer]
    -> Peer
    -> Version
    -> STM (Either PeerException OnlinePeer)
setPeerVersion :: TVar [OnlinePeer]
-> Peer -> Version -> STM (Either PeerException OnlinePeer)
setPeerVersion TVar [OnlinePeer]
b Peer
p Version
v = ExceptT PeerException STM OnlinePeer
-> STM (Either PeerException OnlinePeer)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PeerException STM OnlinePeer
 -> STM (Either PeerException OnlinePeer))
-> ExceptT PeerException STM OnlinePeer
-> STM (Either PeerException OnlinePeer)
forall a b. (a -> b) -> a -> b
$ do
    Bool
-> ExceptT PeerException STM () -> ExceptT PeerException STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> Word64
services Version
v Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
nodeNetwork Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) (ExceptT PeerException STM () -> ExceptT PeerException STM ())
-> ExceptT PeerException STM () -> ExceptT PeerException STM ()
forall a b. (a -> b) -> a -> b
$
        PeerException -> ExceptT PeerException STM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
NotNetworkPeer
    [OnlinePeer]
ops <- STM [OnlinePeer] -> ExceptT PeerException STM [OnlinePeer]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM [OnlinePeer] -> ExceptT PeerException STM [OnlinePeer])
-> STM [OnlinePeer] -> ExceptT PeerException STM [OnlinePeer]
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> STM [OnlinePeer]
forall a. TVar a -> STM a
readTVar TVar [OnlinePeer]
b
    Bool
-> ExceptT PeerException STM () -> ExceptT PeerException STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OnlinePeer -> Bool) -> [OnlinePeer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Version -> Word64
verNonce Version
v Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
==) (Word64 -> Bool) -> (OnlinePeer -> Word64) -> OnlinePeer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Word64
onlinePeerNonce) [OnlinePeer]
ops) (ExceptT PeerException STM () -> ExceptT PeerException STM ())
-> ExceptT PeerException STM () -> ExceptT PeerException STM ()
forall a b. (a -> b) -> a -> b
$
        PeerException -> ExceptT PeerException STM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerIsMyself
    STM (Maybe OnlinePeer)
-> ExceptT PeerException STM (Maybe OnlinePeer)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) ExceptT PeerException STM (Maybe OnlinePeer)
-> (Maybe OnlinePeer -> ExceptT PeerException STM OnlinePeer)
-> ExceptT PeerException STM OnlinePeer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> PeerException -> ExceptT PeerException STM OnlinePeer
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
UnknownPeer
        Just OnlinePeer
o -> do
            let n :: OnlinePeer
n = OnlinePeer
o { onlinePeerVersion :: Maybe Version
onlinePeerVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
                      , onlinePeerConnected :: Bool
onlinePeerConnected = OnlinePeer -> Bool
onlinePeerVerAck OnlinePeer
o }
            STM () -> ExceptT PeerException STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> ExceptT PeerException STM ())
-> STM () -> ExceptT PeerException STM ()
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b OnlinePeer
n
            OnlinePeer -> ExceptT PeerException STM OnlinePeer
forall (m :: * -> *) a. Monad m => a -> m a
return OnlinePeer
n

setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
setPeerVerAck TVar [OnlinePeer]
b Peer
p = MaybeT STM OnlinePeer -> STM (Maybe OnlinePeer)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT STM OnlinePeer -> STM (Maybe OnlinePeer))
-> MaybeT STM OnlinePeer -> STM (Maybe OnlinePeer)
forall a b. (a -> b) -> a -> b
$ do
    OnlinePeer
o <- STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer)
-> STM (Maybe OnlinePeer) -> MaybeT STM OnlinePeer
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p
    let n :: OnlinePeer
n = OnlinePeer
o { onlinePeerVerAck :: Bool
onlinePeerVerAck = Bool
True
              , onlinePeerConnected :: Bool
onlinePeerConnected = Maybe Version -> Bool
forall a. Maybe a -> Bool
isJust (OnlinePeer -> Maybe Version
onlinePeerVersion OnlinePeer
o) }
    STM () -> MaybeT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> MaybeT STM ()) -> STM () -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b OnlinePeer
n
    OnlinePeer -> MaybeT STM OnlinePeer
forall (m :: * -> *) a. Monad m => a -> m a
return OnlinePeer
n

newOnlinePeer ::
       TVar [OnlinePeer]
    -> SockAddr
    -> Word64
    -> Peer
    -> Async ()
    -> UTCTime
    -> UTCTime
    -> STM OnlinePeer
newOnlinePeer :: TVar [OnlinePeer]
-> SockAddr
-> Word64
-> Peer
-> Async ()
-> UTCTime
-> UTCTime
-> STM OnlinePeer
newOnlinePeer TVar [OnlinePeer]
box SockAddr
addr Word64
nonce Peer
p Async ()
peer_async UTCTime
connect_time UTCTime
dc = do
    let op :: OnlinePeer
op = OnlinePeer :: SockAddr
-> Bool
-> Bool
-> Maybe Version
-> Async ()
-> Peer
-> Word64
-> Maybe (UTCTime, Word64)
-> [NominalDiffTime]
-> UTCTime
-> UTCTime
-> UTCTime
-> OnlinePeer
OnlinePeer
             { onlinePeerAddress :: SockAddr
onlinePeerAddress = SockAddr
addr
             , onlinePeerVerAck :: Bool
onlinePeerVerAck = Bool
False
             , onlinePeerConnected :: Bool
onlinePeerConnected = Bool
False
             , onlinePeerVersion :: Maybe Version
onlinePeerVersion = Maybe Version
forall a. Maybe a
Nothing
             , onlinePeerAsync :: Async ()
onlinePeerAsync = Async ()
peer_async
             , onlinePeerMailbox :: Peer
onlinePeerMailbox = Peer
p
             , onlinePeerNonce :: Word64
onlinePeerNonce = Word64
nonce
             , onlinePeerPings :: [NominalDiffTime]
onlinePeerPings = []
             , onlinePeerPing :: Maybe (UTCTime, Word64)
onlinePeerPing = Maybe (UTCTime, Word64)
forall a. Maybe a
Nothing
             , onlinePeerConnectTime :: UTCTime
onlinePeerConnectTime = UTCTime
connect_time
             , onlinePeerTickled :: UTCTime
onlinePeerTickled = UTCTime
connect_time
             , onlinePeerDisconnect :: UTCTime
onlinePeerDisconnect = UTCTime
dc
             }
    TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
box OnlinePeer
op
    OnlinePeer -> STM OnlinePeer
forall (m :: * -> *) a. Monad m => a -> m a
return OnlinePeer
op

findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p =
    (OnlinePeer -> Bool) -> [OnlinePeer] -> Maybe OnlinePeer
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p) (Peer -> Bool) -> (OnlinePeer -> Peer) -> OnlinePeer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Peer
onlinePeerMailbox)
    ([OnlinePeer] -> Maybe OnlinePeer)
-> STM [OnlinePeer] -> STM (Maybe OnlinePeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [OnlinePeer] -> STM [OnlinePeer]
forall a. TVar a -> STM a
readTVar TVar [OnlinePeer]
b

insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b OnlinePeer
o =
    TVar [OnlinePeer] -> ([OnlinePeer] -> [OnlinePeer]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [OnlinePeer]
b (([OnlinePeer] -> [OnlinePeer]) -> STM ())
-> ([OnlinePeer] -> [OnlinePeer]) -> STM ()
forall a b. (a -> b) -> a -> b
$ \[OnlinePeer]
x -> [OnlinePeer] -> [OnlinePeer]
forall a. Ord a => [a] -> [a]
sort ([OnlinePeer] -> [OnlinePeer])
-> ([OnlinePeer] -> [OnlinePeer]) -> [OnlinePeer] -> [OnlinePeer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OnlinePeer] -> [OnlinePeer]
forall a. Eq a => [a] -> [a]
nub ([OnlinePeer] -> [OnlinePeer]) -> [OnlinePeer] -> [OnlinePeer]
forall a b. (a -> b) -> a -> b
$ OnlinePeer
o OnlinePeer -> [OnlinePeer] -> [OnlinePeer]
forall a. a -> [a] -> [a]
: [OnlinePeer]
x

modifyPeer :: TVar [OnlinePeer]
           -> Peer
           -> (OnlinePeer -> OnlinePeer)
           -> STM ()
modifyPeer :: TVar [OnlinePeer] -> Peer -> (OnlinePeer -> OnlinePeer) -> STM ()
modifyPeer TVar [OnlinePeer]
b Peer
p OnlinePeer -> OnlinePeer
f =
    TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p STM (Maybe OnlinePeer) -> (Maybe OnlinePeer -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just OnlinePeer
o  -> TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b (OnlinePeer -> STM ()) -> OnlinePeer -> STM ()
forall a b. (a -> b) -> a -> b
$ OnlinePeer -> OnlinePeer
f OnlinePeer
o

removePeer :: TVar [OnlinePeer] -> Peer -> STM ()
removePeer :: TVar [OnlinePeer] -> Peer -> STM ()
removePeer TVar [OnlinePeer]
b Peer
p =
    TVar [OnlinePeer] -> ([OnlinePeer] -> [OnlinePeer]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [OnlinePeer]
b (([OnlinePeer] -> [OnlinePeer]) -> STM ())
-> ([OnlinePeer] -> [OnlinePeer]) -> STM ()
forall a b. (a -> b) -> a -> b
$
    (OnlinePeer -> Bool) -> [OnlinePeer] -> [OnlinePeer]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
/= Peer
p) (Peer -> Bool) -> (OnlinePeer -> Peer) -> OnlinePeer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Peer
onlinePeerMailbox)

findPeerAsync :: TVar [OnlinePeer]
              -> Async ()
              -> STM (Maybe OnlinePeer)
findPeerAsync :: TVar [OnlinePeer] -> Async () -> STM (Maybe OnlinePeer)
findPeerAsync TVar [OnlinePeer]
b Async ()
a =
    (OnlinePeer -> Bool) -> [OnlinePeer] -> Maybe OnlinePeer
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Async () -> Async () -> Bool
forall a. Eq a => a -> a -> Bool
== Async ()
a) (Async () -> Bool)
-> (OnlinePeer -> Async ()) -> OnlinePeer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Async ()
onlinePeerAsync)
    ([OnlinePeer] -> Maybe OnlinePeer)
-> STM [OnlinePeer] -> STM (Maybe OnlinePeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [OnlinePeer] -> STM [OnlinePeer]
forall a. TVar a -> STM a
readTVar TVar [OnlinePeer]
b

findPeerAddress :: TVar [OnlinePeer]
                -> SockAddr
                -> STM (Maybe OnlinePeer)
findPeerAddress :: TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
b SockAddr
a =
    (OnlinePeer -> Bool) -> [OnlinePeer] -> Maybe OnlinePeer
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((SockAddr -> SockAddr -> Bool
forall a. Eq a => a -> a -> Bool
== SockAddr
a) (SockAddr -> Bool)
-> (OnlinePeer -> SockAddr) -> OnlinePeer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> SockAddr
onlinePeerAddress)
    ([OnlinePeer] -> Maybe OnlinePeer)
-> STM [OnlinePeer] -> STM (Maybe OnlinePeer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [OnlinePeer] -> STM [OnlinePeer]
forall a. TVar a -> STM a
readTVar TVar [OnlinePeer]
b

getPeers :: MonadIO m => PeerManager -> m [OnlinePeer]
getPeers :: forall (m :: * -> *). MonadIO m => PeerManager -> m [OnlinePeer]
getPeers = ReaderT PeerManager m [OnlinePeer] -> PeerManager -> m [OnlinePeer]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PeerManager m [OnlinePeer]
forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getConnectedPeers

getOnlinePeer :: MonadIO m
              => Peer
              -> PeerManager
              -> m (Maybe OnlinePeer)
getOnlinePeer :: forall (m :: * -> *).
MonadIO m =>
Peer -> PeerManager -> m (Maybe OnlinePeer)
getOnlinePeer Peer
p =
    ReaderT PeerManager m (Maybe OnlinePeer)
-> PeerManager -> m (Maybe OnlinePeer)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT PeerManager m (Maybe OnlinePeer)
 -> PeerManager -> m (Maybe OnlinePeer))
-> ReaderT PeerManager m (Maybe OnlinePeer)
-> PeerManager
-> m (Maybe OnlinePeer)
forall a b. (a -> b) -> a -> b
$ (PeerManager -> TVar [OnlinePeer])
-> ReaderT PeerManager m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers ReaderT PeerManager m (TVar [OnlinePeer])
-> (TVar [OnlinePeer] -> ReaderT PeerManager m (Maybe OnlinePeer))
-> ReaderT PeerManager m (Maybe OnlinePeer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (Maybe OnlinePeer) -> ReaderT PeerManager m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe OnlinePeer)
 -> ReaderT PeerManager m (Maybe OnlinePeer))
-> (TVar [OnlinePeer] -> STM (Maybe OnlinePeer))
-> TVar [OnlinePeer]
-> ReaderT PeerManager m (Maybe OnlinePeer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
`findPeer` Peer
p)

managerCheck :: MonadIO m => Peer -> PeerManager -> m ()
managerCheck :: forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerCheck Peer
p PeerManager
mgr =
    Peer -> ManagerMessage
CheckPeer Peer
p ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerConnect :: MonadIO m => SockAddr -> PeerManager -> m ()
managerConnect :: forall (m :: * -> *). MonadIO m => SockAddr -> PeerManager -> m ()
managerConnect SockAddr
sa PeerManager
mgr =
    SockAddr -> ManagerMessage
Connect SockAddr
sa ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerBest :: MonadIO m => BlockHeight -> PeerManager -> m ()
managerBest :: forall (m :: * -> *). MonadIO m => Word32 -> PeerManager -> m ()
managerBest Word32
bh PeerManager
mgr =
    Word32 -> ManagerMessage
ManagerBest Word32
bh ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerVerAck :: MonadIO m => Peer -> PeerManager -> m ()
managerVerAck :: forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerVerAck Peer
p PeerManager
mgr =
    Peer -> ManagerMessage
PeerVerAck Peer
p ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerVersion :: MonadIO m
               => Peer -> Version -> PeerManager -> m ()
managerVersion :: forall (m :: * -> *).
MonadIO m =>
Peer -> Version -> PeerManager -> m ()
managerVersion Peer
p Version
ver PeerManager
mgr =
    Peer -> Version -> ManagerMessage
PeerVersion Peer
p Version
ver ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerPing :: MonadIO m
            => Peer -> Word64 -> PeerManager -> m ()
managerPing :: forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerManager -> m ()
managerPing Peer
p Word64
nonce PeerManager
mgr =
    Peer -> Word64 -> ManagerMessage
PeerPing Peer
p Word64
nonce ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerPong :: MonadIO m
            => Peer -> Word64 -> PeerManager -> m ()
managerPong :: forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerManager -> m ()
managerPong Peer
p Word64
nonce PeerManager
mgr =
    Peer -> Word64 -> ManagerMessage
PeerPong Peer
p Word64
nonce ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerAddrs :: MonadIO m
             => Peer -> [NetworkAddress] -> PeerManager -> m ()
managerAddrs :: forall (m :: * -> *).
MonadIO m =>
Peer -> [NetworkAddress] -> PeerManager -> m ()
managerAddrs Peer
p [NetworkAddress]
addrs PeerManager
mgr =
    Peer -> [NetworkAddress] -> ManagerMessage
PeerAddrs Peer
p [NetworkAddress]
addrs ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

managerTickle :: MonadIO m
              => Peer -> PeerManager -> m ()
managerTickle :: forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerTickle Peer
p PeerManager
mgr =
    Peer -> ManagerMessage
PeerTickle Peer
p ManagerMessage -> Mailbox ManagerMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerManager -> Mailbox ManagerMessage
myMailbox PeerManager
mgr

toHostService :: String -> (Maybe String, Maybe String)
toHostService :: String -> (Maybe String, Maybe String)
toHostService String
str =
    let host :: Maybe String
host = case Maybe (String, String)
m6 of
            Just (String
x, String
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
            Maybe (String, String)
Nothing -> case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
str of
                [] -> Maybe String
forall a. Maybe a
Nothing
                String
xs -> String -> Maybe String
forall a. a -> Maybe a
Just String
xs
        srv :: Maybe String
srv = case Maybe (String, String)
m6 of
            Just (String
_, String
y) -> String -> Maybe String
s String
y
            Maybe (String, String)
Nothing -> String -> Maybe String
s String
str
        s :: String -> Maybe String
s String
xs =
            case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
xs of
                [] -> Maybe String
forall a. Maybe a
Nothing
                Char
_ : String
ys -> String -> Maybe String
forall a. a -> Maybe a
Just String
ys
        m6 :: Maybe (String, String)
m6 = case String
str of
            (Char
x : String
xs)
                | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' -> do
                    Int
i <- Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
']' String
xs
                    (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> String
forall a. [a] -> [a]
tail ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i String
xs
                | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' -> do
                    (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
str, String
"")
            String
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
    in (Maybe String
host, Maybe String
srv)

toSockAddr :: MonadUnliftIO m => Network -> String -> m [SockAddr]
toSockAddr :: forall (m :: * -> *).
MonadUnliftIO m =>
Network -> String -> m [SockAddr]
toSockAddr Network
net String
str = 
    m [SockAddr]
go m [SockAddr] -> (SomeException -> m [SockAddr]) -> m [SockAddr]
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m [SockAddr]
forall (m :: * -> *). Monad m => SomeException -> m [SockAddr]
e
  where
    go :: m [SockAddr]
go = ([AddrInfo] -> [SockAddr]) -> m [AddrInfo] -> m [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress) (m [AddrInfo] -> m [SockAddr]) -> m [AddrInfo] -> m [SockAddr]
forall a b. (a -> b) -> a -> b
$ IO [AddrInfo] -> m [AddrInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [AddrInfo] -> m [AddrInfo]) -> IO [AddrInfo] -> m [AddrInfo]
forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing Maybe String
host Maybe String
srv
    (Maybe String
host, Maybe String
srv) = 
        (Maybe String -> Maybe String)
-> (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe String
forall a. a -> Maybe a
Just (Int -> String
forall a. Show a => a -> String
show (Network -> Int
getDefaultPort Network
net))) ((Maybe String, Maybe String) -> (Maybe String, Maybe String))
-> (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$
        String -> (Maybe String, Maybe String)
toHostService String
str
    e :: Monad m => SomeException -> m [SockAddr]
    e :: forall (m :: * -> *). Monad m => SomeException -> m [SockAddr]
e SomeException
_ = [SockAddr] -> m [SockAddr]
forall (m :: * -> *) a. Monad m => a -> m a
return []

median :: (Ord a, Fractional a) => [a] -> Maybe a
median :: forall a. (Ord a, Fractional a) => [a] -> Maybe a
median [a]
ls
    | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ls =
          Maybe a
forall a. Maybe a
Nothing
    | Int -> Bool
forall a. Integral a => a -> Bool
even ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls) =
          a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ([a] -> a) -> [a] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2) (a -> a) -> ([a] -> a) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([a] -> a) -> ([a] -> [a]) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
2 ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$
          Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
ls'
    | Bool
otherwise =
          a -> Maybe a
forall a. a -> Maybe a
Just ([a]
ls' [a] -> Int -> a
forall a. [a] -> Int -> a
!! ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
  where
    ls' :: [a]
ls' = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
ls

buildVersion
    :: Network
    -> Word64
    -> BlockHeight
    -> NetworkAddress
    -> NetworkAddress
    -> Word64
    -> Version
buildVersion :: Network
-> Word64
-> Word32
-> NetworkAddress
-> NetworkAddress
-> Word64
-> Version
buildVersion Network
net Word64
nonce Word32
height NetworkAddress
loc NetworkAddress
rmt Word64
time =
    Version :: Word32
-> Word64
-> Word64
-> NetworkAddress
-> NetworkAddress
-> Word64
-> VarString
-> Word32
-> Bool
-> Version
Version
        { version :: Word32
version = Word32
myVersion
        , services :: Word64
services = NetworkAddress -> Word64
naServices NetworkAddress
loc
        , timestamp :: Word64
timestamp = Word64
time
        , addrRecv :: NetworkAddress
addrRecv = NetworkAddress
rmt
        , addrSend :: NetworkAddress
addrSend = NetworkAddress
loc
        , verNonce :: Word64
verNonce = Word64
nonce
        , userAgent :: VarString
userAgent = ByteString -> VarString
VarString (Network -> ByteString
getHaskoinUserAgent Network
net)
        , startHeight :: Word32
startHeight = Word32
height
        , relay :: Bool
relay = Bool
True
        }

myVersion :: Word32
myVersion :: Word32
myVersion = Word32
70012