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)
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.Bloom
import Haskoin.Network.Common
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
  | 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
  | 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 (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 (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 MGetAddr = MCGetAddr
msgType (MOther c _) = MCOther c

-- | Deserializer for network messages.
getMessage :: (MonadGet m) => Network -> m Message
getMessage net = do
  (MessageHeader mgc cmd len chk) <- deserialize
  bs <- lookAhead $ getByteString $ fromIntegral len
  unless
    (mgc == net.magic)
    (fail $ "get: Invalid network magic bytes: " ++ show mgc)
  unless
    (checkSum32 bs == chk)
    (fail $ "get: Invalid message checksum: " ++ show chk)
  if len > 0
    then do
      bs <- ensure (fromIntegral len)
      let f = case cmd of
            MCVersion -> MVersion <$> deserialize
            MCAddr -> MAddr <$> deserialize
            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
            MCFilterLoad -> MFilterLoad <$> deserialize
            MCFilterAdd -> MFilterAdd <$> deserialize
            MCPing -> MPing <$> deserialize
            MCPong -> MPong <$> deserialize
            MCAlert -> MAlert <$> deserialize
            MCReject -> MReject <$> deserialize
            MCOther c -> MOther c <$> getByteString (fromIntegral len)
            _ ->
              fail $
                "get: command "
                  ++ show cmd
                  ++ " should not carry a payload"
      either fail return (runGetS f bs)
    else case cmd of
      MCGetAddr -> return MGetAddr
      MCVerAck -> return MVerAck
      MCFilterClear -> return MFilterClear
      MCMempool -> return MMempool
      MCSendHeaders -> return MSendHeaders
      MCOther c -> return (MOther c B.empty)
      _ ->
        fail $
          "get: command "
            ++ show cmd
            ++ " is expected to carry a payload"

-- | 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)
          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)
          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