module Network.Haskoin.Block.Types
( Block(..)
, BlockHeader
, createBlockHeader
, blockVersion
, prevBlock
, merkleRoot
, blockTimestamp
, blockBits
, bhNonce
, headerHash
, BlockLocator
, GetBlocks(..)
, GetHeaders(..)
, BlockHeaderCount
, BlockHash(..)
, blockHashToHex
, hexToBlockHash
, Headers(..)
, decodeCompact
, encodeCompact
) where
import Control.DeepSeq (NFData, rnf)
import Control.Monad (forM_, liftM2, mzero,
replicateM)
import Data.Aeson (FromJSON, ToJSON,
Value (String), parseJSON,
toJSON, withText)
import Data.Bits (shiftL, shiftR, (.&.),
(.|.))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (length, reverse)
import Data.Maybe (fromMaybe)
import Data.Serialize (Serialize, encode, get, put)
import Data.Serialize.Get (getWord32le, lookAhead,
remaining, getByteString)
import Data.Serialize.Put (Put, putWord32le)
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.Word (Word32)
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Node.Types
import Network.Haskoin.Transaction.Types
import Network.Haskoin.Util
import Text.Read (lexP, parens, pfail,
readPrec)
import qualified Text.Read as Read (Lexeme (Ident, String))
data Block =
Block {
blockHeader :: !BlockHeader
, blockTxns :: ![Tx]
} deriving (Eq, Show, Read)
instance NFData Block where
rnf (Block h ts) = rnf h `seq` rnf ts
instance Serialize Block where
get = do
header <- get
(VarInt c) <- get
txs <- replicateM (fromIntegral c) get
return $ Block header txs
put (Block h txs) = do
put h
put $ VarInt $ fromIntegral $ length txs
forM_ txs put
newtype BlockHash = BlockHash { getBlockHash :: Hash256 }
deriving (Eq, Ord)
instance NFData BlockHash where
rnf (BlockHash h) = rnf $ getHash256 h
instance Show BlockHash where
showsPrec d h = showParen (d > 10) $
showString "BlockHash " . shows (blockHashToHex h)
instance Read BlockHash where
readPrec = parens $ do
Read.Ident "BlockHash" <- lexP
Read.String str <- lexP
maybe pfail return $ hexToBlockHash $ cs str
instance IsString BlockHash where
fromString = fromMaybe e . hexToBlockHash . cs where
e = error "Could not read block hash from hex string"
instance Serialize BlockHash where
get = BlockHash <$> get
put = put . getBlockHash
instance FromJSON BlockHash where
parseJSON = withText "Block hash" $ \t ->
maybe mzero return $ hexToBlockHash $ cs t
instance ToJSON BlockHash where
toJSON = String . cs . blockHashToHex
blockHashToHex :: BlockHash -> ByteString
blockHashToHex (BlockHash h) = encodeHex $ BS.reverse $ getHash256 h
hexToBlockHash :: ByteString -> Maybe BlockHash
hexToBlockHash hex = do
bs <- BS.reverse <$> decodeHex hex
h <- bsToHash256 bs
return $ BlockHash h
data BlockHeader =
BlockHeader {
_blockVersion :: !Word32
, _prevBlock :: !BlockHash
, _merkleRoot :: !Hash256
, _blockTimestamp :: !Word32
, _blockBits :: !Word32
, _bhNonce :: !Word32
, _headerHash :: !BlockHash
} deriving (Eq, Show, Read)
createBlockHeader :: Word32 -> BlockHash -> Hash256
-> Word32 -> Word32 -> Word32 -> BlockHeader
createBlockHeader v p m t b n =
BlockHeader { _blockVersion = v
, _prevBlock = p
, _merkleRoot = m
, _blockTimestamp = t
, _blockBits = b
, _bhNonce = n
, _headerHash = BlockHash $ doubleHash256 $ encode bh
}
where
bh = BlockHeader { _blockVersion = v
, _prevBlock = p
, _merkleRoot = m
, _blockTimestamp = t
, _blockBits = b
, _bhNonce = n
, _headerHash = fromString $ replicate 64 '0'
}
blockVersion :: BlockHeader -> Word32
blockVersion = _blockVersion
prevBlock :: BlockHeader -> BlockHash
prevBlock = _prevBlock
merkleRoot :: BlockHeader -> Hash256
merkleRoot = _merkleRoot
blockTimestamp :: BlockHeader -> Word32
blockTimestamp = _blockTimestamp
blockBits :: BlockHeader -> Word32
blockBits = _blockBits
bhNonce :: BlockHeader -> Word32
bhNonce = _bhNonce
headerHash :: BlockHeader -> BlockHash
headerHash = _headerHash
instance NFData BlockHeader where
rnf (BlockHeader v p m t b n h) =
rnf v `seq` rnf p `seq` rnf m `seq`
rnf t `seq` rnf b `seq` rnf n `seq` rnf h
instance Serialize BlockHeader where
get = do
start <- remaining
(v, p, m, t, b, n, end) <- lookAhead $ do
v <- getWord32le
p <- get
m <- get
t <- getWord32le
b <- getWord32le
n <- getWord32le
end <- remaining
return (v, p, m, t, b, n, end)
bs <- getByteString $ fromIntegral $ start end
return $ BlockHeader
{ _blockVersion = v
, _prevBlock = p
, _merkleRoot = m
, _blockTimestamp = t
, _blockBits = b
, _bhNonce = n
, _headerHash = BlockHash $ doubleHash256 bs
}
put (BlockHeader v p m bt bb n _) = do
putWord32le v
put p
put m
putWord32le bt
putWord32le bb
putWord32le n
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 Serialize GetBlocks where
get = GetBlocks <$> getWord32le
<*> (repList =<< get)
<*> get
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (GetBlocks v xs h) = putGetBlockMsg v xs h
putGetBlockMsg :: Word32 -> BlockLocator -> BlockHash -> Put
putGetBlockMsg v xs h = do
putWord32le v
put $ VarInt $ fromIntegral $ length xs
forM_ xs put
put h
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 Serialize GetHeaders where
get = GetHeaders <$> getWord32le
<*> (repList =<< get)
<*> get
where
repList (VarInt c) = replicateM (fromIntegral c) get
put (GetHeaders v xs h) = putGetBlockMsg v xs h
type BlockHeaderCount = (BlockHeader, VarInt)
data Headers =
Headers {
headersList :: ![BlockHeaderCount]
}
deriving (Eq, Show, Read)
instance NFData Headers where
rnf (Headers l) = rnf l
instance Serialize 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
decodeCompact :: Word32 -> Integer
decodeCompact c =
if neg then (res) else res
where
size = fromIntegral $ c `shiftR` 24
neg = (c .&. 0x00800000) /= 0
wrd = c .&. 0x007fffff
res | size <= 3 = toInteger wrd `shiftR` (8*(3 size))
| otherwise = toInteger wrd `shiftL` (8*(size 3))
encodeCompact :: Integer -> Word32
encodeCompact i
| i < 0 = c3 .|. 0x00800000
| otherwise = c3
where
posi = abs i
s1 = BS.length $ integerToBS posi
c1 | s1 < 3 = posi `shiftL` (8*(3 s1))
| otherwise = posi `shiftR` (8*(s1 3))
(s2,c2) | c1 .&. 0x00800000 /= 0 = (s1 + 1, c1 `shiftR` 8)
| otherwise = (s1, c1)
c3 = fromIntegral $ c2 .|. (toInteger s2 `shiftL` 24)