{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeFamilies          #-}
module Haskoin.Node.Peer
    ( PeerConfig(..)
    , Conduits(..)
    , PeerException(..)
    , WithConnection
    , Peer
    , peer
    , wrapPeer
    , peerPublisher
    , peerText
    , sendMessage
    , killPeer
    , getBlocks
    , getTxs
    , getData
    , pingPeer
    , getBusy
    , setBusy
    , setFree
    ) where

import           Conduit                   (ConduitT, Void, awaitForever, foldC,
                                            mapM_C, runConduit, takeCE,
                                            transPipe, yield, (.|))
import           Control.Monad             (forever, join, when)
import           Control.Monad.Logger      (MonadLoggerIO, logErrorS)
import           Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import           Data.ByteString           (ByteString)
import qualified Data.ByteString           as B
import           Data.Function             (on)
import           Data.List                 (union)
import           Data.Maybe                (isJust)
import           Data.Serialize            (decode, runGet, runPut)
import           Data.String.Conversions   (cs)
import           Data.Text                 (Text)
import           Data.Word                 (Word32)
import           Haskoin                   (Block (..), BlockHash (..),
                                            GetData (..), InvType (..),
                                            InvVector (..), Message (..),
                                            MessageCommand (..),
                                            MessageHeader (..), Network (..),
                                            NotFound (..), Ping (..), Pong (..),
                                            Tx, TxHash (..), commandToString,
                                            encodeHex, getMessage, headerHash,
                                            putMessage, txHash)
import           NQE                       (Inbox, Mailbox, Publisher,
                                            inboxToMailbox, publish, receive,
                                            receiveMatchS, send,
                                            withSubscription)
import           System.Random             (randomIO)
import           UnliftIO                  (Exception, MonadIO, MonadUnliftIO,
                                            TVar, atomically, liftIO, link,
                                            readTVar, readTVarIO, throwIO,
                                            timeout, withAsync, withRunInIO,
                                            writeTVar)

data Conduits =
    Conduits
        { Conduits -> ConduitT () ByteString IO ()
inboundConduit  :: ConduitT () ByteString IO ()
        , Conduits -> ConduitT ByteString Void IO ()
outboundConduit :: ConduitT ByteString Void IO ()
        }

type WithConnection = (Conduits -> IO ()) -> IO ()

data PeerConfig = PeerConfig
    { PeerConfig -> Publisher (Peer, Message)
peerConfPub     :: !(Publisher (Peer, Message))
    , PeerConfig -> Network
peerConfNetwork :: !Network
    , PeerConfig -> Text
peerConfText    :: !Text
    , PeerConfig -> WithConnection
peerConfConnect :: !WithConnection
    }

data PeerException
    = PeerMisbehaving !String
    | DuplicateVersion
    | DecodeHeaderError
    | CannotDecodePayload !MessageCommand
    | PeerIsMyself
    | PayloadTooLarge !Word32
    | PeerAddressInvalid
    | PeerSentBadHeaders
    | NotNetworkPeer
    | PeerNoSegWit
    | PeerTimeout
    | UnknownPeer
    | PeerTooOld
    | EmptyHeader
    deriving PeerException -> PeerException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeerException -> PeerException -> Bool
$c/= :: PeerException -> PeerException -> Bool
== :: PeerException -> PeerException -> Bool
$c== :: PeerException -> PeerException -> Bool
Eq

instance Show PeerException where
    show :: PeerException -> String
show (PeerMisbehaving String
s)     = String
"Peer misbehaving: " forall a. Semigroup a => a -> a -> a
<> String
s
    show PeerException
DuplicateVersion        = String
"Duplicate version"
    show PeerException
DecodeHeaderError       = String
"Error decoding header"
    show (CannotDecodePayload MessageCommand
c) = String
"Cannot decode payload: " forall a. Semigroup a => a -> a -> a
<>
                                   forall a b. ConvertibleStrings a b => a -> b
cs (MessageCommand -> ByteString
commandToString MessageCommand
c)
    show PeerException
PeerIsMyself            = String
"Peer is myself"
    show (PayloadTooLarge Word32
s)     = String
"Payload too large: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word32
s
    show PeerException
PeerAddressInvalid      = String
"Peer address invalid"
    show PeerException
PeerSentBadHeaders      = String
"Peer sent bad headers"
    show PeerException
NotNetworkPeer          = String
"Not network peer"
    show PeerException
PeerNoSegWit            = String
"Segwit not supported by peer"
    show PeerException
PeerTimeout             = String
"Peer timed out"
    show PeerException
UnknownPeer             = String
"Unknown peer"
    show PeerException
PeerTooOld              = String
"Peer too old"
    show PeerException
EmptyHeader             = String
"Empty header"

instance Exception PeerException

-- | Mailbox for a peer.
data Peer = Peer { Peer -> Mailbox PeerMessage
peerMailbox   :: !(Mailbox PeerMessage)
                 , Peer -> Publisher (Peer, Message)
peerPublisher :: !(Publisher (Peer, Message))
                 , Peer -> Text
peerText      :: !Text
                 , Peer -> TVar Bool
peerBusy      :: !(TVar Bool)
                 }

instance Eq Peer where
    == :: Peer -> Peer -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Peer -> Mailbox PeerMessage
peerMailbox

instance Show Peer where
    show :: Peer -> String
show = forall a b. ConvertibleStrings a b => a -> b
cs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer -> Text
peerText

-- | Incoming messages that a peer accepts.
data PeerMessage
    = KillPeer !PeerException
    | SendMessage !Message

wrapPeer :: MonadIO m
         => PeerConfig
         -> TVar Bool
         -> Mailbox PeerMessage
         -> m Peer
wrapPeer :: forall (m :: * -> *).
MonadIO m =>
PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer PeerConfig
cfg TVar Bool
busy Mailbox PeerMessage
mbox =
    forall (m :: * -> *) a. Monad m => a -> m a
return Peer { peerMailbox :: Mailbox PeerMessage
peerMailbox = Mailbox PeerMessage
mbox
                , peerPublisher :: Publisher (Peer, Message)
peerPublisher = PeerConfig -> Publisher (Peer, Message)
peerConfPub PeerConfig
cfg
                , peerText :: Text
peerText = PeerConfig -> Text
peerConfText PeerConfig
cfg
                , peerBusy :: TVar Bool
peerBusy = TVar Bool
busy
                }

-- | Run peer process in current thread.
peer :: (MonadUnliftIO m, MonadLoggerIO m)
     => PeerConfig
     -> TVar Bool
     -> Inbox PeerMessage
     -> m ()
peer :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerConfig -> TVar Bool -> Inbox PeerMessage -> m ()
peer cfg :: PeerConfig
cfg@PeerConfig{Text
Network
Publisher (Peer, Message)
WithConnection
peerConfConnect :: WithConnection
peerConfText :: Text
peerConfNetwork :: Network
peerConfPub :: Publisher (Peer, Message)
peerConfConnect :: PeerConfig -> WithConnection
peerConfText :: PeerConfig -> Text
peerConfNetwork :: PeerConfig -> Network
peerConfPub :: PeerConfig -> Publisher (Peer, Message)
..} TVar Bool
busy Inbox PeerMessage
inbox = do
    Peer
p <- forall (m :: * -> *).
MonadIO m =>
PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer PeerConfig
cfg TVar Bool
busy (forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox PeerMessage
inbox)
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
restore -> do
        WithConnection
peerConfConnect (Peer -> Conduits -> IO ()
peer_session Peer
p)
  where
    go :: ConduitT () Message IO ()
go = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox PeerMessage
inbox forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) i.
MonadIO m =>
PeerConfig -> PeerMessage -> ConduitT i Message m ()
dispatchMessage PeerConfig
cfg
    peer_session :: Peer -> Conduits -> IO ()
peer_session Peer
p Conduits
ad = do
        let ins :: ConduitT () ByteString IO ()
ins = forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT () ByteString IO ()
inboundConduit Conduits
ad)
            ons :: ConduitT ByteString Void IO ()
ons = forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT ByteString Void IO ()
outboundConduit Conduits
ad)
            src :: IO ()
src = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
                ConduitT () ByteString IO ()
ins
                forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadIO m =>
Network -> Text -> ConduitT ByteString Message m ()
inPeerConduit Network
peerConfNetwork Text
peerConfText
                forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (Peer -> Message -> IO ()
send_msg Peer
p)
            snk :: ConduitT Message Void IO ()
snk = forall (m :: * -> *).
Monad m =>
Network -> ConduitT Message ByteString m ()
outPeerConduit Network
peerConfNetwork forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void IO ()
ons
        forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO ()
src forall a b. (a -> b) -> a -> b
$ \Async ()
as -> do
            forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
as
            forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Message IO ()
go forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Message Void IO ()
snk)
    send_msg :: Peer -> Message -> IO ()
send_msg Peer
p Message
msg = forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (Peer
p, Message
msg) Publisher (Peer, Message)
peerConfPub

-- | Internal function to dispatch peer messages.
dispatchMessage :: MonadIO m
                => PeerConfig
                -> PeerMessage
                -> ConduitT i Message m ()
dispatchMessage :: forall (m :: * -> *) i.
MonadIO m =>
PeerConfig -> PeerMessage -> ConduitT i Message m ()
dispatchMessage PeerConfig
_ (SendMessage Message
msg) = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Message
msg
dispatchMessage PeerConfig
_ (KillPeer PeerException
e)      = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
e

-- | Internal conduit to parse messages coming from peer.
inPeerConduit :: MonadIO m
              => Network
              -> Text
              -> ConduitT ByteString Message m ()
inPeerConduit :: forall (m :: * -> *).
MonadIO m =>
Network -> Text -> ConduitT ByteString Message m ()
inPeerConduit Network
net Text
a =
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        ByteString
x <- forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE Int
24 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
x) forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
EmptyHeader
        case forall a. Serialize a => ByteString -> Either String a
decode ByteString
x of
            Left String
e -> do
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
DecodeHeaderError
            Right (MessageHeader Word32
_ MessageCommand
cmd Word32
len CheckSum32
_) -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
len forall a. Ord a => a -> a -> Bool
> Word32
32 forall a. Num a => a -> a -> a
* Word32
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
20 :: Int)) forall a b. (a -> b) -> a -> b
$ do
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Word32 -> PeerException
PayloadTooLarge Word32
len
                ByteString
y <- forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
                case forall a. Get a -> ByteString -> Either String a
runGet (forall (m :: * -> *). MonadGet m => Network -> m Message
getMessage Network
net) forall a b. (a -> b) -> a -> b
$ ByteString
x ByteString -> ByteString -> ByteString
`B.append` ByteString
y of
                    Left String
e -> do
                        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MessageCommand -> PeerException
CannotDecodePayload MessageCommand
cmd)
                    Right Message
msg -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Message
msg

-- | Outgoing peer conduit to serialize and send messages.
outPeerConduit :: Monad m => Network -> ConduitT Message ByteString m ()
outPeerConduit :: forall (m :: * -> *).
Monad m =>
Network -> ConduitT Message ByteString m ()
outPeerConduit Network
net = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadPut m => Network -> Message -> m ()
putMessage Network
net

-- | Kill a peer with the provided exception.
killPeer :: MonadIO m => PeerException -> Peer -> m ()
killPeer :: forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
e Peer
p = PeerException -> PeerMessage
KillPeer PeerException
e forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Peer -> Mailbox PeerMessage
peerMailbox Peer
p

-- | Send a network message to peer.
sendMessage :: MonadIO m => Message -> Peer -> m ()
sendMessage :: forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
sendMessage Message
msg Peer
p = Message -> PeerMessage
SendMessage Message
msg forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Peer -> Mailbox PeerMessage
peerMailbox Peer
p

getBusy :: MonadIO m => Peer -> m Bool
getBusy :: forall (m :: * -> *). MonadIO m => Peer -> m Bool
getBusy Peer
p = forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (Peer -> TVar Bool
peerBusy Peer
p)

setBusy :: MonadIO m => Peer -> m Bool
setBusy :: forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p =
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        forall a. TVar a -> STM a
readTVar (Peer -> TVar Bool
peerBusy Peer
p) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Bool
False -> forall a. TVar a -> a -> STM ()
writeTVar (Peer -> TVar Bool
peerBusy Peer
p) Bool
True forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                     forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

setFree :: MonadIO m => Peer -> m ()
setFree :: forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (Peer -> TVar Bool
peerBusy Peer
p) Bool
False

-- | Request full blocks from peer. Will return 'Nothing' if the list of blocks
-- returned by the peer is incomplete, comes out of order, or a timeout is
-- reached.
getBlocks :: MonadUnliftIO m
          => Network
          -> Int
          -> Peer
          -> [BlockHash]
          -> m (Maybe [Block])
getBlocks :: forall (m :: * -> *).
MonadUnliftIO m =>
Network -> Int -> Peer -> [BlockHash] -> m (Maybe [Block])
getBlocks Network
net Int
time Peer
p [BlockHash]
bhs =
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a} {a}. Monad m => Either a a -> MaybeT m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (m :: * -> *).
MonadUnliftIO m =>
Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
getData Int
time Peer
p ([InvVector] -> GetData
GetData [InvVector]
ivs))
  where
    f :: Either a a -> MaybeT m a
f (Right a
b) = forall (m :: * -> *) a. Monad m => a -> m a
return a
b
    f (Left a
_)  = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    c :: InvType
c
        | Network -> Bool
getSegWit Network
net = InvType
InvWitnessBlock
        | Bool
otherwise = InvType
InvBlock
    ivs :: [InvVector]
ivs = forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Hash256
getBlockHash) [BlockHash]
bhs

-- | Request transactions from peer. Will return 'Nothing' if the list of
-- transactions returned by the peer is incomplete, comes out of order, or a
-- timeout is reached.
getTxs :: MonadUnliftIO m
       => Network
       -> Int
       -> Peer
       -> [TxHash]
       -> m (Maybe [Tx])
getTxs :: forall (m :: * -> *).
MonadUnliftIO m =>
Network -> Int -> Peer -> [TxHash] -> m (Maybe [Tx])
getTxs Network
net Int
time Peer
p [TxHash]
ths =
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a} {b}. Monad m => Either a b -> MaybeT m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (m :: * -> *).
MonadUnliftIO m =>
Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
getData Int
time Peer
p ([InvVector] -> GetData
GetData [InvVector]
ivs))
  where
    f :: Either a b -> MaybeT m a
f (Right b
_) = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    f (Left a
t)  = forall (m :: * -> *) a. Monad m => a -> m a
return a
t
    c :: InvType
c
        | Network -> Bool
getSegWit Network
net = InvType
InvWitnessTx
        | Bool
otherwise = InvType
InvTx
    ivs :: [InvVector]
ivs = forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Hash256
getTxHash) [TxHash]
ths

-- | Request transactions and/or blocks from peer. Return 'Nothing' if any
-- single inventory fails to be retrieved, if they come out of order, or if
-- timeout is reached.
getData :: MonadUnliftIO m
        => Int
        -> Peer
        -> GetData
        -> m (Maybe [Either Tx Block])
getData :: forall (m :: * -> *).
MonadUnliftIO m =>
Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
getData Int
seconds Peer
p gd :: GetData
gd@(GetData [InvVector]
ivs) =
    forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription (Peer -> Publisher (Peer, Message)
peerPublisher Peer
p) forall a b. (a -> b) -> a -> b
$ \Inbox (Peer, Message)
inb -> do
    GetData -> Message
MGetData GetData
gd forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
    Word64
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
    Ping -> Message
MPing (Word64 -> Ping
Ping Word64
r) forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
seconds forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ Inbox (Peer, Message)
-> Word64
-> [Either Tx Block]
-> [InvVector]
-> MaybeT m [Either Tx Block]
get_thing Inbox (Peer, Message)
inb Word64
r [] [InvVector]
ivs
  where
    get_thing :: Inbox (Peer, Message)
-> Word64
-> [Either Tx Block]
-> [InvVector]
-> MaybeT m [Either Tx Block]
get_thing Inbox (Peer, Message)
_inb Word64
_r [Either Tx Block]
acc [] =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Either Tx Block]
acc
    get_thing Inbox (Peer, Message)
inb Word64
r [Either Tx Block]
acc hss :: [InvVector]
hss@(InvVector InvType
t Hash256
h : [InvVector]
hs) =
        forall (m :: * -> *).
MonadIO m =>
Peer -> Inbox (Peer, Message) -> m Message
filterReceive Peer
p Inbox (Peer, Message)
inb forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            MTx Tx
tx
                | InvType -> Bool
is_tx InvType
t Bool -> Bool -> Bool
&& TxHash -> Hash256
getTxHash (Tx -> TxHash
txHash Tx
tx) forall a. Eq a => a -> a -> Bool
== Hash256
h ->
                      Inbox (Peer, Message)
-> Word64
-> [Either Tx Block]
-> [InvVector]
-> MaybeT m [Either Tx Block]
get_thing Inbox (Peer, Message)
inb Word64
r (forall a b. a -> Either a b
Left Tx
tx forall a. a -> [a] -> [a]
: [Either Tx Block]
acc) [InvVector]
hs
            MBlock b :: Block
b@(Block BlockHeader
bh [Tx]
_)
                | InvType -> Bool
is_block InvType
t Bool -> Bool -> Bool
&& BlockHash -> Hash256
getBlockHash (BlockHeader -> BlockHash
headerHash BlockHeader
bh) forall a. Eq a => a -> a -> Bool
== Hash256
h ->
                      Inbox (Peer, Message)
-> Word64
-> [Either Tx Block]
-> [InvVector]
-> MaybeT m [Either Tx Block]
get_thing Inbox (Peer, Message)
inb Word64
r (forall a b. b -> Either a b
Right Block
b forall a. a -> [a] -> [a]
: [Either Tx Block]
acc) [InvVector]
hs
            MNotFound (NotFound [InvVector]
nvs)
                | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([InvVector]
nvs forall a. Eq a => [a] -> [a] -> [a]
`union` [InvVector]
hs)) ->
                      forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            MPong (Pong Word64
r')
                | Word64
r forall a. Eq a => a -> a -> Bool
== Word64
r' ->
                      forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Message
_
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Either Tx Block]
acc ->
                      Inbox (Peer, Message)
-> Word64
-> [Either Tx Block]
-> [InvVector]
-> MaybeT m [Either Tx Block]
get_thing Inbox (Peer, Message)
inb Word64
r [Either Tx Block]
acc [InvVector]
hss
                | Bool
otherwise ->
                      forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    is_tx :: InvType -> Bool
is_tx InvType
InvWitnessTx = Bool
True
    is_tx InvType
InvTx        = Bool
True
    is_tx InvType
_            = Bool
False
    is_block :: InvType -> Bool
is_block InvType
InvWitnessBlock = Bool
True
    is_block InvType
InvBlock        = Bool
True
    is_block InvType
_               = Bool
False

-- | Ping a peer and await response. Return 'False' if response not received
-- before timeout.
pingPeer :: MonadUnliftIO m => Int -> Peer -> m Bool
pingPeer :: forall (m :: * -> *). MonadUnliftIO m => Int -> Peer -> m Bool
pingPeer Int
time Peer
p =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription (Peer -> Publisher (Peer, Message)
peerPublisher Peer
p) forall a b. (a -> b) -> a -> b
$ \Inbox (Peer, Message)
sub -> do
        Word64
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
        Ping -> Message
MPing (Word64 -> Ping
Ping Word64
r) forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
        forall (m :: * -> *) (mbox :: * -> *) msg a.
(MonadUnliftIO m, InChan mbox) =>
Int -> mbox msg -> (msg -> Maybe a) -> m (Maybe a)
receiveMatchS Int
time Inbox (Peer, Message)
sub forall a b. (a -> b) -> a -> b
$ \case
            (Peer
p', MPong (Pong Word64
r'))
                | Peer
p forall a. Eq a => a -> a -> Bool
== Peer
p' Bool -> Bool -> Bool
&& Word64
r forall a. Eq a => a -> a -> Bool
== Word64
r' -> forall a. a -> Maybe a
Just ()
            (Peer, Message)
_ -> forall a. Maybe a
Nothing

-- | Peer string for logging
peerLog :: Text -> Text
peerLog :: Text -> Text
peerLog = forall a. Monoid a => a -> a -> a
mappend Text
"Peer|"

filterReceive :: MonadIO m => Peer -> Inbox (Peer, Message) -> m Message
filterReceive :: forall (m :: * -> *).
MonadIO m =>
Peer -> Inbox (Peer, Message) -> m Message
filterReceive Peer
p Inbox (Peer, Message)
inb =
    forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox (Peer, Message)
inb forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Peer
p', Message
msg) | Peer
p forall a. Eq a => a -> a -> Bool
== Peer
p' -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
msg
        (Peer, Message)
_                   -> forall (m :: * -> *).
MonadIO m =>
Peer -> Inbox (Peer, Message) -> m Message
filterReceive Peer
p Inbox (Peer, Message)
inb