{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
import Control.Concurrent.NQE
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 Network.Haskoin.Address
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Keys
import Network.Haskoin.Network
import Network.Haskoin.Node
import Network.Haskoin.Transaction
import Network.Socket (SockAddr (..))
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 <- Inbox <$> liftIO newTQueueIO
ch <- Inbox <$> liftIO newTQueueIO
ns <- Inbox <$> liftIO newTQueueIO
mgr <- Inbox <$> liftIO 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)
, nodeSupervisor = ns
, nodeChain = ch
, nodeManager = mgr
, nodeNet = net
}
withAsync (node cfg) $ \nd -> do
link nd
lift $
f TestNode {testMgr = mgr, testChain = ch, testEvents = events}
stopSupervisor ns
wait nd