{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
module Haskoin.Node
( module Haskoin.Node.Peer,
module Haskoin.Node.PeerMgr,
module Haskoin.Node.Chain,
NodeConfig (..),
NodeEvent (..),
Node (..),
withNode,
withConnection,
)
where
import Control.Monad (forever)
import Control.Monad.Cont (ContT (..), MonadCont (callCC), cont, lift, runCont, runContT)
import Control.Monad.Logger (MonadLoggerIO)
import Data.Conduit.Network
( ClientSettings,
appSink,
appSource,
clientSettings,
runTCPClient,
)
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.Peer
import Haskoin.Node.PeerMgr
import NQE
( Inbox,
Publisher,
publish,
receive,
withPublisher,
withSubscription,
)
import Network.Socket
( NameInfoFlag (..),
SockAddr,
getNameInfo,
)
import Text.Read (readMaybe)
import UnliftIO
( MonadUnliftIO,
SomeException,
catch,
liftIO,
link,
throwIO,
withAsync,
)
data NodeConfig = NodeConfig
{
NodeConfig -> Int
maxPeers :: !Int,
NodeConfig -> DB
db :: !DB,
NodeConfig -> Maybe ColumnFamily
cf :: !(Maybe ColumnFamily),
NodeConfig -> [String]
peers :: ![String],
NodeConfig -> Bool
discover :: !Bool,
NodeConfig -> NetworkAddress
address :: !NetworkAddress,
NodeConfig -> Network
net :: !Network,
NodeConfig -> Publisher NodeEvent
pub :: !(Publisher NodeEvent),
NodeConfig -> NominalDiffTime
timeout :: !NominalDiffTime,
NodeConfig -> NominalDiffTime
maxPeerLife :: !NominalDiffTime,
NodeConfig -> SockAddr -> WithConnection
connect :: !(SockAddr -> WithConnection)
}
data Node = Node
{ Node -> PeerMgr
peerMgr :: !PeerMgr,
Node -> Chain
chain :: !Chain
}
data NodeEvent
= ChainEvent !ChainEvent
| PeerEvent !PeerEvent
deriving (NodeEvent -> NodeEvent -> Bool
(NodeEvent -> NodeEvent -> Bool)
-> (NodeEvent -> NodeEvent -> Bool) -> Eq NodeEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeEvent -> NodeEvent -> Bool
== :: NodeEvent -> NodeEvent -> Bool
$c/= :: NodeEvent -> NodeEvent -> Bool
/= :: NodeEvent -> NodeEvent -> Bool
Eq)
withConnection :: SockAddr -> WithConnection
withConnection :: SockAddr -> WithConnection
withConnection SockAddr
na Conduits -> IO ()
f =
SockAddr -> IO (Maybe ClientSettings)
forall (m :: * -> *).
MonadUnliftIO m =>
SockAddr -> m (Maybe ClientSettings)
fromSockAddr SockAddr
na IO (Maybe ClientSettings)
-> (Maybe ClientSettings -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ClientSettings
Nothing -> PeerException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PeerException
PeerAddressInvalid
Just ClientSettings
cset ->
ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient ClientSettings
cset ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppData
ad ->
Conduits -> IO ()
f (ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> Conduits
Conduits (AppData -> ConduitT () ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource AppData
ad) (AppData -> ConduitT ByteString Void IO ()
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 m (Maybe ClientSettings)
-> (SomeException -> m (Maybe ClientSettings))
-> m (Maybe ClientSettings)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m (Maybe ClientSettings)
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) <- IO (Maybe String, Maybe String) -> m (Maybe String, Maybe String)
forall a. IO a -> m a
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)
Maybe ClientSettings -> m (Maybe ClientSettings)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ClientSettings -> m (Maybe ClientSettings))
-> Maybe ClientSettings -> m (Maybe ClientSettings)
forall a b. (a -> b) -> a -> b
$
Int -> ByteString -> ClientSettings
clientSettings
(Int -> ByteString -> ClientSettings)
-> Maybe Int -> Maybe (ByteString -> ClientSettings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
maybe_port)
Maybe (ByteString -> ClientSettings)
-> Maybe ByteString -> Maybe ClientSettings
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (String -> ByteString) -> Maybe String -> Maybe ByteString
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
_ = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
chainEvents ::
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerMgr ->
Inbox ChainEvent ->
Publisher NodeEvent ->
m ()
chainEvents :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerMgr -> Inbox ChainEvent -> Publisher NodeEvent -> m ()
chainEvents PeerMgr
mgr Inbox ChainEvent
input Publisher NodeEvent
output = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ChainEvent
event <- Inbox ChainEvent -> m ChainEvent
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox ChainEvent
input
case ChainEvent
event of
ChainBestBlock BlockNode
bb ->
BlockHeight -> PeerMgr -> m ()
forall (m :: * -> *). MonadIO m => BlockHeight -> PeerMgr -> m ()
peerMgrBest BlockNode
bb.height PeerMgr
mgr
ChainEvent
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
NodeEvent -> Publisher NodeEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (ChainEvent -> NodeEvent
ChainEvent ChainEvent
event) Publisher NodeEvent
output
peerEvents ::
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain ->
PeerMgr ->
Inbox PeerEvent ->
Publisher NodeEvent ->
m ()
peerEvents :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> PeerMgr -> Inbox PeerEvent -> Publisher NodeEvent -> m ()
peerEvents Chain
ch PeerMgr
mgr Inbox PeerEvent
input Publisher NodeEvent
output = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
PeerEvent
event <- Inbox PeerEvent -> m PeerEvent
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox PeerEvent
input
case PeerEvent
event of
PeerConnected Peer
p ->
Peer -> Chain -> m ()
forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerConnected Peer
p Chain
ch
PeerDisconnected Peer
p ->
Peer -> Chain -> m ()
forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerDisconnected Peer
p Chain
ch
PeerMessage Peer
p Message
msg -> do
case Message
msg of
MVersion Version
v ->
Peer -> Version -> PeerMgr -> m ()
forall (m :: * -> *).
MonadIO m =>
Peer -> Version -> PeerMgr -> m ()
peerMgrVersion Peer
p Version
v PeerMgr
mgr
Message
MVerAck ->
Peer -> PeerMgr -> m ()
forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
peerMgrVerAck Peer
p PeerMgr
mgr
MPing (Ping Word64
n) ->
Peer -> Word64 -> PeerMgr -> m ()
forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerMgr -> m ()
peerMgrPing Peer
p Word64
n PeerMgr
mgr
MPong (Pong Word64
n) ->
Peer -> Word64 -> PeerMgr -> m ()
forall (m :: * -> *).
MonadIO m =>
Peer -> Word64 -> PeerMgr -> m ()
peerMgrPong Peer
p Word64
n PeerMgr
mgr
MAddr (Addr [NetworkAddressTime]
ns) ->
Peer -> [NetworkAddress] -> PeerMgr -> m ()
forall (m :: * -> *).
MonadIO m =>
Peer -> [NetworkAddress] -> PeerMgr -> m ()
peerMgrAddrs Peer
p ((NetworkAddressTime -> NetworkAddress)
-> [NetworkAddressTime] -> [NetworkAddress]
forall a b. (a -> b) -> [a] -> [b]
map NetworkAddressTime -> NetworkAddress
forall a b. (a, b) -> b
snd [NetworkAddressTime]
ns) PeerMgr
mgr
MHeaders (Headers [BlockHeaderCount]
hs) ->
Peer -> [BlockHeader] -> Chain -> m ()
forall (m :: * -> *).
MonadIO m =>
Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders Peer
p ((BlockHeaderCount -> BlockHeader)
-> [BlockHeaderCount] -> [BlockHeader]
forall a b. (a -> b) -> [a] -> [b]
map BlockHeaderCount -> BlockHeader
forall a b. (a, b) -> a
fst [BlockHeaderCount]
hs) Chain
ch
Message
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Peer -> PeerMgr -> m ()
forall (m :: * -> *). MonadIO m => Peer -> PeerMgr -> m ()
peerMgrTickle Peer
p PeerMgr
mgr
NodeEvent -> Publisher NodeEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (PeerEvent -> NodeEvent
PeerEvent PeerEvent
event) Publisher NodeEvent
output
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 {Bool
Int
[String]
Maybe ColumnFamily
NetworkAddress
Network
Publisher NodeEvent
DB
NominalDiffTime
SockAddr -> WithConnection
$sel:maxPeers:NodeConfig :: NodeConfig -> Int
$sel:db:NodeConfig :: NodeConfig -> DB
$sel:cf:NodeConfig :: NodeConfig -> Maybe ColumnFamily
$sel:peers:NodeConfig :: NodeConfig -> [String]
$sel:discover:NodeConfig :: NodeConfig -> Bool
$sel:address:NodeConfig :: NodeConfig -> NetworkAddress
$sel:net:NodeConfig :: NodeConfig -> Network
$sel:pub:NodeConfig :: NodeConfig -> Publisher NodeEvent
$sel:timeout:NodeConfig :: NodeConfig -> NominalDiffTime
$sel:maxPeerLife:NodeConfig :: NodeConfig -> NominalDiffTime
$sel:connect:NodeConfig :: NodeConfig -> SockAddr -> WithConnection
maxPeers :: Int
db :: DB
cf :: Maybe ColumnFamily
peers :: [String]
discover :: Bool
address :: NetworkAddress
net :: Network
pub :: Publisher NodeEvent
timeout :: NominalDiffTime
maxPeerLife :: NominalDiffTime
connect :: SockAddr -> WithConnection
..} Node -> m a
action = (ContT a m a -> (a -> m a) -> m a)
-> (a -> m a) -> ContT a m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContT a m a -> (a -> m a) -> m a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContT a m a -> m a) -> ContT a m a -> m a
forall a b. (a -> b) -> a -> b
$ do
Publisher PeerEvent
peerPub <- ((Publisher PeerEvent -> m a) -> m a)
-> ContT a m (Publisher PeerEvent)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Publisher PeerEvent -> m a) -> m a
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
(Publisher msg -> m a) -> m a
withPublisher
Inbox PeerEvent
peerSub <- ((Inbox PeerEvent -> m a) -> m a) -> ContT a m (Inbox PeerEvent)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Publisher PeerEvent -> (Inbox PeerEvent -> m a) -> m a
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription Publisher PeerEvent
peerPub)
Publisher ChainEvent
chainPub <- ((Publisher ChainEvent -> m a) -> m a)
-> ContT a m (Publisher ChainEvent)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Publisher ChainEvent -> m a) -> m a
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
(Publisher msg -> m a) -> m a
withPublisher
Inbox ChainEvent
chainSub <- ((Inbox ChainEvent -> m a) -> m a) -> ContT a m (Inbox ChainEvent)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Publisher ChainEvent -> (Inbox ChainEvent -> m a) -> m a
forall (m :: * -> *) msg a.
MonadUnliftIO m =>
Publisher msg -> (Inbox msg -> m a) -> m a
withSubscription Publisher ChainEvent
chainPub)
let peerMgrCfg :: PeerMgrConfig
peerMgrCfg = PeerMgrConfig {$sel:pub:PeerMgrConfig :: Publisher PeerEvent
pub = Publisher PeerEvent
peerPub, Bool
Int
[String]
NetworkAddress
Network
NominalDiffTime
SockAddr -> WithConnection
maxPeers :: Int
peers :: [String]
discover :: Bool
address :: NetworkAddress
net :: Network
timeout :: NominalDiffTime
maxPeerLife :: NominalDiffTime
connect :: SockAddr -> WithConnection
$sel:maxPeers:PeerMgrConfig :: Int
$sel:peers:PeerMgrConfig :: [String]
$sel:discover:PeerMgrConfig :: Bool
$sel:address:PeerMgrConfig :: NetworkAddress
$sel:net:PeerMgrConfig :: Network
$sel:timeout:PeerMgrConfig :: NominalDiffTime
$sel:maxPeerLife:PeerMgrConfig :: NominalDiffTime
$sel:connect:PeerMgrConfig :: SockAddr -> WithConnection
..}
let chainCfg :: ChainConfig
chainCfg = ChainConfig {$sel:pub:ChainConfig :: Publisher ChainEvent
pub = Publisher ChainEvent
chainPub, Maybe ColumnFamily
Network
DB
NominalDiffTime
db :: DB
cf :: Maybe ColumnFamily
net :: Network
timeout :: NominalDiffTime
$sel:db:ChainConfig :: DB
$sel:cf:ChainConfig :: Maybe ColumnFamily
$sel:net:ChainConfig :: Network
$sel:timeout:ChainConfig :: NominalDiffTime
..}
Chain
chain <- ((Chain -> m a) -> m a) -> ContT a m Chain
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (ChainConfig -> (Chain -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
ChainConfig -> (Chain -> m a) -> m a
withChain ChainConfig
chainCfg)
PeerMgr
peerMgr <- ((PeerMgr -> m a) -> m a) -> ContT a m PeerMgr
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((PeerMgr -> m a) -> m a) -> ContT a m PeerMgr)
-> ((PeerMgr -> m a) -> m a) -> ContT a m PeerMgr
forall a b. (a -> b) -> a -> b
$ PeerMgrConfig -> (PeerMgr -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerMgrConfig -> (PeerMgr -> m a) -> m a
withPeerMgr PeerMgrConfig
peerMgrCfg
m () -> ContT a m ()
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ContT a m ())
-> (Async () -> m ()) -> Async () -> ContT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link (Async () -> ContT a m ()) -> ContT a m (Async ()) -> ContT a m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Async () -> m a) -> m a) -> ContT a m (Async ())
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (m () -> (Async () -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (m () -> (Async () -> m a) -> m a)
-> m () -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ PeerMgr -> Inbox ChainEvent -> Publisher NodeEvent -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PeerMgr -> Inbox ChainEvent -> Publisher NodeEvent -> m ()
chainEvents PeerMgr
peerMgr Inbox ChainEvent
chainSub Publisher NodeEvent
pub)
m () -> ContT a m ()
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ContT a m ())
-> (Async () -> m ()) -> Async () -> ContT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link (Async () -> ContT a m ()) -> ContT a m (Async ()) -> ContT a m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Async () -> m a) -> m a) -> ContT a m (Async ())
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (m () -> (Async () -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (m () -> (Async () -> m a) -> m a)
-> m () -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ Chain -> PeerMgr -> Inbox PeerEvent -> Publisher NodeEvent -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> PeerMgr -> Inbox PeerEvent -> Publisher NodeEvent -> m ()
peerEvents Chain
chain PeerMgr
peerMgr Inbox PeerEvent
peerSub Publisher NodeEvent
pub)
m a -> ContT a m a
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ContT a m a) -> m a -> ContT a m a
forall a b. (a -> b) -> a -> b
$ Node -> m a
action Node {PeerMgr
Chain
$sel:peerMgr:Node :: PeerMgr
$sel:chain:Node :: Chain
chain :: Chain
peerMgr :: PeerMgr
..}