{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Network.Haskoin.Node.Common where
import Data.ByteString (ByteString)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Word
import Database.RocksDB (DB)
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Network
import Network.Haskoin.Transaction
import Network.Socket (AddrInfo (..), AddrInfoFlag (..),
Family (..), NameInfoFlag (..),
SockAddr (..), SocketType (..),
addrAddress, defaultHints,
getAddrInfo, getNameInfo)
import NQE
import Text.Read
import UnliftIO
type HostPort = (Host, Port)
type Host = String
type Port = Int
data OnlinePeer = OnlinePeer
{ onlinePeerAddress :: !SockAddr
, onlinePeerConnected :: !Bool
, onlinePeerVersion :: !Word32
, onlinePeerServices :: !Word64
, onlinePeerRemoteNonce :: !Word64
, onlinePeerUserAgent :: !ByteString
, onlinePeerRelay :: !Bool
, onlinePeerBestBlock :: !BlockNode
, onlinePeerAsync :: !(Async ())
, onlinePeerMailbox :: !Peer
, onlinePeerNonce :: !Word64
, onlinePeerPings :: ![NominalDiffTime]
}
type Peer = Inbox PeerMessage
type Chain = Inbox ChainMessage
type Manager = Inbox ManagerMessage
data NodeConfig = NodeConfig
{ maxPeers :: !Int
, database :: !DB
, initPeers :: ![HostPort]
, discover :: !Bool
, nodeEvents :: !(Listen NodeEvent)
, netAddress :: !NetworkAddress
, nodeNet :: !Network
}
data ManagerConfig = ManagerConfig
{ mgrConfMaxPeers :: !Int
, mgrConfDB :: !DB
, mgrConfPeers :: ![HostPort]
, mgrConfDiscover :: !Bool
, mgrConfMgrListener :: !(Listen ManagerEvent)
, mgrConfPeerListener :: !(Listen (Peer, PeerEvent))
, mgrConfNetAddr :: !NetworkAddress
, mgrConfManager :: !Manager
, mgrConfChain :: !Chain
, mgrConfNetwork :: !Network
}
data NodeEvent
= ManagerEvent !ManagerEvent
| ChainEvent !ChainEvent
| PeerEvent !(Peer, PeerEvent)
data ManagerEvent
= ManagerConnect !Peer
| ManagerDisconnect !Peer
data ManagerMessage
= ManagerSetFilter !BloomFilter
| ManagerSetBest !BlockNode
| ManagerPing
| ManagerGetAddr !Peer
| ManagerNewPeers !Peer
![NetworkAddressTime]
| ManagerKill !PeerException
!Peer
| ManagerSetPeerBest !Peer
!BlockNode
| ManagerGetPeerBest !Peer
!(Reply (Maybe BlockNode))
| ManagerSetPeerVersion !Peer
!Version
| ManagerGetPeerVersion !Peer
!(Reply (Maybe Word32))
| ManagerGetPeers !(Reply [OnlinePeer])
| ManagerGetOnlinePeer !Peer !(Reply (Maybe OnlinePeer))
| ManagerPeerPing !Peer
!NominalDiffTime
| PeerStopped !(Async (), Either SomeException ())
data ChainConfig = ChainConfig
{ chainConfDB :: !DB
, chainConfListener :: !(Listen ChainEvent)
, chainConfManager :: !Manager
, chainConfChain :: !Chain
, chainConfNetwork :: !Network
}
data ChainMessage
= ChainNewHeaders !Peer
![BlockHeaderCount]
| ChainNewPeer !Peer
| ChainRemovePeer !Peer
| ChainGetBest !(Reply BlockNode)
| ChainGetAncestor !BlockHeight
!BlockNode
!(Reply (Maybe BlockNode))
| ChainGetSplit !BlockNode
!BlockNode
!(Reply BlockNode)
| ChainGetBlock !BlockHash
!(Reply (Maybe BlockNode))
| ChainNewBlocks !Peer ![BlockHash]
| ChainSendHeaders !Peer
| ChainIsSynced !(Reply Bool)
data ChainEvent
= ChainNewBest !BlockNode
| ChainSynced !BlockNode
deriving (Eq, Show)
data PeerConfig = PeerConfig
{ peerConfConnect :: !NetworkAddress
, peerConfLocal :: !NetworkAddress
, peerConfManager :: !Manager
, peerConfChain :: !Chain
, peerConfListener :: !(Listen (Peer, PeerEvent))
, peerConfNonce :: !Word64
, peerConfNetwork :: !Network
}
data PeerException
= PeerMisbehaving !String
| DecodeMessageError !String
| CannotDecodePayload !String
| PeerIsMyself
| PayloadTooLarge !Word32
| PeerAddressInvalid
| BloomFiltersNotSupported
| PeerSentBadHeaders
| NotNetworkPeer
| PeerNoSegWit
| PeerTimeout
deriving (Eq, Show)
instance Exception PeerException
data PeerEvent
= TxAvail ![TxHash]
| GotBlock !Block
| GotMerkleBlock !MerkleBlock
| GotTx !Tx
| GotPong !Word64
| SendBlocks !GetBlocks
| SendHeaders !GetHeaders
| SendData ![InvVector]
| TxNotFound !TxHash
| BlockNotFound !BlockHash
| WantMempool
| Rejected !Reject
data PeerMessage
= PeerOutgoing !Message
| PeerIncoming !Message
toSockAddr :: (MonadUnliftIO m) => HostPort -> m [SockAddr]
toSockAddr (host, port) = go `catch` e
where
go =
fmap (map addrAddress) . liftIO $
getAddrInfo
(Just
defaultHints
{ addrFlags = [AI_ADDRCONFIG]
, addrSocketType = Stream
, addrFamily = AF_INET
})
(Just host)
(Just (show port))
e :: Monad m => SomeException -> m [SockAddr]
e _ = return []
fromSockAddr ::
(MonadUnliftIO m) => SockAddr -> m (Maybe HostPort)
fromSockAddr sa = go `catch` e
where
go = do
(hostM, portM) <- liftIO (getNameInfo flags True True sa)
return $ (,) <$> hostM <*> (readMaybe =<< portM)
flags = [NI_NUMERICHOST, NI_NUMERICSERV]
e :: Monad m => SomeException -> m (Maybe a)
e _ = return Nothing
computeTime :: MonadIO m => m Word32
computeTime = round <$> liftIO getPOSIXTime
myVersion :: Word32
myVersion = 70012
managerSetBest :: MonadIO m => BlockNode -> Manager -> m ()
managerSetBest bn mgr = ManagerSetBest bn `send` mgr
managerSetPeerVersion :: MonadIO m => Peer -> Version -> Manager -> m ()
managerSetPeerVersion p v mgr = ManagerSetPeerVersion p v `send` mgr
managerGetPeerVersion :: MonadIO m => Peer -> Manager -> m (Maybe Word32)
managerGetPeerVersion p mgr = ManagerGetPeerVersion p `query` mgr
managerGetPeerBest :: MonadIO m => Peer -> Manager -> m (Maybe BlockNode)
managerGetPeerBest p mgr = ManagerGetPeerBest p `query` mgr
managerSetPeerBest :: MonadIO m => Peer -> BlockNode -> Manager -> m ()
managerSetPeerBest p bn mgr = ManagerSetPeerBest p bn `send` mgr
managerGetPeers :: MonadIO m => Manager -> m [OnlinePeer]
managerGetPeers mgr = ManagerGetPeers `query` mgr
managerGetPeer :: MonadIO m => Manager -> Peer -> m (Maybe OnlinePeer)
managerGetPeer mgr p = ManagerGetOnlinePeer p `query` mgr
managerGetAddr :: MonadIO m => Peer -> Manager -> m ()
managerGetAddr p mgr = ManagerGetAddr p `send` mgr
managerKill :: MonadIO m => PeerException -> Peer -> Manager -> m ()
managerKill e p mgr = ManagerKill e p `send` mgr
managerNewPeers ::
MonadIO m => Peer -> [NetworkAddressTime] -> Manager -> m ()
managerNewPeers p as mgr = ManagerNewPeers p as `send` mgr
setManagerFilter :: MonadIO m => BloomFilter -> Manager -> m ()
setManagerFilter bf mgr = ManagerSetFilter bf `send` mgr
sendMessage :: MonadIO m => Message -> Peer -> m ()
sendMessage msg p = PeerOutgoing msg `send` p
peerSetFilter :: MonadIO m => BloomFilter -> Peer -> m ()
peerSetFilter f p = MFilterLoad (FilterLoad f) `sendMessage` p
getMerkleBlocks ::
(MonadIO m)
=> Peer
-> [BlockHash]
-> m ()
getMerkleBlocks p bhs = PeerOutgoing (MGetData (GetData ivs)) `send` p
where
ivs = map (InvVector InvMerkleBlock . getBlockHash) bhs
peerGetBlocks ::
MonadIO m => Network -> Peer -> [BlockHash] -> m ()
peerGetBlocks net p bhs = PeerOutgoing (MGetData (GetData ivs)) `send` p
where
con
| getSegWit net = InvWitnessBlock
| otherwise = InvBlock
ivs = map (InvVector con . getBlockHash) bhs
peerGetTxs :: MonadIO m => Network -> Peer -> [TxHash] -> m ()
peerGetTxs net p ths = PeerOutgoing (MGetData (GetData ivs)) `send` p
where
con
| getSegWit net = InvWitnessTx
| otherwise = InvTx
ivs = map (InvVector con . getTxHash) ths
buildVersion ::
MonadIO m
=> Network
-> Word64
-> BlockHeight
-> NetworkAddress
-> NetworkAddress
-> m Version
buildVersion net nonce height loc rmt = do
time <- fromIntegral <$> computeTime
return
Version
{ version = myVersion
, services = naServices loc
, timestamp = time
, addrRecv = rmt
, addrSend = loc
, verNonce = nonce
, userAgent = VarString (getHaskoinUserAgent net)
, startHeight = height
, relay = True
}
chainNewPeer :: MonadIO m => Peer -> Chain -> m ()
chainNewPeer p ch = ChainNewPeer p `send` ch
chainRemovePeer :: MonadIO m => Peer -> Chain -> m ()
chainRemovePeer p ch = ChainRemovePeer p `send` ch
chainGetBlock :: MonadIO m => BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock bh ch = ChainGetBlock bh `query` ch
chainGetBest :: MonadIO m => Chain -> m BlockNode
chainGetBest ch = ChainGetBest `query` ch
chainGetAncestor ::
MonadIO m => BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor h n c = ChainGetAncestor h n `query` c
chainGetParents ::
MonadIO m => BlockHeight -> BlockNode -> Chain -> m [BlockNode]
chainGetParents height top ch = go [] top
where
go acc b
| height >= nodeHeight b = return acc
| otherwise = do
m <- chainGetBlock (prevBlock $ nodeHeader b) ch
case m of
Nothing -> return acc
Just p -> go (p : acc) p
chainGetSplitBlock ::
MonadIO m => BlockNode -> BlockNode -> Chain -> m BlockNode
chainGetSplitBlock l r c = ChainGetSplit l r `query` c
chainBlockMain :: MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain bh ch =
chainGetBest ch >>= \bb ->
chainGetBlock bh ch >>= \case
Nothing -> return False
bm@(Just bn) -> (== bm) <$> chainGetAncestor (nodeHeight bn) bb ch
chainIsSynced :: MonadIO m => Chain -> m Bool
chainIsSynced ch = ChainIsSynced `query` ch