module Network.Haskoin.Protocol.Types
( Addr(..)
, NetworkAddressTime
, Alert(..)
, Block(..)
, BlockHeader(..)
, BloomFlags(..)
, BloomFilter(..)
, FilterLoad(..)
, FilterAdd(..)
, GetBlocks(..)
, BlockLocator
, GetData(..)
, GetHeaders(..)
, Headers(..)
, BlockHeaderCount
, Inv(..)
, InvVector(..)
, InvType(..)
, MerkleBlock(..)
, NetworkAddress(..)
, NotFound(..)
, Ping(..)
, Pong(..)
, Reject(..)
, RejectCode(..)
, reject
, Tx(..)
, TxIn(..)
, TxOut(..)
, OutPoint(..)
, CoinbaseTx(..)
, VarInt(..)
, VarString(..)
, Version(..)
, MessageCommand(..)
) where
import Control.DeepSeq (NFData, rnf)
import Control.Monad (liftM2, replicateM, forM_, unless)
import Control.Applicative ((<$>),(<*>))
import Data.Aeson (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText)
import Data.Bits (testBit, setBit)
import Data.Word (Word8, Word16, Word32, Word64)
import qualified Data.Text as T
import Data.Binary (Binary, get, put)
import Data.Binary.Get
( Get
, getWord8
, getWord16le
, getWord16be
, getWord32le
, getWord64le
, getWord64be
, getByteString
, isEmpty
)
import Data.Binary.Put
( Put
, putWord8
, putWord16le
, putWord16be
, putWord32le
, putWord64le
, putWord64be
, putByteString
)
import qualified Data.Foldable as F (toList)
import qualified Data.Sequence as S (Seq, fromList, length)
import qualified Data.ByteString as BS
( ByteString
, length
, takeWhile
)
import Network.Haskoin.Util
import Network.Haskoin.Crypto.BigWord
type NetworkAddressTime = (Word32, NetworkAddress)
data Addr =
Addr {
addrList :: ![NetworkAddressTime]
}
deriving (Eq, Show, Read)
instance NFData Addr where
rnf (Addr as) = rnf as
instance Binary Addr where
get = Addr <$> (repList =<< get)
where
repList (VarInt c) = replicateM (fromIntegral c) action
action = liftM2 (,) getWord32le get
put (Addr xs) = do
put $ VarInt $ fromIntegral $ length xs
forM_ xs $ \(a,b) -> (putWord32le a) >> (put b)
data Alert =
Alert {
alertPayload :: !VarString
, alertSignature :: !VarString
} deriving (Eq, Show, Read)
instance NFData Alert where
rnf (Alert p s) = rnf p `seq` rnf s
instance Binary Alert where
get = Alert <$> get <*> get
put (Alert p s) = put p >> put s
data Block =
Block {
blockHeader :: !BlockHeader
, blockCoinbaseTx :: !CoinbaseTx
, blockTxns :: ![Tx]
} deriving (Eq, Show, Read)
instance NFData Block where
rnf (Block h c ts) = rnf h `seq` rnf c `seq` rnf ts
instance Binary Block where
get = do
header <- get
(VarInt c) <- get
cb <- get
txs <- replicateM (fromIntegral (c1)) get
return $ Block header cb txs
put (Block h cb txs) = do
put h
put $ VarInt $ fromIntegral $ (length txs) + 1
put cb
forM_ txs put
data BlockHeader =
BlockHeader {
blockVersion :: !Word32
, prevBlock :: !BlockHash
, merkleRoot :: !Word256
, blockTimestamp :: !Word32
, blockBits :: !Word32
, bhNonce :: !Word32
} deriving (Eq, Show, Read)
instance NFData BlockHeader where
rnf (BlockHeader v p m t b n) =
rnf v `seq` rnf p `seq` rnf m `seq` rnf t `seq` rnf b `seq` rnf n
instance Binary BlockHeader where
get = BlockHeader <$> getWord32le
<*> get
<*> get
<*> getWord32le
<*> getWord32le
<*> getWord32le
put (BlockHeader v p m bt bb n) = do
putWord32le v
put p
put m
putWord32le bt
putWord32le bb
putWord32le n
data BloomFlags
= BloomUpdateNone
| BloomUpdateAll
| BloomUpdateP2PubKeyOnly
deriving (Eq, Show, Read)
instance NFData BloomFlags
instance Binary BloomFlags where
get = go =<< getWord8
where
go 0 = return BloomUpdateNone
go 1 = return BloomUpdateAll
go 2 = return BloomUpdateP2PubKeyOnly
go _ = fail "BloomFlags get: Invalid bloom flag"
put f = putWord8 $ case f of
BloomUpdateNone -> 0
BloomUpdateAll -> 1
BloomUpdateP2PubKeyOnly -> 2
data BloomFilter = BloomFilter
{ bloomData :: !(S.Seq Word8)
, bloomHashFuncs :: !Word32
, bloomTweak :: !Word32
, bloomFlags :: !BloomFlags
}
deriving (Eq, Show, Read)
instance NFData BloomFilter where
rnf (BloomFilter d h t g) =
rnf d `seq` rnf h `seq` rnf t `seq` rnf g
instance Binary BloomFilter where
get = BloomFilter <$> (S.fromList <$> (readDat =<< get))
<*> getWord32le <*> getWord32le
<*> get
where
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
put (BloomFilter dat hashFuncs tweak flags) = do
put $ VarInt $ fromIntegral $ S.length dat
forM_ (F.toList dat) putWord8
putWord32le hashFuncs
putWord32le tweak
put flags
newtype FilterLoad = FilterLoad { getBloomFilter :: BloomFilter }
deriving (Eq, Show, Read)
instance NFData FilterLoad where
rnf (FilterLoad f) = rnf f
instance Binary FilterLoad where
get = FilterLoad <$> get
put (FilterLoad f) = put f
newtype FilterAdd = FilterAdd { getFilterData :: BS.ByteString }
deriving (Eq, Show, Read)
instance NFData FilterAdd where
rnf (FilterAdd f) = rnf f
instance Binary FilterAdd where
get = do
(VarInt len) <- get
dat <- getByteString $ fromIntegral len
return $ FilterAdd dat
put (FilterAdd bs) = do
put $ VarInt $ fromIntegral $ BS.length bs
putByteString bs
type BlockLocator = [BlockHash]
data GetBlocks =
GetBlocks {
getBlocksVersion :: !Word32
, getBlocksLocator :: !BlockLocator
, getBlocksHashStop :: !BlockHash
} deriving (Eq, Show, Read)
instance NFData GetBlocks where
rnf (GetBlocks v l h) = rnf v `seq` rnf l `seq` rnf h
instance Binary GetBlocks where
get = GetBlocks <$> getWord32le
<*> (repList =<< get)
<*> get
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (GetBlocks v xs h) = do
putWord32le v
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
put h
data GetData =
GetData {
getDataList :: ![InvVector]
} deriving (Eq, Show, Read)
instance NFData GetData where
rnf (GetData l) = rnf l
instance Binary GetData where
get = GetData <$> (repList =<< get)
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (GetData xs) = do
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
data GetHeaders =
GetHeaders {
getHeadersVersion :: !Word32
, getHeadersBL :: !BlockLocator
, getHeadersHashStop :: !BlockHash
} deriving (Eq, Show, Read)
instance NFData GetHeaders where
rnf (GetHeaders v l h) = rnf v `seq` rnf l `seq` rnf h
instance Binary GetHeaders where
get = GetHeaders <$> getWord32le
<*> (repList =<< get)
<*> get
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (GetHeaders v xs h) = do
putWord32le v
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
put h
type BlockHeaderCount = (BlockHeader, VarInt)
data Headers =
Headers {
headersList :: ![BlockHeaderCount]
}
deriving (Eq, Show, Read)
instance NFData Headers where
rnf (Headers l) = rnf l
instance Binary Headers where
get = Headers <$> (repList =<< get)
where
repList (VarInt c) = replicateM (fromIntegral c) action
action = liftM2 (,) get get
put (Headers xs) = do
put $ VarInt $ fromIntegral $ length xs
forM_ xs $ \(a,b) -> put a >> put b
data Inv =
Inv {
invList :: ![InvVector]
} deriving (Eq, Show, Read)
instance NFData Inv where
rnf (Inv l) = rnf l
instance Binary Inv where
get = Inv <$> (repList =<< get)
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (Inv xs) = do
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
data InvType
= InvError
| InvTx
| InvBlock
| InvMerkleBlock
deriving (Eq, Show, Read)
instance NFData InvType
instance Binary InvType where
get = go =<< getWord32le
where
go x = case x of
0 -> return InvError
1 -> return InvTx
2 -> return InvBlock
3 -> return InvMerkleBlock
_ -> fail "bitcoinGet InvType: Invalid Type"
put x = putWord32le $ case x of
InvError -> 0
InvTx -> 1
InvBlock -> 2
InvMerkleBlock -> 3
data InvVector =
InvVector {
invType :: !InvType
, invHash :: !Word256
} deriving (Eq, Show, Read)
instance NFData InvVector where
rnf (InvVector t h) = rnf t `seq` rnf h
instance Binary InvVector where
get = InvVector <$> get <*> get
put (InvVector t h) = put t >> put h
data MerkleBlock =
MerkleBlock {
merkleHeader :: !BlockHeader
, merkleTotalTxns :: !Word32
, mHashes :: ![Word256]
, mFlags :: ![Bool]
} deriving (Eq, Show, Read)
instance NFData MerkleBlock where
rnf (MerkleBlock m t h f) = rnf m `seq` rnf t `seq` rnf h `seq` rnf f
instance Binary MerkleBlock where
get = do
header <- get
ntx <- getWord32le
(VarInt matchLen) <- get
hashes <- replicateM (fromIntegral matchLen) get
(VarInt flagLen) <- get
ws <- replicateM (fromIntegral flagLen) getWord8
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
put (MerkleBlock h ntx hashes flags) = do
put h
putWord32le ntx
put $ VarInt $ fromIntegral $ length hashes
forM_ hashes put
let ws = encodeMerkleFlags flags
put $ VarInt $ fromIntegral $ length ws
forM_ ws putWord8
decodeMerkleFlags :: [Word8] -> [Bool]
decodeMerkleFlags ws =
[ b | p <- [0..(length ws)*81]
, b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)]
]
encodeMerkleFlags :: [Bool] -> [Word8]
encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs
splitIn :: Int -> [a] -> [[a]]
splitIn _ [] = []
splitIn c xs = take c xs : (splitIn c $ drop c xs)
boolsToWord8 :: [Bool] -> Word8
boolsToWord8 [] = 0
boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0..7])
data NetworkAddress =
NetworkAddress {
naServices :: !Word64
, naAddress :: !(Word64, Word64)
, naPort :: !Word16
} deriving (Eq, Show, Read)
instance NFData NetworkAddress where
rnf (NetworkAddress s a p) = rnf s `seq` rnf a `seq` rnf p
instance Binary NetworkAddress where
get = NetworkAddress <$> getWord64le
<*> (liftM2 (,) getWord64be getWord64be)
<*> getWord16be
put (NetworkAddress s (al,ar) p) = do
putWord64le s
putWord64be al
putWord64be ar
putWord16be p
data NotFound =
NotFound {
notFoundList :: ![InvVector]
} deriving (Eq, Show, Read)
instance NFData NotFound where
rnf (NotFound l) = rnf l
instance Binary NotFound where
get = NotFound <$> (repList =<< get)
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (NotFound xs) = do
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
newtype Ping =
Ping {
pingNonce :: Word64
} deriving (Eq, Show, Read)
instance NFData Ping where
rnf (Ping n) = rnf n
newtype Pong =
Pong {
pongNonce :: Word64
} deriving (Eq, Show, Read)
instance NFData Pong where
rnf (Pong n) = rnf n
instance Binary Ping where
get = Ping <$> getWord64le
put (Ping n) = putWord64le n
instance Binary Pong where
get = Pong <$> getWord64le
put (Pong n) = putWord64le n
data Reject =
Reject {
rejectMessage :: !MessageCommand
, rejectCode :: !RejectCode
, rejectReason :: !VarString
} deriving (Eq, Show, Read)
data RejectCode
= RejectMalformed
| RejectInvalid
| RejectObsolete
| RejectDuplicate
| RejectNonStandard
| RejectDust
| RejectInsufficientFee
| RejectCheckpoint
deriving (Eq, Show, Read)
instance Binary RejectCode where
get = getWord8 >>= \code -> case code of
0x01 -> return RejectMalformed
0x10 -> return RejectInvalid
0x11 -> return RejectObsolete
0x12 -> return RejectDuplicate
0x40 -> return RejectNonStandard
0x41 -> return RejectDust
0x42 -> return RejectInsufficientFee
0x43 -> return RejectCheckpoint
_ -> fail $ unwords
[ "Reject get: Invalid code"
, show code
]
put code = putWord8 $ case code of
RejectMalformed -> 0x01
RejectInvalid -> 0x10
RejectObsolete -> 0x11
RejectDuplicate -> 0x12
RejectNonStandard -> 0x40
RejectDust -> 0x41
RejectInsufficientFee -> 0x42
RejectCheckpoint -> 0x43
reject :: MessageCommand -> RejectCode -> String -> Reject
reject cmd code reason = Reject cmd code (VarString $ stringToBS reason)
instance Binary Reject where
get = get >>= \(VarString bs) -> case stringToCommand $ bsToString bs of
Just cmd -> Reject cmd <$> get <*> get
_ -> fail $ unwords $
[ "Reason get: Invalid message command"
, bsToString bs
]
put (Reject cmd code reason) = do
put $ VarString $ stringToBS $ commandToString cmd
put code
put reason
data Tx =
Tx {
txVersion :: !Word32
, txIn :: ![TxIn]
, txOut :: ![TxOut]
, txLockTime :: !Word32
} deriving (Eq, Show, Read)
instance NFData Tx where
rnf (Tx v i o l) = rnf v `seq` rnf i `seq` rnf o `seq` rnf l
instance Binary Tx where
get = Tx <$> getWord32le
<*> (replicateList =<< get)
<*> (replicateList =<< get)
<*> getWord32le
where
replicateList (VarInt c) = replicateM (fromIntegral c) get
put (Tx v is os l) = do
putWord32le v
put $ VarInt $ fromIntegral $ length is
forM_ is put
put $ VarInt $ fromIntegral $ length os
forM_ os put
putWord32le l
instance FromJSON Tx where
parseJSON = withText "transaction" $ \t -> either fail return $
maybeToEither "tx not hex" (hexToBS $ T.unpack t) >>= decodeToEither
instance ToJSON Tx where
toJSON = String . T.pack . bsToHex . encode'
data CoinbaseTx =
CoinbaseTx {
cbVersion :: !Word32
, cbPrevOutput :: !OutPoint
, cbData :: !BS.ByteString
, cbInSequence :: !Word32
, cbOut :: ![TxOut]
, cbLockTime :: !Word32
} deriving (Eq, Show, Read)
instance NFData CoinbaseTx where
rnf (CoinbaseTx v p d i o l) =
rnf v `seq` rnf p `seq` rnf d `seq` rnf i `seq` rnf o `seq` rnf l
instance Binary CoinbaseTx where
get = do
v <- getWord32le
(VarInt len) <- get
unless (len == 1) $ fail "CoinbaseTx get: Input size is not 1"
op <- get
(VarInt cbLen) <- get
cb <- getByteString (fromIntegral cbLen)
sq <- getWord32le
(VarInt oLen) <- get
os <- replicateM (fromIntegral oLen) get
lt <- getWord32le
return $ CoinbaseTx v op cb sq os lt
put (CoinbaseTx v op cb sq os lt) = do
putWord32le v
put $ VarInt 1
put op
put $ VarInt $ fromIntegral $ BS.length cb
putByteString cb
putWord32le sq
put $ VarInt $ fromIntegral $ length os
forM_ os put
putWord32le lt
data TxIn =
TxIn {
prevOutput :: !OutPoint
, scriptInput :: !BS.ByteString
, txInSequence :: !Word32
} deriving (Eq, Show, Read)
instance NFData TxIn where
rnf (TxIn p i s) = rnf p `seq` rnf i `seq` rnf s
instance Binary TxIn where
get =
TxIn <$> get <*> (readBS =<< get) <*> getWord32le
where
readBS (VarInt len) = getByteString $ fromIntegral len
put (TxIn o s q) = do
put o
put $ VarInt $ fromIntegral $ BS.length s
putByteString s
putWord32le q
data TxOut =
TxOut {
outValue :: !Word64
, scriptOutput :: !BS.ByteString
} deriving (Eq, Show, Read)
instance NFData TxOut where
rnf (TxOut v o) = rnf v `seq` rnf o
instance Binary TxOut where
get = do
val <- getWord64le
unless (val <= 2100000000000000) $ fail $
"Invalid TxOut value: " ++ (show val)
(VarInt len) <- get
TxOut val <$> (getByteString $ fromIntegral len)
put (TxOut o s) = do
putWord64le o
put $ VarInt $ fromIntegral $ BS.length s
putByteString s
data OutPoint =
OutPoint {
outPointHash :: !TxHash
, outPointIndex :: !Word32
} deriving (Read, Show, Eq)
instance NFData OutPoint where
rnf (OutPoint h i) = rnf h `seq` rnf i
instance FromJSON OutPoint where
parseJSON = withText "outpoint" $ \t -> either fail return $
maybeToEither "outpoint not hex"
(hexToBS $ T.unpack t) >>= decodeToEither
instance ToJSON OutPoint where
toJSON = String . T.pack . bsToHex . encode'
instance Binary OutPoint where
get = do
(h,i) <- liftM2 (,) get getWord32le
return $ OutPoint h i
put (OutPoint h i) = put h >> putWord32le i
newtype VarInt = VarInt { getVarInt :: Word64 }
deriving (Eq, Show, Read)
instance NFData VarInt where
rnf (VarInt w) = rnf w
instance Binary VarInt where
get = VarInt <$> ( getWord8 >>= go )
where
go 0xff = getWord64le
go 0xfe = fromIntegral <$> getWord32le
go 0xfd = fromIntegral <$> getWord16le
go x = fromIntegral <$> return x
put (VarInt x)
| x < 0xfd =
putWord8 $ fromIntegral x
| x <= 0xffff = do
putWord8 0xfd
putWord16le $ fromIntegral x
| x <= 0xffffffff = do
putWord8 0xfe
putWord32le $ fromIntegral x
| otherwise = do
putWord8 0xff
putWord64le x
newtype VarString = VarString { getVarString :: BS.ByteString }
deriving (Eq, Show, Read)
instance NFData VarString where
rnf (VarString s) = rnf s
instance Binary VarString where
get = VarString <$> (readBS =<< get)
where
readBS (VarInt len) = getByteString (fromIntegral len)
put (VarString bs) = do
put $ VarInt $ fromIntegral $ BS.length bs
putByteString bs
data Version =
Version {
version :: !Word32
, services :: !Word64
, timestamp :: !Word64
, addrRecv :: !NetworkAddress
, addrSend :: !NetworkAddress
, verNonce :: !Word64
, userAgent :: !VarString
, startHeight :: !Word32
, relay :: !Bool
} deriving (Eq, Show, Read)
instance NFData Version where
rnf (Version ver ser ts ar as vn ua sh re) =
rnf ver `seq` rnf ser `seq` rnf ts `seq` rnf ar `seq`
rnf as `seq` rnf vn `seq` rnf ua `seq` rnf sh `seq` rnf re
instance Binary Version where
get = Version <$> getWord32le
<*> getWord64le
<*> getWord64le
<*> get
<*> get
<*> getWord64le
<*> get
<*> getWord32le
<*> (go =<< isEmpty)
where
go True = return True
go False = getBool
put (Version v s t ar as n ua sh r) = do
putWord32le v
putWord64le s
putWord64le t
put ar
put as
putWord64le n
put ua
putWord32le sh
putBool r
getBool :: Get Bool
getBool = go =<< getWord8
where
go 0 = return False
go _ = return True
putBool :: Bool -> Put
putBool True = putWord8 1
putBool False = putWord8 0
data MessageCommand
= MCVersion
| MCVerAck
| MCAddr
| MCInv
| MCGetData
| MCNotFound
| MCGetBlocks
| MCGetHeaders
| MCTx
| MCBlock
| MCMerkleBlock
| MCHeaders
| MCGetAddr
| MCFilterLoad
| MCFilterAdd
| MCFilterClear
| MCPing
| MCPong
| MCAlert
| MCReject
deriving (Eq, Show, Read)
instance NFData MessageCommand
instance Binary MessageCommand where
get = go =<< getByteString 12
where
go bs = case stringToCommand $ unpackCommand bs of
Just cmd -> return cmd
Nothing -> fail "get MessageCommand : Invalid command"
put mc = putByteString $ packCommand $ commandToString mc
stringToCommand :: String -> Maybe MessageCommand
stringToCommand str = case str of
"version" -> Just MCVersion
"verack" -> Just MCVerAck
"addr" -> Just MCAddr
"inv" -> Just MCInv
"getdata" -> Just MCGetData
"notfound" -> Just MCNotFound
"getblocks" -> Just MCGetBlocks
"getheaders" -> Just MCGetHeaders
"tx" -> Just MCTx
"block" -> Just MCBlock
"merkleblock" -> Just MCMerkleBlock
"headers" -> Just MCHeaders
"getaddr" -> Just MCGetAddr
"filterload" -> Just MCFilterLoad
"filteradd" -> Just MCFilterAdd
"filterclear" -> Just MCFilterClear
"ping" -> Just MCPing
"pong" -> Just MCPong
"alert" -> Just MCAlert
"reject" -> Just MCReject
_ -> Nothing
commandToString :: MessageCommand -> String
commandToString mc = case mc of
MCVersion -> "version"
MCVerAck -> "verack"
MCAddr -> "addr"
MCInv -> "inv"
MCGetData -> "getdata"
MCNotFound -> "notfound"
MCGetBlocks -> "getblocks"
MCGetHeaders -> "getheaders"
MCTx -> "tx"
MCBlock -> "block"
MCMerkleBlock -> "merkleblock"
MCHeaders -> "headers"
MCGetAddr -> "getaddr"
MCFilterLoad -> "filterload"
MCFilterAdd -> "filteradd"
MCFilterClear -> "filterclear"
MCPing -> "ping"
MCPong -> "pong"
MCAlert -> "alert"
MCReject -> "reject"
packCommand :: String -> BS.ByteString
packCommand s = stringToBS $ take 12 $ s ++ repeat '\NUL'
unpackCommand :: BS.ByteString -> String
unpackCommand bs = bsToString $ BS.takeWhile (/= 0) bs