NodeSpec.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module Haskoin.NodeSpec (spec) where

import Conduit
import Control.Concurrent.Async
import Control.Logging
import Control.Monad (forM_, forever, replicateM)
import Control.Monad.Cont
import Control.Monad.Trans (lift)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Base64 (decodeBase64Lenient)
import Data.Default (def)
import Data.Either (fromRight)
import Data.List (find)
import Data.Maybe (isJust, mapMaybe)
import Data.Serialize (decode, get, runGet, runPut)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.RocksDB qualified as R
import Haskoin
import Haskoin.Node
import NQE
import Network.Socket (AddrInfo (addrAddress), SockAddr (..))
import System.IO.Temp
import System.Random (randomIO)
import Test.Hspec
import Test.Hspec.QuickCheck

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

dummyPeerConnect ::
  Network ->
  NetworkAddress ->
  SockAddr ->
  WithConnection
dummyPeerConnect net ad sa f = do
  r <- newInbox
  s <- newInbox
  let s' = inboxToMailbox s
  withAsync (go r s') $ \_ -> do
    let o = awaitForever (`send` r)
        i = forever (receive s >>= yield)
    f (Conduits i o) :: IO ()
  where
    go :: Inbox ByteString -> Mailbox ByteString -> IO ()
    go r s = do
      nonce <- randomIO
      now <- round <$> getPOSIXTime
      let rmt = NetworkAddress 0 (sockToHostAddress sa)
          ver = buildVersion net nonce 0 ad rmt now
      runPut (putMessage net (MVersion ver)) `send` s
      runConduit $
        forever (receive r >>= yield)
          .| inc
          .| concatMapC mockPeerReact
          .| outc
          .| awaitForever (`send` s)
    outc = mapMC $ \msg -> return $ runPut (putMessage net msg)
    inc =
      forever $ do
        x <- takeCE 24 .| foldC
        y <- case decode x of
          Left _ -> error "Dummy peer not decode message header"
          Right (MessageHeader _ _ len _) ->
            takeCE (fromIntegral len) .| foldC
        case runGet (getMessage net) $ x `B.append` y of
          Left e ->
            error $
              "Dummy peer could not decode payload: " <> show e
          Right msg -> yield msg

mockPeerReact :: Message -> [Message]
mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]
mockPeerReact (MVersion _) = [MVerAck]
mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')]
  where
    f b = (b.header, (VarInt . fromIntegral . length) b.txs)
    hs' = map f allBlocks
mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs
  where
    f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks
    f _ = Nothing
    l h b = headerHash b.header == BlockHash h
mockPeerReact _ = []

spec :: Spec
spec = do
  let net = bchRegTest
  describe "reads address/port combinations" $ do
    prop "reads arbitrary addresses" $ \(e, w1, w2, w3, w4, b) -> do
      let p = toEnum (e `mod` 65536)
          a =
            if b
              then SockAddrInet p w1
              else SockAddrInet6 p 0 (w1, w2, w3, w4) 0
      s <- head <$> toSockAddr net (show a)
      s `shouldBe` a
    it "reads some specific addresses" $ do
      toHostService "localhost" `shouldBe` (Just "localhost", Nothing)
      toHostService "::1" `shouldBe` (Just "::1", Nothing)
      toHostService "localhost:8080" `shouldBe` (Just "localhost", Just "8080")
      toHostService "example.com" `shouldBe` (Just "example.com", Nothing)
      toHostService "api.example.com:443" `shouldBe` (Just "api.example.com", Just "443")
      toHostService "api.example.com:http" `shouldBe` (Just "api.example.com", Just "http")
      toHostService "[::1]" `shouldBe` (Just "::1", Nothing)
      toHostService "[::1]:8080" `shouldBe` (Just "::1", Just "8080")
      toHostService "[2002::dead:beef]:ssh" `shouldBe` (Just "2002::dead:beef", Just "ssh")
  describe "peer manager on test network" $ do
    it "connects to a peer" $
      withTestNode net "connect-one-peer" $ \TestNode {..} -> do
        p <- waitForPeer nodeEvents
        Just OnlinePeer {version = Just Version {version = ver}} <-
          getOnlinePeer testMgr p
        ver `shouldSatisfy` (>= 70002)
    it "downloads some blocks" $
      withTestNode net "get-blocks" $ \TestNode {..} -> do
        let h1 =
              "3094ed3592a06f3d8e099eed2d9c1192329944f5df4a48acb29e08f12cfbb660"
            h2 =
              "0c89955fc5c9f98ecc71954f167b938138c90c6a094c4737f2e901669d26763f"
        p <- waitForPeer nodeEvents
        pbs <- getBlocks net 10 p [h1, h2]
        pbs `shouldSatisfy` isJust
        let Just [b1, b2] = pbs
        headerHash b1.header `shouldBe` h1
        headerHash b2.header `shouldBe` h2
        let ths b = map txHash b.txs
            testMerkle b = b.header.merkle `shouldBe` buildMerkleRoot (ths b)
        testMerkle b1
        testMerkle b2
  describe "chain on test network" $ do
    it "syncs some headers" $
      withTestNode net "connect-sync" $ \TestNode {..} -> do
        let bh =
              "3bfa0c6da615fc45aa44ddea6854ac19d16f3ca167e0e21ac2cc262a49c9b002"
            ah =
              "7dc835a78a55fa76f9184dc4f6663a73e418c7afec789c5ae25e432fd7fc8467"
        bn <-
          receiveMatch nodeEvents $ \case
            ChainEvent (ChainBestBlock bn)
              | bn.height > 0 -> Just bn
            _ -> Nothing
        bb <- chainGetBest testChain
        bb.height `shouldSatisfy` (== 15)
        an <-
          maybe (error "No ancestor found") return
            =<< chainGetAncestor testChain 10 bn
        headerHash bn.header `shouldBe` bh
        headerHash an.header `shouldBe` ah
    it "downloads some block parents" $
      withTestNode net "parents" $ \TestNode {..} -> do
        let hs =
              [ "52e886df7b166d961ac2d3d2d561d806325d51a609dc0a5d9d5fcb65d47906d7",
                "2537a081b9e2b24d217fac2886f387758cb3aa4e4956b3be7ed229bafbb71b0f",
                "7c72f306215a296f9714320a497b1f2cb5f9b99f162d7e04333c243fac9a54d8"
              ]
        [_, bn] <-
          replicateM 2 $
            receiveMatch nodeEvents $ \case
              ChainEvent (ChainBestBlock bn) -> Just bn
              _ -> Nothing
        bn.height `shouldBe` 15
        ps <- chainGetParents testChain 12 bn
        length ps `shouldBe` 3
        forM_ (zip ps hs) $ \(p, h) ->
          headerHash p.header `shouldBe` h

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

withTestNode :: Network -> String -> (TestNode -> IO a) -> IO a
withTestNode net str f = withStderrLogging $ flip runContT return $ do
  lift $ setLogLevel LevelError
  w <- ContT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-")
  pub <- ContT withPublisher
  sub <- ContT $ withSubscription pub
  db <- ContT $ R.withDBCF w cfg cols
  let ad =
        NetworkAddress
          nodeNetwork
          (sockToHostAddress (SockAddrInet 0 0))
      na =
        NetworkAddress
          0
          (sockToHostAddress (SockAddrInet 0 0))
      cfg' =
        NodeConfig
          { maxPeers = 20,
            db = db,
            cf = Just (head (R.columnFamilies db)),
            peers = ["[::1]:17486"],
            discover = False,
            address = na,
            net = net,
            pub = pub,
            timeout = 120,
            maxPeerLife = 48 * 3600,
            connect = dummyPeerConnect net ad
          }
  Node mgr ch <- ContT $ withNode cfg'
  lift $
    f
      TestNode
        { testMgr = mgr,
          testChain = ch,
          nodeEvents = sub
        }
  where
    cfg = def {R.createIfMissing = True, R.errorIfExists = True}
    cols = [("node", def)]

allBlocks :: [Block]
allBlocks =
  fromRight (error "Could not decode blocks") $
    runGet f (decodeBase64Lenient allBlocksBase64)
  where
    f = mapM (const get) [(1 :: Int) .. 15]

allBlocksBase64 :: ByteString
allBlocksBase64 =
  "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\
  \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\
  \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\
  \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\
  \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\
  \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\
  \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\
  \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\
  \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\
  \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\
  \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\
  \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\
  \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\
  \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\
  \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\
  \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\
  \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\
  \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\
  \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\
  \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\
  \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\
  \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\
  \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\
  \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\
  \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\
  \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\
  \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\
  \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\
  \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\
  \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\
  \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\
  \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\
  \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\
  \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\
  \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\
  \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\
  \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\
  \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\
  \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\
  \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\
  \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\
  \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\
  \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\
  \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\
  \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\
  \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\
  \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\
  \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\
  \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\
  \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA"