diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,14 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.17.0 +### Added +- Support for Bitcoin Cash November 2020 hard fork. +- Functions to find block headers matching arbitrary sorted attributes. + +### Removed +- GenesisNode constructor for BlockNode type. + ## 0.15.0 ### Added - Add more test vectors diff --git a/haskoin-core.cabal b/haskoin-core.cabal --- a/haskoin-core.cabal +++ b/haskoin-core.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: da33a2de954861b59726562ecc494205eab150409d75381e7e3c867546e2d48f +-- hash: 181e7ec454b3259ee0885c9cc758b5f23e592c6d353720e57cdc74186bc03e96 name: haskoin-core -version: 0.15.0 +version: 0.17.0 synopsis: Bitcoin & Bitcoin Cash library for Haskell description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -156,7 +156,7 @@ , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 - , haskoin-core ==0.15.0 + , haskoin-core ==0.17.0 , hspec >=2.7.1 , lens >=4.18.1 , lens-aeson >=1.1 diff --git a/src/Haskoin/Block/Common.hs b/src/Haskoin/Block/Common.hs --- a/src/Haskoin/Block/Common.hs +++ b/src/Haskoin/Block/Common.hs @@ -319,8 +319,7 @@ -- | Encode an 'Integer' to the compact number format used in the difficulty -- target of a block. -encodeCompact :: Integer - -> Word32 +encodeCompact :: Integer -> Word32 encodeCompact i = nCompact where i' = abs i diff --git a/src/Haskoin/Block/Headers.hs b/src/Haskoin/Block/Headers.hs --- a/src/Haskoin/Block/Headers.hs +++ b/src/Haskoin/Block/Headers.hs @@ -49,6 +49,8 @@ , nextWorkRequired , nextEdaWorkRequired , nextDaaWorkRequired + , nextAsertWorkRequired + , computeAsertBits , computeTarget , getSuitableBlock , nextPowWorkRequired @@ -60,33 +62,36 @@ , blockLocatorNodes , mineBlock , computeSubsidy + , mtp + , firstGreaterOrEqual + , lastSmallerOrEqual , ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) import Control.DeepSeq -import Control.Monad (guard, unless, when) -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.State.Strict as State (StateT, get, gets, lift, - modify) +import Control.Monad (guard, mzero, unless, when) +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.State.Strict as State (StateT, get, gets, lift, + modify) import Control.Monad.Trans.Maybe -import Data.Bits (shiftL, shiftR, (.&.)) -import qualified Data.ByteString as B -import Data.ByteString.Short (ShortByteString, fromShort, - toShort) -import Data.Function (on) +import Data.Bits (shiftL, shiftR, (.&.)) +import qualified Data.ByteString as B +import Data.ByteString.Short (ShortByteString, fromShort, + toShort) +import Data.Function (on) import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List (sort, sortBy) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Serialize as S (Serialize (..), decode, - encode, get, put) -import Data.Serialize.Get as S -import Data.Serialize.Put as S -import Data.Typeable (Typeable) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (sort, sortBy) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Serialize as S (Serialize (..), decode, + encode, get, put) +import Data.Serialize.Get as S +import Data.Serialize.Put as S +import Data.Typeable (Typeable) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) import Haskoin.Block.Common import Haskoin.Constants import Haskoin.Crypto @@ -108,21 +113,14 @@ -- | Data structure representing a block header and its position in the -- block chain. data BlockNode - -- | non-Genesis block header = BlockNode { nodeHeader :: !BlockHeader , nodeHeight :: !BlockHeight -- | accumulated work so far , nodeWork :: !BlockWork - -- | akip magic block hash + -- | skip magic block hash , nodeSkip :: !BlockHash } - -- | Genesis block header - | GenesisNode - { nodeHeader :: !BlockHeader - , nodeHeight :: !BlockHeight - , nodeWork :: !BlockWork - } deriving (Show, Read, Generic, Hashable, NFData) instance Serialize BlockNode where @@ -131,7 +129,9 @@ nodeHeight <- getWord32le nodeWork <- S.get if nodeHeight == 0 - then return GenesisNode {..} + then do + let nodeSkip = headerHash nodeHeader + return BlockNode {..} else do nodeSkip <- S.get return BlockNode {..} @@ -139,9 +139,9 @@ put $ nodeHeader bn putWord32le $ nodeHeight bn put $ nodeWork bn - case bn of - GenesisNode {} -> return () - BlockNode {} -> put $ nodeSkip bn + case nodeHeight bn of + 0 -> return () + _ -> put $ nodeSkip bn instance Eq BlockNode where (==) = (==) `on` nodeHeader @@ -248,16 +248,17 @@ -- | Is the provided 'BlockNode' the Genesis block? isGenesis :: BlockNode -> Bool -isGenesis GenesisNode{} = True -isGenesis BlockNode{} = False +isGenesis BlockNode {nodeHeight = 0} = True +isGenesis _ = False -- | Build the genesis 'BlockNode' for the supplied 'Network'. genesisNode :: Network -> BlockNode genesisNode net = - GenesisNode + BlockNode { nodeHeader = getGenesisHeader net , nodeHeight = 0 , nodeWork = headerWork (getGenesisHeader net) + , nodeSkip = headerHash (getGenesisHeader net) } -- | Validate a list of continuous block headers and import them to the @@ -412,8 +413,9 @@ getParents = getpars [] where getpars acc 0 _ = return $ reverse acc - getpars acc _ GenesisNode{} = return $ reverse acc - getpars acc n BlockNode{..} = do + getpars acc n BlockNode{..} + | nodeHeight == 0 = return $ reverse acc + | otherwise = do parM <- getBlockHeader $ prevBlock nodeHeader case parM of Just bn -> getpars (bn : acc) (n - 1) bn @@ -470,6 +472,7 @@ -- | Find last block with normal, as opposed to minimum difficulty (for test -- networks). lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode +lastNoMinDiff _ bn@BlockNode {nodeHeight = 0} = return bn lastNoMinDiff net bn@BlockNode {..} = do let i = nodeHeight `mod` diffInterval net /= 0 c = encodeCompact (getPowLimit net) @@ -484,8 +487,6 @@ lastNoMinDiff net bn' else return bn -lastNoMinDiff _ bn@GenesisNode{} = return bn - -- | Returns the work required on a block header given the previous block. This -- coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@. nextWorkRequired :: BlockHeaders m @@ -494,20 +495,24 @@ -> BlockHeader -> m Word32 nextWorkRequired net par bh = do - let mf = daa <|> eda <|> pow - case mf of - Just f -> f net par bh - Nothing -> - error - "Could not get an appropriate difficulty calculation algorithm" + ma <- getAsertAnchor net + case asert ma <|> daa <|> eda <|> pow of + Just f -> f par bh + Nothing -> error "Could not determine difficulty algorithm" where - daa = getDaaBlockHeight net >>= \daaHeight -> do - guard (nodeHeight par + 1 >= daaHeight) - return nextDaaWorkRequired - eda = getEdaBlockHeight net >>= \edaHeight -> do - guard (nodeHeight par + 1 >= edaHeight) - return nextEdaWorkRequired - pow = return nextPowWorkRequired + asert ma = do + anchor <- ma + guard (nodeHeight par > nodeHeight anchor) + return $ nextAsertWorkRequired net anchor + daa = do + daa_height <- getDaaBlockHeight net + guard (nodeHeight par + 1 >= daa_height) + return $ nextDaaWorkRequired net + eda = do + eda_height <- getEdaBlockHeight net + guard (nodeHeight par + 1 >= eda_height) + return $ nextEdaWorkRequired net + pow = return $ nextPowWorkRequired net -- | Find out the next amount of work required according to the Emergency -- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. @@ -548,7 +553,6 @@ nextDaaWorkRequired net par bh | minDifficulty = return (encodeCompact (getPowLimit net)) | otherwise = do - let height = nodeHeight par unless (height >= diffInterval net) $ error "Block height below difficulty interval" l <- getSuitableBlock par @@ -559,10 +563,153 @@ then return $ encodeCompact (getPowLimit net) else return $ encodeCompact nextTarget where + height = nodeHeight par e1 = error "Cannot get ancestor at parent - 144 height" minDifficulty = blockTimestamp bh > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + +mtp :: BlockHeaders m => BlockNode -> m Timestamp +mtp bn + | nodeHeight bn == 0 = return 0 + | otherwise = do + pars <- getParents 11 bn + return $ medianTime (map (blockTimestamp . nodeHeader) pars) + +firstGreaterOrEqual :: BlockHeaders m + => Network + -> (BlockNode -> m Ordering) + -> m (Maybe BlockNode) +firstGreaterOrEqual = binSearch False + +lastSmallerOrEqual :: BlockHeaders m + => Network + -> (BlockNode -> m Ordering) + -> m (Maybe BlockNode) +lastSmallerOrEqual = binSearch True + +binSearch :: BlockHeaders m + => Bool + -> Network + -> (BlockNode -> m Ordering) + -> m (Maybe BlockNode) +binSearch top net f = runMaybeT $ do + (a, b) <- lift $ extremes net + go a b + where + go a b = do + m <- lift $ middleBlock a b + a' <- lift $ f a + b' <- lift $ f b + m' <- lift $ f m + r (a, a') (b, b') (m, m') + r (a, a') (b, b') (m, m') + | out_of_bounds a' b' = mzero + | no_middle a b = choose_one a b + | is_between a' m' = go a m + | is_between m' b' = go m b + | otherwise = mzero + out_of_bounds a' b' = a' == GT || b' == LT + no_middle a b = nodeHeight b - nodeHeight a <= 1 + is_between a' b' = a' /= GT && b' /= LT + choose_one a b + | top = return b + | otherwise = return a + +extremes :: BlockHeaders m => Network -> m (BlockNode, BlockNode) +extremes net = do + b <- getBestBlockHeader + return (genesisNode net, b) + +middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode +middleBlock a b = + getAncestor h b >>= \case + Nothing -> error "You fell into a pit full of mud and snakes" + Just x -> return x + where + h = middleOf (nodeHeight a) (nodeHeight b) + +middleOf :: Integral a => a -> a -> a +middleOf a b = a + ((b - a) `div` 2) + +-- TODO: Use known anchor after fork +getAsertAnchor :: BlockHeaders m => Network -> m (Maybe BlockNode) +getAsertAnchor net = + case getAsertActivationTime net of + Nothing -> return Nothing + Just act -> firstGreaterOrEqual net (f act) + where + f act bn = do + m <- mtp bn + return $ compare m act + +-- | Find the next amount of work required according to the aserti3-2d algorithm. +nextAsertWorkRequired :: BlockHeaders m + => Network + -> BlockNode + -> BlockNode + -> BlockHeader + -> m Word32 +nextAsertWorkRequired net anchor par bh = do + anchor_parent <- fromMaybe e_fork <$> + getBlockHeader (prevBlock (nodeHeader anchor)) + let anchor_parent_time = toInteger $ blockTimestamp $ nodeHeader anchor_parent + time_diff = current_time - anchor_parent_time + return $ computeAsertBits halflife anchor_bits time_diff height_diff + where + halflife = getAsertHalfLife net + anchor_height = toInteger $ nodeHeight anchor + anchor_bits = blockBits $ nodeHeader anchor + current_height = toInteger (nodeHeight par) + 1 + height_diff = current_height - anchor_height + current_time = toInteger $ blockTimestamp bh + e_fork = error "Could not get fork block header" + +idealBlockTime :: Integer +idealBlockTime = 10 * 60 + +rBits :: Int +rBits = 16 + +radix :: Integer +radix = 1 `shiftL` rBits + +maxBits :: Word32 +maxBits = 0x1d00ffff + +maxTarget :: Integer +maxTarget = fst $ decodeCompact maxBits + +computeAsertBits + :: Integer + -> Word32 + -> Integer + -> Integer + -> Word32 +computeAsertBits halflife anchor_bits time_diff height_diff = + if e2 >= 0 && e2 < 65536 + then if g4 == 0 + then encodeCompact 1 + else if g4 > maxTarget + then maxBits + else encodeCompact g4 + else error $ "Exponent not in range: " ++ show e2 + where + g1 = fst (decodeCompact anchor_bits) + e1 = ((time_diff - idealBlockTime * (height_diff + 1)) * radix) + `quot` + halflife + s = e1 `shiftR` rBits + e2 = e1 - s * radix + g2 = g1 * (radix + + ((195766423245049*e2 + 971821376*e2^2 + 5127*e2^3 + 2^47) + `shiftR` + (rBits*3))) + g3 = if s < 0 + then g2 `shiftR` negate (fromIntegral s) + else g2 `shiftL` fromIntegral s + g4 = g3 `shiftR` rBits + -- | Compute Bitcoin Cash DAA target for a new block. computeTarget :: Network -> BlockNode -> BlockNode -> Integer diff --git a/src/Haskoin/Constants.hs b/src/Haskoin/Constants.hs --- a/src/Haskoin/Constants.hs +++ b/src/Haskoin/Constants.hs @@ -103,6 +103,11 @@ , getEdaBlockHeight :: !(Maybe Word32) -- | DAA start block height , getDaaBlockHeight :: !(Maybe Word32) + -- | asert3-2d algorithm activation time + -- TODO: Replace with block height after fork + , getAsertActivationTime :: !(Maybe Word32) + -- | asert3-2d algorithm halflife (not used for non-BCH networks) + , getAsertHalfLife :: !Integer -- | segregated witness active , getSegWit :: !Bool -- | 'CashAddr' prefix (for Bitcoin Cash) @@ -222,6 +227,8 @@ , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing + , getAsertActivationTime = Nothing + , getAsertHalfLife = 0 , getSegWit = True , getCashAddrPrefix = Nothing , getBech32Prefix = Just "bc" @@ -279,6 +286,8 @@ , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing + , getAsertActivationTime = Nothing + , getAsertHalfLife = 0 , getSegWit = True , getCashAddrPrefix = Nothing , getBech32Prefix = Just "tb" @@ -328,6 +337,8 @@ , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing + , getAsertActivationTime = Nothing + , getAsertHalfLife = 0 , getSegWit = True , getCashAddrPrefix = Nothing , getBech32Prefix = Just "bcrt" @@ -417,6 +428,8 @@ , getSigHashForkId = Just 0 , getEdaBlockHeight = Just 478559 , getDaaBlockHeight = Just 404031 + , getAsertActivationTime = Just 1605441600 + , getAsertHalfLife = 60 * 60 * 10 , getSegWit = False , getCashAddrPrefix = Just "bitcoincash" , getBech32Prefix = Nothing @@ -481,6 +494,8 @@ , getSigHashForkId = Just 0 , getEdaBlockHeight = Just 1155876 , getDaaBlockHeight = Just 1188697 + , getAsertActivationTime = Just 1605441600 + , getAsertHalfLife = 60 * 60 , getSegWit = False , getCashAddrPrefix = Just "bchtest" , getBech32Prefix = Nothing @@ -533,6 +548,8 @@ , getSigHashForkId = Just 0 , getEdaBlockHeight = Nothing , getDaaBlockHeight = Just 0 + , getAsertActivationTime = Just 1605441600 + , getAsertHalfLife = 2 * 24 * 60 * 60 , getSegWit = False , getCashAddrPrefix = Just "bchreg" , getBech32Prefix = Nothing diff --git a/src/Haskoin/Util/Arbitrary/Block.hs b/src/Haskoin/Util/Arbitrary/Block.hs --- a/src/Haskoin/Util/Arbitrary/Block.hs +++ b/src/Haskoin/Util/Arbitrary/Block.hs @@ -29,11 +29,11 @@ arbitraryBlockHeader :: Gen BlockHeader arbitraryBlockHeader = BlockHeader <$> arbitrary - <*> arbitraryBlockHash - <*> arbitraryHash256 - <*> arbitrary - <*> arbitrary - <*> arbitrary + <*> arbitraryBlockHash + <*> arbitraryHash256 + <*> arbitrary + <*> arbitrary + <*> arbitrary -- | Arbitrary block hash. arbitraryBlockHash :: Gen BlockHash @@ -74,13 +74,9 @@ oneof [ BlockNode <$> arbitraryBlockHeader - <*> choose (1, maxBound) + <*> choose (0, maxBound) <*> arbitrarySizedNatural <*> arbitraryBlockHash - , GenesisNode - <$> arbitraryBlockHeader - <*> (return 0) - <*> arbitrarySizedNatural ] -- | Arbitrary 'HeaderMemory' diff --git a/test/Haskoin/BlockSpec.hs b/test/Haskoin/BlockSpec.hs --- a/test/Haskoin/BlockSpec.hs +++ b/test/Haskoin/BlockSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module Haskoin.BlockSpec ( spec ) where @@ -9,6 +10,7 @@ import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text) +import Data.Word (Word32) import Haskoin.Block import Haskoin.Constants import Haskoin.Transaction @@ -17,6 +19,7 @@ import Test.Hspec.QuickCheck import Test.HUnit hiding (State) import Test.QuickCheck +import Text.Printf (printf) serialVals :: [SerialBox] @@ -106,6 +109,10 @@ describe "compact number" $ do it "compact number local vectors" testCompact it "compact number imported vectors" testCompactBitcoinCore + describe "asert" $ + mapM_ (\x -> asertTests $ + "test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt" + ) [(1 :: Int) .. 12] describe "helper functions" $ do it "computes bitcoin block subsidy correctly" (testSubsidy btc) it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) @@ -356,3 +363,42 @@ else do subsidy `shouldBe` (previous_subsidy `div` 2) go subsidy (halvings + 1) + +data AsertBlock = AsertBlock Int Integer Integer Word32 + +data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock] + +readAsertVector :: FilePath -> IO AsertVector +readAsertVector p = do + (d:ah:apt:ab:_:_:_:_:xs) <- lines <$> readFile ("data/" ++ p) + let desc = drop 16 d + anchor_height = read (words ah !! 3) + anchor_parent_time = read (words apt !! 4) + anchor_nbits = read (words ab !! 3) + blocks = map (f . words) (init xs) + return $ + AsertVector + desc + anchor_height + anchor_parent_time + anchor_nbits + blocks + where + f [i,h,t,g] = AsertBlock (read i) (read h) (read t) (read g) + f _ = undefined + +asertTests :: FilePath -> SpecWith () +asertTests file = do + v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file + it d $ testAsertBits v + +testAsertBits :: AsertVector -> Assertion +testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) = + forM_ blocks $ \(AsertBlock _ h t g) -> + computeAsertBits + (2 * 24 * 60 * 60) + anchor_bits + (t - anchor_parent_time) + (h - anchor_height) + `shouldBe` + g