Message.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module      : Haskoin.Network.Message
-- Copyright   : No rights reserved
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- Peer-to-peer network message serialization.
module Haskoin.Network.Message
  ( -- * Network Message
    Message (..),
    MessageHeader (..),
    msgType,
    putMessage,
    getMessage,
  )
where

import Control.DeepSeq
import Control.Monad (unless, when)
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Serialize (Serialize (..))
import Data.Word (Word32)
import GHC.Generics (Generic)
import Haskoin.Block.Common
import Haskoin.Block.Merkle
import Haskoin.Crypto.Hash
import Haskoin.Network.BlockFilter
import Haskoin.Network.Bloom
import Haskoin.Network.Common
import Haskoin.Network.CompactBlock
import Haskoin.Network.Data
import Haskoin.Transaction.Common

-- | Data type representing the header of a 'Message'. All messages sent between
-- nodes contain a message header.
data MessageHeader = MessageHeader
  { -- | magic bytes identify network
    magic :: !Word32,
    -- | message type
    cmd :: !MessageCommand,
    -- | length of payload
    size :: !Word32,
    -- | checksum of payload
    checksum :: !CheckSum32
  }
  deriving (Eq, Show, Generic, NFData)

instance Serial MessageHeader where
  deserialize =
    MessageHeader
      <$> getWord32be
      <*> deserialize
      <*> getWord32le
      <*> deserialize

  serialize (MessageHeader m c l chk) = do
    putWord32be m
    serialize c
    putWord32le l
    serialize chk

instance Binary MessageHeader where
  put = serialize
  get = deserialize

instance Serialize MessageHeader where
  put = serialize
  get = deserialize

-- | The 'Message' type is used to identify all the valid messages that can be
-- sent between bitcoin peers. Only values of type 'Message' will be accepted
-- by other bitcoin peers as bitcoin protocol messages need to be correctly
-- serialized with message headers. Serializing a 'Message' value will
-- include the 'MessageHeader' with the correct checksum value automatically.
-- No need to add the 'MessageHeader' separately.
data Message
  = MVersion !Version
  | MVerAck
  | MAddr !Addr
  | MAddrV2 !AddrV2
  | MSendAddrV2
  | MInv !Inv
  | MGetData !GetData
  | MNotFound !NotFound
  | MGetBlocks !GetBlocks
  | MGetHeaders !GetHeaders
  | MTx !Tx
  | MBlock !Block
  | MMerkleBlock !MerkleBlock
  | MHeaders !Headers
  | MGetAddr
  | MFilterLoad !FilterLoad
  | MFilterAdd !FilterAdd
  | MFilterClear
  | MPing !Ping
  | MPong !Pong
  | MAlert !Alert
  | MMempool
  | MReject !Reject
  | MSendHeaders
  | MFeeFilter !FeeFilter
  | MSendCompact !SendCompact
  | MCompactBlock !CompactBlock
  | MGetBlockTxn !GetBlockTxn
  | MBlockTxn !BlockTxn
  | MGetCFilters !GetCFilters
  | MCFilter !CFilter
  | MGetCFHeaders !GetCFHeaders
  | MCFHeaders !CFHeaders
  | MGetCFCheckpt !GetCFCheckpt
  | MCFCheckpt !CFCheckpt
  | MWtxidRelay
  | MSendTxRcncl !SendTxRcncl
  | -- | a message of a command this library does not know, with its payload
    MOther !ByteString !ByteString
  deriving (Eq, Show, Generic, NFData)

-- | Get 'MessageCommand' assocated with a message.
msgType :: Message -> MessageCommand
msgType (MVersion _) = MCVersion
msgType MVerAck = MCVerAck
msgType (MAddr _) = MCAddr
msgType (MAddrV2 _) = MCAddrV2
msgType MSendAddrV2 = MCSendAddrV2
msgType (MInv _) = MCInv
msgType (MGetData _) = MCGetData
msgType (MNotFound _) = MCNotFound
msgType (MGetBlocks _) = MCGetBlocks
msgType (MGetHeaders _) = MCGetHeaders
msgType (MTx _) = MCTx
msgType (MBlock _) = MCBlock
msgType (MMerkleBlock _) = MCMerkleBlock
msgType (MHeaders _) = MCHeaders
msgType MGetAddr = MCGetAddr
msgType (MFilterLoad _) = MCFilterLoad
msgType (MFilterAdd _) = MCFilterAdd
msgType MFilterClear = MCFilterClear
msgType (MPing _) = MCPing
msgType (MPong _) = MCPong
msgType (MAlert _) = MCAlert
msgType MMempool = MCMempool
msgType (MReject _) = MCReject
msgType MSendHeaders = MCSendHeaders
msgType (MFeeFilter _) = MCFeeFilter
msgType (MSendCompact _) = MCSendCmpct
msgType (MCompactBlock _) = MCCmpctBlock
msgType (MGetBlockTxn _) = MCGetBlockTxn
msgType (MBlockTxn _) = MCBlockTxn
msgType (MGetCFilters _) = MCGetCFilters
msgType (MCFilter _) = MCCFilter
msgType (MGetCFHeaders _) = MCGetCFHeaders
msgType (MCFHeaders _) = MCCFHeaders
msgType (MGetCFCheckpt _) = MCGetCFCheckpt
msgType (MCFCheckpt _) = MCCFCheckpt
msgType MWtxidRelay = MCWtxidRelay
msgType (MSendTxRcncl _) = MCSendTxRcncl
msgType (MOther c _) = MCOther c

-- | Deserializer for network messages. It reads one message and nothing
-- more, so messages can be read one after the other from a stream. The parse
-- fails for a header with the magic of another network, a payload larger
-- than the 'maxMessageSize' of the network, or a checksum that does not
-- match the payload. Only the declared payload is handed to the parser of the
-- message type. A message type that carries no payload is accepted with
-- whatever payload it comes with, as in Bitcoin Core.
getMessage :: (MonadGet m) => Network -> m Message
getMessage net = do
  (MessageHeader mgc cmd len chk) <- deserialize
  unless
    (mgc == net.magic)
    (fail $ "get: Invalid network magic bytes: " ++ show mgc)
  when (len > net.maxMessageSize) $
    fail $
      "get: Message of "
        ++ show len
        ++ " bytes is larger than the limit of "
        ++ show net.maxMessageSize
  payload <- getByteString (fromIntegral len)
  unless
    (checkSum32 payload == chk)
    (fail $ "get: Invalid message checksum: " ++ show chk)
  either fail return (runGetS (getPayload cmd len) payload)

-- | Parser for the payload of a message of the given command.
getPayload :: (MonadGet m) => MessageCommand -> Word32 -> m Message
getPayload cmd len =
  case cmd of
    MCVersion -> MVersion <$> deserialize
    MCVerAck -> return MVerAck
    MCAddr -> MAddr <$> deserialize
    MCAddrV2 -> MAddrV2 <$> deserialize
    MCSendAddrV2 -> return MSendAddrV2
    MCInv -> MInv <$> deserialize
    MCGetData -> MGetData <$> deserialize
    MCNotFound -> MNotFound <$> deserialize
    MCGetBlocks -> MGetBlocks <$> deserialize
    MCGetHeaders -> MGetHeaders <$> deserialize
    MCTx -> MTx <$> deserialize
    MCBlock -> MBlock <$> deserialize
    MCMerkleBlock -> MMerkleBlock <$> deserialize
    MCHeaders -> MHeaders <$> deserialize
    MCGetAddr -> return MGetAddr
    MCFilterLoad -> MFilterLoad <$> deserialize
    MCFilterAdd -> MFilterAdd <$> deserialize
    MCFilterClear -> return MFilterClear
    MCPing -> MPing <$> deserialize
    MCPong -> MPong <$> deserialize
    MCAlert -> MAlert <$> deserialize
    MCMempool -> return MMempool
    MCReject -> MReject <$> deserialize
    MCSendHeaders -> return MSendHeaders
    MCFeeFilter -> MFeeFilter <$> deserialize
    MCSendCmpct -> MSendCompact <$> deserialize
    MCCmpctBlock -> MCompactBlock <$> deserialize
    MCGetBlockTxn -> MGetBlockTxn <$> deserialize
    MCBlockTxn -> MBlockTxn <$> deserialize
    MCGetCFilters -> MGetCFilters <$> deserialize
    MCCFilter -> MCFilter <$> deserialize
    MCGetCFHeaders -> MGetCFHeaders <$> deserialize
    MCCFHeaders -> MCFHeaders <$> deserialize
    MCGetCFCheckpt -> MGetCFCheckpt <$> deserialize
    MCCFCheckpt -> MCFCheckpt <$> deserialize
    MCWtxidRelay -> return MWtxidRelay
    MCSendTxRcncl -> MSendTxRcncl <$> deserialize
    MCOther c -> MOther c <$> getByteString (fromIntegral len)

-- | Serializer for network messages.
putMessage :: (MonadPut m) => Network -> Message -> m ()
putMessage net msg = do
  let (cmd, payload) =
        case msg of
          MVersion m -> (MCVersion, runPutS $ serialize m)
          MVerAck -> (MCVerAck, B.empty)
          MAddr m -> (MCAddr, runPutS $ serialize m)
          MAddrV2 m -> (MCAddrV2, runPutS $ serialize m)
          MSendAddrV2 -> (MCSendAddrV2, B.empty)
          MInv m -> (MCInv, runPutS $ serialize m)
          MGetData m -> (MCGetData, runPutS $ serialize m)
          MNotFound m -> (MCNotFound, runPutS $ serialize m)
          MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m)
          MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m)
          MTx m -> (MCTx, runPutS $ serialize m)
          MBlock m -> (MCBlock, runPutS $ serialize m)
          MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m)
          MHeaders m -> (MCHeaders, runPutS $ serialize m)
          MGetAddr -> (MCGetAddr, B.empty)
          MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m)
          MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m)
          MFilterClear -> (MCFilterClear, B.empty)
          MPing m -> (MCPing, runPutS $ serialize m)
          MPong m -> (MCPong, runPutS $ serialize m)
          MAlert m -> (MCAlert, runPutS $ serialize m)
          MMempool -> (MCMempool, B.empty)
          MReject m -> (MCReject, runPutS $ serialize m)
          MSendHeaders -> (MCSendHeaders, B.empty)
          MFeeFilter m -> (MCFeeFilter, runPutS $ serialize m)
          MSendCompact m -> (MCSendCmpct, runPutS $ serialize m)
          MCompactBlock m -> (MCCmpctBlock, runPutS $ serialize m)
          MGetBlockTxn m -> (MCGetBlockTxn, runPutS $ serialize m)
          MBlockTxn m -> (MCBlockTxn, runPutS $ serialize m)
          MGetCFilters m -> (MCGetCFilters, runPutS $ serialize m)
          MCFilter m -> (MCCFilter, runPutS $ serialize m)
          MGetCFHeaders m -> (MCGetCFHeaders, runPutS $ serialize m)
          MCFHeaders m -> (MCCFHeaders, runPutS $ serialize m)
          MGetCFCheckpt m -> (MCGetCFCheckpt, runPutS $ serialize m)
          MCFCheckpt m -> (MCCFCheckpt, runPutS $ serialize m)
          MWtxidRelay -> (MCWtxidRelay, B.empty)
          MSendTxRcncl m -> (MCSendTxRcncl, runPutS $ serialize m)
          MOther c p -> (MCOther c, p)
      chk = checkSum32 payload
      len = fromIntegral $ B.length payload
      header = MessageHeader net.magic cmd len chk
  serialize header
  putByteString payload