{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Network.Haskoin.Node.Common where
import Conduit
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Conduit.Network
import Data.Function
import Data.List
import Data.Maybe
import Data.String.Conversions
import Data.Time.Clock
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 hiding (send)
import NQE
import System.Random
import Text.Read
import UnliftIO
type HostPort = (Host, Port)
type Host = String
type Port = Int
data OnlinePeer = OnlinePeer
{ onlinePeerAddress :: !SockAddr
, onlinePeerVerAck :: !Bool
, onlinePeerConnected :: !Bool
, onlinePeerVersion :: !(Maybe Version)
, onlinePeerAsync :: !(Async ())
, onlinePeerMailbox :: !Peer
, onlinePeerNonce :: !Word64
, onlinePeerPing :: !(Maybe (UTCTime, Word64))
, onlinePeerPings :: ![NominalDiffTime]
}
instance Eq OnlinePeer where
(==) = (==) `on` f
where
f OnlinePeer {onlinePeerMailbox = p} = p
instance Ord OnlinePeer where
compare = compare `on` f
where
f OnlinePeer {onlinePeerPings = pings} = fromMaybe 60 (median pings)
type Peer = Mailbox PeerMessage
type Chain = Mailbox ChainMessage
type Manager = Mailbox ManagerMessage
data NodeConfig = NodeConfig
{ nodeConfMaxPeers :: !Int
, nodeConfDB :: !DB
, nodeConfPeers :: ![HostPort]
, nodeConfDiscover :: !Bool
, nodeConfNetAddr :: !NetworkAddress
, nodeConfNet :: !Network
, nodeConfEvents :: !(Listen NodeEvent)
, nodeConfTimeout :: !Int
}
data ManagerConfig = ManagerConfig
{ mgrConfMaxPeers :: !Int
, mgrConfDB :: !DB
, mgrConfPeers :: ![HostPort]
, mgrConfDiscover :: !Bool
, mgrConfNetAddr :: !NetworkAddress
, mgrConfNetwork :: !Network
, mgrConfEvents :: !(Listen PeerEvent)
, mgrConfTimeout :: !Int
}
data ManagerMessage
= ManagerConnect
| ManagerGetPeers !(Listen [OnlinePeer])
| ManagerGetOnlinePeer !Peer !(Listen (Maybe OnlinePeer))
| ManagerPurgePeers
| ManagerCheckPeer !Peer
| ManagerPeerMessage !Peer !Message
| ManagerPeerDied !Child !(Maybe SomeException)
| ManagerBestBlock !BlockHeight
data ChainConfig = ChainConfig
{ chainConfDB :: !DB
, chainConfNetwork :: !Network
, chainConfEvents :: !(Listen ChainEvent)
, chainConfTimeout :: !Int
}
data ChainMessage
= ChainGetBest !(Listen BlockNode)
| ChainHeaders !Peer
![BlockHeader]
| ChainGetAncestor !BlockHeight
!BlockNode
!(Listen (Maybe BlockNode))
| ChainGetSplit !BlockNode
!BlockNode
!(Listen BlockNode)
| ChainGetBlock !BlockHash
!(Listen (Maybe BlockNode))
| ChainIsSynced !(Listen Bool)
| ChainPing
| ChainPeerConnected !Peer
!SockAddr
| ChainPeerDisconnected !Peer
!SockAddr
data ChainEvent
= ChainBestBlock !BlockNode
| ChainSynced !BlockNode
deriving (Eq, Show)
data NodeEvent
= ChainEvent !ChainEvent
| PeerEvent !PeerEvent
deriving Eq
data PeerConfig = PeerConfig
{ peerConfListen :: !(Publisher Message)
, peerConfNetwork :: !Network
, peerConfAddress :: !SockAddr
}
data PeerException
= PeerMisbehaving !String
| DuplicateVersion
| DecodeHeaderError
| CannotDecodePayload
| PeerIsMyself
| PayloadTooLarge !Word32
| PeerAddressInvalid
| PeerSentBadHeaders
| NotNetworkPeer
| PeerNoSegWit
| PeerTimeout
| PurgingPeer
| UnknownPeer
deriving (Eq, Show)
instance Exception PeerException
data PeerEvent
= PeerConnected !Peer
!SockAddr
| PeerDisconnected !Peer
!SockAddr
| PeerMessage !Peer
!Message
deriving Eq
data PeerMessage
= GetPublisher !(Listen (Publisher Message))
| KillPeer !PeerException
| SendMessage !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
(maybe_host, maybe_port) <- liftIO (getNameInfo flags True True sa)
return $ (,) <$> maybe_host <*> (readMaybe =<< maybe_port)
flags = [NI_NUMERICHOST, NI_NUMERICSERV]
e :: Monad m => SomeException -> m (Maybe a)
e _ = return Nothing
myVersion :: Word32
myVersion = 70012
managerPeerMessage :: MonadIO m => Peer -> Message -> Manager -> m ()
managerPeerMessage p msg mgr = ManagerPeerMessage p msg `send` mgr
managerGetPeers ::
MonadIO m => Manager -> m [OnlinePeer]
managerGetPeers mgr = ManagerGetPeers `query` mgr
managerGetPeer :: MonadIO m => Peer -> Manager -> m (Maybe OnlinePeer)
managerGetPeer p mgr = ManagerGetOnlinePeer p `query` mgr
killPeer :: MonadIO m => PeerException -> Peer -> m ()
killPeer e p = KillPeer e `send` p
managerCheck :: MonadIO m => Peer -> Manager -> m ()
managerCheck p mgr = ManagerCheckPeer p `send` mgr
managerConnect :: MonadIO m => Manager -> m ()
managerConnect mgr = ManagerConnect `send` mgr
managerSetBest :: MonadIO m => BlockHeight -> Manager -> m ()
managerSetBest bh mgr = ManagerBestBlock bh `send` mgr
sendMessage :: MonadIO m => Message -> Peer -> m ()
sendMessage msg p = SendMessage msg `send` p
peerGetPublisher ::
MonadUnliftIO m => Int -> Peer -> m (Maybe (Publisher Message))
peerGetPublisher time = queryS time GetPublisher
peerGetBlocks ::
MonadUnliftIO m
=> Network
-> Int
-> Peer
-> [BlockHash]
-> m (Maybe [Block])
peerGetBlocks net time p bhs =
runMaybeT $ mapM f =<< MaybeT (peerGetData time p (GetData ivs))
where
f (Right b) = return b
f (Left _) = MaybeT $ return Nothing
c
| getSegWit net = InvWitnessBlock
| otherwise = InvBlock
ivs = map (InvVector c . getBlockHash) bhs
peerGetTxs ::
MonadUnliftIO m
=> Network
-> Int
-> Peer
-> [TxHash]
-> m (Maybe [Tx])
peerGetTxs net time p ths =
runMaybeT $ mapM f =<< MaybeT (peerGetData time p (GetData ivs))
where
f (Right _) = MaybeT $ return Nothing
f (Left t) = return t
c
| getSegWit net = InvWitnessTx
| otherwise = InvTx
ivs = map (InvVector c . getTxHash) ths
peerGetData ::
MonadUnliftIO m => Int -> Peer -> GetData -> m (Maybe [Either Tx Block])
peerGetData time p gd@(GetData ivs) =
runMaybeT $ do
pub <- MaybeT $ queryS time GetPublisher p
MaybeT $
withSubscription pub $ \sub -> do
MGetData gd `sendMessage` p
r <- liftIO randomIO
MPing (Ping r) `sendMessage` p
join <$>
timeout
(time * 1000 * 1000)
(runMaybeT (get_thing sub r [] ivs))
where
get_thing _ _ acc [] = return $ reverse acc
get_thing sub r acc hss@(InvVector t h:hs) =
receive sub >>= \case
MTx tx
| is_tx t && getTxHash (txHash tx) == h ->
get_thing sub r (Left tx : acc) hs
MBlock b@(Block bh _)
| is_block t && getBlockHash (headerHash bh) == h ->
get_thing sub r (Right b : acc) hs
MNotFound (NotFound nvs)
| not (null (nvs `union` hs)) -> MaybeT $ return Nothing
MPong (Pong r')
| r == r' -> MaybeT $ return Nothing
_
| null acc -> get_thing sub r acc hss
| otherwise -> MaybeT $ return Nothing
is_tx InvWitnessTx = True
is_tx InvTx = True
is_tx _ = False
is_block InvWitnessBlock = True
is_block InvBlock = True
is_block _ = False
peerPing :: MonadUnliftIO m => Int -> Peer -> m Bool
peerPing time p =
fmap isJust . runMaybeT $ do
pub <- MaybeT $ queryS time GetPublisher p
MaybeT $
withSubscription pub $ \sub -> do
r <- liftIO randomIO
MPing (Ping r) `sendMessage` p
receiveMatchS time sub $ \case
MPong (Pong r')
| r == r' -> Just ()
_ -> Nothing
buildVersion ::
Network
-> Word64
-> BlockHeight
-> NetworkAddress
-> NetworkAddress
-> Word64
-> Version
buildVersion net nonce height loc rmt time =
Version
{ version = myVersion
, services = naServices loc
, timestamp = time
, addrRecv = rmt
, addrSend = loc
, verNonce = nonce
, userAgent = VarString (getHaskoinUserAgent net)
, startHeight = height
, relay = True
}
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
chainPeerConnected :: MonadIO m => Peer -> SockAddr -> Chain -> m ()
chainPeerConnected p a ch = ChainPeerConnected p a `send` ch
chainPeerDisconnected :: MonadIO m => Peer -> SockAddr -> Chain -> m ()
chainPeerDisconnected p a ch = ChainPeerDisconnected p a `send` ch
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
chainHeaders :: MonadIO m => Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders p hs ch = ChainHeaders p hs `send` ch
withConnection ::
MonadUnliftIO m => SockAddr -> (AppData -> m a) -> m a
withConnection na f =
fromSockAddr na >>= \case
Nothing -> throwIO PeerAddressInvalid
Just (host, port) ->
let cset = clientSettings port (cs host)
in runGeneralTCPClient cset f
median :: Fractional a => [a] -> Maybe a
median ls
| null ls = Nothing
| length ls `mod` 2 == 0 =
Just . (/ 2) . sum . take 2 $ drop (length ls `div` 2 - 1) ls
| otherwise = Just . head $ drop (length ls `div` 2) ls