{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}

{- |
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 qualified Data.ByteString as BS
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.Data
import Haskoin.Network.Bloom
import Haskoin.Network.Common
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
      MessageHeader -> Word32
headMagic :: !Word32
    , -- | message type
      MessageHeader -> MessageCommand
headCmd :: !MessageCommand
    , -- | length of payload
      MessageHeader -> Word32
headPayloadSize :: !Word32
    , -- | checksum of payload
      MessageHeader -> CheckSum32
headChecksum :: !CheckSum32
    }
    deriving (MessageHeader -> MessageHeader -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageHeader -> MessageHeader -> Bool
$c/= :: MessageHeader -> MessageHeader -> Bool
== :: MessageHeader -> MessageHeader -> Bool
$c== :: MessageHeader -> MessageHeader -> Bool
Eq, Int -> MessageHeader -> ShowS
[MessageHeader] -> ShowS
MessageHeader -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageHeader] -> ShowS
$cshowList :: [MessageHeader] -> ShowS
show :: MessageHeader -> String
$cshow :: MessageHeader -> String
showsPrec :: Int -> MessageHeader -> ShowS
$cshowsPrec :: Int -> MessageHeader -> ShowS
Show, forall x. Rep MessageHeader x -> MessageHeader
forall x. MessageHeader -> Rep MessageHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageHeader x -> MessageHeader
$cfrom :: forall x. MessageHeader -> Rep MessageHeader x
Generic, MessageHeader -> ()
forall a. (a -> ()) -> NFData a
rnf :: MessageHeader -> ()
$crnf :: MessageHeader -> ()
NFData)

instance Serial MessageHeader where
    deserialize :: forall (m :: * -> *). MonadGet m => m MessageHeader
deserialize =
        Word32 -> MessageCommand -> Word32 -> CheckSum32 -> MessageHeader
MessageHeader
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGet m => m Word32
getWord32be
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadGet m => m Word32
getWord32le
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

    serialize :: forall (m :: * -> *). MonadPut m => MessageHeader -> m ()
serialize (MessageHeader Word32
m MessageCommand
c Word32
l CheckSum32
chk) = do
        forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be Word32
m
        forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize MessageCommand
c
        forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32le Word32
l
        forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize CheckSum32
chk

instance Binary MessageHeader where
    put :: MessageHeader -> Put
put = forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get MessageHeader
get = forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance Serialize MessageHeader where
    put :: Putter MessageHeader
put = forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get MessageHeader
get = forall a (m :: * -> *). (Serial a, MonadGet m) => m a
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 (Message -> Message -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, forall x. Rep Message x -> Message
forall x. Message -> Rep Message x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Message x -> Message
$cfrom :: forall x. Message -> Rep Message x
Generic, Message -> ()
forall a. (a -> ()) -> NFData a
rnf :: Message -> ()
$crnf :: Message -> ()
NFData)

-- | Get 'MessageCommand' assocated with a message.
msgType :: Message -> MessageCommand
msgType :: Message -> MessageCommand
msgType (MVersion Version
_) = MessageCommand
MCVersion
msgType Message
MVerAck = MessageCommand
MCVerAck
msgType (MAddr Addr
_) = MessageCommand
MCAddr
msgType (MInv Inv
_) = MessageCommand
MCInv
msgType (MGetData GetData
_) = MessageCommand
MCGetData
msgType (MNotFound NotFound
_) = MessageCommand
MCNotFound
msgType (MGetBlocks GetBlocks
_) = MessageCommand
MCGetBlocks
msgType (MGetHeaders GetHeaders
_) = MessageCommand
MCGetHeaders
msgType (MTx Tx
_) = MessageCommand
MCTx
msgType (MBlock Block
_) = MessageCommand
MCBlock
msgType (MMerkleBlock MerkleBlock
_) = MessageCommand
MCMerkleBlock
msgType (MHeaders Headers
_) = MessageCommand
MCHeaders
msgType (MFilterLoad FilterLoad
_) = MessageCommand
MCFilterLoad
msgType (MFilterAdd FilterAdd
_) = MessageCommand
MCFilterAdd
msgType Message
MFilterClear = MessageCommand
MCFilterClear
msgType (MPing Ping
_) = MessageCommand
MCPing
msgType (MPong Pong
_) = MessageCommand
MCPong
msgType (MAlert Alert
_) = MessageCommand
MCAlert
msgType Message
MMempool = MessageCommand
MCMempool
msgType (MReject Reject
_) = MessageCommand
MCReject
msgType Message
MSendHeaders = MessageCommand
MCSendHeaders
msgType Message
MGetAddr = MessageCommand
MCGetAddr
msgType (MOther ByteString
c ByteString
_) = ByteString -> MessageCommand
MCOther ByteString
c

-- | Deserializer for network messages.
getMessage :: MonadGet m => Network -> m Message
getMessage :: forall (m :: * -> *). MonadGet m => Network -> m Message
getMessage Network
net = do
    (MessageHeader Word32
mgc MessageCommand
cmd Word32
len CheckSum32
chk) <- forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
    ByteString
bs <- forall (m :: * -> *) a. MonadGet m => m a -> m a
lookAhead forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGet m => Int -> m ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (Word32
mgc forall a. Eq a => a -> a -> Bool
== Network -> Word32
getNetworkMagic Network
net)
        (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"get: Invalid network magic bytes: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
mgc)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
bs forall a. Eq a => a -> a -> Bool
== CheckSum32
chk)
        (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"get: Invalid message checksum: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CheckSum32
chk)
    if Word32
len forall a. Ord a => a -> a -> Bool
> Word32
0
        then do
            ByteString
bs <- forall (m :: * -> *). MonadGet m => Int -> m ByteString
ensure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
            let f :: Get Message
f = case MessageCommand
cmd of
                    MessageCommand
MCVersion -> Version -> Message
MVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCAddr -> Addr -> Message
MAddr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCInv -> Inv -> Message
MInv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCGetData -> GetData -> Message
MGetData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCNotFound -> NotFound -> Message
MNotFound forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCGetBlocks -> GetBlocks -> Message
MGetBlocks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCGetHeaders -> GetHeaders -> Message
MGetHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCTx -> Tx -> Message
MTx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCBlock -> Block -> Message
MBlock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCMerkleBlock -> MerkleBlock -> Message
MMerkleBlock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCHeaders -> Headers -> Message
MHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCFilterLoad -> FilterLoad -> Message
MFilterLoad forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCFilterAdd -> FilterAdd -> Message
MFilterAdd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCPing -> Ping -> Message
MPing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCPong -> Pong -> Message
MPong forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCAlert -> Alert -> Message
MAlert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MessageCommand
MCReject -> Reject -> Message
MReject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                    MCOther ByteString
c -> ByteString -> ByteString -> Message
MOther ByteString
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGet m => Int -> m ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
                    MessageCommand
_ ->
                        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                            String
"get: command " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MessageCommand
cmd
                                forall a. [a] -> [a] -> [a]
++ String
" should not carry a payload"
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Get a -> ByteString -> Either String a
runGetS Get Message
f ByteString
bs)
        else case MessageCommand
cmd of
            MessageCommand
MCGetAddr -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
MGetAddr
            MessageCommand
MCVerAck -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
MVerAck
            MessageCommand
MCFilterClear -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
MFilterClear
            MessageCommand
MCMempool -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
MMempool
            MessageCommand
MCSendHeaders -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
MSendHeaders
            MCOther ByteString
c -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString -> Message
MOther ByteString
c ByteString
BS.empty)
            MessageCommand
_ ->
                forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                    String
"get: command " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MessageCommand
cmd
                        forall a. [a] -> [a] -> [a]
++ String
" is expected to carry a payload"

-- | Serializer for network messages.
putMessage :: MonadPut m => Network -> Message -> m ()
putMessage :: forall (m :: * -> *). MonadPut m => Network -> Message -> m ()
putMessage Network
net Message
msg = do
    let (MessageCommand
cmd, ByteString
payload) =
            case Message
msg of
                MVersion Version
m -> (MessageCommand
MCVersion, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Version
m)
                Message
MVerAck -> (MessageCommand
MCVerAck, ByteString
BS.empty)
                MAddr Addr
m -> (MessageCommand
MCAddr, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Addr
m)
                MInv Inv
m -> (MessageCommand
MCInv, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Inv
m)
                MGetData GetData
m -> (MessageCommand
MCGetData, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize GetData
m)
                MNotFound NotFound
m -> (MessageCommand
MCNotFound, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize NotFound
m)
                MGetBlocks GetBlocks
m -> (MessageCommand
MCGetBlocks, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize GetBlocks
m)
                MGetHeaders GetHeaders
m -> (MessageCommand
MCGetHeaders, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize GetHeaders
m)
                MTx Tx
m -> (MessageCommand
MCTx, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Tx
m)
                MBlock Block
m -> (MessageCommand
MCBlock, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Block
m)
                MMerkleBlock MerkleBlock
m -> (MessageCommand
MCMerkleBlock, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize MerkleBlock
m)
                MHeaders Headers
m -> (MessageCommand
MCHeaders, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Headers
m)
                Message
MGetAddr -> (MessageCommand
MCGetAddr, ByteString
BS.empty)
                MFilterLoad FilterLoad
m -> (MessageCommand
MCFilterLoad, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize FilterLoad
m)
                MFilterAdd FilterAdd
m -> (MessageCommand
MCFilterAdd, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize FilterAdd
m)
                Message
MFilterClear -> (MessageCommand
MCFilterClear, ByteString
BS.empty)
                MPing Ping
m -> (MessageCommand
MCPing, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Ping
m)
                MPong Pong
m -> (MessageCommand
MCPong, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Pong
m)
                MAlert Alert
m -> (MessageCommand
MCAlert, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Alert
m)
                Message
MMempool -> (MessageCommand
MCMempool, ByteString
BS.empty)
                MReject Reject
m -> (MessageCommand
MCReject, Put -> ByteString
runPutS forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Reject
m)
                Message
MSendHeaders -> (MessageCommand
MCSendHeaders, ByteString
BS.empty)
                MOther ByteString
c ByteString
p -> (ByteString -> MessageCommand
MCOther ByteString
c, ByteString
p)
        chk :: CheckSum32
chk = forall b. ByteArrayAccess b => b -> CheckSum32
checkSum32 ByteString
payload
        len :: Word32
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
payload
        header :: MessageHeader
header = Word32 -> MessageCommand -> Word32 -> CheckSum32 -> MessageHeader
MessageHeader (Network -> Word32
getNetworkMagic Network
net) MessageCommand
cmd Word32
len CheckSum32
chk
    forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize MessageHeader
header
    forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString ByteString
payload