NodeSpec.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
module Haskoin.NodeSpec
    ( spec
    ) where

import           Control.Monad        (forM_, replicateM, replicateM_)
import           Control.Monad.Logger (runNoLoggingT)
import           Control.Monad.Trans  (lift)
import           Data.Maybe           (isJust)
import qualified Database.RocksDB     as R
import           Haskoin              (Block (..), BlockHeader (..),
                                       BlockNode (..), Network,
                                       NetworkAddress (..), Version (..),
                                       btcTest, buildMerkleRoot,
                                       getGenesisHeader, headerHash,
                                       sockToHostAddress, txHash)
import           Haskoin.Node         (Chain, ChainEvent (..), NodeConfig (..),
                                       NodeEvent (..), OnlinePeer (..), Peer,
                                       PeerEvent (..), PeerManager,
                                       chainGetAncestor, chainGetBest,
                                       chainGetParents, managerGetPeer,
                                       peerGetBlocks, peerGetTxs, withNode)
import           Network.Socket       (SockAddr (..))
import           NQE                  (Inbox, newInbox, receiveMatch, sendSTM)
import           Test.Hspec           (Spec, describe, it, shouldBe,
                                       shouldReturn, shouldSatisfy)
import           UnliftIO             (MonadIO, MonadUnliftIO, throwString,
                                       withSystemTempDirectory)

data TestNode = TestNode
    { testMgr    :: PeerManager
    , testChain  :: Chain
    , nodeEvents :: Inbox NodeEvent
    }

spec :: Spec
spec = do
    let net = btcTest
    describe "peer manager on test network" $ do
        it "connects to a peer" $
            withTestNode net "connect-one-peer" $ \TestNode {..} -> do
                p <- waitForPeer nodeEvents
                Just OnlinePeer {onlinePeerVersion = Just Version {version = ver}} <-
                    managerGetPeer p testMgr
                ver `shouldSatisfy` (>= 70002)
        it "downloads some blocks" $
            withTestNode net "get-blocks" $ \TestNode {..} -> do
                let h1 =
                        "000000000babf10e26f6cba54d9c282983f1d1ce7061f7e875b58f8ca47db932"
                    h2 =
                        "00000000851f278a8b2c466717184aae859af5b83c6f850666afbc349cf61577"
                p <- waitForPeer nodeEvents
                pbs <- peerGetBlocks net 30 p [h1, h2]
                pbs `shouldSatisfy` isJust
                let Just [b1, b2] = pbs
                headerHash (blockHeader b1) `shouldBe` h1
                headerHash (blockHeader b2) `shouldBe` h2
                let testMerkle b =
                        merkleRoot (blockHeader b) `shouldBe`
                        buildMerkleRoot (map txHash (blockTxns b))
                testMerkle b1
                testMerkle b2
        it "connects to two peers" $
            withTestNode net "connect-peers" $ \TestNode {..} ->
                replicateM_ 2 (waitForPeer nodeEvents) `shouldReturn` ()
        it "attempts to get inexistent things" $
            withTestNode net "download-fail" $ \TestNode {..} -> do
                let hs =
                        [ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
                        , "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
                        ]
                p <- waitForPeer nodeEvents
                peerGetTxs net 30 p hs `shouldReturn` Nothing
    describe "chain on test network" $ do
        it "syncs some headers" $
            withTestNode net "connect-sync" $ \TestNode {..} -> do
                let h =
                        "000000009ec921df4bb16aedd11567e27ede3c0b63835b257475d64a059f102b"
                    hs =
                        [ headerHash (getGenesisHeader net)
                        , "0000000005bdbddb59a3cd33b69db94fa67669c41d9d32751512b5d7b68c71cf"
                        , "00000000185b36fa6e406626a722793bea80531515e0b2a99ff05b73738901f1"
                        , "000000001ab69b12b73ccdf46c9fbb4489e144b54f1565e42e481c8405077bdd"
                        ]
                bns <-
                    replicateM 4 . receiveMatch nodeEvents $ \case
                        ChainEvent (ChainBestBlock bn) -> Just bn
                        _ -> Nothing
                bb <- chainGetBest testChain
                nodeHeight bb `shouldSatisfy` (>= 6000)
                an <-
                    maybe (throwString "No ancestor found") return =<<
                    chainGetAncestor 2357 (last bns) testChain
                map (headerHash . nodeHeader) bns `shouldBe` hs
                headerHash (nodeHeader an) `shouldBe` h
        it "downloads some block parents" $
            withTestNode net "parents" $ \TestNode {..} -> do
                let hs =
                        [ "00000000c74a24e1b1f2c04923c514ed88fc785cf68f52ed0ccffd3c6fe3fbd9"
                        , "000000007e5c5f40e495186ac4122f2e4ee25788cc36984a5760c55ecb376cb1"
                        , "00000000a6299059b2bff3479bc569019792e75f3c0f39b10a0bc85eac1b1615"
                        ]
                [_, bn] <-
                    replicateM 2 $
                    receiveMatch nodeEvents $ \case
                        ChainEvent (ChainBestBlock 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

waitForPeer :: MonadIO m => Inbox NodeEvent -> m Peer
waitForPeer inbox =
    receiveMatch inbox $ \case
        PeerEvent (PeerConnected p _) -> Just p
        _ -> Nothing


withTestNode ::
       MonadUnliftIO m
    => Network
    -> String
    -> (TestNode -> m a)
    -> m a
withTestNode net str f =
    runNoLoggingT $
    withSystemTempDirectory ("haskoin-node-test-" <> str <> "-") $ \w -> do
        node_inbox <- newInbox
        db <-
            R.open
                w
                R.defaultOptions
                    { R.createIfMissing = True
                    , R.errorIfExists = True
                    , R.compression = R.SnappyCompression
                    }
        let cfg =
                NodeConfig
                    { nodeConfMaxPeers = 20
                    , nodeConfDB = db
                    , nodeConfPeers = []
                    , nodeConfDiscover = True
                    , nodeConfNetAddr = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0))
                    , nodeConfNet = net
                    , nodeConfEvents = (`sendSTM` node_inbox)
                    , nodeConfTimeout = 120
                    , nodeConfPeerOld = 48 * 3600
                    }
        withNode cfg $ \(mgr, ch) ->
            lift $
            f TestNode {testMgr = mgr, testChain = ch, nodeEvents = node_inbox}