{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# 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 (..),
                                            MessageHeader (..), Network (..),
                                            NotFound (..), Ping (..), Pong (..),
                                            Tx, TxHash (..), 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
    | PeerIsMyself
    | PayloadTooLarge !Word32
    | PeerAddressInvalid
    | PeerSentBadHeaders
    | NotNetworkPeer
    | PeerNoSegWit
    | PeerTimeout
    | UnknownPeer
    | PeerTooOld
    deriving PeerException -> PeerException -> Bool
(PeerException -> PeerException -> Bool)
-> (PeerException -> PeerException -> Bool) -> Eq PeerException
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 s :: String
s) = "Peer misbehaving: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
    show DuplicateVersion    = "Duplicate version"
    show DecodeHeaderError   = "Error decoding header"
    show CannotDecodePayload = "Cannot decode payload"
    show PeerIsMyself        = "Peer is myself"
    show (PayloadTooLarge s :: Word32
s) = "Payload too large: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show Word32
s
    show PeerAddressInvalid  = "Peer address invalid"
    show PeerSentBadHeaders  = "Peer sent bad headers"
    show NotNetworkPeer      = "Not network peer"
    show PeerNoSegWit        = "Segwit not supported by peer"
    show PeerTimeout         = "Peer timed out"
    show UnknownPeer         = "Unknown peer"
    show PeerTooOld          = "Peer too old"

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
(==) = Mailbox PeerMessage -> Mailbox PeerMessage -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Mailbox PeerMessage -> Mailbox PeerMessage -> Bool)
-> (Peer -> Mailbox PeerMessage) -> Peer -> Peer -> 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 = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> (Peer -> Text) -> Peer -> String
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 :: PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer cfg :: PeerConfig
cfg busy :: TVar Bool
busy mbox :: Mailbox PeerMessage
mbox =
    Peer -> m Peer
forall (m :: * -> *) a. Monad m => a -> m a
return $WPeer :: Mailbox PeerMessage
-> Publisher (Peer, Message) -> Text -> TVar Bool -> Peer
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 :: PeerConfig -> TVar Bool -> Inbox PeerMessage -> m ()
peer cfg :: PeerConfig
cfg busy :: TVar Bool
busy inbox :: Inbox PeerMessage
inbox = do
    Peer
p <- PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
forall (m :: * -> *).
MonadIO m =>
PeerConfig -> TVar Bool -> Mailbox PeerMessage -> m Peer
wrapPeer PeerConfig
cfg TVar Bool
busy (Inbox PeerMessage -> Mailbox PeerMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox PeerMessage
inbox)
    ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ WithConnection
connect WithConnection
-> ((m () -> IO ()) -> Conduits -> IO ())
-> (m () -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m () -> IO ()) -> (Conduits -> m ()) -> Conduits -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer -> Conduits -> m ()
peer_session Peer
p)
  where
    connect :: WithConnection
connect = PeerConfig -> WithConnection
peerConfConnect PeerConfig
cfg
    go :: ConduitT () Message m ()
go = ConduitT () Message m () -> ConduitT () Message m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitT () Message m () -> ConduitT () Message m ())
-> ConduitT () Message m () -> ConduitT () Message m ()
forall a b. (a -> b) -> a -> b
$ Inbox PeerMessage -> ConduitT () Message m PeerMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox PeerMessage
inbox ConduitT () Message m PeerMessage
-> (PeerMessage -> ConduitT () Message m ())
-> ConduitT () Message m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PeerConfig -> PeerMessage -> ConduitT () Message m ()
forall (m :: * -> *) i.
MonadLoggerIO m =>
PeerConfig -> PeerMessage -> ConduitT i Message m ()
dispatchMessage PeerConfig
cfg
    net :: Network
net = PeerConfig -> Network
peerConfNetwork PeerConfig
cfg
    peer_session :: Peer -> Conduits -> m ()
peer_session p :: Peer
p ad :: Conduits
ad =
        let ins :: ConduitT () ByteString m ()
ins = (forall a. IO a -> m a)
-> ConduitT () ByteString IO () -> ConduitT () ByteString m ()
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT () ByteString IO ()
inboundConduit Conduits
ad)
            ons :: ConduitT ByteString Void m ()
ons = (forall a. IO a -> m a)
-> ConduitT ByteString Void IO () -> ConduitT ByteString Void m ()
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT ByteString Void IO ()
outboundConduit Conduits
ad)
            src :: m ()
src = ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$
                ConduitT () ByteString m ()
ins
                ConduitT () ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Network -> Text -> ConduitT ByteString Message m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Network -> Text -> ConduitT ByteString Message m ()
inPeerConduit Network
net (PeerConfig -> Text
peerConfText PeerConfig
cfg)
                ConduitT ByteString Message m ()
-> ConduitM Message Void m () -> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Message -> m ()) -> ConduitM Message Void m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (Peer -> Message -> m ()
send_msg Peer
p)
            snk :: ConduitM Message Void m ()
snk = Network -> ConduitT Message ByteString m ()
forall (m :: * -> *).
Monad m =>
Network -> ConduitT Message ByteString m ()
outPeerConduit Network
net ConduitT Message ByteString m ()
-> ConduitT ByteString Void m () -> ConduitM Message Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString Void m ()
ons
         in m () -> (Async () -> m ()) -> m ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync m ()
src ((Async () -> m ()) -> m ()) -> (Async () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \as :: Async ()
as -> do
                Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
as
                ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Message m ()
go ConduitT () Message m ()
-> ConduitM Message Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Message Void m ()
snk)
    send_msg :: Peer -> Message -> m ()
send_msg p :: Peer
p msg :: Message
msg = (Peer, Message) -> Publisher (Peer, Message) -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (Peer
p, Message
msg) (PeerConfig -> Publisher (Peer, Message)
peerConfPub PeerConfig
cfg)

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

-- | Internal conduit to parse messages coming from peer.
inPeerConduit :: MonadLoggerIO m
              => Network
              -> Text
              -> ConduitT ByteString Message m ()
inPeerConduit :: Network -> Text -> ConduitT ByteString Message m ()
inPeerConduit net :: Network
net a :: Text
a =
    ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitT ByteString Message m ()
 -> ConduitT ByteString Message m ())
-> ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString
x <- Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE 24 ConduitT ByteString ByteString m ()
-> ConduitM ByteString Message m ByteString
-> ConduitM ByteString Message m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Message m ByteString
forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
        case ByteString -> Either String MessageHeader
forall a. Serialize a => ByteString -> Either String a
decode ByteString
x of
            Left _ -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ConduitT ByteString Message m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
logErrorS)
                    (Text -> Text
peerLog Text
a)
                    "Could not decode incoming message header"
                PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
DecodeHeaderError
            Right (MessageHeader _ _ len :: Word32
len _) -> do
                Bool
-> ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
len Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> 32 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 2 Word32 -> Int -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ (20 :: Int)) (ConduitT ByteString Message m ()
 -> ConduitT ByteString Message m ())
-> ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall a b. (a -> b) -> a -> b
$ do
                    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ConduitT ByteString Message m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) (Text -> Text
peerLog Text
a) "Payload too large"
                    PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PeerException -> ConduitT ByteString Message m ())
-> PeerException -> ConduitT ByteString Message m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> PeerException
PayloadTooLarge Word32
len
                ByteString
y <- Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) ConduitT ByteString ByteString m ()
-> ConduitM ByteString Message m ByteString
-> ConduitM ByteString Message m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Message m ByteString
forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC
                case Get Message -> ByteString -> Either String Message
forall a. Get a -> ByteString -> Either String a
runGet (Network -> Get Message
getMessage Network
net) (ByteString -> Either String Message)
-> ByteString -> Either String Message
forall a b. (a -> b) -> a -> b
$ ByteString
x ByteString -> ByteString -> ByteString
`B.append` ByteString
y of
                    Left e :: String
e -> do
                        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ConduitT ByteString Message m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) (Text -> Text
peerLog Text
a) (Text -> ConduitT ByteString Message m ())
-> Text -> ConduitT ByteString Message m ()
forall a b. (a -> b) -> a -> b
$
                            "Cannot decode payload: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ShowS
forall a. Show a => a -> String
show String
e)
                        PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
CannotDecodePayload
                    Right msg :: Message
msg -> Message -> ConduitT ByteString Message m ()
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 :: Network -> ConduitT Message ByteString m ()
outPeerConduit net :: Network
net = (Message -> ConduitT Message ByteString m ())
-> ConduitT Message ByteString m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Message -> ConduitT Message ByteString m ())
 -> ConduitT Message ByteString m ())
-> (Message -> ConduitT Message ByteString m ())
-> ConduitT Message ByteString m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitT Message ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ConduitT Message ByteString m ())
-> (Message -> ByteString)
-> Message
-> ConduitT Message ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (Message -> Put) -> Message -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Message -> Put
putMessage Network
net

-- | Kill a peer with the provided exception.
killPeer :: MonadIO m => PeerException -> Peer -> m ()
killPeer :: PeerException -> Peer -> m ()
killPeer e :: PeerException
e p :: Peer
p = PeerException -> PeerMessage
KillPeer PeerException
e PeerMessage -> Mailbox PeerMessage -> m ()
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 :: Message -> Peer -> m ()
sendMessage msg :: Message
msg p :: Peer
p = Message -> PeerMessage
SendMessage Message
msg PeerMessage -> Mailbox PeerMessage -> m ()
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 :: Peer -> m Bool
getBusy p :: Peer
p = TVar Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (Peer -> TVar Bool
peerBusy Peer
p)

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

setFree :: MonadIO m => Peer -> m ()
setFree :: Peer -> m ()
setFree p :: Peer
p = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
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 :: Network -> Int -> Peer -> [BlockHash] -> m (Maybe [Block])
getBlocks net :: Network
net time :: Int
time p :: Peer
p bhs :: [BlockHash]
bhs =
    MaybeT m [Block] -> m (Maybe [Block])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [Block] -> m (Maybe [Block]))
-> MaybeT m [Block] -> m (Maybe [Block])
forall a b. (a -> b) -> a -> b
$ (Either Tx Block -> MaybeT m Block)
-> [Either Tx Block] -> MaybeT m [Block]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Either Tx Block -> MaybeT m Block
forall (m :: * -> *) a a. Monad m => Either a a -> MaybeT m a
f ([Either Tx Block] -> MaybeT m [Block])
-> MaybeT m [Either Tx Block] -> MaybeT m [Block]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
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 b :: a
b) = a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
    f (Left _)  = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a) -> m (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    c :: InvType
c
        | Network -> Bool
getSegWit Network
net = InvType
InvWitnessBlock
        | Bool
otherwise = InvType
InvBlock
    ivs :: [InvVector]
ivs = (BlockHash -> InvVector) -> [BlockHash] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
c (Hash256 -> InvVector)
-> (BlockHash -> Hash256) -> BlockHash -> InvVector
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 :: Network -> Int -> Peer -> [TxHash] -> m (Maybe [Tx])
getTxs net :: Network
net time :: Int
time p :: Peer
p ths :: [TxHash]
ths =
    MaybeT m [Tx] -> m (Maybe [Tx])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [Tx] -> m (Maybe [Tx]))
-> MaybeT m [Tx] -> m (Maybe [Tx])
forall a b. (a -> b) -> a -> b
$ (Either Tx Block -> MaybeT m Tx)
-> [Either Tx Block] -> MaybeT m [Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Either Tx Block -> MaybeT m Tx
forall (m :: * -> *) a b. Monad m => Either a b -> MaybeT m a
f ([Either Tx Block] -> MaybeT m [Tx])
-> MaybeT m [Either Tx Block] -> MaybeT m [Tx]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
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 _) = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a) -> m (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    f (Left t :: a
t)  = a -> MaybeT m a
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 = (TxHash -> InvVector) -> [TxHash] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
c (Hash256 -> InvVector)
-> (TxHash -> Hash256) -> TxHash -> InvVector
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 :: Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
getData seconds :: Int
seconds p :: Peer
p gd :: GetData
gd@(GetData ivs :: [InvVector]
ivs) =
    Publisher (Peer, Message)
-> (Inbox (Peer, Message) -> m (Maybe [Either Tx Block]))
-> m (Maybe [Either Tx Block])
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription (Peer -> Publisher (Peer, Message)
peerPublisher Peer
p) ((Inbox (Peer, Message) -> m (Maybe [Either Tx Block]))
 -> m (Maybe [Either Tx Block]))
-> (Inbox (Peer, Message) -> m (Maybe [Either Tx Block]))
-> m (Maybe [Either Tx Block])
forall a b. (a -> b) -> a -> b
$ \inb :: Inbox (Peer, Message)
inb -> do
    GetData -> Message
MGetData GetData
gd Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
    Word64
r <- IO Word64 -> m Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
    Ping -> Message
MPing (Word64 -> Ping
Ping Word64
r) Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
    (Maybe (Maybe [Either Tx Block]) -> Maybe [Either Tx Block])
-> m (Maybe (Maybe [Either Tx Block]))
-> m (Maybe [Either Tx Block])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [Either Tx Block]) -> Maybe [Either Tx Block]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (Maybe (Maybe [Either Tx Block]))
 -> m (Maybe [Either Tx Block]))
-> (MaybeT m [Either Tx Block]
    -> m (Maybe (Maybe [Either Tx Block])))
-> MaybeT m [Either Tx Block]
-> m (Maybe [Either Tx Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> m (Maybe [Either Tx Block])
-> m (Maybe (Maybe [Either Tx Block]))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000) (m (Maybe [Either Tx Block])
 -> m (Maybe (Maybe [Either Tx Block])))
-> (MaybeT m [Either Tx Block] -> m (Maybe [Either Tx Block]))
-> MaybeT m [Either Tx Block]
-> m (Maybe (Maybe [Either Tx Block]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        MaybeT m [Either Tx Block] -> m (Maybe [Either Tx Block])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m [Either Tx Block] -> m (Maybe [Either Tx Block]))
-> MaybeT m [Either Tx Block] -> m (Maybe [Either Tx Block])
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 _inb :: Inbox (Peer, Message)
_inb _r :: Word64
_r acc :: [Either Tx Block]
acc [] =
        [Either Tx Block] -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Tx Block] -> MaybeT m [Either Tx Block])
-> [Either Tx Block] -> MaybeT m [Either Tx Block]
forall a b. (a -> b) -> a -> b
$ [Either Tx Block] -> [Either Tx Block]
forall a. [a] -> [a]
reverse [Either Tx Block]
acc
    get_thing inb :: Inbox (Peer, Message)
inb r :: Word64
r acc :: [Either Tx Block]
acc hss :: [InvVector]
hss@(InvVector t :: InvType
t h :: Hash256
h : hs :: [InvVector]
hs) =
        Peer -> Inbox (Peer, Message) -> MaybeT m Message
forall (m :: * -> *).
MonadIO m =>
Peer -> Inbox (Peer, Message) -> m Message
filterReceive Peer
p Inbox (Peer, Message)
inb MaybeT m Message
-> (Message -> MaybeT m [Either Tx Block])
-> MaybeT m [Either Tx Block]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            MTx tx :: Tx
tx
                | InvType -> Bool
is_tx InvType
t Bool -> Bool -> Bool
&& TxHash -> Hash256
getTxHash (Tx -> TxHash
txHash Tx
tx) Hash256 -> Hash256 -> Bool
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 (Tx -> Either Tx Block
forall a b. a -> Either a b
Left Tx
tx Either Tx Block -> [Either Tx Block] -> [Either Tx Block]
forall a. a -> [a] -> [a]
: [Either Tx Block]
acc) [InvVector]
hs
            MBlock b :: Block
b@(Block bh :: BlockHeader
bh _)
                | InvType -> Bool
is_block InvType
t Bool -> Bool -> Bool
&& BlockHash -> Hash256
getBlockHash (BlockHeader -> BlockHash
headerHash BlockHeader
bh) Hash256 -> Hash256 -> Bool
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 (Block -> Either Tx Block
forall a b. b -> Either a b
Right Block
b Either Tx Block -> [Either Tx Block] -> [Either Tx Block]
forall a. a -> [a] -> [a]
: [Either Tx Block]
acc) [InvVector]
hs
            MNotFound (NotFound nvs :: [InvVector]
nvs)
                | Bool -> Bool
not ([InvVector] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([InvVector]
nvs [InvVector] -> [InvVector] -> [InvVector]
forall a. Eq a => [a] -> [a] -> [a]
`union` [InvVector]
hs)) ->
                      m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block])
-> m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall a b. (a -> b) -> a -> b
$ Maybe [Either Tx Block] -> m (Maybe [Either Tx Block])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Either Tx Block]
forall a. Maybe a
Nothing
            MPong (Pong r' :: Word64
r')
                | Word64
r Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
r' ->
                      m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block])
-> m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall a b. (a -> b) -> a -> b
$ Maybe [Either Tx Block] -> m (Maybe [Either Tx Block])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Either Tx Block]
forall a. Maybe a
Nothing
            _
                | [Either Tx Block] -> Bool
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 ->
                      m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block])
-> m (Maybe [Either Tx Block]) -> MaybeT m [Either Tx Block]
forall a b. (a -> b) -> a -> b
$ Maybe [Either Tx Block] -> m (Maybe [Either Tx Block])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Either Tx Block]
forall a. Maybe a
Nothing
    is_tx :: InvType -> Bool
is_tx InvWitnessTx = Bool
True
    is_tx InvTx        = Bool
True
    is_tx _            = Bool
False
    is_block :: InvType -> Bool
is_block InvWitnessBlock = Bool
True
    is_block InvBlock        = Bool
True
    is_block _               = Bool
False

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

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

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