{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Trans
import qualified Data.ByteString as BS
import Data.Either
import Data.Maybe
import Data.Serialize
import qualified Database.RocksDB as RocksDB
import Haskoin
import Haskoin.Node
import Network.Socket (SockAddr (..))
import NQE
import System.Random
import Test.Hspec
import UnliftIO
data TestNode = TestNode
{ testMgr :: Manager
, testChain :: Chain
, testEvents :: Inbox NodeEvent
}
main :: IO ()
main = do
let net = btcTest
hspec . describe "peer-to-peer client" $ do
it "connects to a peer" $
withTestNode net "connect-one-peer" $ \TestNode {..} -> do
p <-
receiveMatch testEvents $ \case
ManagerEvent (ManagerConnect p) -> Just p
_ -> Nothing
v <-
fromMaybe (error "No version") <$>
managerGetPeerVersion p testMgr
v `shouldSatisfy` (>= 70002)
bb <-
fromMaybe (error "No best block") <$>
managerGetPeerBest p testMgr
bb `shouldBe` genesisNode net
it "downloads some blocks" $
withTestNode net "get-blocks" $ \TestNode {..} -> do
let hs = [h1, h2]
h1 =
"000000000babf10e26f6cba54d9c282983f1d1ce7061f7e875b58f8ca47db932"
h2 =
"00000000851f278a8b2c466717184aae859af5b83c6f850666afbc349cf61577"
p <-
receiveMatch testEvents $ \case
ManagerEvent (ManagerConnect p) -> Just p
_ -> Nothing
peerGetBlocks net p hs
b1 <-
receiveMatch testEvents $ \case
PeerEvent (p', GotBlock b)
| p == p' -> Just b
_ -> Nothing
b2 <-
receiveMatch testEvents $ \case
PeerEvent (p', GotBlock b)
| p == p' -> Just b
_ -> Nothing
headerHash (blockHeader b1) `shouldSatisfy` (`elem` hs)
headerHash (blockHeader b2) `shouldSatisfy` (`elem` hs)
let testMerkle b =
merkleRoot (blockHeader b) `shouldBe`
buildMerkleRoot (map txHash (blockTxns b))
testMerkle b1
testMerkle b2
it "downloads some merkle blocks" $
withTestNode net "get-merkle-blocks" $ \TestNode {..} -> do
let a =
fromJust $
stringToAddr net "mgpS4Zis8iwNhriKMro1QSGDAbY6pqzRtA"
k :: PubKey
k =
"02c3cface1777c70251cb206f7c80cabeae195dfbeeff0767cbd2a58d22be383da"
h1 =
"000000006cf9d53d65522002a01d8c7091c78d644106832bc3da0b7644f94d36"
h2 =
"000000000babf10e26f6cba54d9c282983f1d1ce7061f7e875b58f8ca47db932"
bhs = [h1, h2]
n <- randomIO
let f0 = bloomCreate 2 0.001 n BloomUpdateAll
f1 = bloomInsert f0 $ exportPubKey True k
f2 = bloomInsert f1 $ encode $ getAddrHash160 a
f2 `setManagerFilter` testMgr
p <-
receiveMatch testEvents $ \case
ManagerEvent (ManagerConnect p) -> Just p
_ -> Nothing
getMerkleBlocks p bhs
b1 <-
receiveMatch testEvents $ \case
PeerEvent (p', GotMerkleBlock b)
| p == p' -> Just b
_ -> Nothing
b2 <-
receiveMatch testEvents $ \case
PeerEvent (p', GotMerkleBlock b)
| p == p' -> Just b
_ -> Nothing
liftIO $ do
a `shouldBe` pubKeyAddr net (wrapPubKey True k)
b1 `shouldSatisfy` testMerkleRoot net
b2 `shouldSatisfy` testMerkleRoot net
it "connects to multiple peers" $
withTestNode net "connect-peers" $ \TestNode {..} -> do
replicateM_ 3 $ do
pc <- receive testEvents
case pc of
ManagerEvent (ManagerDisconnect _) ->
expectationFailure "Received peer disconnection"
_ -> return ()
ps <- managerGetPeers testMgr
length ps `shouldSatisfy` (>= 2)
it "connects and syncs some headers" $
withTestNode net "connect-sync" $ \TestNode {..} -> do
let h =
"000000009ec921df4bb16aedd11567e27ede3c0b63835b257475d64a059f102b"
hs =
[ "0000000005bdbddb59a3cd33b69db94fa67669c41d9d32751512b5d7b68c71cf"
, "00000000185b36fa6e406626a722793bea80531515e0b2a99ff05b73738901f1"
, "000000001ab69b12b73ccdf46c9fbb4489e144b54f1565e42e481c8405077bdd"
]
bns <-
replicateM 3 . receiveMatch testEvents $ \case
ChainEvent (ChainNewBest bn) -> Just bn
_ -> Nothing
bb <- chainGetBest testChain
an <-
fromMaybe (error "No ancestor found") <$>
chainGetAncestor 2357 (last bns) testChain
map (headerHash . nodeHeader) bns `shouldBe` hs
nodeHeight bb `shouldSatisfy` (>= 6000)
headerHash (nodeHeader an) `shouldBe` h
it "downloads a single block" $
withTestNode net "download-block" $ \TestNode {..} -> do
let h =
"000000009ec921df4bb16aedd11567e27ede3c0b63835b257475d64a059f102b"
p <-
receiveMatch testEvents $ \case
ManagerEvent (ManagerConnect p) -> Just p
_ -> Nothing
peerGetBlocks net p [h]
b <-
receiveMatch testEvents $ \case
PeerEvent (p', GotBlock b)
| p == p' -> Just b
_ -> Nothing
headerHash (blockHeader b) `shouldBe` h
it "attempts to get inexistent things" $
withTestNode net "download-fail" $ \TestNode {..} -> do
let h =
TxHash .
fromRight (error "We will, we will rock you!") . decode $
BS.replicate 32 0xaa
p <-
receiveMatch testEvents $ \case
ManagerEvent (ManagerConnect p) -> Just p
_ -> Nothing
peerGetTxs net p [h]
n <-
receiveMatch testEvents $ \case
PeerEvent (p', TxNotFound n)
| p == p' -> Just n
_ -> Nothing
n `shouldBe` h
it "downloads some block parents" $
withTestNode net "parents" $ \TestNode {..} -> do
let hs =
[ "00000000c74a24e1b1f2c04923c514ed88fc785cf68f52ed0ccffd3c6fe3fbd9"
, "000000007e5c5f40e495186ac4122f2e4ee25788cc36984a5760c55ecb376cb1"
, "00000000a6299059b2bff3479bc569019792e75f3c0f39b10a0bc85eac1b1615"
]
bn <-
receiveMatch testEvents $ \case
ChainEvent (ChainNewBest bn) -> Just bn
_ -> Nothing
nodeHeight bn `shouldBe` 2000
ps <- chainGetParents 1997 bn testChain
length ps `shouldBe` 3
forM_ (zip ps hs) $ \(p, h) ->
headerHash (nodeHeader p) `shouldBe` h
withTestNode ::
(MonadUnliftIO m)
=> Network
-> String
-> (TestNode -> m ())
-> m ()
withTestNode net t f =
runNoLoggingT . withSystemTempDirectory ("haskoin-node-test-" <> t <> "-") $ \w -> do
events <- newInbox =<< newTQueueIO
db <-
RocksDB.open
w
RocksDB.defaultOptions
{ RocksDB.createIfMissing = True
, RocksDB.compression = RocksDB.SnappyCompression
}
let cfg =
NodeConfig
{ maxPeers = 20
, database = db
, initPeers = []
, discover = True
, nodeEvents = (`sendSTM` events)
, netAddress = NetworkAddress 0 (SockAddrInet 0 0)
, nodeNet = net
}
withNode cfg $ \(mgr, ch) ->
lift $
f TestNode {testMgr = mgr, testChain = ch, testEvents = events}