{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Haskoin.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 =
{
MessageHeader -> Word32
headMagic :: !Word32
,
MessageHeader -> MessageCommand
headCmd :: !MessageCommand
,
MessageHeader -> Word32
headPayloadSize :: !Word32
,
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
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
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)
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
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"
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