{-# 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
|
| CannotDecodePayload !MessageCommand
| PeerIsMyself
| PayloadTooLarge !Word32
| PeerAddressInvalid
|
| 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 String
s) = String
"Peer misbehaving: " String -> ShowS
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: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
ByteString -> String
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: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
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
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
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 =
Peer -> m Peer
forall (m :: * -> *) a. Monad m => a -> m a
return Peer :: 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
}
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 <- 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
$ \forall a. m a -> IO a
restore -> do
WithConnection
peerConfConnect (Peer -> Conduits -> IO ()
peer_session Peer
p)
where
go :: ConduitT () Message IO ()
go = ConduitT () Message IO () -> ConduitT () Message IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitT () Message IO () -> ConduitT () Message IO ())
-> ConduitT () Message IO () -> ConduitT () Message IO ()
forall a b. (a -> b) -> a -> b
$ Inbox PeerMessage -> ConduitT () Message IO PeerMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox PeerMessage
inbox ConduitT () Message IO PeerMessage
-> (PeerMessage -> ConduitT () Message IO ())
-> ConduitT () Message IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PeerConfig -> PeerMessage -> ConduitT () Message IO ()
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 a. IO a -> IO a)
-> ConduitT () ByteString IO () -> ConduitT () ByteString IO ()
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 -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT () ByteString IO ()
inboundConduit Conduits
ad)
ons :: ConduitT ByteString Void IO ()
ons = (forall a. IO a -> IO a)
-> ConduitT ByteString Void IO () -> ConduitT ByteString Void IO ()
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 -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Conduits -> ConduitT ByteString Void IO ()
outboundConduit Conduits
ad)
src :: IO ()
src = ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ConduitT () ByteString IO ()
ins
ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
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 IO ()
forall (m :: * -> *).
MonadIO m =>
Network -> Text -> ConduitT ByteString Message m ()
inPeerConduit Network
peerConfNetwork Text
peerConfText
ConduitT ByteString Message IO ()
-> ConduitM Message Void IO () -> ConduitT ByteString Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Message -> IO ()) -> ConduitM Message Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (Peer -> Message -> IO ()
send_msg Peer
p)
snk :: ConduitM Message Void IO ()
snk = Network -> ConduitT Message ByteString IO ()
forall (m :: * -> *).
Monad m =>
Network -> ConduitT Message ByteString m ()
outPeerConduit Network
peerConfNetwork ConduitT Message ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitM Message Void IO ()
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 IO ()
ons
IO () -> (Async () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO ()
src ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
as -> do
Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
as
ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Message IO ()
go ConduitT () Message IO ()
-> ConduitM Message Void IO () -> ConduitT () Void IO ()
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 IO ()
snk)
send_msg :: Peer -> Message -> IO ()
send_msg Peer
p Message
msg = (Peer, Message) -> Publisher (Peer, Message) -> IO ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (Peer
p, Message
msg) Publisher (Peer, Message)
peerConfPub
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) = Message -> ConduitT i Message m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Message
msg
dispatchMessage PeerConfig
_ (KillPeer PeerException
e) = PeerException -> ConduitT i Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
e
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 =
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 Index ByteString
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
Bool
-> ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
x) (ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ())
-> ConduitT ByteString Message m ()
-> ConduitT ByteString Message m ()
forall a b. (a -> b) -> a -> b
$ do
PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
EmptyHeader
case ByteString -> Either String MessageHeader
forall a. Serialize a => ByteString -> Either String a
decode ByteString
x of
Left String
e -> do
PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
DecodeHeaderError
Right (MessageHeader Word32
_ MessageCommand
cmd Word32
len CheckSum32
_) -> 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
> Word32
32 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
2 Word32 -> Int -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
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
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
forall (m :: * -> *). MonadGet m => Network -> m 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 String
e -> do
PeerException -> ConduitT ByteString Message m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MessageCommand -> PeerException
CannotDecodePayload MessageCommand
cmd)
Right Message
msg -> Message -> ConduitT ByteString Message m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Message
msg
outPeerConduit :: Monad m => Network -> ConduitT Message ByteString m ()
outPeerConduit :: forall (m :: * -> *).
Monad m =>
Network -> ConduitT Message ByteString m ()
outPeerConduit 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
forall (m :: * -> *). MonadPut m => Network -> Message -> m ()
putMessage Network
net
killPeer :: MonadIO m => PeerException -> Peer -> m ()
killPeer :: forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
e 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
sendMessage :: MonadIO m => Message -> Peer -> m ()
sendMessage :: forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
sendMessage Message
msg 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 :: forall (m :: * -> *). MonadIO m => Peer -> m Bool
getBusy 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 :: forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy 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
Bool
True -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool
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 :: forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree 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
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 =
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 a
b) = a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
f (Left a
_) = 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
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 =
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 b
_) = 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 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
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) =
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
$ \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
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 Inbox (Peer, Message)
_inb Word64
_r [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 Inbox (Peer, Message)
inb Word64
r [Either Tx Block]
acc hss :: [InvVector]
hss@(InvVector InvType
t Hash256
h : [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
| 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 BlockHeader
bh [Tx]
_)
| 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 [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 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
Message
_
| [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 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
pingPeer :: MonadUnliftIO m => Int -> Peer -> m Bool
pingPeer :: forall (m :: * -> *). MonadUnliftIO m => Int -> Peer -> m Bool
pingPeer Int
time 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
$ \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
(Peer
p', MPong (Pong 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 ()
(Peer, Message)
_ -> Maybe ()
forall a. Maybe a
Nothing
peerLog :: Text -> Text
peerLog :: Text -> Text
peerLog = Text -> Text -> Text
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 =
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
(Peer
p', 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, Message)
_ -> Peer -> Inbox (Peer, Message) -> m Message
forall (m :: * -> *).
MonadIO m =>
Peer -> Inbox (Peer, Message) -> m Message
filterReceive Peer
p Inbox (Peer, Message)
inb