{-# 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.ByteString            (ByteString)
import qualified Data.ByteString            as BS
import           Data.Serialize             (Serialize, encode, get, put)
import           Data.Serialize.Get         (Get, getByteString, getWord32be,
                                             getWord32le, isolate, lookAhead)
import           Data.Serialize.Put         (Putter, putByteString, putWord32be,
                                             putWord32le)
import           Data.Word                  (Word32)
import           GHC.Generics               (Generic)
import           Haskoin.Block.Common
import           Haskoin.Block.Merkle
import           Haskoin.Constants
import           Haskoin.Crypto.Hash
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
(MessageHeader -> MessageHeader -> Bool)
-> (MessageHeader -> MessageHeader -> Bool) -> Eq MessageHeader
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
(Int -> MessageHeader -> ShowS)
-> (MessageHeader -> String)
-> ([MessageHeader] -> ShowS)
-> Show MessageHeader
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. MessageHeader -> Rep MessageHeader x)
-> (forall x. Rep MessageHeader x -> MessageHeader)
-> Generic MessageHeader
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 -> ()
(MessageHeader -> ()) -> NFData MessageHeader
forall a. (a -> ()) -> NFData a
rnf :: MessageHeader -> ()
$crnf :: MessageHeader -> ()
NFData)

instance Serialize MessageHeader where

    get :: Get MessageHeader
get = Word32 -> MessageCommand -> Word32 -> CheckSum32 -> MessageHeader
MessageHeader (Word32 -> MessageCommand -> Word32 -> CheckSum32 -> MessageHeader)
-> Get Word32
-> Get (MessageCommand -> Word32 -> CheckSum32 -> MessageHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
                        Get (MessageCommand -> Word32 -> CheckSum32 -> MessageHeader)
-> Get MessageCommand
-> Get (Word32 -> CheckSum32 -> MessageHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get MessageCommand
forall t. Serialize t => Get t
get
                        Get (Word32 -> CheckSum32 -> MessageHeader)
-> Get Word32 -> Get (CheckSum32 -> MessageHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32le
                        Get (CheckSum32 -> MessageHeader)
-> Get CheckSum32 -> Get MessageHeader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get CheckSum32
forall t. Serialize t => Get t
get

    put :: Putter MessageHeader
put (MessageHeader m :: Word32
m c :: MessageCommand
c l :: Word32
l chk :: CheckSum32
chk) = do
        Putter Word32
putWord32be Word32
m
        Putter MessageCommand
forall t. Serialize t => Putter t
put         MessageCommand
c
        Putter Word32
putWord32le Word32
l
        Putter CheckSum32
forall t. Serialize t => Putter t
put         CheckSum32
chk

-- | 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
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
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
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
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. Message -> Rep Message x)
-> (forall x. Rep Message x -> Message) -> Generic Message
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 -> ()
(Message -> ()) -> NFData 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 _)     = MessageCommand
MCVersion
msgType MVerAck          = MessageCommand
MCVerAck
msgType (MAddr _)        = MessageCommand
MCAddr
msgType (MInv _)         = MessageCommand
MCInv
msgType (MGetData _)     = MessageCommand
MCGetData
msgType (MNotFound _)    = MessageCommand
MCNotFound
msgType (MGetBlocks _)   = MessageCommand
MCGetBlocks
msgType (MGetHeaders _)  = MessageCommand
MCGetHeaders
msgType (MTx _)          = MessageCommand
MCTx
msgType (MBlock _)       = MessageCommand
MCBlock
msgType (MMerkleBlock _) = MessageCommand
MCMerkleBlock
msgType (MHeaders _)     = MessageCommand
MCHeaders

msgType (MFilterLoad _)  = MessageCommand
MCFilterLoad
msgType (MFilterAdd _)   = MessageCommand
MCFilterAdd
msgType MFilterClear     = MessageCommand
MCFilterClear
msgType (MPing _)        = MessageCommand
MCPing
msgType (MPong _)        = MessageCommand
MCPong
msgType (MAlert _)       = MessageCommand
MCAlert
msgType MMempool         = MessageCommand
MCMempool
msgType (MReject _)      = MessageCommand
MCReject
msgType MSendHeaders     = MessageCommand
MCSendHeaders
msgType MGetAddr         = MessageCommand
MCGetAddr
msgType (MOther c :: ByteString
c _)     = ByteString -> MessageCommand
MCOther ByteString
c

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

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