{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Haskoin.Node
( module Haskoin.Node.Peer
, module Haskoin.Node.Manager
, module Haskoin.Node.Chain
, NodeConfig (..)
, NodeEvent (..)
, Node (..)
, withNode
, withConnection
) where
import Control.Monad (forever)
import Control.Monad.Logger (MonadLoggerIO)
import Data.Conduit.Network (appSink, appSource, clientSettings,
runTCPClient, ClientSettings)
import Data.String.Conversions (cs)
import Data.Time.Clock (NominalDiffTime)
import Database.RocksDB (ColumnFamily, DB)
import Haskoin (Addr (..), BlockNode (..),
Headers (..), Message (..), Network,
NetworkAddress, Ping (..), Pong (..))
import Haskoin.Node.Chain
import Haskoin.Node.Manager
import Haskoin.Node.Peer
import Network.Socket (NameInfoFlag (..), SockAddr,
getNameInfo)
import NQE (Inbox, Publisher, publish, receive,
withPublisher, withSubscription)
import Text.Read (readMaybe)
import UnliftIO (MonadUnliftIO, SomeException, catch,
liftIO, link, throwIO, withAsync)
data NodeConfig = NodeConfig
{ NodeConfig -> Int
nodeConfMaxPeers :: !Int
, NodeConfig -> DB
nodeConfDB :: !DB
, NodeConfig -> Maybe ColumnFamily
nodeConfColumnFamily :: !(Maybe ColumnFamily)
, NodeConfig -> [String]
nodeConfPeers :: ![String]
, NodeConfig -> Bool
nodeConfDiscover :: !Bool
, NodeConfig -> NetworkAddress
nodeConfNetAddr :: !NetworkAddress
, NodeConfig -> Network
nodeConfNet :: !Network
, NodeConfig -> Publisher NodeEvent
nodeConfEvents :: !(Publisher NodeEvent)
, NodeConfig -> NominalDiffTime
nodeConfTimeout :: !NominalDiffTime
, NodeConfig -> NominalDiffTime
nodeConfPeerMaxLife :: !NominalDiffTime
, NodeConfig -> SockAddr -> WithConnection
nodeConfConnect :: !(SockAddr -> WithConnection)
}
data Node = Node { Node -> PeerManager
nodeManager :: !PeerManager
, Node -> Chain
nodeChain :: !Chain
}
data NodeEvent
= ChainEvent !ChainEvent
| PeerEvent !PeerEvent
| PeerMessage !Peer !Message
deriving NodeEvent -> NodeEvent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeEvent -> NodeEvent -> Bool
$c/= :: NodeEvent -> NodeEvent -> Bool
== :: NodeEvent -> NodeEvent -> Bool
$c== :: NodeEvent -> NodeEvent -> Bool
Eq
withConnection :: SockAddr -> WithConnection
withConnection :: SockAddr -> WithConnection
withConnection SockAddr
na Conduits -> IO ()
f =
forall (m :: * -> *).
MonadUnliftIO m =>
SockAddr -> m (Maybe ClientSettings)
fromSockAddr SockAddr
na forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ClientSettings
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
PeerAddressInvalid
Just ClientSettings
cset ->
forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient ClientSettings
cset forall a b. (a -> b) -> a -> b
$ \AppData
ad ->
Conduits -> IO ()
f (ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> Conduits
Conduits (forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource AppData
ad) (forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
appSink AppData
ad))
fromSockAddr ::
(MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings)
fromSockAddr :: forall (m :: * -> *).
MonadUnliftIO m =>
SockAddr -> m (Maybe ClientSettings)
fromSockAddr SockAddr
sa = m (Maybe ClientSettings)
go forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
e
where
go :: m (Maybe ClientSettings)
go = do
(Maybe String
maybe_host, Maybe String
maybe_port) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
getNameInfo [NameInfoFlag]
flags Bool
True Bool
True SockAddr
sa)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Int -> ByteString -> ClientSettings
clientSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
maybe_port)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. ConvertibleStrings a b => a -> b
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
maybe_host)
flags :: [NameInfoFlag]
flags = [NameInfoFlag
NI_NUMERICHOST, NameInfoFlag
NI_NUMERICSERV]
e :: Monad m => SomeException -> m (Maybe a)
e :: forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
e SomeException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
chainForwarder :: MonadLoggerIO m
=> PeerManager
-> Publisher NodeEvent
-> Inbox ChainEvent
-> m ()
chainForwarder :: forall (m :: * -> *).
MonadLoggerIO m =>
PeerManager -> Publisher NodeEvent -> Inbox ChainEvent -> m ()
chainForwarder PeerManager
mgr Publisher NodeEvent
pub Inbox ChainEvent
inbox =
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 ChainEvent
inbox forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ChainEvent
event -> do
case ChainEvent
event of
ChainBestBlock BlockNode
bb ->
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> PeerManager -> m ()
managerBest (BlockNode -> BlockHeight
nodeHeight BlockNode
bb) PeerManager
mgr
ChainEvent
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (ChainEvent -> NodeEvent
ChainEvent ChainEvent
event) Publisher NodeEvent
pub
managerForwarder :: MonadLoggerIO m
=> Chain
-> Publisher NodeEvent
-> Inbox PeerEvent
-> m ()
managerForwarder :: forall (m :: * -> *).
MonadLoggerIO m =>
Chain -> Publisher NodeEvent -> Inbox PeerEvent -> m ()
managerForwarder Chain
ch Publisher NodeEvent
pub Inbox PeerEvent
inbox =
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 PeerEvent
inbox forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PeerEvent
event -> do
case PeerEvent
event of
PeerConnected Peer
p ->
forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerConnected Peer
p Chain
ch
PeerDisconnected Peer
p ->
forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerDisconnected Peer
p Chain
ch
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (PeerEvent -> NodeEvent
PeerEvent PeerEvent
event) Publisher NodeEvent
pub
peerForwarder :: MonadLoggerIO m
=> Chain
-> PeerManager
-> Publisher NodeEvent
-> Inbox (Peer, Message)
-> m ()
peerForwarder :: forall (m :: * -> *).
MonadLoggerIO m =>
Chain
-> PeerManager
-> Publisher NodeEvent
-> Inbox (Peer, Message)
-> m ()
peerForwarder Chain
ch PeerManager
mgr Publisher NodeEvent
pub Inbox (Peer, Message)
inbox =
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 (Peer, Message)
inbox forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Peer
p, Message
msg) -> do
case Message
msg of
MVersion Version
v ->
forall (m :: * -> *).
MonadIO m =>
Peer -> Version -> PeerManager -> m ()
managerVersion Peer
p Version
v PeerManager
mgr
Message
MVerAck ->
forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerVerAck Peer
p PeerManager
mgr
MPing (Ping Word64
n) ->
forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerManager -> m ()
managerPing Peer
p Word64
n PeerManager
mgr
MPong (Pong Word64
n) ->
forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerManager -> m ()
managerPong Peer
p Word64
n PeerManager
mgr
MAddr (Addr [NetworkAddressTime]
ns) ->
forall (m :: * -> *).
MonadIO m =>
Peer -> [NetworkAddress] -> PeerManager -> m ()
managerAddrs Peer
p (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [NetworkAddressTime]
ns) PeerManager
mgr
MHeaders (Headers [BlockHeaderCount]
hs) ->
forall (m :: * -> *).
MonadIO m =>
Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders Peer
p (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [BlockHeaderCount]
hs) Chain
ch
Message
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *). MonadIO m => Peer -> PeerManager -> m ()
managerTickle Peer
p PeerManager
mgr
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (Peer -> Message -> NodeEvent
PeerMessage Peer
p Message
msg) Publisher NodeEvent
pub
withNode ::
( MonadLoggerIO m
, MonadUnliftIO m
)
=> NodeConfig
-> (Node -> m a)
-> m a
withNode :: forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
NodeConfig -> (Node -> m a) -> m a
withNode NodeConfig
cfg Node -> m a
action =
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
(Publisher msg -> m a) -> m a
withPublisher forall a b. (a -> b) -> a -> b
$ \Publisher (Peer, Message)
peer_pub ->
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
(Publisher msg -> m a) -> m a
withPublisher forall a b. (a -> b) -> a -> b
$ \Publisher PeerEvent
mgr_pub ->
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
(Publisher msg -> m a) -> m a
withPublisher forall a b. (a -> b) -> a -> b
$ \Publisher ChainEvent
ch_pub ->
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription Publisher (Peer, Message)
peer_pub forall a b. (a -> b) -> a -> b
$ \Inbox (Peer, Message)
peer_inbox ->
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription Publisher PeerEvent
mgr_pub forall a b. (a -> b) -> a -> b
$ \Inbox PeerEvent
mgr_inbox ->
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription Publisher ChainEvent
ch_pub forall a b. (a -> b) -> a -> b
$ \Inbox ChainEvent
ch_inbox ->
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerManagerConfig -> (PeerManager -> m a) -> m a
withPeerManager (Publisher PeerEvent
-> Publisher (Peer, Message) -> PeerManagerConfig
mgr_config Publisher PeerEvent
mgr_pub Publisher (Peer, Message)
peer_pub) forall a b. (a -> b) -> a -> b
$ \PeerManager
mgr ->
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
ChainConfig -> (Chain -> m a) -> m a
withChain (Publisher ChainEvent -> ChainConfig
chain_config Publisher ChainEvent
ch_pub) forall a b. (a -> b) -> a -> b
$ \Chain
ch ->
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall (m :: * -> *).
MonadLoggerIO m =>
Chain
-> PeerManager
-> Publisher NodeEvent
-> Inbox (Peer, Message)
-> m ()
peerForwarder Chain
ch PeerManager
mgr Publisher NodeEvent
pub Inbox (Peer, Message)
peer_inbox) forall a b. (a -> b) -> a -> b
$ \Async ()
a ->
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall (m :: * -> *).
MonadLoggerIO m =>
Chain -> Publisher NodeEvent -> Inbox PeerEvent -> m ()
managerForwarder Chain
ch Publisher NodeEvent
pub Inbox PeerEvent
mgr_inbox) forall a b. (a -> b) -> a -> b
$ \Async ()
b ->
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall (m :: * -> *).
MonadLoggerIO m =>
PeerManager -> Publisher NodeEvent -> Inbox ChainEvent -> m ()
chainForwarder PeerManager
mgr Publisher NodeEvent
pub Inbox ChainEvent
ch_inbox) forall a b. (a -> b) -> a -> b
$ \Async ()
c ->
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Node -> m a
action Node { nodeManager :: PeerManager
nodeManager = PeerManager
mgr, nodeChain :: Chain
nodeChain = Chain
ch }
where
pub :: Publisher NodeEvent
pub = NodeConfig -> Publisher NodeEvent
nodeConfEvents NodeConfig
cfg
chain_config :: Publisher ChainEvent -> ChainConfig
chain_config Publisher ChainEvent
ch_pub =
ChainConfig
{ chainConfDB :: DB
chainConfDB = NodeConfig -> DB
nodeConfDB NodeConfig
cfg
, chainConfColumnFamily :: Maybe ColumnFamily
chainConfColumnFamily = NodeConfig -> Maybe ColumnFamily
nodeConfColumnFamily NodeConfig
cfg
, chainConfNetwork :: Network
chainConfNetwork = NodeConfig -> Network
nodeConfNet NodeConfig
cfg
, chainConfEvents :: Publisher ChainEvent
chainConfEvents = Publisher ChainEvent
ch_pub
, chainConfTimeout :: NominalDiffTime
chainConfTimeout = NodeConfig -> NominalDiffTime
nodeConfTimeout NodeConfig
cfg
}
mgr_config :: Publisher PeerEvent
-> Publisher (Peer, Message) -> PeerManagerConfig
mgr_config Publisher PeerEvent
mgr_pub Publisher (Peer, Message)
peer_pub =
PeerManagerConfig
{ peerManagerMaxPeers :: Int
peerManagerMaxPeers = NodeConfig -> Int
nodeConfMaxPeers NodeConfig
cfg
, peerManagerPeers :: [String]
peerManagerPeers = NodeConfig -> [String]
nodeConfPeers NodeConfig
cfg
, peerManagerDiscover :: Bool
peerManagerDiscover = NodeConfig -> Bool
nodeConfDiscover NodeConfig
cfg
, peerManagerNetAddr :: NetworkAddress
peerManagerNetAddr = NodeConfig -> NetworkAddress
nodeConfNetAddr NodeConfig
cfg
, peerManagerNetwork :: Network
peerManagerNetwork = NodeConfig -> Network
nodeConfNet NodeConfig
cfg
, peerManagerEvents :: Publisher PeerEvent
peerManagerEvents = Publisher PeerEvent
mgr_pub
, peerManagerMaxLife :: NominalDiffTime
peerManagerMaxLife = NodeConfig -> NominalDiffTime
nodeConfPeerMaxLife NodeConfig
cfg
, peerManagerTimeout :: NominalDiffTime
peerManagerTimeout = NodeConfig -> NominalDiffTime
nodeConfTimeout NodeConfig
cfg
, peerManagerConnect :: SockAddr -> WithConnection
peerManagerConnect = NodeConfig -> SockAddr -> WithConnection
nodeConfConnect NodeConfig
cfg
, peerManagerPub :: Publisher (Peer, Message)
peerManagerPub = Publisher (Peer, Message)
peer_pub
}