{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Haskoin.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 =
{
MessageHeader -> Word32
headMagic :: !Word32
, MessageHeader -> MessageCommand
headCmd :: !MessageCommand
, MessageHeader -> Word32
headPayloadSize :: !Word32
, 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
data Message
= MVersion !Version
| MVerAck
| MAddr !Addr
| MInv !Inv
| MGetData !GetData
| MNotFound !NotFound
| MGetBlocks !GetBlocks
| !GetHeaders
| MTx !Tx
| MBlock !Block
| MMerkleBlock !MerkleBlock
| !Headers
| MGetAddr
| MFilterLoad !FilterLoad
| MFilterAdd !FilterAdd
| MFilterClear
| MPing !Ping
| MPong !Pong
| MAlert !Alert
| MMempool
| MReject !Reject
|
| 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)
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
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"
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