{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoFieldSelectors #-}

module Haskoin.Node.PeerMgr
  ( PeerMgrConfig (..),
    PeerEvent (..),
    OnlinePeer (..),
    PeerMgr,
    withPeerMgr,
    peerMgrBest,
    peerMgrVersion,
    peerMgrPing,
    peerMgrPong,
    peerMgrAddrs,
    peerMgrVerAck,
    peerMgrTickle,
    getPeers,
    getOnlinePeer,
    buildVersion,
    myVersion,
    toSockAddr,
    toHostService,
  )
where

import Control.Applicative ((<|>))
import Control.Arrow
import Control.Monad
  ( forM_,
    forever,
    guard,
    unless,
    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 (dropWhileEnd, elemIndex, find, nub, sort)
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)

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

data PeerMgrConfig = PeerMgrConfig
  { PeerMgrConfig -> Int
maxPeers :: !Int,
    PeerMgrConfig -> [String]
peers :: ![String],
    PeerMgrConfig -> Bool
discover :: !Bool,
    PeerMgrConfig -> NetworkAddress
address :: !NetworkAddress,
    PeerMgrConfig -> Network
net :: !Network,
    PeerMgrConfig -> Publisher PeerEvent
pub :: !(Publisher PeerEvent),
    PeerMgrConfig -> NominalDiffTime
timeout :: !NominalDiffTime,
    PeerMgrConfig -> NominalDiffTime
maxPeerLife :: !NominalDiffTime,
    PeerMgrConfig -> SockAddr -> WithConnection
connect :: !(SockAddr -> WithConnection)
  }

data PeerMgr = PeerMgr
  { PeerMgr -> PeerMgrConfig
config :: !PeerMgrConfig,
    PeerMgr -> Supervisor
supervisor :: !Supervisor,
    PeerMgr -> Mailbox PeerMgrMessage
mailbox :: !(Mailbox PeerMgrMessage),
    PeerMgr -> TVar Word32
best :: !(TVar BlockHeight),
    PeerMgr -> TVar (Set SockAddr)
addresses :: !(TVar (Set SockAddr)),
    PeerMgr -> TVar [OnlinePeer]
peers :: !(TVar [OnlinePeer])
  }

data PeerMgrMessage
  = 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
address :: !SockAddr,
    OnlinePeer -> Bool
verack :: !Bool,
    OnlinePeer -> Bool
online :: !Bool,
    OnlinePeer -> Maybe Version
version :: !(Maybe Version),
    OnlinePeer -> Async ()
async :: !(Async ()),
    OnlinePeer -> Peer
mailbox :: !Peer,
    OnlinePeer -> Word64
nonce :: !Word64,
    OnlinePeer -> Maybe (UTCTime, Word64)
ping :: !(Maybe (UTCTime, Word64)),
    OnlinePeer -> [NominalDiffTime]
pings :: ![NominalDiffTime],
    OnlinePeer -> UTCTime
connected :: !UTCTime,
    OnlinePeer -> UTCTime
tickled :: !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 {$sel:mailbox:OnlinePeer :: OnlinePeer -> Peer
mailbox = 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 {$sel:pings:OnlinePeer :: OnlinePeer -> [NominalDiffTime]
pings = [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)

withPeerMgr ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  PeerMgrConfig ->
  (PeerMgr -> m a) ->
  m a
withPeerMgr :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerMgrConfig -> (PeerMgr -> m a) -> m a
withPeerMgr PeerMgrConfig
cfg PeerMgr -> m a
action = do
  Inbox PeerMgrMessage
inbox <- m (Inbox PeerMgrMessage)
forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
  let mgr :: Mailbox PeerMgrMessage
mgr = Inbox PeerMgrMessage -> Mailbox PeerMgrMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox PeerMgrMessage
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 PeerMgrMessage -> Listen (Async (), Maybe SomeException)
forall {mbox :: * -> *}.
OutChan mbox =>
mbox PeerMgrMessage -> Listen (Async (), Maybe SomeException)
death Mailbox PeerMgrMessage
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 []
    ReaderT PeerMgr m a -> PeerMgr -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
      (Inbox PeerMgrMessage -> ReaderT PeerMgr m a
go Inbox PeerMgrMessage
inbox)
      PeerMgr
        { $sel:config:PeerMgr :: PeerMgrConfig
config = PeerMgrConfig
cfg,
          $sel:supervisor:PeerMgr :: Supervisor
supervisor = Supervisor
sup,
          $sel:mailbox:PeerMgr :: Mailbox PeerMgrMessage
mailbox = Mailbox PeerMgrMessage
mgr,
          $sel:best:PeerMgr :: TVar Word32
best = TVar Word32
bb,
          $sel:addresses:PeerMgr :: TVar (Set SockAddr)
addresses = TVar (Set SockAddr)
kp,
          $sel:peers:PeerMgr :: TVar [OnlinePeer]
peers = TVar [OnlinePeer]
ob
        }
  where
    death :: mbox PeerMgrMessage -> Listen (Async (), Maybe SomeException)
death mbox PeerMgrMessage
mgr (Async ()
a, Maybe SomeException
ex) = Async () -> Maybe SomeException -> PeerMgrMessage
PeerDied Async ()
a Maybe SomeException
ex PeerMgrMessage -> mbox PeerMgrMessage -> STM ()
forall msg. msg -> mbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` mbox PeerMgrMessage
mgr
    go :: Inbox PeerMgrMessage -> ReaderT PeerMgr m a
go Inbox PeerMgrMessage
inbox =
      ReaderT PeerMgr m ()
-> (Async () -> ReaderT PeerMgr m a) -> ReaderT PeerMgr m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Inbox PeerMgrMessage -> ReaderT PeerMgr m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
Inbox PeerMgrMessage -> m ()
peerManager Inbox PeerMgrMessage
inbox) ((Async () -> ReaderT PeerMgr m a) -> ReaderT PeerMgr m a)
-> (Async () -> ReaderT PeerMgr m a) -> ReaderT PeerMgr m a
forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
        ReaderT PeerMgr m a -> ReaderT PeerMgr m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadManager m) =>
m a -> m a
withConnectLoop (ReaderT PeerMgr m a -> ReaderT PeerMgr m a)
-> ReaderT PeerMgr m a -> ReaderT PeerMgr m a
forall a b. (a -> b) -> a -> b
$
          Async () -> ReaderT PeerMgr m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a ReaderT PeerMgr m () -> ReaderT PeerMgr m a -> ReaderT PeerMgr m a
forall a b.
ReaderT PeerMgr m a -> ReaderT PeerMgr m b -> ReaderT PeerMgr m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (PeerMgr -> m a) -> ReaderT PeerMgr m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT PeerMgr -> m a
action

peerManager ::
  ( MonadUnliftIO m,
    MonadManager m,
    MonadLoggerIO m
  ) =>
  Inbox PeerMgrMessage ->
  m ()
peerManager :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
Inbox PeerMgrMessage -> m ()
peerManager Inbox PeerMgrMessage
inb = do
  $(logDebugS) Text
"PeerMgr" Text
"Awaiting best block"
  Word32 -> m ()
forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock (Word32 -> m ())
-> ((PeerMgrMessage -> Maybe Word32) -> m Word32)
-> (PeerMgrMessage -> Maybe Word32)
-> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Inbox PeerMgrMessage
-> (PeerMgrMessage -> Maybe Word32) -> m Word32
forall (m :: * -> *) (mbox :: * -> *) msg a.
(MonadIO m, InChan mbox) =>
mbox msg -> (msg -> Maybe a) -> m a
receiveMatch Inbox PeerMgrMessage
inb ((PeerMgrMessage -> Maybe Word32) -> m ())
-> (PeerMgrMessage -> 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
    PeerMgrMessage
_ -> Maybe Word32
forall a. Maybe a
Nothing
  $(logDebugS) Text
"PeerMgr" Text
"Starting peer manager actor"
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    $(logDebugS) Text
"PeerMgr" Text
"Awaiting event..."
    PeerMgrMessage -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
PeerMgrMessage -> m ()
dispatch (PeerMgrMessage -> m ()) -> m PeerMgrMessage -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Inbox PeerMgrMessage -> m PeerMgrMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox PeerMgrMessage
inb

putBestBlock :: (MonadManager m) => BlockHeight -> m ()
putBestBlock :: forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock Word32
bb = do
  TVar Word32
b <- (PeerMgr -> TVar Word32) -> m (TVar Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.best)
  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 =
  (PeerMgr -> TVar Word32) -> m (TVar Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.best) m (TVar Word32) -> (TVar Word32 -> m Word32) -> m Word32
forall a b. m a -> (a -> m b) -> m b
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 =
  (PeerMgr -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.net)

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 <- (PeerMgr -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.net)
  [String]
xs <- (PeerMgr -> [String]) -> m [String]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.peers)
  (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 =
  (PeerMgr -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.discover) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Network -> String -> m [SockAddr]
forall (m :: * -> *).
MonadUnliftIO m =>
Network -> String -> m [SockAddr]
toSockAddr Network
net) Network
net.seeds
      (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 <- (PeerMgr -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.maxPeers)
  Int
l <- [OnlinePeer] -> Int
forall a. [a] -> 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
"PeerMgr" (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 =
  (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers) m (TVar [OnlinePeer])
-> (TVar [OnlinePeer] -> m [OnlinePeer]) -> m [OnlinePeer]
forall a b. m a -> (a -> m b) -> m b
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 (.online) ([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
=<< (PeerMgr -> Publisher PeerEvent) -> m (Publisher PeerEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.pub)

dispatch ::
  ( MonadUnliftIO m,
    MonadManager m,
    MonadLoggerIO m
  ) =>
  PeerMgrMessage ->
  m ()
dispatch :: forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
PeerMgrMessage -> m ()
dispatch (PeerVersion Peer
p Version
v) = do
  $(logDebugS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Received peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Version -> String
forall a. Show a => a -> String
show Version
v)
  TVar [OnlinePeer]
b <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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
o.online (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
"PeerMgr" (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
p.label
      Message
MVerAck Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
    Left PeerException
x -> do
      $(logErrorS) Text
"PeerMgr" (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
p.label
          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
dispatch (PeerVerAck Peer
p) = do
  TVar [OnlinePeer]
b <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just OnlinePeer
o -> do
      $(logDebugS) Text
"PeerMgr" (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
p.label
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when OnlinePeer
o.online (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
"PeerMgr" (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
p.label
      PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
UnknownPeer Peer
p
dispatch (PeerAddrs Peer
p [NetworkAddress]
nas) = do
  $(logDebugS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Received addresses from peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
  Bool
discover <- (PeerMgr -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.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
    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
. (.address)) [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
"PeerMgr" (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 a. [a] -> 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
p.label
      SockAddr -> m ()
forall (m :: * -> *).
(MonadIO m, MonadManager m) =>
SockAddr -> m ()
newPeer SockAddr
a
dispatch (PeerPong Peer
p Word64
n) = do
  TVar [OnlinePeer]
b <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  $(logDebugS) Text
"PeerMgr" (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
p.label
  UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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)
dispatch (PeerPing Peer
p Word64
n) = do
  $(logDebugS) Text
"PeerMgr" (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
p.label
  Pong -> Message
MPong (Word64 -> Pong
Pong Word64
n) Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
dispatch (ManagerBest Word32
h) = do
  $(logDebugS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Setting best block to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word32 -> String
forall a. Show a => a -> String
show Word32
h)
  Word32 -> m ()
forall (m :: * -> *). MonadManager m => Word32 -> m ()
putBestBlock Word32
h
dispatch (Connect SockAddr
sa) = do
  SockAddr -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadManager m, MonadLoggerIO m) =>
SockAddr -> m ()
connectPeer SockAddr
sa
dispatch (PeerDied Async ()
a Maybe SomeException
e) = do
  Async () -> Maybe SomeException -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Async () -> Maybe SomeException -> m ()
processPeerOffline Async ()
a Maybe SomeException
e
dispatch (CheckPeer Peer
p) = do
  $(logDebugS) Text
"PeerManager" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Housekeeping for peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
  Peer -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
checkPeer Peer
p
dispatch (PeerTickle Peer
p) = do
  $(logDebugS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Tickled peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
  TVar [OnlinePeer]
b <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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 {tickled = now}

checkPeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m ()
checkPeer :: forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
checkPeer Peer
p = do
  Bool
busy <- Peer -> m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
getBusy Peer
p
  TVar [OnlinePeer]
b <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  Maybe OnlinePeer
mp <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers) m (TVar [OnlinePeer])
-> (TVar [OnlinePeer] -> m (Maybe OnlinePeer))
-> m (Maybe OnlinePeer)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe OnlinePeer) -> m (Maybe OnlinePeer))
-> (TVar [OnlinePeer] -> STM (Maybe OnlinePeer))
-> TVar [OnlinePeer]
-> m (Maybe OnlinePeer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer))
-> Peer -> TVar [OnlinePeer] -> STM (Maybe OnlinePeer)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer)
findPeer Peer
p
  case Maybe OnlinePeer
mp of
    Maybe OnlinePeer
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just OnlinePeer
o ->
      IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime m UTCTime -> (UTCTime -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UTCTime
now -> do
        NominalDiffTime
maxLife <- (PeerMgr -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.maxPeerLife)
        let disconnect :: UTCTime
disconnect = NominalDiffTime
maxLife NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` OnlinePeer
o.connected
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
disconnect) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          $(logErrorS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Disconnecting old peer "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" online since "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (UTCTime -> String
forall a. Show a => a -> String
show OnlinePeer
o.connected)
          PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTooOld Peer
p
        NominalDiffTime
timeout <- (PeerMgr -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.timeout)
        let pingTime :: UTCTime
pingTime = NominalDiffTime
timeout NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` OnlinePeer
o.tickled
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
pingTime) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          case OnlinePeer
o.ping of
            Maybe (UTCTime, Word64)
Nothing ->
              Peer -> m ()
forall (m :: * -> *).
(MonadManager m, MonadLoggerIO m) =>
Peer -> m ()
sendPing Peer
p
            Just (UTCTime, Word64)
_ -> do
              $(logWarnS) Text
"PeerMgr" (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
p.label
              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 <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe OnlinePeer
Nothing ->
      $(logWarnS) Text
"PeerMgr" (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
p.label
    Just OnlinePeer
o
      | OnlinePeer
o.online -> do
          Word64
n <- IO Word64 -> m Word64
forall a. IO a -> m a
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 a. IO a -> m a
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
p.label
          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 a. a -> m a
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 <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. m a -> (a -> m b) -> m b
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
o.mailbox
      if OnlinePeer
o.online
        then do
          Peer -> Maybe SomeException -> m ()
forall {m :: * -> *} {r} {a}.
(MonadLogger m, HasField "label" r Text, Show a) =>
r -> 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 :: * -> *} {r} {a}.
(MonadLogger m, HasField "label" r Text, Show a) =>
r -> 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
"PeerMgr"
        Text
"Disconnected unknown peer"
    log_unknown (Just a
x) =
      $(logErrorS) Text
"PeerMgr" (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 :: r -> Maybe a -> m ()
log_disconnected r
p Maybe a
Nothing =
      $(logWarnS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Disconnected peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> r
p.label
    log_disconnected r
p (Just a
x) =
      $(logErrorS) Text
"PeerMgr" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> r
p.label 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 :: r -> Maybe a -> m ()
log_not_connect r
p Maybe a
Nothing =
      $(logWarnS) Text
"PeerMgr" (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
<> r
p.label
    log_not_connect r
p (Just a
x) =
      $(logErrorS) Text
"PeerMgr" (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
<> r
p.label
          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 <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just OnlinePeer {$sel:online:OnlinePeer :: OnlinePeer -> Bool
online = Bool
True} -> do
      $(logInfoS) Text
"PeerMgr" (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
p.label
      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 {$sel:online:OnlinePeer :: OnlinePeer -> Bool
online = Bool
False} ->
      () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe OnlinePeer
Nothing ->
      $(logErrorS) Text
"PeerMgr" (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
p.label

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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 a b. MaybeT m a -> MaybeT m b -> MaybeT m b
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 <- (PeerMgr -> TVar (Set SockAddr)) -> MaybeT m (TVar (Set SockAddr))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.addresses)
      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 a. IO a -> MaybeT m a
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 a. [a] -> 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. HasCallStack => [a] -> Int -> a
!! Int
a
      TVar [OnlinePeer]
o <- (PeerMgr -> TVar [OnlinePeer]) -> MaybeT m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
      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 a. a -> MaybeT m a
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 <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just OnlinePeer
_ ->
      $(logErrorS) Text
"PeerMgr" (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
"PeerMgr" (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)
      PeerMgrConfig
        { $sel:address:PeerMgrConfig :: PeerMgrConfig -> NetworkAddress
address = NetworkAddress
ad,
          $sel:net:PeerMgrConfig :: PeerMgrConfig -> Network
net = Network
net
        } <-
        (PeerMgr -> PeerMgrConfig) -> m PeerMgrConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config)
      Supervisor
sup <- (PeerMgr -> Supervisor) -> m Supervisor
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.supervisor)
      SockAddr -> WithConnection
conn <- (PeerMgr -> SockAddr -> WithConnection)
-> m (SockAddr -> WithConnection)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.connect)
      Publisher PeerEvent
pub <- (PeerMgr -> Publisher PeerEvent) -> m (Publisher PeerEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.pub)
      Word64
nonce <- IO Word64 -> m Word64
forall a. IO a -> m a
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let rmt :: NetworkAddress
rmt = Word64 -> HostAddress -> NetworkAddress
NetworkAddress (Network -> Word64
forall {r} {a}. (HasField "segWit" r Bool, Num a) => r -> a
srv Network
net) (SockAddr -> HostAddress
sockToHostAddress SockAddr
sa)
          unix :: Word64
unix = NominalDiffTime -> Word64
forall b. Integral b => NominalDiffTime -> b
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
              { $sel:pub:PeerConfig :: Publisher PeerEvent
pub = Publisher PeerEvent
pub,
                $sel:net:PeerConfig :: Network
net = Network
net,
                $sel:label:PeerConfig :: Text
label = Text
text,
                $sel:connect:PeerConfig :: WithConnection
connect = 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 b. ((forall a. m a -> IO a) -> IO b) -> m b
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 PeerMgr 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 <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
      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] -> OnlinePeer -> STM ()
insertPeer
          TVar [OnlinePeer]
b
          OnlinePeer
            { $sel:address:OnlinePeer :: SockAddr
address = SockAddr
sa,
              $sel:verack:OnlinePeer :: Bool
verack = Bool
False,
              $sel:online:OnlinePeer :: Bool
online = Bool
False,
              $sel:version:OnlinePeer :: Maybe Version
version = Maybe Version
forall a. Maybe a
Nothing,
              $sel:async:OnlinePeer :: Async ()
async = Async ()
a,
              $sel:mailbox:OnlinePeer :: Peer
mailbox = Peer
p,
              $sel:nonce:OnlinePeer :: Word64
nonce = Word64
nonce,
              $sel:pings:OnlinePeer :: [NominalDiffTime]
pings = [],
              $sel:ping:OnlinePeer :: Maybe (UTCTime, Word64)
ping = Maybe (UTCTime, Word64)
forall a. Maybe a
Nothing,
              $sel:connected:OnlinePeer :: UTCTime
connected = UTCTime
now,
              $sel:tickled:OnlinePeer :: UTCTime
tickled = UTCTime
now
            }
  where
    srv :: r -> a
srv r
net
      | r
net.segWit = 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 =
      m PeerMgr
forall r (m :: * -> *). MonadReader r m => m r
ask m PeerMgr -> (PeerMgr -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PeerMgr
mgr ->
        SockAddr -> Peer -> PeerMgr -> (Async () -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
SockAddr -> Peer -> PeerMgr -> (Async a -> m a) -> m a
withPeerLoop SockAddr
sa Peer
p PeerMgr
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 a b. m a -> m b -> m b
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 ->
  PeerMgr ->
  (Async a -> m a) ->
  m a
withPeerLoop :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
SockAddr -> Peer -> PeerMgr -> (Async a -> m a) -> m a
withPeerLoop SockAddr
_ Peer
p PeerMgr
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 = PeerMgr
mgr.config.timeout
        y :: Int
y = NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
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 a. IO a -> m a
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 -> PeerMgr -> m ()
forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
managerCheck Peer
p PeerMgr
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 a b. m a -> m b -> m b
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 a. [a] -> 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 <- (PeerMgr -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.maxPeers)
      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 a b. m a -> (a -> m b) -> m b
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 PeerMgr
forall r (m :: * -> *). MonadReader r m => m r
ask m PeerMgr -> (PeerMgr -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SockAddr -> PeerMgr -> m ()
forall (m :: * -> *). MonadIO m => SockAddr -> PeerMgr -> m ()
managerConnect SockAddr
sa)
      Int
delay <-
        IO Int -> m Int
forall a. IO a -> m a
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 <- (PeerMgr -> TVar (Set SockAddr)) -> m (TVar (Set SockAddr))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.addresses)
  TVar [OnlinePeer]
o <- (PeerMgr -> TVar [OnlinePeer]) -> m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers)
  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 a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just OnlinePeer
_ -> () -> STM ()
forall a. a -> STM a
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 (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 (Maybe (UTCTime, Word64) -> STM (Maybe (UTCTime, Word64))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return OnlinePeer
o.ping)
  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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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
        { ping = Nothing,
          pings = sort $ take 11 $ diff : o.pings
        }

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 {ping = Just (now, 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
v.services 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 a. PeerException -> ExceptT PeerException STM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
NotNetworkPeer
  [OnlinePeer]
ops <- STM [OnlinePeer] -> ExceptT PeerException STM [OnlinePeer]
forall (m :: * -> *) a. Monad m => m a -> ExceptT PeerException m a
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
v.nonce 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
. (.nonce)) [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 a. PeerException -> ExceptT PeerException STM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerIsMyself
  STM (Maybe OnlinePeer)
-> ExceptT PeerException STM (Maybe OnlinePeer)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PeerException m a
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 a b.
ExceptT PeerException STM a
-> (a -> ExceptT PeerException STM b)
-> ExceptT PeerException STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe OnlinePeer
Nothing -> PeerException -> ExceptT PeerException STM OnlinePeer
forall a. PeerException -> ExceptT PeerException STM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
UnknownPeer
    Just OnlinePeer
o -> do
      let n :: OnlinePeer
n =
            OnlinePeer
o
              { version = Just v,
                online = o.verack
              }
      STM () -> ExceptT PeerException STM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PeerException m a
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 a. a -> ExceptT PeerException STM a
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
          { verack = True,
            online = isJust o.version
          }
  STM () -> MaybeT STM ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 a. a -> MaybeT STM a
forall (m :: * -> *) a. Monad m => a -> m a
return OnlinePeer
n

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
. (.mailbox))
    ([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 a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe OnlinePeer
Nothing -> () -> STM ()
forall a. a -> STM a
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
. (.mailbox))

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
. (.async))
    ([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
. (.address))
    ([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) => PeerMgr -> m [OnlinePeer]
getPeers :: forall (m :: * -> *). MonadIO m => PeerMgr -> m [OnlinePeer]
getPeers = ReaderT PeerMgr m [OnlinePeer] -> PeerMgr -> m [OnlinePeer]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PeerMgr m [OnlinePeer]
forall (m :: * -> *). MonadManager m => m [OnlinePeer]
getConnectedPeers

getOnlinePeer ::
  (MonadIO m) =>
  Peer ->
  PeerMgr ->
  m (Maybe OnlinePeer)
getOnlinePeer :: forall (m :: * -> *).
MonadIO m =>
Peer -> PeerMgr -> m (Maybe OnlinePeer)
getOnlinePeer Peer
p =
  ReaderT PeerMgr m (Maybe OnlinePeer)
-> PeerMgr -> m (Maybe OnlinePeer)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT PeerMgr m (Maybe OnlinePeer)
 -> PeerMgr -> m (Maybe OnlinePeer))
-> ReaderT PeerMgr m (Maybe OnlinePeer)
-> PeerMgr
-> m (Maybe OnlinePeer)
forall a b. (a -> b) -> a -> b
$ (PeerMgr -> TVar [OnlinePeer])
-> ReaderT PeerMgr m (TVar [OnlinePeer])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peers) ReaderT PeerMgr m (TVar [OnlinePeer])
-> (TVar [OnlinePeer] -> ReaderT PeerMgr m (Maybe OnlinePeer))
-> ReaderT PeerMgr m (Maybe OnlinePeer)
forall a b.
ReaderT PeerMgr m a
-> (a -> ReaderT PeerMgr m b) -> ReaderT PeerMgr m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (Maybe OnlinePeer) -> ReaderT PeerMgr m (Maybe OnlinePeer)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe OnlinePeer) -> ReaderT PeerMgr m (Maybe OnlinePeer))
-> (TVar [OnlinePeer] -> STM (Maybe OnlinePeer))
-> TVar [OnlinePeer]
-> ReaderT PeerMgr 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 -> PeerMgr -> m ()
managerCheck :: forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
managerCheck Peer
p PeerMgr
mgr =
  Peer -> PeerMgrMessage
CheckPeer Peer
p PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

managerConnect :: (MonadIO m) => SockAddr -> PeerMgr -> m ()
managerConnect :: forall (m :: * -> *). MonadIO m => SockAddr -> PeerMgr -> m ()
managerConnect SockAddr
sa PeerMgr
mgr =
  SockAddr -> PeerMgrMessage
Connect SockAddr
sa PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrBest :: (MonadIO m) => BlockHeight -> PeerMgr -> m ()
peerMgrBest :: forall (m :: * -> *). MonadIO m => Word32 -> PeerMgr -> m ()
peerMgrBest Word32
bh PeerMgr
mgr =
  Word32 -> PeerMgrMessage
ManagerBest Word32
bh PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrVerAck :: (MonadIO m) => Peer -> PeerMgr -> m ()
peerMgrVerAck :: forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
peerMgrVerAck Peer
p PeerMgr
mgr =
  Peer -> PeerMgrMessage
PeerVerAck Peer
p PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrVersion ::
  (MonadIO m) =>
  Peer ->
  Version ->
  PeerMgr ->
  m ()
peerMgrVersion :: forall (m :: * -> *).
MonadIO m =>
Peer -> Version -> PeerMgr -> m ()
peerMgrVersion Peer
p Version
ver PeerMgr
mgr =
  Peer -> Version -> PeerMgrMessage
PeerVersion Peer
p Version
ver PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrPing ::
  (MonadIO m) =>
  Peer ->
  Word64 ->
  PeerMgr ->
  m ()
peerMgrPing :: forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerMgr -> m ()
peerMgrPing Peer
p Word64
nonce PeerMgr
mgr =
  Peer -> Word64 -> PeerMgrMessage
PeerPing Peer
p Word64
nonce PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrPong ::
  (MonadIO m) =>
  Peer ->
  Word64 ->
  PeerMgr ->
  m ()
peerMgrPong :: forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerMgr -> m ()
peerMgrPong Peer
p Word64
nonce PeerMgr
mgr =
  Peer -> Word64 -> PeerMgrMessage
PeerPong Peer
p Word64
nonce PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrAddrs ::
  (MonadIO m) =>
  Peer ->
  [NetworkAddress] ->
  PeerMgr ->
  m ()
peerMgrAddrs :: forall (m :: * -> *).
MonadIO m =>
Peer -> [NetworkAddress] -> PeerMgr -> m ()
peerMgrAddrs Peer
p [NetworkAddress]
addrs PeerMgr
mgr =
  Peer -> [NetworkAddress] -> PeerMgrMessage
PeerAddrs Peer
p [NetworkAddress]
addrs PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

peerMgrTickle ::
  (MonadIO m) =>
  Peer ->
  PeerMgr ->
  m ()
peerMgrTickle :: forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
peerMgrTickle Peer
p PeerMgr
mgr =
  Peer -> PeerMgrMessage
PeerTickle Peer
p PeerMgrMessage -> Mailbox PeerMgrMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` PeerMgr
mgr.mailbox

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 a. a -> Maybe a
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 b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> String
forall a. HasCallStack => [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 a. a -> Maybe a
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 a b. (a -> b) -> m a -> m b
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 a. IO a -> m a
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 b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
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
net.defaultPort)) ((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 a. a -> m a
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 a. [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 a. [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 a. Num a => [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 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 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. HasCallStack => [a] -> Int -> a
!! ([a] -> Int
forall 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
    { $sel:version:Version :: Word32
version = Word32
myVersion,
      $sel:services:Version :: Word64
services = NetworkAddress
loc.services,
      $sel:timestamp:Version :: Word64
timestamp = Word64
time,
      $sel:addrRecv:Version :: NetworkAddress
addrRecv = NetworkAddress
rmt,
      $sel:addrSend:Version :: NetworkAddress
addrSend = NetworkAddress
loc,
      $sel:nonce:Version :: Word64
nonce = Word64
nonce,
      $sel:userAgent:Version :: VarString
userAgent = ByteString -> VarString
VarString Network
net.userAgent,
      $sel:startHeight:Version :: Word32
startHeight = Word32
height,
      $sel:relay:Version :: Bool
relay = Bool
True
    }

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