{-# 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
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
(==) = forall a. Eq a => a -> a -> 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 = forall a. Ord a => a -> a -> Ordering
compare 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} = forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
60 (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 <- forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
    let mgr :: Mailbox ManagerMessage
mgr = forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox ManagerMessage
inbox
    forall (m :: * -> *) a.
MonadUnliftIO m =>
Strategy -> (Supervisor -> m a) -> m a
withSupervisor (Listen (Async (), Maybe SomeException) -> Strategy
Notify (forall {mbox :: * -> *}.
OutChan mbox =>
mbox ManagerMessage -> Listen (Async (), Maybe SomeException)
death Mailbox ManagerMessage
mgr)) forall a b. (a -> b) -> a -> b
$ \Supervisor
sup -> do
        TVar Word32
bb <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Word32
0
        TVar (Set SockAddr)
kp <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. Set a
Set.empty
        TVar [OnlinePeer]
ob <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        let rd :: PeerManager
rd = 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 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 forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` mbox ManagerMessage
mgr
    go :: Inbox ManagerMessage -> ReaderT PeerManager m a
go Inbox ManagerMessage
inbox =
        forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
Inbox ManagerMessage -> m ()
peerManager Inbox ManagerMessage
inbox) forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
        forall (m :: * -> *) a.
(MonadUnliftIO m, MonadManager m) =>
m a -> m a
withConnectLoop forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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"
    forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) (mbox :: * -> *) msg a.
(MonadIO m, InChan mbox) =>
mbox msg -> (msg -> Maybe a) -> m a
receiveMatch Inbox ManagerMessage
inb forall a b. (a -> b) -> a -> b
$ \case
        ManagerBest Word32
b -> forall a. a -> Maybe a
Just Word32
b
        ManagerMessage
_             -> forall a. Maybe a
Nothing
    $(logDebugS) Text
"PeerManager" Text
"Starting peer manager actor"
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever m ()
loop
  where
    loop :: m ()
loop = do
        ManagerMessage
m <- forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox ManagerMessage
inb
        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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar Word32
myBestBlock
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ 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 =
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar Word32
myBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO

getNetwork :: MonadManager m => m Network
getNetwork :: forall (m :: * -> *). MonadManager m => m Network
getNetwork =
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Network
peerManagerNetwork 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
    forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadStaticPeers
    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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Network
peerManagerNetwork forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    [String]
xs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> [String]
peerManagerPeers forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 =
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Bool
peerManagerDiscover forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
discover ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
discover forall a b. (a -> b) -> a -> b
$ do
            Network
net <- forall (m :: * -> *). MonadManager m => m Network
getNetwork
            [SockAddr]
ss <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadUnliftIO m =>
Network -> String -> m [SockAddr]
toSockAddr Network
net) (Network -> [String]
getSeeds Network
net)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Int
peerManagerMaxPeers forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
    Int
l <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getConnectedPeers
    $(logInfoS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
        Text
"Peers connected: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
l) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
m)

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

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

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

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

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

managerMessage (PeerPong Peer
p Word64
n) = do
    TVar [OnlinePeer]
b <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    $(logDebugS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
        Text
"Received pong "
        forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Word64
n)
        forall a. Semigroup a => a -> a -> a
<> Text
" from: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    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" forall a b. (a -> b) -> a -> b
$
        Text
"Responding to ping "
        forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Word64
n)
        forall a. Semigroup a => a -> a -> a
<> Text
" from: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Pong -> Message
MPong (Word64 -> Pong
Pong Word64
n) forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p

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

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

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

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

managerMessage (PeerTickle Peer
p) = do
    TVar [OnlinePeer]
b <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> Peer -> (OnlinePeer -> OnlinePeer) -> STM ()
modifyPeer TVar [OnlinePeer]
b Peer
p 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 =
    forall (m :: * -> *). MonadIO m => Peer -> m Bool
getBusy Peer
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> do
            NominalDiffTime
to <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> NominalDiffTime
peerManagerTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            TVar [OnlinePeer]
b <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
            forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe OnlinePeer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just OnlinePeer
o -> do
                    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                    forall {f :: * -> *}. MonadIO f => UTCTime -> OnlinePeer -> f ()
check_conn UTCTime
now OnlinePeer
o
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime -> NominalDiffTime -> OnlinePeer -> Bool
check_tickle UTCTime
now NominalDiffTime
to OnlinePeer
o) (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 forall a. Ord a => a -> a -> Bool
> NominalDiffTime
to
    check_conn :: UTCTime -> OnlinePeer -> f ()
check_conn UTCTime
now OnlinePeer
o =
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` OnlinePeer -> UTCTime
onlinePeerDisconnect OnlinePeer
o forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0) forall a b. (a -> b) -> a -> b
$
        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 ->
                forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
sendPing Peer
p
            Just (UTCTime, Word64)
_ -> do
                $(logWarnS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
                    Text
"Peer ping timeout: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing ->
            $(logWarnS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
            Text
"Will not ping unknown peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Just OnlinePeer
o
            | OnlinePeer -> Bool
onlinePeerConnected OnlinePeer
o -> do
                Word64
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
                UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                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" forall a b. (a -> b) -> a -> b
$
                    Text
"Sending ping " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Word64
n)
                    forall a. Semigroup a => a -> a -> a
<> Text
" to: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                Ping -> Message
MPing (Word64 -> Ping
Ping Word64
n) forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
            | Bool
otherwise -> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Async () -> STM (Maybe OnlinePeer)
findPeerAsync TVar [OnlinePeer]
b Async ()
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> 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
                    forall {m :: * -> *} {a}.
(MonadLogger m, Show a) =>
Peer -> Maybe a -> m ()
log_disconnected Peer
p Maybe SomeException
e
                    forall (m :: * -> *). MonadManager m => PeerEvent -> m ()
managerEvent forall a b. (a -> b) -> a -> b
$ Peer -> PeerEvent
PeerDisconnected Peer
p
                else forall {m :: * -> *} {a}.
(MonadLogger m, Show a) =>
Peer -> Maybe a -> m ()
log_not_connect Peer
p Maybe SomeException
e
            forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> Peer -> STM ()
removePeer TVar [OnlinePeer]
b Peer
p
            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" forall a b. (a -> b) -> a -> b
$
        Text
"Unknown peer died: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (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" forall a b. (a -> b) -> a -> b
$
        Text
"Disconnected peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    log_disconnected Peer
p (Just a
x) =
        $(logErrorS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
        Text
"Peer " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p forall a. Semigroup a => a -> a -> a
<> Text
" died: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (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" forall a b. (a -> b) -> a -> b
$
        Text
"Could not connect to peer " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    log_not_connect Peer
p (Just a
x) =
        $(logErrorS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
        Text
"Could not connect to peer "
        forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p) 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" forall a b. (a -> b) -> a -> b
$
                Text
"Connected to peer " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            forall (m :: * -> *). MonadManager m => PeerEvent -> m ()
managerEvent forall a b. (a -> b) -> a -> b
$ Peer -> PeerEvent
PeerConnected Peer
p
            forall (m :: * -> *). (MonadManager m, MonadLoggerIO m) => m ()
logConnectedPeers
        Just OnlinePeer {onlinePeerConnected :: OnlinePeer -> Bool
onlinePeerConnected = Bool
False} ->
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe OnlinePeer
Nothing ->
            $(logErrorS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
            Text
"Not announcing disconnected peer: "
            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 =
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). (MonadUnliftIO m, MonadManager m) => m ()
loadPeers 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar (Set SockAddr)
knownPeers
        Set SockAddr
ks <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set SockAddr)
b
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set SockAddr
ks
        let xs :: [SockAddr]
xs = forall a. Set a -> [a]
Set.toList Set SockAddr
ks
        Int
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
xs forall a. Num a => a -> a -> a
- Int
1)
        let p :: SockAddr
p = [SockAddr]
xs forall a. [a] -> Int -> a
!! Int
a
        TVar [OnlinePeer]
o <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
        Maybe OnlinePeer
m <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SockAddr)
b forall a b. (a -> b) -> a -> b
$ 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
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
p) (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
os SockAddr
sa) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just OnlinePeer
_ ->
            $(logErrorS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$
            Text
"Attempted to connect to peer twice: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show SockAddr
sa)
        Maybe OnlinePeer
Nothing -> do
            $(logInfoS) Text
"PeerManager" forall a b. (a -> b) -> a -> b
$ Text
"Connecting to " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show SockAddr
sa)
            PeerManagerConfig { peerManagerNetAddr :: PeerManagerConfig -> NetworkAddress
peerManagerNetAddr = NetworkAddress
ad
                              , peerManagerNetwork :: PeerManagerConfig -> Network
peerManagerNetwork = Network
net
                              } <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> PeerManagerConfig
myConfig
            Supervisor
sup <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> Supervisor
mySupervisor
            SockAddr -> WithConnection
conn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> SockAddr -> WithConnection
peerManagerConnect forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Publisher (Peer, Message)
pub <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Publisher (Peer, Message)
peerManagerPub forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Word64
nonce <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
            Word32
bb <- forall (m :: * -> *). MonadManager m => m Word32
getBestBlock
            UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let rmt :: NetworkAddress
rmt = Word64 -> HostAddress -> NetworkAddress
NetworkAddress (forall {a}. Num a => Network -> a
srv Network
net) (SockAddr -> HostAddress
sockToHostAddress SockAddr
sa)
                unix :: Word64
unix = 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 = forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show SockAddr
sa)
            (Inbox PeerMessage
inbox, Mailbox PeerMessage
mailbox) <- forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
            let pc :: PeerConfig
pc = 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 <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
            Peer
p <- forall (m :: * -> *).
MonadIO m =>
PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer PeerConfig
pc TVar Bool
busy Mailbox PeerMessage
mailbox
            Async ()
a <- forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
io ->
                Supervisor
sup forall (m :: * -> *).
MonadIO m =>
Supervisor -> ChildAction -> m (Async ())
`addChild` forall a. m a -> IO a
io (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 forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
            TVar [OnlinePeer]
b <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
            NominalDiffTime
max_life <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> NominalDiffTime
peerManagerMaxLife forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
            Rational
rand <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Num a => a -> a -> a
* forall a. Fractional a => Rational -> a
fromRational Rational
rand
            let dc :: UTCTime
dc = NominalDiffTime
life NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now
            OnlinePeer
_ <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically 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
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    srv :: Network -> a
srv Network
net
        | Network -> Bool
getSegWit Network
net = a
8
        | Bool
otherwise = a
0
    launch :: PeerConfig -> TVar Bool -> Inbox PeerMessage -> Peer -> m ()
launch PeerConfig
pc TVar Bool
busy Inbox PeerMessage
inbox Peer
p =
        forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PeerManager
mgr ->
        forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
SockAddr -> Peer -> PeerManager -> (Async a -> m a) -> m a
withPeerLoop SockAddr
sa Peer
p PeerManager
mgr forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
        forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 =
    forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        let x :: NominalDiffTime
x = PeerManagerConfig -> NominalDiffTime
peerManagerTimeout (PeerManager -> PeerManagerConfig
myConfig PeerManager
mgr)
            y :: Int
y = forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime
x forall a. Num a => a -> a -> a
* NominalDiffTime
1000000)
        Int
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
y forall a. Num a => a -> a -> a
* Int
3 forall a. Integral a => a -> a -> a
`div` Int
4, Int
y)
        forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
r
        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 =
    forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync forall {b}. m b
go forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
    forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
act
  where
    go :: m b
go = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        Int
l <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getOnlinePeers
        Int
x <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (PeerManagerConfig -> Int
peerManagerMaxPeers forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerManager -> PeerManagerConfig
myConfig)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l forall a. Ord a => a -> a -> Bool
< Int
x) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m) =>
m (Maybe SockAddr)
getNewPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\SockAddr
sa -> forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => SockAddr -> PeerManager -> m ()
managerConnect SockAddr
sa)
        Int
delay <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO ( Int
100 forall a. Num a => a -> a -> a
* Int
1000
                      , Int
10 forall a. Num a => a -> a -> a
* Int
500 forall a. Num a => a -> a -> a
* Int
1000 )
        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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar (Set SockAddr)
knownPeers
    TVar [OnlinePeer]
o <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer)
findPeerAddress TVar [OnlinePeer]
o SockAddr
sa forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just OnlinePeer
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe OnlinePeer
Nothing -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SockAddr)
b forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    OnlinePeer
o <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer TVar [OnlinePeer]
b Peer
p
    (UTCTime
time, Word64
old_nonce) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OnlinePeer -> Maybe (UTCTime, Word64)
onlinePeerPing OnlinePeer
o
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word64
nonce forall a. Eq a => a -> a -> Bool
== Word64
old_nonce
    let diff :: NominalDiffTime
diff = UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
time
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
        TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer
            TVar [OnlinePeer]
b
            OnlinePeer
o { onlinePeerPing :: Maybe (UTCTime, Word64)
onlinePeerPing = forall a. Maybe a
Nothing
              , onlinePeerPings :: [NominalDiffTime]
onlinePeerPings = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
11 forall a b. (a -> b) -> a -> b
$ NominalDiffTime
diff 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 forall a b. (a -> b) -> a -> b
$ \OnlinePeer
o -> OnlinePeer
o {onlinePeerPing :: Maybe (UTCTime, Word64)
onlinePeerPing = 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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> Word64
services Version
v forall a. Bits a => a -> a -> a
.&. Word64
nodeNetwork forall a. Eq a => a -> a -> Bool
== Word64
0) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
NotNetworkPeer
    [OnlinePeer]
ops <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar [OnlinePeer]
b
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Version -> Word64
verNonce Version
v forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Word64
onlinePeerNonce) [OnlinePeer]
ops) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerIsMyself
    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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> 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 = forall a. a -> Maybe a
Just Version
v
                      , onlinePeerConnected :: Bool
onlinePeerConnected = OnlinePeer -> Bool
onlinePeerVerAck OnlinePeer
o }
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b OnlinePeer
n
            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 = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    OnlinePeer
o <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT 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 = forall a. Maybe a -> Bool
isJust (OnlinePeer -> Maybe Version
onlinePeerVersion OnlinePeer
o) }
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b OnlinePeer
n
    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
             { onlinePeerAddress :: SockAddr
onlinePeerAddress = SockAddr
addr
             , onlinePeerVerAck :: Bool
onlinePeerVerAck = Bool
False
             , onlinePeerConnected :: Bool
onlinePeerConnected = Bool
False
             , onlinePeerVersion :: Maybe Version
onlinePeerVersion = 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 = 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
    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 =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Peer
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Peer
onlinePeerMailbox)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [OnlinePeer]
b forall a b. (a -> b) -> a -> b
$ \[OnlinePeer]
x -> forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ OnlinePeer
o 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe OnlinePeer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just OnlinePeer
o  -> TVar [OnlinePeer] -> OnlinePeer -> STM ()
insertPeer TVar [OnlinePeer]
b 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 =
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [OnlinePeer]
b forall a b. (a -> b) -> a -> b
$
    forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Peer
p) 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 =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Async ()
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> Async ()
onlinePeerAsync)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== SockAddr
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlinePeer -> SockAddr
onlinePeerAddress)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT 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 =
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PeerManager -> TVar [OnlinePeer]
onlinePeers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically 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 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 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 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 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 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 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 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 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 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
_) -> forall a. a -> Maybe a
Just String
x
            Maybe (String, String)
Nothing -> case forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
':') String
str of
                [] -> forall a. Maybe a
Nothing
                String
xs -> 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 forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
':') String
xs of
                [] -> forall a. Maybe a
Nothing
                Char
_ : String
ys -> forall a. a -> Maybe a
Just String
ys
        m6 :: Maybe (String, String)
m6 = case String
str of
            (Char
x : String
xs)
                | Char
x forall a. Eq a => a -> a -> Bool
== Char
'[' -> do
                    Int
i <- forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
']' String
xs
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
splitAt Int
i String
xs
                | Char
x forall a. Eq a => a -> a -> Bool
== Char
':' -> do
                    forall (m :: * -> *) a. Monad m => a -> m a
return (String
str, 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 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *). Monad m => SomeException -> m [SockAddr]
e
  where
    go :: m [SockAddr]
go = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo forall a. Maybe a
Nothing Maybe String
host Maybe String
srv
    (Maybe String
host, Maybe String
srv) = 
        forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (forall a. Show a => a -> String
show (Network -> Int
getDefaultPort Network
net))) 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
_ = 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ls =
          forall a. Maybe a
Nothing
    | forall a. Integral a => a -> Bool
even (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls) =
          forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ a
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
2 forall a b. (a -> b) -> a -> b
$
          forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls forall a. Integral a => a -> a -> a
`div` Int
2 forall a. Num a => a -> a -> a
- Int
1) [a]
ls'
    | Bool
otherwise =
          forall a. a -> Maybe a
Just ([a]
ls' forall a. [a] -> Int -> a
!! (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls forall a. Integral a => a -> a -> a
`div` Int
2))
  where
    ls' :: [a]
ls' = 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
        { 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