{-# 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 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