diff --git a/Network/Haskoin/Protocol.hs b/Network/Haskoin/Protocol.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol.hs @@ -0,0 +1,83 @@ +{-| + This package provides all of the basic types used for the Bitcoin + networking protocol together with Data.Binary instances for efficiently + serializing and de-serializing them. More information on the bitcoin protocol + is available here: +-} +module Network.Haskoin.Protocol +( + -- * Blocks + Block(..) +, GetBlocks(..) + + -- * Block Headers +, BlockHeader(..) +, GetHeaders(..) +, Headers(..) +, BlockHeaderCount + + -- * Requesting data +, GetData(..) +, Inv(..) +, InvVector(..) +, InvType(..) +, NotFound(..) + + -- *Scripts + -- | More informations on scripts is available here: + -- +, Script(..) +, ScriptOp(..) +, getScriptOps +, putScriptOps +, decodeScriptOps +, encodeScriptOps + + -- *Transactions +, Tx(..) +, txid +, CoinbaseTx(..) +, TxIn(..) +, TxOut(..) +, OutPoint(..) +, encodeTxid +, decodeTxid + + -- * Network types +, VarInt(..) +, VarString(..) +, NetworkAddress(..) +, Addr(..) +, NetworkAddressTime +, Version(..) +, Ping(..) +, Pong(..) +, Alert(..) + + -- *Messages +, Message(..) +, MessageHeader(..) +, MessageCommand(..) +) where + +import Network.Haskoin.Protocol.Message +import Network.Haskoin.Protocol.Addr +import Network.Haskoin.Protocol.Alert +import Network.Haskoin.Protocol.BlockHeader +import Network.Haskoin.Protocol.Block +import Network.Haskoin.Protocol.GetBlocks +import Network.Haskoin.Protocol.GetData +import Network.Haskoin.Protocol.GetHeaders +import Network.Haskoin.Protocol.Headers +import Network.Haskoin.Protocol.Inv +import Network.Haskoin.Protocol.InvVector +import Network.Haskoin.Protocol.MessageHeader +import Network.Haskoin.Protocol.NetworkAddress +import Network.Haskoin.Protocol.NotFound +import Network.Haskoin.Protocol.Ping +import Network.Haskoin.Protocol.Script +import Network.Haskoin.Protocol.Tx +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.VarString +import Network.Haskoin.Protocol.Version + diff --git a/Network/Haskoin/Protocol/Addr.hs b/Network/Haskoin/Protocol/Addr.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Addr.hs @@ -0,0 +1,39 @@ +module Network.Haskoin.Protocol.Addr +( Addr(..) +, NetworkAddressTime +) where + +import Control.Monad (liftM2, replicateM, forM_) +import Control.Applicative ((<$>)) + +import Data.Word (Word32) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.NetworkAddress + +-- | Network address with a timestamp +type NetworkAddressTime = (Word32, NetworkAddress) + +-- | Provides information on known nodes in the bitcoin network. An 'Addr' +-- type is sent inside a 'Message' as a response to a 'GetAddr' message. +data Addr = + Addr { + -- List of addresses of other nodes on the network with timestamps. + addrList :: ![NetworkAddressTime] + } + deriving (Eq, Show) + +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) + diff --git a/Network/Haskoin/Protocol/Alert.hs b/Network/Haskoin/Protocol/Alert.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Alert.hs @@ -0,0 +1,21 @@ +module Network.Haskoin.Protocol.Alert ( Alert(..) ) where + +import Control.Applicative ((<$>),(<*>)) +import Data.Binary (Binary, get, put) +import Network.Haskoin.Protocol.VarString + +-- | Data type describing signed messages that can be sent between bitcoin +-- nodes to display important notifications to end users about the health of +-- the network. +data Alert = + Alert { + -- | Alert payload. + alertPayload :: !VarString + -- | ECDSA signature of the payload + , alertSignature :: !VarString + } deriving (Eq, Show) + +instance Binary Alert where + get = Alert <$> get <*> get + put (Alert p s) = put p >> put s + diff --git a/Network/Haskoin/Protocol/Arbitrary.hs b/Network/Haskoin/Protocol/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Arbitrary.hs @@ -0,0 +1,195 @@ +{-| + This package provides QuickCheck Arbitrary instances for all the protocol + data types defined in 'Network.Haskoin.Protocol'. +-} +module Network.Haskoin.Protocol.Arbitrary () where + +import Test.QuickCheck +import Network.Haskoin.Util.Arbitrary (nonEmptyBS) +import Network.Haskoin.Crypto.Arbitrary() + +import Control.Monad +import Control.Applicative + +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +instance Arbitrary VarInt where + arbitrary = VarInt <$> arbitrary + +instance Arbitrary VarString where + arbitrary = VarString <$> arbitrary + +instance Arbitrary NetworkAddress where + arbitrary = do + s <- arbitrary + a <- liftM2 (,) arbitrary arbitrary + p <- arbitrary + return $ NetworkAddress s a p + +instance Arbitrary InvType where + arbitrary = elements [InvError, InvTx, InvBlock] + +instance Arbitrary InvVector where + arbitrary = InvVector <$> arbitrary <*> (hash256 <$> arbitrary) + +instance Arbitrary Inv where + arbitrary = Inv <$> listOf arbitrary + +instance Arbitrary Version where + arbitrary = Version <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Addr where + arbitrary = Addr <$> listOf arbitrary + +instance Arbitrary Alert where + arbitrary = Alert <$> arbitrary <*> arbitrary + +instance Arbitrary BlockHeader where + arbitrary = BlockHeader <$> arbitrary + <*> (hash256 <$> arbitrary) + <*> (hash256 <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Script where + arbitrary = do + i <- choose (1,10) + Script <$> (vectorOf i arbitrary) + +instance Arbitrary Tx where + arbitrary = do + v <- arbitrary + tin <- do + l <- choose (0,10) + vectorOf l arbitrary + tout <- do + l <- choose (0,10) + vectorOf l arbitrary + t <- arbitrary + return $ Tx v tin tout t + +instance Arbitrary CoinbaseTx where + arbitrary = CoinbaseTx <$> arbitrary + <*> arbitrary + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary TxIn where + arbitrary = TxIn <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary TxOut where + arbitrary = TxOut <$> (choose (0,2100000000000000)) + <*> arbitrary + +instance Arbitrary OutPoint where + arbitrary = OutPoint <$> arbitrary + <*> (choose (0,2147483647)) + +instance Arbitrary Block where + arbitrary = do + h <- arbitrary + c <- arbitrary + t <- do + l <- choose (0,10) + vectorOf l arbitrary + return $ Block h c t + +instance Arbitrary ScriptOp where + arbitrary = oneof [ OP_PUSHDATA <$> nonEmptyBS + , return OP_0 + , return OP_1NEGATE + , return OP_1 + , return OP_2, return OP_3, return OP_4, return OP_5 + , return OP_6, return OP_7, return OP_8, return OP_9 + , return OP_10, return OP_11, return OP_12, return OP_13 + , return OP_14, return OP_15, return OP_16 + , return OP_VERIFY + , return OP_DUP + , return OP_EQUAL + , return OP_EQUALVERIFY + , return OP_HASH160 + , return OP_CHECKSIG + , return OP_CHECKMULTISIG + , OP_PUBKEY <$> arbitrary + , return $ OP_INVALIDOPCODE 0xff + ] + +instance Arbitrary GetBlocks where + arbitrary = GetBlocks <$> arbitrary + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary GetData where + arbitrary = GetData <$> (listOf arbitrary) + +instance Arbitrary GetHeaders where + arbitrary = GetHeaders <$> arbitrary + <*> (listOf arbitrary) + <*> arbitrary + +instance Arbitrary Headers where + arbitrary = Headers <$> (listOf (liftM2 (,) arbitrary arbitrary)) + +instance Arbitrary NotFound where + arbitrary = NotFound <$> (listOf arbitrary) + +instance Arbitrary Ping where + arbitrary = Ping <$> arbitrary + +instance Arbitrary Pong where + arbitrary = Pong <$> arbitrary + +instance Arbitrary MessageCommand where + arbitrary = elements [ MCVersion + , MCVerAck + , MCAddr + , MCInv + , MCGetData + , MCNotFound + , MCGetBlocks + , MCGetHeaders + , MCTx + , MCBlock + , MCHeaders + , MCGetAddr + , MCPing + , MCPong + , MCAlert + ] + +instance Arbitrary MessageHeader where + arbitrary = MessageHeader <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Message where + arbitrary = oneof [ MVersion <$> arbitrary + , return MVerAck + , MAddr <$> arbitrary + , MInv <$> arbitrary + , MGetData <$> arbitrary + , MNotFound <$> arbitrary + , MGetBlocks <$> arbitrary + , MGetHeaders <$> arbitrary + , MTx <$> arbitrary + , MBlock <$> arbitrary + , MHeaders <$> arbitrary + , return MGetAddr + , MPing <$> arbitrary + , MPong <$> arbitrary + , MAlert <$> arbitrary + ] + diff --git a/Network/Haskoin/Protocol/Block.hs b/Network/Haskoin/Protocol/Block.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Block.hs @@ -0,0 +1,38 @@ +module Network.Haskoin.Protocol.Block ( Block(..) ) where + +import Control.Monad (replicateM, forM_) + +import Data.Binary (Binary, get, put) + +import Network.Haskoin.Protocol.Tx +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.BlockHeader + +-- | Data type describing a block in the bitcoin protocol. Blocks are sent in +-- response to 'GetData' messages that are requesting information from a +-- block hash. +data Block = + Block { + -- | Header information for this block + blockHeader :: !BlockHeader + -- | Coinbase transaction of this block + , blockCoinbaseTx :: !CoinbaseTx + -- | List of transactions pertaining to this block + , blockTxns :: ![Tx] + } deriving (Eq, Show) + +instance Binary Block where + + get = do + header <- get + (VarInt c) <- get + cb <- get + txs <- replicateM (fromIntegral (c-1)) 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 + diff --git a/Network/Haskoin/Protocol/BlockHeader.hs b/Network/Haskoin/Protocol/BlockHeader.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/BlockHeader.hs @@ -0,0 +1,55 @@ +module Network.Haskoin.Protocol.BlockHeader ( BlockHeader(..) ) where + +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) + +import Network.Haskoin.Crypto (Hash256) + +-- | Data type recording information on a 'Block'. The hash of a block is +-- defined as the hash of this data structure. The block mining process +-- involves finding a partial hash collision by varying the nonce in the +-- 'BlockHeader' and/or additional randomness in the 'CoinbaseTx' of this +-- 'Block'. Variations in the 'CoinbaseTx' will result in different merkle +-- roots in the 'BlockHeader'. +data BlockHeader = + BlockHeader { + -- | Block version information, based on the version of the + -- software creating this block. + blockVersion :: !Word32 + -- | Hash of the previous block (parent) referenced by this + -- block. + , prevBlock :: !Hash256 + -- | Root of the merkle tree of all transactions pertaining + -- to this block. + , merkleRoot :: !Hash256 + -- | Unix timestamp recording when this block was created + , blockTimestamp :: !Word32 + -- | The difficulty target being used for this block + , blockBits :: !Word32 + -- | A random nonce used to generate this block. Additional + -- randomness is included in the coinbase transaction of + -- this block. + , bhNonce :: !Word32 + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/GetBlocks.hs b/Network/Haskoin/Protocol/GetBlocks.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetBlocks.hs @@ -0,0 +1,53 @@ +module Network.Haskoin.Protocol.GetBlocks +( GetBlocks(..) +, BlockLocator +) where + +import Control.Monad (replicateM, forM_) +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Crypto (Hash256) + +type BlockLocator = [Hash256] + +-- | Data type representing a GetBlocks message request. It is used in the +-- bitcoin protocol to retrieve blocks from a peer by providing it a +-- 'BlockLocator' object. The 'BlockLocator' is a sparse list of block hashes +-- from the caller node with the purpose of informing the receiving node +-- about the state of the caller's blockchain. The receiver node will detect +-- a wrong branch in the caller's main chain and send the caller appropriate +-- 'Blocks'. The response to a 'GetBlocks' message is an 'Inv' message +-- containing the list of block hashes pertaining to the request. +data GetBlocks = + GetBlocks { + -- | The protocol version + getBlocksVersion :: !Word32 + -- | Block locator object. It is a list of block hashes from the + -- most recent block back to the genesis block. The list is + -- dense at first and sparse towards the end. + , getBlocksLocator :: !BlockLocator + -- | Hash of the last desired block. If set to zero, the + -- maximum number of block hashes is returned (500). + , getBlocksHashStop :: !Hash256 + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/GetData.hs b/Network/Haskoin/Protocol/GetData.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetData.hs @@ -0,0 +1,34 @@ +module Network.Haskoin.Protocol.GetData ( GetData(..) ) where + +import Control.Monad (replicateM, forM_) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) + +import Network.Haskoin.Protocol.InvVector +import Network.Haskoin.Protocol.VarInt + +-- | The 'GetData' type is used to retrieve information on a specific object +-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' +-- request is a list of 'InvVector' which represent all the hashes for which a +-- node wants to request information. The response to a 'GetBlock' message +-- wille be either a 'Block' or a 'Tx' message depending on the type of the +-- object referenced by the hash. Usually, 'GetData' messages are sent after a +-- node receives an 'Inv' message to obtain information on unknown object +-- hashes. +data GetData = + GetData { + -- | List of object hashes + getDataList :: ![InvVector] + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/GetHeaders.hs b/Network/Haskoin/Protocol/GetHeaders.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/GetHeaders.hs @@ -0,0 +1,47 @@ +module Network.Haskoin.Protocol.GetHeaders ( GetHeaders(..) ) where + +import Control.Monad (replicateM, forM_) +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.GetBlocks (BlockLocator) + +import Network.Haskoin.Crypto (Hash256) + +-- | Similar to the 'GetBlocks' message type but for retrieving block headers +-- only. The response to a 'GetHeaders' request is a 'Headers' message +-- containing a list of block headers pertaining to the request. A maximum of +-- 2000 block headers can be returned. 'GetHeaders' is used by thin (SPV) +-- clients to exclude block contents when synchronizing the blockchain. +data GetHeaders = + GetHeaders { + -- | The protocol version + getHeadersVersion :: !Word32 + -- | Block locator object. It is a list of block hashes from + -- the most recent block back to the Genesis block. The list + -- is dense at first and sparse towards the end. + , getHeadersBL :: !BlockLocator + -- | Hash of the last desired block header. When set to zero, + -- the maximum number of block headers is returned (2000) + , getHeadersHashStop :: !Hash256 + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/Headers.hs b/Network/Haskoin/Protocol/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Headers.hs @@ -0,0 +1,36 @@ +module Network.Haskoin.Protocol.Headers +( Headers(..) +, BlockHeaderCount +) where + +import Control.Monad (liftM2, replicateM, forM_) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.BlockHeader + +-- | 'BlockHeader' type with a transaction count as 'VarInt' +type BlockHeaderCount = (BlockHeader, VarInt) + +-- | The 'Headers' type is used to return a list of block headers in +-- response to a 'GetHeaders' message. +data Headers = + Headers { + -- | List of block headers with respective transaction counts + headersList :: ![BlockHeaderCount] + } + deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/Inv.hs b/Network/Haskoin/Protocol/Inv.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Inv.hs @@ -0,0 +1,29 @@ +module Network.Haskoin.Protocol.Inv ( Inv(..) ) where + +import Control.Monad (replicateM, forM_) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) + +import Network.Haskoin.Protocol.InvVector +import Network.Haskoin.Protocol.VarInt + +-- | 'Inv' messages are used by nodes to advertise their knowledge of new +-- objects by publishing a list of hashes. 'Inv' messages can be sent +-- unsolicited or in response to a 'GetBlocks' message. +data Inv = + Inv { + -- | Inventory vectors + invList :: ![InvVector] + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/InvVector.hs b/Network/Haskoin/Protocol/InvVector.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/InvVector.hs @@ -0,0 +1,51 @@ +module Network.Haskoin.Protocol.InvVector +( InvVector(..) +, InvType(..) +) where + +import Control.Applicative ((<$>),(<*>)) + +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) + +import Network.Haskoin.Crypto (Hash256) + +-- | Data type identifying the type of an inventory vector. +data InvType + = InvError -- ^ Error. Data containing this type can be ignored. + | InvTx -- ^ InvVector hash is related to a transaction + | InvBlock -- ^ InvVector hash is related to a block + deriving (Eq, Show) + +instance Binary InvType where + + get = go =<< getWord32le + where + go x = case x of + 0 -> return InvError + 1 -> return InvTx + 2 -> return InvBlock + _ -> fail "bitcoinGet InvType: Invalid Type" + + put x = putWord32le $ case x of + InvError -> 0 + InvTx -> 1 + InvBlock -> 2 + +-- | Invectory vectors represent hashes identifying objects such as a 'Block' +-- or a 'Tx'. They are sent inside messages to notify other peers about +-- new data or data they have requested. +data InvVector = + InvVector { + -- | Type of the object referenced by this inventory vector + invType :: !InvType + -- | Hash of the object referenced by this inventory vector + , invHash :: !Hash256 + } deriving (Eq, Show) + +instance Binary InvVector where + get = InvVector <$> get <*> get + put (InvVector t h) = put t >> put h + + diff --git a/Network/Haskoin/Protocol/Message.hs b/Network/Haskoin/Protocol/Message.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Message.hs @@ -0,0 +1,114 @@ +module Network.Haskoin.Protocol.Message ( Message(..) ) where + +import Control.Monad (unless) +import Control.Applicative ((<$>)) + +import Data.Word (Word32) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( lookAhead + , getByteString + ) +import Data.Binary.Put (putByteString) +import qualified Data.ByteString as BS + ( length + , append + , empty + ) + +import Network.Haskoin.Protocol.MessageHeader +import Network.Haskoin.Protocol.Version +import Network.Haskoin.Protocol.Addr +import Network.Haskoin.Protocol.Inv +import Network.Haskoin.Protocol.GetData +import Network.Haskoin.Protocol.NotFound +import Network.Haskoin.Protocol.GetBlocks +import Network.Haskoin.Protocol.GetHeaders +import Network.Haskoin.Protocol.Tx +import Network.Haskoin.Protocol.Block +import Network.Haskoin.Protocol.Headers +import Network.Haskoin.Protocol.Ping +import Network.Haskoin.Protocol.Alert + +import Network.Haskoin.Util (isolate, encode') +import Network.Haskoin.Crypto (chksum32) + +networkMagic :: Word32 +networkMagic = 0xf9beb4d9 + +-- | 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 + | MHeaders Headers + | MGetAddr + | MPing Ping + | MPong Pong + | MAlert Alert + deriving (Eq, Show) + +instance Binary Message where + + get = do + (MessageHeader mgc cmd len chk) <- get + bs <- lookAhead $ getByteString $ fromIntegral len + unless (mgc == networkMagic) + (fail $ "get: Invalid network magic bytes: " ++ (show mgc)) + unless (chksum32 bs == chk) + (fail $ "get: Invalid message checksum: " ++ (show chk)) + if len > 0 + then isolate (fromIntegral len) $ case cmd of + MCVersion -> MVersion <$> get + MCAddr -> MAddr <$> get + MCInv -> MInv <$> get + MCGetData -> MGetData <$> get + MCNotFound -> MNotFound <$> get + MCGetBlocks -> MGetBlocks <$> get + MCGetHeaders -> MGetHeaders <$> get + MCTx -> MTx <$> get + MCBlock -> MBlock <$> get + MCHeaders -> MHeaders <$> get + MCPing -> MPing <$> get + MCPong -> MPong <$> get + MCAlert -> MAlert <$> get + _ -> fail $ "get: Invalid command " ++ (show cmd) + else case cmd of + MCGetAddr -> return MGetAddr + MCVerAck -> return MVerAck + _ -> fail $ "get: Invalid command " ++ (show cmd) + + put msg = do + let (cmd, payload) = case msg of + (MVersion m) -> (MCVersion, encode' m) + (MVerAck) -> (MCVerAck, BS.empty) + (MAddr m) -> (MCAddr, encode' m) + (MInv m) -> (MCInv, encode' m) + (MGetData m) -> (MCGetData, encode' m) + (MNotFound m) -> (MCNotFound, encode' m) + (MGetBlocks m) -> (MCGetBlocks, encode' m) + (MGetHeaders m) -> (MCGetHeaders, encode' m) + (MTx m) -> (MCTx, encode' m) + (MBlock m) -> (MCBlock, encode' m) + (MHeaders m) -> (MCHeaders, encode' m) + (MGetAddr) -> (MCGetAddr, BS.empty) + (MPing m) -> (MCPing, encode' m) + (MPong m) -> (MCPong, encode' m) + (MAlert m) -> (MCAlert, encode' m) + chk = chksum32 payload + len = fromIntegral $ BS.length payload + header = MessageHeader networkMagic cmd len chk + putByteString $ (encode' header) `BS.append` payload + diff --git a/Network/Haskoin/Protocol/MessageHeader.hs b/Network/Haskoin/Protocol/MessageHeader.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/MessageHeader.hs @@ -0,0 +1,125 @@ +module Network.Haskoin.Protocol.MessageHeader + ( MessageHeader(..) + , MessageCommand(..) + ) where + +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32) +import qualified Data.ByteString as BS + ( ByteString + , takeWhile + ) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( getWord32le + , getWord32be + , getByteString + ) +import Data.Binary.Put + ( putWord32le + , putWord32be + , putByteString + ) + +import Network.Haskoin.Util (stringToBS, bsToString) +import Network.Haskoin.Crypto (CheckSum32) + +-- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify +-- the type of message present in the payload. This allows the message +-- de-serialization code to know how to decode a particular message payload. +-- Every valid 'Message' constructor has a corresponding 'MessageCommand' +-- constructor. +data MessageCommand + = MCVersion + | MCVerAck + | MCAddr + | MCInv + | MCGetData + | MCNotFound + | MCGetBlocks + | MCGetHeaders + | MCTx + | MCBlock + | MCHeaders + | MCGetAddr + | MCPing + | MCPong + | MCAlert + deriving (Eq, Show) + +instance Binary MessageCommand where + + get = go =<< getByteString 12 + where + go bs = case unpackCommand bs of + "version" -> return MCVersion + "verack" -> return MCVerAck + "addr" -> return MCAddr + "inv" -> return MCInv + "getdata" -> return MCGetData + "notfound" -> return MCNotFound + "getblocks" -> return MCGetBlocks + "getheaders" -> return MCGetHeaders + "tx" -> return MCTx + "block" -> return MCBlock + "headers" -> return MCHeaders + "getaddr" -> return MCGetAddr + "ping" -> return MCPing + "pong" -> return MCPong + "alert" -> return MCAlert + _ -> fail "get MessageCommand : Invalid command" + + put mc = putByteString $ packCommand $ case mc of + MCVersion -> "version" + MCVerAck -> "verack" + MCAddr -> "addr" + MCInv -> "inv" + MCGetData -> "getdata" + MCNotFound -> "notfound" + MCGetBlocks -> "getblocks" + MCGetHeaders -> "getheaders" + MCTx -> "tx" + MCBlock -> "block" + MCHeaders -> "headers" + MCGetAddr -> "getaddr" + MCPing -> "ping" + MCPong -> "pong" + MCAlert -> "alert" + +packCommand :: String -> BS.ByteString +packCommand s = stringToBS $ take 12 $ s ++ repeat '\NUL' + +unpackCommand :: BS.ByteString -> String +unpackCommand bs = bsToString $ BS.takeWhile (/= 0) bs + +-- | Data type representing the header of a 'Message'. All messages sent between +-- nodes contain a message header. +data MessageHeader = + MessageHeader { + -- | Network magic bytes. It is used to differentiate + -- messages meant for different bitcoin networks, such as + -- prodnet and testnet. + headMagic :: !Word32 + -- | Message command identifying the type of message. + -- included in the payload. + , headCmd :: !MessageCommand + -- | Byte length of the payload. + , headPayloadSize :: !Word32 + -- | Checksum of the payload. + , headChecksum :: !CheckSum32 + } deriving (Eq, Show) + +instance Binary MessageHeader where + + get = MessageHeader <$> getWord32be + <*> get + <*> getWord32le + <*> get + + put (MessageHeader m c l chk) = do + putWord32be m + put c + putWord32le l + put chk + diff --git a/Network/Haskoin/Protocol/NetworkAddress.hs b/Network/Haskoin/Protocol/NetworkAddress.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/NetworkAddress.hs @@ -0,0 +1,45 @@ +module Network.Haskoin.Protocol.NetworkAddress ( NetworkAddress(..) ) where + +import Control.Monad (liftM2) +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word16, Word64) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( getWord16be + , getWord64le + , getWord64be + ) +import Data.Binary.Put + ( putWord16be + , putWord64le + , putWord64be + ) + +-- | Data type describing a bitcoin network address. Addresses are stored in +-- IPv6. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 addresses: +-- . Sometimes, +-- timestamps are sent together with the 'NetworkAddress' such as in the 'Addr' +-- data type. +data NetworkAddress = + NetworkAddress { + -- | Bitmask of services available for this address + naServices :: !Word64 + -- | IPv6 address serialized as big endian + , naAddress :: !(Word64, Word64) + -- | Port number serialized as big endian + , naPort :: !Word16 + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/NotFound.hs b/Network/Haskoin/Protocol/NotFound.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/NotFound.hs @@ -0,0 +1,30 @@ +module Network.Haskoin.Protocol.NotFound ( NotFound(..) ) where + +import Control.Monad (replicateM, forM_) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.InvVector + +-- | A 'NotFound' message is returned as a response to a 'GetData' message +-- whe one of the requested objects could not be retrieved. This could happen, +-- for example, if a tranasaction was requested and was not available in the +-- memory pool of the receiving node. +data NotFound = + NotFound { + -- | Inventory vectors related to this request + notFoundList :: ![InvVector] + } deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/Ping.hs b/Network/Haskoin/Protocol/Ping.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Ping.hs @@ -0,0 +1,37 @@ +module Network.Haskoin.Protocol.Ping +( Ping(..) +, Pong(..) +) where + +import Control.Applicative ((<$>)) + +import Data.Word (Word64) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) + +-- | A Ping message is sent to bitcoin peers to check if a TCP\/IP connection +-- is still valid. +newtype Ping = + Ping { + -- | A random nonce used to identify the recipient of the ping + -- request once a Pong response is received. + pingNonce :: Word64 + } deriving (Eq, Show) + +-- | A Pong message is sent as a response to a ping message. +newtype Pong = + Pong { + -- | When responding to a Ping request, the nonce from the Ping + -- is copied in the Pong response. + pongNonce :: Word64 + } deriving (Eq, Show) + +instance Binary Ping where + get = Ping <$> getWord64le + put (Ping n) = putWord64le n + +instance Binary Pong where + get = Pong <$> getWord64le + put (Pong n) = putWord64le n + diff --git a/Network/Haskoin/Protocol/Script.hs b/Network/Haskoin/Protocol/Script.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Script.hs @@ -0,0 +1,257 @@ +module Network.Haskoin.Protocol.Script +( ScriptOp(..) +, Script(..) +, getScriptOps +, putScriptOps +, decodeScriptOps +, encodeScriptOps +) where + +import Control.Monad (liftM2) +import Control.Applicative ((<$>)) + +import Data.Word (Word8) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( Get + , isEmpty + , getWord8 + , getWord16le + , getWord32le + , getByteString + ) +import Data.Binary.Put + ( Put + , putWord8 + , putWord16le + , putWord32le + , putByteString + ) +import qualified Data.ByteString as BS + ( ByteString + , length + ) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Util + ( isolate + , runPut' + , encode' + , bsToHex + , fromRunGet + ) +import Network.Haskoin.Crypto (PubKey) + +-- | Data type representing a transaction script. Scripts are defined as lists +-- of script operators 'ScriptOp'. Scripts are used to: +-- +-- * Define the spending conditions in the output of a transaction +-- +-- * Provide the spending signatures in the input of a transaction +data Script = + Script { + -- | List of script operators defining this script + scriptOps :: [ScriptOp] + } + deriving (Eq, Show) + +instance Binary Script where + get = do + (VarInt len) <- get + isolate (fromIntegral len) $ Script <$> getScriptOps + + put (Script ops) = do + let bs = runPut' $ putScriptOps ops + put $ VarInt $ fromIntegral $ BS.length bs + putByteString bs + +-- | Deserialize a list of 'ScriptOp' inside the 'Data.Binary.Get' monad. +-- This deserialization does not take into account the length of the script. +getScriptOps :: Get [ScriptOp] +getScriptOps = do + empty <- isEmpty + if empty + then return [] + else liftM2 (:) get getScriptOps + +-- | Serialize a list of 'ScriptOp' inside the 'Data.Binary.Put' monad. +-- This serialization does not take into account the length of the script. +putScriptOps :: [ScriptOp] -> Put +putScriptOps (x:xs) = put x >> putScriptOps xs +putScriptOps _ = return () + +-- | Decode a 'Script' from a ByteString by omiting the length of the script. +-- This is used to produce scripthash addresses. +decodeScriptOps :: BS.ByteString -> Either String Script +decodeScriptOps bs = fromRunGet getScriptOps bs msg (return . Script) + where + msg = Left "decodeScriptOps: Could not decode scriptops" + +-- | Encode a 'Script' into a ByteString by omiting the length of the script. +-- This is used to produce scripthash addresses. +encodeScriptOps :: Script -> BS.ByteString +encodeScriptOps = runPut' . putScriptOps . scriptOps + +-- | Data type representing all of the operators allowed inside a 'Script'. +data ScriptOp + = + -- Pushing Data + OP_PUSHDATA BS.ByteString + | OP_0 + | OP_1NEGATE + | OP_1 | OP_2 | OP_3 | OP_4 + | OP_5 | OP_6 | OP_7 | OP_8 + | OP_9 | OP_10 | OP_11 | OP_12 + | OP_13 | OP_14 | OP_15 | OP_16 + + -- Flow control + | OP_VERIFY + + -- Stack operations + | OP_DUP + + -- Bitwise logic + | OP_EQUAL + | OP_EQUALVERIFY + + -- Crypto + | OP_HASH160 + | OP_CHECKSIG + | OP_CHECKMULTISIG + + -- Other + | OP_PUBKEY PubKey + | OP_INVALIDOPCODE Word8 + deriving Eq + +instance Show ScriptOp where + show op = case op of + (OP_PUSHDATA bs) -> "OP_PUSHDATA " ++ (show $ bsToHex bs) + OP_0 -> "OP_0" + OP_1NEGATE -> "OP_1NEGATE" + OP_1 -> "OP_1" + OP_2 -> "OP_2" + OP_3 -> "OP_3" + OP_4 -> "OP_4" + OP_5 -> "OP_5" + OP_6 -> "OP_6" + OP_7 -> "OP_7" + OP_8 -> "OP_8" + OP_9 -> "OP_9" + OP_10 -> "OP_10" + OP_11 -> "OP_11" + OP_12 -> "OP_12" + OP_13 -> "OP_13" + OP_14 -> "OP_14" + OP_15 -> "OP_15" + OP_16 -> "OP_16" + OP_VERIFY -> "OP_VERIFY" + OP_DUP -> "OP_DUP" + OP_EQUAL -> "OP_EQUAL" + OP_EQUALVERIFY -> "OP_EQUALVERIFY" + OP_HASH160 -> "OP_HASH160" + OP_CHECKSIG -> "OP_CHECKSIG" + OP_CHECKMULTISIG -> "OP_CHECKMULTISIG" + (OP_PUBKEY p) -> "OP_PUBKEY " ++ (show $ bsToHex $ encode' p) + (OP_INVALIDOPCODE w) -> "OP_INVALIDOPCODE " ++ (show w) + +instance Binary ScriptOp where + + get = go =<< (fromIntegral <$> getWord8) + where + go op + | op == 0x00 = return $ OP_0 + | op <= 0x4b = do + payload <- getByteString (fromIntegral op) + return $ OP_PUSHDATA payload + | op == 0x4c = do + len <- getWord8 + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload + | op == 0x4d = do + len <- getWord16le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload + | op == 0x4e = do + len <- getWord32le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload + | op == 0x4f = return $ OP_1NEGATE + | op == 0x51 = return $ OP_1 + | op == 0x52 = return $ OP_2 + | op == 0x53 = return $ OP_3 + | op == 0x54 = return $ OP_4 + | op == 0x55 = return $ OP_5 + | op == 0x56 = return $ OP_6 + | op == 0x57 = return $ OP_7 + | op == 0x58 = return $ OP_8 + | op == 0x59 = return $ OP_9 + | op == 0x5a = return $ OP_10 + | op == 0x5b = return $ OP_11 + | op == 0x5c = return $ OP_12 + | op == 0x5d = return $ OP_13 + | op == 0x5e = return $ OP_14 + | op == 0x5f = return $ OP_15 + | op == 0x60 = return $ OP_16 + | op == 0x69 = return $ OP_VERIFY + | op == 0x76 = return $ OP_DUP + | op == 0x87 = return $ OP_EQUAL + | op == 0x88 = return $ OP_EQUALVERIFY + | op == 0xa9 = return $ OP_HASH160 + | op == 0xac = return $ OP_CHECKSIG + | op == 0xae = return $ OP_CHECKMULTISIG + | op == 0xfe = OP_PUBKEY <$> get + | otherwise = return $ OP_INVALIDOPCODE op + + put op = case op of + + (OP_PUSHDATA payload) -> go payload (BS.length payload) + where + go p len + | len <= 0 = fail "OP_PUSHDATA: data length must be > 0" + | len <= 0x4b = do + putWord8 $ fromIntegral len + putByteString p + | len <= 0xff = do + putWord8 0x4c + putWord8 $ fromIntegral len + putByteString p + | len <= 0xffff = do + putWord8 0x4d + putWord16le $ fromIntegral len + putByteString p + | len <= 0xffffffff = do + putWord8 0x4e + putWord32le $ fromIntegral len + putByteString p + | otherwise = + fail "bitcoinPut OP_PUSHDATA payload too big" + + OP_0 -> putWord8 0x00 + OP_1NEGATE -> putWord8 0x4f + OP_1 -> putWord8 0x51 + OP_2 -> putWord8 0x52 + OP_3 -> putWord8 0x53 + OP_4 -> putWord8 0x54 + OP_5 -> putWord8 0x55 + OP_6 -> putWord8 0x56 + OP_7 -> putWord8 0x57 + OP_8 -> putWord8 0x58 + OP_9 -> putWord8 0x59 + OP_10 -> putWord8 0x5a + OP_11 -> putWord8 0x5b + OP_12 -> putWord8 0x5c + OP_13 -> putWord8 0x5d + OP_14 -> putWord8 0x5e + OP_15 -> putWord8 0x5f + OP_16 -> putWord8 0x60 + OP_VERIFY -> putWord8 0x69 + OP_DUP -> putWord8 0x76 + OP_EQUAL -> putWord8 0x87 + OP_EQUALVERIFY -> putWord8 0x88 + OP_HASH160 -> putWord8 0xa9 + OP_CHECKSIG -> putWord8 0xac + OP_CHECKMULTISIG -> putWord8 0xae + (OP_PUBKEY pk) -> putWord8 0xfe >> put pk + (OP_INVALIDOPCODE _) -> putWord8 0xff + diff --git a/Network/Haskoin/Protocol/Tx.hs b/Network/Haskoin/Protocol/Tx.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Tx.hs @@ -0,0 +1,189 @@ +module Network.Haskoin.Protocol.Tx +( Tx(..) +, TxIn(..) +, TxOut(..) +, OutPoint(..) +, CoinbaseTx(..) +, txid +, encodeTxid +, decodeTxid +) where + +import Control.Monad (replicateM, forM_, liftM2, unless) +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32, Word64) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( getWord32le + , getWord64le + , getByteString + , skip + ) +import Data.Binary.Put + ( putWord32le + , putWord64le + , putByteString + ) +import qualified Data.ByteString as BS + ( ByteString + , length + , reverse + ) + +import Network.Haskoin.Protocol.VarInt +import Network.Haskoin.Protocol.Script +import Network.Haskoin.Crypto (Hash256, doubleHash256) +import Network.Haskoin.Util (bsToHex, hexToBS, encode', decodeToMaybe) + +-- | Data type representing a bitcoin transaction +data Tx = + Tx { + -- | Transaction data format version + txVersion :: !Word32 + -- | List of transaction inputs + , txIn :: ![TxIn] + -- | List of transaction outputs + , txOut :: ![TxOut] + -- | The block number of timestamp at which this transaction is locked + , txLockTime :: !Word32 + } deriving (Eq, Show) + +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 + +-- | Data type representing the coinbase transaction of a 'Block'. Coinbase +-- transactions are special types of transactions which are created by miners +-- when they find a new block. Coinbase transactions have no inputs. They have +-- outputs sending the newly generated bitcoins together with all the block's +-- fees to a bitcoin address (usually the miners address). Data can be embedded +-- in a Coinbase transaction which can be chosen by the miner of a block. This +-- data also typically contains some randomness which is used, together with +-- the nonce, to find a partial hash collision on the block's hash. +data CoinbaseTx = + CoinbaseTx { + -- | Transaction data format version. + cbVersion :: !Word32 + -- | Data embedded inside the coinbase transaction. + , cbData :: !BS.ByteString + -- | List of transaction outputs. + , cbOut :: ![TxOut] + -- | The block number of timestamp at which this + -- transaction is locked. + , cbLockTime :: !Word32 + } deriving (Eq, Show) + +instance Binary CoinbaseTx where + + get = CoinbaseTx <$> getWord32le + <*> (readCoinbase =<< get) + <*> (replicateList =<< get) + <*> getWord32le + where + readCoinbase (VarInt _) = do + skip 36 -- skip OutPoint + (VarInt len) <- get + coinbase <- getByteString (fromIntegral len) + skip 4 -- skip sequence + return coinbase + replicateList (VarInt c) = replicateM (fromIntegral c) get + + put (CoinbaseTx v cb os l) = do + putWord32le v + put $ VarInt 1 + put $ OutPoint 0 maxBound + put $ VarInt $ fromIntegral $ BS.length cb + putByteString cb + putWord32le 0 --sequence number + put $ VarInt $ fromIntegral $ length os + forM_ os put + putWord32le l + +-- | Data type representing a transaction input. +data TxIn = + TxIn { + -- | Reference the previous transaction output (hash + position) + prevOutput :: !OutPoint + -- | Script providing the requirements of the previous transaction + -- output to spend those coins. + , scriptInput :: !Script + -- | Transaction version as defined by the sender of the + -- transaction. The intended use is for replacing transactions with + -- new information before the transaction is included in a block. + , txInSequence :: !Word32 + } deriving (Eq, Show) + +instance Binary TxIn where + get = TxIn <$> get <*> get <*> getWord32le + put (TxIn o s q) = put o >> put s >> putWord32le q + +-- | Data type representing a transaction output. +data TxOut = + TxOut { + -- | Transaction output value. + outValue :: !Word64 + -- | Script specifying the conditions to spend this output. + , scriptOutput :: !Script + } deriving (Eq, Show) + +instance Binary TxOut where + get = do + val <- getWord64le + unless (val <= 2100000000000000) $ fail $ + "Invalid TxOut value: " ++ (show val) + TxOut val <$> get + put (TxOut o s) = putWord64le o >> put s + +-- | The OutPoint is used inside a transaction input to reference the previous +-- transaction output that it is spending. +data OutPoint = + OutPoint { + -- | The hash of the referenced transaction. + outPointHash :: !Hash256 + -- | The position of the specific output in the transaction. + -- The first output position is 0. + , outPointIndex :: !Word32 + } deriving Eq + +instance Show OutPoint where + show (OutPoint h i) = show ("txid = " ++ h',"index = " ++ (show i)) + where + h' = encodeTxid h + +instance Binary OutPoint where + get = do + (h,i) <- liftM2 (,) get getWord32le + unless (i <= 2147483647) $ fail $ + "Invalid OutPoint index: " ++ (show i) + return $ OutPoint h i + put (OutPoint h i) = put h >> putWord32le i + +-- | Computed the hash of a transaction. +txid :: Tx -> Hash256 +txid = doubleHash256 . encode' + +-- | Encodes a transaction hash as little endian in HEX format. +-- This is mostly used for displaying transaction ids. Internally, these ids +-- are handled as big endian but are transformed to little endian when +-- displaying them. +encodeTxid :: Hash256 -> String +encodeTxid = bsToHex . BS.reverse . encode' + +-- | Decodes a little endian transaction hash in HEX format. +decodeTxid :: String -> Maybe Hash256 +decodeTxid = (decodeToMaybe . BS.reverse =<<) . hexToBS + diff --git a/Network/Haskoin/Protocol/VarInt.hs b/Network/Haskoin/Protocol/VarInt.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/VarInt.hs @@ -0,0 +1,46 @@ +module Network.Haskoin.Protocol.VarInt ( VarInt(..) ) where + +import Data.Word (Word64) +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( getWord8 + , getWord16le + , getWord32le + , getWord64le + ) +import Data.Binary.Put + ( putWord8 + , putWord16le + , putWord32le + , putWord64le + ) + +-- | Data type representing a variable length integer. The 'VarInt' type +-- usually precedes an array or a string that can vary in length. +newtype VarInt = VarInt { getVarInt :: Word64 } + deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/VarString.hs b/Network/Haskoin/Protocol/VarString.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/VarString.hs @@ -0,0 +1,29 @@ +module Network.Haskoin.Protocol.VarString ( VarString(..) ) where + +import Control.Applicative ((<$>)) + +import qualified Data.ByteString as BS + ( ByteString + , length + ) +import Data.Binary (Binary, get, put) +import Data.Binary.Get (getByteString) +import Data.Binary.Put (putByteString) + +import Network.Haskoin.Protocol.VarInt + +-- | Data type for variable length strings. Variable length strings are +-- serialized as a 'VarInt' followed by a bytestring. +newtype VarString = VarString { getVarString :: BS.ByteString } + deriving (Eq, Show) + +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 + diff --git a/Network/Haskoin/Protocol/Version.hs b/Network/Haskoin/Protocol/Version.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Protocol/Version.hs @@ -0,0 +1,85 @@ +module Network.Haskoin.Protocol.Version ( Version(..) ) where + +import Control.Applicative ((<$>),(<*>)) + +import Data.Word (Word32, Word64) +import Data.Binary (Binary, get, put, Get, Put) +import Data.Binary.Get + ( getWord8 + , getWord32le + , getWord64le + , isEmpty + ) +import Data.Binary.Put + ( putWord8 + , putWord32le + , putWord64le + ) + +import Network.Haskoin.Protocol.VarString +import Network.Haskoin.Protocol.NetworkAddress + +-- | When a bitcoin node creates an outgoing connection to another node, +-- the first message it will send is a 'Version' message. The other node +-- will similarly respond with it's own 'Version' message. +data Version = + Version { + -- | Protocol version being used by the node. + version :: !Word32 + -- | Bitmask of features to enable for this connection. + , services :: !Word64 + -- | UNIX timestamp + , timestamp :: !Word64 + -- | Network address of the node receiving this message. + , addrRecv :: !NetworkAddress + -- | Network address of the node sending this message. + , addrSend :: !NetworkAddress + -- | Randomly generated identifying sent with every version + -- message. This nonce is used to detect connection to self. + , verNonce :: !Word64 + -- | User agent + , userAgent :: !VarString + -- | The height of the last block received by the sending node. + , startHeight :: !Word32 + -- | Wether the remote peer should announce relaying transactions + -- or not. This feature is enabled since version >= 70001. See + -- BIP37 for more details. + , relay :: !Bool + } deriving (Eq, Show) + +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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/haskoin-protocol.cabal b/haskoin-protocol.cabal new file mode 100644 --- /dev/null +++ b/haskoin-protocol.cabal @@ -0,0 +1,71 @@ +name: haskoin-protocol +version: 0.0.1 +synopsis: Implementation of the Bitcoin network protocol messages +description: + This package provides all of the basic types used for the Bitcoin + networking protocol together with Data.Binary instances for efficiently + serializing and de-serializing them. +homepage: http://github.com/plaprade/haskoin-protocol +bug-reports: http://github.com/plaprade/haskoin-protocol/issues +stability: experimental +license: PublicDomain +license-file: UNLICENSE +author: Philippe Laprade +maintainer: plaprade+hackage@gmail.com +category: Bitcoin, Finance, Network +build-type: Simple +cabal-version: >= 1.9.2 + +source-repository head + type: git + location: git://github.com/plaprade/haskoin-protocol.git + +library + exposed-modules: Network.Haskoin.Protocol, + Network.Haskoin.Protocol.Arbitrary + other-modules: Network.Haskoin.Protocol.Message, + Network.Haskoin.Protocol.VarInt, + Network.Haskoin.Protocol.BlockHeader, + Network.Haskoin.Protocol.Addr, + Network.Haskoin.Protocol.Tx, + Network.Haskoin.Protocol.NotFound, + Network.Haskoin.Protocol.NetworkAddress, + Network.Haskoin.Protocol.Inv, + Network.Haskoin.Protocol.VarString, + Network.Haskoin.Protocol.GetBlocks, + Network.Haskoin.Protocol.Ping, + Network.Haskoin.Protocol.Script, + Network.Haskoin.Protocol.InvVector, + Network.Haskoin.Protocol.Alert, + Network.Haskoin.Protocol.MessageHeader, + Network.Haskoin.Protocol.Block, + Network.Haskoin.Protocol.Version, + Network.Haskoin.Protocol.GetData, + Network.Haskoin.Protocol.Headers, + Network.Haskoin.Protocol.GetHeaders + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + haskoin-util == 0.0.*, + haskoin-crypto == 0.0.*, + QuickCheck == 2.6.* + ghc-options: -Wall -fno-warn-orphans + +Test-Suite test-haskoin-protocol + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Network.Haskoin.Protocol.Tests, + Units + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + haskoin-util == 0.0.*, + haskoin-crypto == 0.0.*, + QuickCheck == 2.6.*, + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.*, + HUnit == 1.2.* + hs-source-dirs: . tests + ghc-options: -Wall -fno-warn-orphans + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.Framework (defaultMain) + +import qualified Network.Haskoin.Protocol.Tests (tests) +import qualified Units (tests) + +main :: IO () +main = defaultMain + ( Network.Haskoin.Protocol.Tests.tests + ++ Units.tests + ) + diff --git a/tests/Network/Haskoin/Protocol/Tests.hs b/tests/Network/Haskoin/Protocol/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Haskoin/Protocol/Tests.hs @@ -0,0 +1,56 @@ +module Network.Haskoin.Protocol.Tests (tests) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Maybe +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +import Network.Haskoin.Protocol.Arbitrary() +import Network.Haskoin.Protocol +import Network.Haskoin.Crypto + +tests :: [Test] +tests = + [ testGroup "Serialize & de-serialize protocol messages" + [ testProperty "VarInt" (metaGetPut :: VarInt -> Bool) + , testProperty "VarString" (metaGetPut :: VarString -> Bool) + , testProperty "NetworkAddress" (metaGetPut :: NetworkAddress -> Bool) + , testProperty "InvType" (metaGetPut :: InvType -> Bool) + , testProperty "InvVector" (metaGetPut :: InvVector -> Bool) + , testProperty "Inv" (metaGetPut :: Inv -> Bool) + , testProperty "Version" (metaGetPut :: Version -> Bool) + , testProperty "Addr" (metaGetPut :: Addr -> Bool) + , testProperty "Alert" (metaGetPut :: Alert -> Bool) + , testProperty "TxIn" (metaGetPut :: TxIn -> Bool) + , testProperty "TxOut" (metaGetPut :: TxOut -> Bool) + , testProperty "OutPoint" (metaGetPut :: OutPoint -> Bool) + , testProperty "ScriptOp" (metaGetPut :: ScriptOp -> Bool) + , testProperty "Script" (metaGetPut :: Script -> Bool) + , testProperty "Tx" (metaGetPut :: Tx -> Bool) + , testProperty "CoinbaseTx" (metaGetPut :: CoinbaseTx -> Bool) + , testProperty "BlockHeader" (metaGetPut :: BlockHeader -> Bool) + , testProperty "Block" (metaGetPut :: Block -> Bool) + , testProperty "GetBlocks" (metaGetPut :: GetBlocks -> Bool) + , testProperty "GetData" (metaGetPut :: GetData -> Bool) + , testProperty "GetHeaders" (metaGetPut :: GetHeaders -> Bool) + , testProperty "Headers" (metaGetPut :: Headers -> Bool) + , testProperty "NotFound" (metaGetPut :: NotFound -> Bool) + , testProperty "Ping" (metaGetPut :: Ping -> Bool) + , testProperty "Pong" (metaGetPut :: Pong -> Bool) + , testProperty "MessageCommand" (metaGetPut :: MessageCommand -> Bool) + , testProperty "MessageHeader" (metaGetPut :: MessageHeader -> Bool) + , testProperty "Message" (metaGetPut :: Message -> Bool) + ] + , testGroup "Transactions" + [ testProperty "decode . encode Txid" decEncTxid ] + ] + +metaGetPut :: (Binary a, Eq a) => a -> Bool +metaGetPut x = (runGet get (runPut $ put x)) == x + +decEncTxid :: Hash256 -> Bool +decEncTxid h = (fromJust $ decodeTxid $ encodeTxid h) == h + diff --git a/tests/Units.hs b/tests/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Units.hs @@ -0,0 +1,44 @@ +module Units (tests) where + +import Test.HUnit (Assertion, assertBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Maybe + +import Network.Haskoin.Protocol +import Network.Haskoin.Util + +tests :: [Test] +tests = + [ testGroup "Computing TxID from Tx" + ( map mapTxIDVec $ zip txIDVec [0..] ) + ] + +mapTxIDVec :: ((String,String),Int) -> Test.Framework.Test +mapTxIDVec (v,i) = testCase name $ runTxIDVec v + where + name = "Compute TxID " ++ (show i) + +runTxIDVec :: (String,String) -> Assertion +runTxIDVec (tid,tx) = assertBool "TxID" $ + (encodeTxid $ txid txBS) == tid + where + txBS = decode' $ fromJust $ hexToBS tx + +txIDVec :: [(String,String)] +txIDVec = + [ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63" + , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ) + , ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73" + , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000" + ) + , ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb" + , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000" + ) + , ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae" + , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000" + ) + ] +