NodeSpec.hs

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

module Haskoin.NodeSpec (spec) where

import Conduit
  ( awaitForever,
    concatMapC,
    foldC,
    mapMC,
    runConduit,
    takeCE,
    yield,
    (.|),
  )
import Control.Monad (forM_, forever, replicateM)
import Control.Monad.Cont
import Control.Monad.Logger (runNoLoggingT)
import Control.Monad.Trans (lift)
import Data.ByteString (ByteString)
import qualified Data.ByteString 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 qualified Database.RocksDB as R
import Haskoin
  ( Block (..),
    BlockHash (..),
    BlockHeader (..),
    BlockNode (..),
    GetData (..),
    GetHeaders (..),
    Headers (..),
    InvType (..),
    InvVector (..),
    Message (..),
    MessageHeader (..),
    Network (..),
    NetworkAddress (..),
    Ping (..),
    Pong (..),
    VarInt (..),
    Version (..),
    bchRegTest,
    buildMerkleRoot,
    getMessage,
    headerHash,
    nodeNetwork,
    putMessage,
    sockToHostAddress,
    txHash,
  )
import Haskoin.Node
import NQE
  ( Inbox,
    Mailbox,
    inboxToMailbox,
    newInbox,
    receive,
    receiveMatch,
    send,
    withPublisher,
    withSubscription,
  )
import Network.Socket (AddrInfo (addrAddress), SockAddr (..))
import System.Random (randomIO)
import Test.Hspec
import Test.Hspec.QuickCheck
import UnliftIO
  ( MonadIO,
    MonadUnliftIO,
    liftIO,
    throwString,
    withAsync,
    withSystemTempDirectory,
  )

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 <$> liftIO 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 p testMgr
        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 (throwString "No ancestor found") return
            =<< chainGetAncestor 10 bn testChain
        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 12 bn testChain
        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 ::
  (MonadUnliftIO m) =>
  Network ->
  String ->
  (TestNode -> m a) ->
  m a
withTestNode net str f = runNoLoggingT $ flip runContT return $ do
  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 . 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"