{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Network.Haskoin.Block.Common
( Block(..)
, BlockHeight
, Timestamp
, BlockHeader(..)
, headerHash
, BlockLocator
, GetBlocks(..)
, GetHeaders(..)
, BlockHeaderCount
, BlockHash(..)
, blockHashToHex
, hexToBlockHash
, Headers(..)
, decodeCompact
, encodeCompact
) where
import Control.Monad (forM_, liftM2, mzero,
replicateM)
import Data.Aeson (FromJSON, ToJSON,
Value (String), parseJSON,
toJSON, withText)
import Data.Bits (shiftL, shiftR, (.&.),
(.|.))
import qualified Data.ByteString as B
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.Serialize (Serialize, decode, encode,
get, put)
import Data.Serialize.Get (getWord32le)
import Data.Serialize.Put (Put, putWord32le)
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Word (Word32)
import GHC.Generics
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Network.Common
import Network.Haskoin.Transaction.Common
import Network.Haskoin.Util
import qualified Text.Read as R
type BlockHeight = Word32
type Timestamp = Word32
data Block =
Block { blockHeader :: !BlockHeader
, blockTxns :: ![Tx]
} deriving (Eq, Show, Read, Generic, Hashable)
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, Generic, Hashable, Serialize)
instance Show BlockHash where
showsPrec _ = shows . blockHashToHex
instance Read BlockHash where
readPrec = do
R.String str <- R.lexP
maybe R.pfail return $ hexToBlockHash $ cs str
instance IsString BlockHash where
fromString s =
let e = error "Could not read block hash from hex string"
in fromMaybe e $ hexToBlockHash $ cs s
instance FromJSON BlockHash where
parseJSON = withText "block hash" $
maybe mzero return . hexToBlockHash
instance ToJSON BlockHash where
toJSON = String . blockHashToHex
blockHashToHex :: BlockHash -> Text
blockHashToHex (BlockHash h) = encodeHex (B.reverse (encode h))
hexToBlockHash :: Text -> Maybe BlockHash
hexToBlockHash hex = do
bs <- B.reverse <$> decodeHex hex
h <- eitherToMaybe (decode bs)
return $ BlockHash h
data BlockHeader =
BlockHeader { blockVersion :: !Word32
, prevBlock :: !BlockHash
, merkleRoot :: !Hash256
, blockTimestamp :: !Timestamp
, blockBits :: !Word32
, bhNonce :: !Word32
} deriving (Eq, Ord, Show, Read, Generic, Hashable)
headerHash :: BlockHeader -> BlockHash
headerHash = BlockHash . doubleSHA256 . encode
instance Serialize BlockHeader where
get = do
v <- getWord32le
p <- get
m <- get
t <- getWord32le
b <- getWord32le
n <- getWord32le
return BlockHeader
{ blockVersion = v
, prevBlock = p
, merkleRoot = m
, blockTimestamp = t
, blockBits = b
, bhNonce = n
}
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)
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)
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)
newtype Headers =
Headers {
headersList :: [BlockHeaderCount]
}
deriving (Eq, Show)
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, Bool)
decodeCompact nCompact = (if neg then res * (-1) else res, over)
where
nSize :: Int
nSize = fromIntegral nCompact `shiftR` 24
nWord' :: Word32
nWord' = nCompact .&. 0x007fffff
nWord :: Word32
nWord | nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize))
| otherwise = nWord'
res :: Integer
res | nSize <= 3 = fromIntegral nWord
| otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3))
neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0
over = nWord /= 0 && (nSize > 34 ||
nWord > 0xff && nSize > 33 ||
nWord > 0xffff && nSize > 32)
encodeCompact :: Integer
-> Word32
encodeCompact i = nCompact
where
i' = abs i
neg = i < 0
nSize' :: Int
nSize' = let f 0 = 0
f n = 1 + f (n `shiftR` 8)
in f i'
nCompact''' :: Word32
nCompact'''
| nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize'))
| otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3)))
nCompact'' :: Word32
nSize :: Int
(nCompact'', nSize)
| nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1)
| otherwise = (nCompact''', nSize')
nCompact' :: Word32
nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24)
nCompact :: Word32
nCompact | neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000
| otherwise = nCompact'
low64 :: Integer
low64 = 0xffffffffffffffff