{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Network.Common
(
Addr(..)
, NetworkAddressTime
, Alert(..)
, GetData(..)
, Inv(..)
, InvVector(..)
, InvType(..)
, NetworkAddress(..)
, NotFound(..)
, Ping(..)
, Pong(..)
, Reject(..)
, RejectCode(..)
, VarInt(..)
, VarString(..)
, Version(..)
, MessageCommand(..)
, reject
, nodeNone
, nodeNetwork
, nodeGetUTXO
, nodeBloom
, nodeWitness
, nodeXThin
, commandToString
, stringToCommand
, putVarInt
) where
import Control.Monad (forM_, liftM2, replicateM, unless)
import Data.Bits (shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 as C (replicate)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Serialize as S
import Data.String
import Data.String.Conversions (cs)
import Data.Word (Word32, Word64)
import Network.Haskoin.Crypto.Hash
import Network.Socket (SockAddr (..))
import Text.Read as R
type NetworkAddressTime = (Word32, NetworkAddress)
newtype Addr =
Addr {
addrList :: [NetworkAddressTime]
}
deriving (Eq, Show)
instance Serialize Addr where
get = Addr <$> (repList =<< S.get)
where
repList (VarInt c) = replicateM (fromIntegral c) action
action = liftM2 (,) getWord32le S.get
put (Addr xs) = do
putVarInt $ length xs
forM_ xs $ \(a,b) -> putWord32le a >> put b
data Alert =
Alert {
alertPayload :: !VarString
, alertSignature :: !VarString
} deriving (Eq, Show, Read)
instance Serialize Alert where
get = Alert <$> S.get <*> S.get
put (Alert p s) = put p >> put s
newtype GetData =
GetData {
getDataList :: [InvVector]
} deriving (Eq, Show)
instance Serialize GetData where
get = GetData <$> (repList =<< S.get)
where
repList (VarInt c) = replicateM (fromIntegral c) S.get
put (GetData xs) = do
putVarInt $ length xs
forM_ xs put
newtype Inv =
Inv {
invList :: [InvVector]
} deriving (Eq, Show)
instance Serialize Inv where
get = Inv <$> (repList =<< S.get)
where
repList (VarInt c) = replicateM (fromIntegral c) S.get
put (Inv xs) = do
putVarInt $ length xs
forM_ xs put
data InvType
= InvError
| InvTx
| InvBlock
| InvMerkleBlock
| InvWitnessTx
| InvWitnessBlock
| InvWitnessMerkleBlock
deriving (Eq, Show, Read)
instance Serialize InvType where
get = go =<< getWord32le
where
go x =
case x of
0 -> return InvError
1 -> return InvTx
2 -> return InvBlock
3 -> return InvMerkleBlock
_
| x == 1 `shiftL` 30 + 1 -> return InvWitnessTx
| x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock
| x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock
| otherwise -> fail "bitcoinGet InvType: Invalid Type"
put x =
putWord32le $
case x of
InvError -> 0
InvTx -> 1
InvBlock -> 2
InvMerkleBlock -> 3
InvWitnessTx -> 1 `shiftL` 30 + 1
InvWitnessBlock -> 1 `shiftL` 30 + 2
InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3
data InvVector =
InvVector {
invType :: !InvType
, invHash :: !Hash256
} deriving (Eq, Show)
instance Serialize InvVector where
get = InvVector <$> S.get <*> S.get
put (InvVector t h) = put t >> put h
data NetworkAddress =
NetworkAddress {
naServices :: !Word64
, naAddress :: !SockAddr
} deriving (Eq, Show)
instance Serialize NetworkAddress where
get = NetworkAddress <$> getWord64le
<*> getAddrPort
where
getAddrPort = do
a <- getWord32be
b <- getWord32be
c <- getWord32be
if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff
then do
d <- getWord32host
p <- getWord16be
return $ SockAddrInet (fromIntegral p) d
else do
d <- getWord32be
p <- getWord16be
return $ SockAddrInet6 (fromIntegral p) 0 (a,b,c,d) 0
put (NetworkAddress s (SockAddrInet6 p _ (a,b,c,d) _)) = do
putWord64le s
putWord32be a
putWord32be b
putWord32be c
putWord32be d
putWord16be (fromIntegral p)
put (NetworkAddress s (SockAddrInet p a)) = do
putWord64le s
putWord32be 0x00000000
putWord32be 0x00000000
putWord32be 0x0000ffff
putWord32host a
putWord16be (fromIntegral p)
put _ = error "NetworkAddress can onle be IPv4 or IPv6"
newtype NotFound =
NotFound {
notFoundList :: [InvVector]
} deriving (Eq, Show)
instance Serialize NotFound where
get = NotFound <$> (repList =<< S.get)
where
repList (VarInt c) = replicateM (fromIntegral c) S.get
put (NotFound xs) = do
putVarInt $ length xs
forM_ xs put
newtype Ping =
Ping {
pingNonce :: Word64
} deriving (Eq, Show, Read)
newtype Pong =
Pong {
pongNonce :: Word64
} deriving (Eq, Show, Read)
instance Serialize Ping where
get = Ping <$> getWord64le
put (Ping n) = putWord64le n
instance Serialize Pong where
get = Pong <$> getWord64le
put (Pong n) = putWord64le n
data Reject =
Reject {
rejectMessage :: !MessageCommand
, rejectCode :: !RejectCode
, rejectReason :: !VarString
, rejectData :: !ByteString
} deriving (Eq, Show, Read)
data RejectCode
= RejectMalformed
| RejectInvalid
| RejectObsolete
| RejectDuplicate
| RejectNonStandard
| RejectDust
| RejectInsufficientFee
| RejectCheckpoint
deriving (Eq, Show, Read)
instance Serialize 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 -> ByteString -> Reject
reject cmd code reason =
Reject cmd code (VarString reason) B.empty
instance Serialize Reject where
get = S.get >>= \(VarString bs) -> case stringToCommand bs of
Just cmd -> Reject cmd <$> S.get <*> S.get <*> maybeData
_ -> fail $ unwords
["Reason get: Invalid message command" ,cs bs]
where
maybeData = isEmpty >>= \done ->
if done then return B.empty else getByteString 32
put (Reject cmd code reason dat) = do
put $ VarString $ commandToString cmd
put code
put reason
unless (B.null dat) $ putByteString dat
newtype VarInt = VarInt { getVarInt :: Word64 }
deriving (Eq, Show, Read)
instance Serialize 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
putVarInt :: Integral a => a -> Put
putVarInt = put . VarInt . fromIntegral
newtype VarString = VarString { getVarString :: ByteString }
deriving (Eq, Show, Read)
instance Serialize VarString where
get = VarString <$> (readBS =<< S.get)
where
readBS (VarInt len) = getByteString (fromIntegral len)
put (VarString bs) = do
putVarInt $ B.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)
instance Serialize Version where
get = Version <$> getWord32le
<*> getWord64le
<*> getWord64le
<*> S.get
<*> S.get
<*> getWord64le
<*> S.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
| MCMempool
| MCReject
| MCSendHeaders
deriving (Eq)
instance Show MessageCommand where
showsPrec _ = shows . commandToString
instance Read MessageCommand where
readPrec = do
String str <- lexP
maybe pfail return (stringToCommand (cs str))
instance Serialize MessageCommand where
get = go =<< getByteString 12
where
go bs =
let str = unpackCommand bs
in case stringToCommand str of
Just cmd -> return cmd
Nothing -> fail $ cs $
"get MessageCommand: Invalid command: " <> str
put mc = putByteString $ packCommand $ commandToString mc
instance IsString MessageCommand where
fromString str =
fromMaybe
(error ("Could not recognize message command " <> str))
(stringToCommand (cs str))
stringToCommand :: ByteString -> 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
"mempool" -> Just MCMempool
"reject" -> Just MCReject
"sendheaders" -> Just MCSendHeaders
_ -> Nothing
commandToString :: MessageCommand -> ByteString
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"
MCMempool -> "mempool"
MCReject -> "reject"
MCSendHeaders -> "sendheaders"
packCommand :: ByteString -> ByteString
packCommand s = B.take 12 $
s `mappend` C.replicate 12 '\NUL'
unpackCommand :: ByteString -> ByteString
unpackCommand = B.takeWhile (/= 0)
nodeNone :: Word64
nodeNone = 0
nodeNetwork :: Word64
nodeNetwork = 1
nodeGetUTXO :: Word64
nodeGetUTXO = 1 `shiftL` 1
nodeBloom :: Word64
nodeBloom = 1 `shiftL` 2
nodeWitness :: Word64
nodeWitness = 1 `shiftL` 3
nodeXThin :: Word64
nodeXThin = 1 `shiftL` 4