{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE RecordWildCards   #-}
{-|
Module      : Haskoin.Block.Headers
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

Block chain header synchronization and proof-of-work consensus functions.
-}
module Haskoin.Block.Headers
    ( -- * Block Headers
      BlockNode(..)
    , BlockHeaders(..)
    , BlockWork
    , genesisNode
    , genesisBlock
    , isGenesis
    , chooseBest
      -- ** Header Store
    , parentBlock
    , getParents
    , getAncestor
    , splitPoint
    , connectBlocks
    , connectBlock
    , blockLocator
      -- ** Header Memory Store
    , HeaderMemory(..)
    , ShortBlockHash
    , BlockMap
    , shortBlockHash
    , initialChain
    , genesisMap
      -- ** Helper Functions
    , appendBlocks
    , validBlock
    , validCP
    , afterLastCP
    , bip34
    , validVersion
    , lastNoMinDiff
    , nextWorkRequired
    , nextEdaWorkRequired
    , nextDaaWorkRequired
    , nextAsertWorkRequired
    , computeAsertBits
    , computeTarget
    , getSuitableBlock
    , nextPowWorkRequired
    , calcNextWork
    , isValidPOW
    , blockPOW
    , headerWork
    , diffInterval
    , blockLocatorNodes
    , mineBlock
    , computeSubsidy
    , mtp
    , firstGreaterOrEqual
    , lastSmallerOrEqual
    , ) where

import           Control.Applicative         ((<|>))
import           Control.DeepSeq
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.Binary                 (Binary (..))
import           Data.Bits                   (shiftL, shiftR, (.&.))
import qualified Data.ByteString             as B
import           Data.ByteString.Short       (ShortByteString, fromShort,
                                              toShort)
import           Data.Bytes.Get
import           Data.Bytes.Put
import           Data.Bytes.Serial
import           Data.Function               (on)
import           Data.HashMap.Strict         (HashMap)
import qualified Data.HashMap.Strict         as HashMap
import           Data.Hashable
import           Data.List                   (sort, sortBy)
import           Data.Maybe                  (fromMaybe, listToMaybe)
import           Data.Serialize              (Serialize (..))
import           Data.Typeable               (Typeable)
import           Data.Word                   (Word32, Word64)
import           GHC.Generics                (Generic)
import           Haskoin.Block.Common
import           Haskoin.Constants
import           Haskoin.Crypto
import           Haskoin.Transaction.Genesis
import           Haskoin.Util

-- | Short version of the block hash. Uses the good end of the hash (the part
-- that doesn't have a long string of zeroes).
type ShortBlockHash = Word64

-- | Memory-based map to a serialized 'BlockNode' data structure.
-- 'ShortByteString' is used to avoid memory fragmentation and make the data
-- structure compact.
type BlockMap = HashMap ShortBlockHash ShortByteString

-- | Represents accumulated work in the block chain so far.
type BlockWork = Integer

-- | Data structure representing a block header and its position in the
-- block chain.
data BlockNode
    = BlockNode
          { BlockNode -> BlockHeader
nodeHeader :: !BlockHeader
          , BlockNode -> BlockHeight
nodeHeight :: !BlockHeight
          -- | accumulated work so far
          , BlockNode -> BlockWork
nodeWork   :: !BlockWork
          -- | skip magic block hash
          , BlockNode -> BlockHash
nodeSkip   :: !BlockHash
          }
    deriving (Int -> BlockNode -> ShowS
[BlockNode] -> ShowS
BlockNode -> String
(Int -> BlockNode -> ShowS)
-> (BlockNode -> String)
-> ([BlockNode] -> ShowS)
-> Show BlockNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockNode] -> ShowS
$cshowList :: [BlockNode] -> ShowS
show :: BlockNode -> String
$cshow :: BlockNode -> String
showsPrec :: Int -> BlockNode -> ShowS
$cshowsPrec :: Int -> BlockNode -> ShowS
Show, ReadPrec [BlockNode]
ReadPrec BlockNode
Int -> ReadS BlockNode
ReadS [BlockNode]
(Int -> ReadS BlockNode)
-> ReadS [BlockNode]
-> ReadPrec BlockNode
-> ReadPrec [BlockNode]
-> Read BlockNode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BlockNode]
$creadListPrec :: ReadPrec [BlockNode]
readPrec :: ReadPrec BlockNode
$creadPrec :: ReadPrec BlockNode
readList :: ReadS [BlockNode]
$creadList :: ReadS [BlockNode]
readsPrec :: Int -> ReadS BlockNode
$creadsPrec :: Int -> ReadS BlockNode
Read, (forall x. BlockNode -> Rep BlockNode x)
-> (forall x. Rep BlockNode x -> BlockNode) -> Generic BlockNode
forall x. Rep BlockNode x -> BlockNode
forall x. BlockNode -> Rep BlockNode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockNode x -> BlockNode
$cfrom :: forall x. BlockNode -> Rep BlockNode x
Generic, Int -> BlockNode -> Int
BlockNode -> Int
(Int -> BlockNode -> Int)
-> (BlockNode -> Int) -> Hashable BlockNode
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: BlockNode -> Int
$chash :: BlockNode -> Int
hashWithSalt :: Int -> BlockNode -> Int
$chashWithSalt :: Int -> BlockNode -> Int
Hashable, BlockNode -> ()
(BlockNode -> ()) -> NFData BlockNode
forall a. (a -> ()) -> NFData a
rnf :: BlockNode -> ()
$crnf :: BlockNode -> ()
NFData)

instance Serial BlockNode where
    deserialize :: m BlockNode
deserialize = do
        BlockHeader
nodeHeader <- m BlockHeader
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        BlockHeight
nodeHeight <- m BlockHeight
forall (m :: * -> *). MonadGet m => m BlockHeight
getWord32le
        BlockWork
nodeWork   <- m BlockWork
forall (m :: * -> *). MonadGet m => m BlockWork
getInteger
        if BlockHeight
nodeHeight BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== 0
            then do
                let nodeSkip :: BlockHash
nodeSkip = BlockHeader -> BlockHash
headerHash BlockHeader
nodeHeader
                BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode {..}
            else do
                BlockHash
nodeSkip <- m BlockHash
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
                BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode {..}
    serialize :: BlockNode -> m ()
serialize bn :: BlockNode
bn = do
        BlockHeader -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (BlockHeader -> m ()) -> BlockHeader -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
        BlockHeight -> m ()
forall (m :: * -> *). MonadPut m => BlockHeight -> m ()
putWord32le (BlockHeight -> m ()) -> BlockHeight -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeight
nodeHeight BlockNode
bn
        BlockWork -> m ()
forall (m :: * -> *). MonadPut m => BlockWork -> m ()
putInteger (BlockWork -> m ()) -> BlockWork -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockWork
nodeWork BlockNode
bn
        case BlockNode -> BlockHeight
nodeHeight BlockNode
bn of
            0 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            _ -> BlockHash -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (BlockHash -> m ()) -> BlockHash -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHash
nodeSkip BlockNode
bn

instance Serialize BlockNode where
    put :: Putter BlockNode
put = Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get BlockNode
get = Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance Binary BlockNode where
    put :: BlockNode -> Put
put = BlockNode -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get BlockNode
get = Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance Eq BlockNode where
    == :: BlockNode -> BlockNode -> Bool
(==) = BlockHeader -> BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
(==) (BlockHeader -> BlockHeader -> Bool)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockNode -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` BlockNode -> BlockHeader
nodeHeader

instance Ord BlockNode where
    compare :: BlockNode -> BlockNode -> Ordering
compare = BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockHeight -> BlockHeight -> Ordering)
-> (BlockNode -> BlockHeight) -> BlockNode -> BlockNode -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` BlockNode -> BlockHeight
nodeHeight

-- | Memory-based header tree.
data HeaderMemory = HeaderMemory
    { HeaderMemory -> BlockMap
memoryHeaderMap  :: !BlockMap
    , HeaderMemory -> BlockNode
memoryBestHeader :: !BlockNode
    } deriving (HeaderMemory -> HeaderMemory -> Bool
(HeaderMemory -> HeaderMemory -> Bool)
-> (HeaderMemory -> HeaderMemory -> Bool) -> Eq HeaderMemory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderMemory -> HeaderMemory -> Bool
$c/= :: HeaderMemory -> HeaderMemory -> Bool
== :: HeaderMemory -> HeaderMemory -> Bool
$c== :: HeaderMemory -> HeaderMemory -> Bool
Eq, Typeable, Int -> HeaderMemory -> ShowS
[HeaderMemory] -> ShowS
HeaderMemory -> String
(Int -> HeaderMemory -> ShowS)
-> (HeaderMemory -> String)
-> ([HeaderMemory] -> ShowS)
-> Show HeaderMemory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderMemory] -> ShowS
$cshowList :: [HeaderMemory] -> ShowS
show :: HeaderMemory -> String
$cshow :: HeaderMemory -> String
showsPrec :: Int -> HeaderMemory -> ShowS
$cshowsPrec :: Int -> HeaderMemory -> ShowS
Show, ReadPrec [HeaderMemory]
ReadPrec HeaderMemory
Int -> ReadS HeaderMemory
ReadS [HeaderMemory]
(Int -> ReadS HeaderMemory)
-> ReadS [HeaderMemory]
-> ReadPrec HeaderMemory
-> ReadPrec [HeaderMemory]
-> Read HeaderMemory
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderMemory]
$creadListPrec :: ReadPrec [HeaderMemory]
readPrec :: ReadPrec HeaderMemory
$creadPrec :: ReadPrec HeaderMemory
readList :: ReadS [HeaderMemory]
$creadList :: ReadS [HeaderMemory]
readsPrec :: Int -> ReadS HeaderMemory
$creadsPrec :: Int -> ReadS HeaderMemory
Read, (forall x. HeaderMemory -> Rep HeaderMemory x)
-> (forall x. Rep HeaderMemory x -> HeaderMemory)
-> Generic HeaderMemory
forall x. Rep HeaderMemory x -> HeaderMemory
forall x. HeaderMemory -> Rep HeaderMemory x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HeaderMemory x -> HeaderMemory
$cfrom :: forall x. HeaderMemory -> Rep HeaderMemory x
Generic, Int -> HeaderMemory -> Int
HeaderMemory -> Int
(Int -> HeaderMemory -> Int)
-> (HeaderMemory -> Int) -> Hashable HeaderMemory
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: HeaderMemory -> Int
$chash :: HeaderMemory -> Int
hashWithSalt :: Int -> HeaderMemory -> Int
$chashWithSalt :: Int -> HeaderMemory -> Int
Hashable, HeaderMemory -> ()
(HeaderMemory -> ()) -> NFData HeaderMemory
forall a. (a -> ()) -> NFData a
rnf :: HeaderMemory -> ()
$crnf :: HeaderMemory -> ()
NFData)

-- | Typeclass for block header chain storage monad.
class Monad m => BlockHeaders m where
    -- | Add a new 'BlockNode' to the chain. Does not validate.
    addBlockHeader :: BlockNode -> m ()
    -- | Get a 'BlockNode' associated with a 'BlockHash'.
    getBlockHeader :: BlockHash -> m (Maybe BlockNode)
    -- | Locate the 'BlockNode' for the highest block in the chain
    getBestBlockHeader :: m BlockNode
    -- | Set the highest block in the chain.
    setBestBlockHeader :: BlockNode -> m ()
    -- | Add a continuous bunch of block headers the chain. Does not validate.
    addBlockHeaders :: [BlockNode] -> m ()
    addBlockHeaders = (BlockNode -> m ()) -> [BlockNode] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader

instance Monad m => BlockHeaders (StateT HeaderMemory m) where
    addBlockHeader :: BlockNode -> StateT HeaderMemory m ()
addBlockHeader = (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ())
-> (BlockNode -> HeaderMemory -> HeaderMemory)
-> BlockNode
-> StateT HeaderMemory m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory
    getBlockHeader :: BlockHash -> StateT HeaderMemory m (Maybe BlockNode)
getBlockHeader bh :: BlockHash
bh = BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory BlockHash
bh (HeaderMemory -> Maybe BlockNode)
-> StateT HeaderMemory m HeaderMemory
-> StateT HeaderMemory m (Maybe BlockNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HeaderMemory m HeaderMemory
forall s (m :: * -> *). MonadState s m => m s
State.get
    getBestBlockHeader :: StateT HeaderMemory m BlockNode
getBestBlockHeader = (HeaderMemory -> BlockNode) -> StateT HeaderMemory m BlockNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HeaderMemory -> BlockNode
memoryBestHeader
    setBestBlockHeader :: BlockNode -> StateT HeaderMemory m ()
setBestBlockHeader bn :: BlockNode
bn = (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ())
-> (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall a b. (a -> b) -> a -> b
$ \s :: HeaderMemory
s -> HeaderMemory
s { memoryBestHeader :: BlockNode
memoryBestHeader = BlockNode
bn }

-- | Initialize memory-based chain.
initialChain :: Network -> HeaderMemory
initialChain :: Network -> HeaderMemory
initialChain net :: Network
net = $WHeaderMemory :: BlockMap -> BlockNode -> HeaderMemory
HeaderMemory
    { memoryHeaderMap :: BlockMap
memoryHeaderMap = Network -> BlockMap
genesisMap Network
net
    , memoryBestHeader :: BlockNode
memoryBestHeader = Network -> BlockNode
genesisNode Network
net
    }

-- | Initialize map for memory-based chain.
genesisMap :: Network -> BlockMap
genesisMap :: Network -> BlockMap
genesisMap net :: Network
net =
    ShortBlockHash -> ShortByteString -> BlockMap
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton
        (BlockHash -> ShortBlockHash
shortBlockHash (BlockHeader -> BlockHash
headerHash (Network -> BlockHeader
getGenesisHeader Network
net)))
        (ByteString -> ShortByteString
toShort (Put -> ByteString
runPutS (Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize (Network -> BlockNode
genesisNode Network
net))))

-- | Add block header to memory block map.
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory bn :: BlockNode
bn s :: HeaderMemory
s@HeaderMemory{..} =
    let bm' :: BlockMap
bm' = BlockNode -> BlockMap -> BlockMap
addBlockToMap BlockNode
bn BlockMap
memoryHeaderMap
    in HeaderMemory
s { memoryHeaderMap :: BlockMap
memoryHeaderMap = BlockMap
bm' }

-- | Get block header from memory block map.
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory bh :: BlockHash
bh HeaderMemory {..} = do
    ShortByteString
bs <- BlockHash -> ShortBlockHash
shortBlockHash BlockHash
bh ShortBlockHash -> BlockMap -> Maybe ShortByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` BlockMap
memoryHeaderMap
    Either String BlockNode -> Maybe BlockNode
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String BlockNode -> Maybe BlockNode)
-> (ByteString -> Either String BlockNode)
-> ByteString
-> Maybe BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get BlockNode -> ByteString -> Either String BlockNode
forall a. Get a -> ByteString -> Either String a
runGetS Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize (ByteString -> Maybe BlockNode) -> ByteString -> Maybe BlockNode
forall a b. (a -> b) -> a -> b
$ ShortByteString -> ByteString
fromShort ShortByteString
bs

-- | Calculate short block hash taking eight non-zero bytes from the 16-byte
-- hash. This function will take the bytes that are not on the zero-side of the
-- hash, making colissions between short block hashes difficult.
shortBlockHash :: BlockHash -> ShortBlockHash
shortBlockHash :: BlockHash -> ShortBlockHash
shortBlockHash =
    (String -> ShortBlockHash)
-> (ShortBlockHash -> ShortBlockHash)
-> Either String ShortBlockHash
-> ShortBlockHash
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ShortBlockHash
forall a. HasCallStack => String -> a
error ShortBlockHash -> ShortBlockHash
forall a. a -> a
id (Either String ShortBlockHash -> ShortBlockHash)
-> (BlockHash -> Either String ShortBlockHash)
-> BlockHash
-> ShortBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get ShortBlockHash -> ByteString -> Either String ShortBlockHash
forall a. Get a -> ByteString -> Either String a
runGetS Get ShortBlockHash
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize (ByteString -> Either String ShortBlockHash)
-> (BlockHash -> ByteString)
-> BlockHash
-> Either String ShortBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.take 8 (ByteString -> ByteString)
-> (BlockHash -> ByteString) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (BlockHash -> Put) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize

-- | Add a block to memory-based block map.
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap node :: BlockNode
node =
    ShortBlockHash -> ShortByteString -> BlockMap -> BlockMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert
    (BlockHash -> ShortBlockHash
shortBlockHash (BlockHash -> ShortBlockHash) -> BlockHash -> ShortBlockHash
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
node)
    (ByteString -> ShortByteString
toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize BlockNode
node)

-- | Get the ancestor of the provided 'BlockNode' at the specified
-- 'BlockHeight'.
getAncestor :: BlockHeaders m
            => BlockHeight
            -> BlockNode
            -> m (Maybe BlockNode)
getAncestor :: BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor height :: BlockHeight
height node :: BlockNode
node
    | BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode -> BlockHeight
nodeHeight BlockNode
node = Maybe BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockNode
forall a. Maybe a
Nothing
    | Bool
otherwise = BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> m (Maybe BlockNode)
go BlockNode
node
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error "Could not get skip header"
    e2 :: a
e2 = String -> a
forall a. HasCallStack => String -> a
error "Could not get previous block header"
    go :: BlockNode -> m (Maybe BlockNode)
go walk :: BlockNode
walk
        | BlockNode -> BlockHeight
nodeHeight BlockNode
walk BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockHeight
height =
            let heightSkip :: BlockHeight
heightSkip = BlockHeight -> BlockHeight
skipHeight (BlockNode -> BlockHeight
nodeHeight BlockNode
walk)
                heightSkipPrev :: BlockHeight
heightSkipPrev = BlockHeight -> BlockHeight
skipHeight (BlockNode -> BlockHeight
nodeHeight BlockNode
walk BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 1)
             in if Bool -> Bool
not (BlockNode -> Bool
isGenesis BlockNode
walk) Bool -> Bool -> Bool
&&
                   (BlockHeight
heightSkip BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
height Bool -> Bool -> Bool
||
                    (BlockHeight
heightSkip BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockHeight
height Bool -> Bool -> Bool
&&
                     Bool -> Bool
not
                         (BlockHeight
heightSkipPrev BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
heightSkip BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 2 Bool -> Bool -> Bool
&&
                          BlockHeight
heightSkipPrev BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
height)))
                    then do
                        BlockNode
walk' <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockNode -> BlockHash
nodeSkip BlockNode
walk)
                        BlockNode -> m (Maybe BlockNode)
go BlockNode
walk'
                    else do
                        BlockNode
walk' <-
                            BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e2 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHeader -> BlockHash
prevBlock (BlockNode -> BlockHeader
nodeHeader BlockNode
walk))
                        BlockNode -> m (Maybe BlockNode)
go BlockNode
walk'
        | Bool
otherwise = Maybe BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe BlockNode -> m (Maybe BlockNode))
-> Maybe BlockNode -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockNode -> Maybe BlockNode
forall a. a -> Maybe a
Just BlockNode
walk

-- | Is the provided 'BlockNode' the Genesis block?
isGenesis :: BlockNode -> Bool
isGenesis :: BlockNode -> Bool
isGenesis BlockNode {nodeHeight :: BlockNode -> BlockHeight
nodeHeight = BlockHeight
0} = Bool
True
isGenesis _                          = Bool
False

-- | Build the genesis 'BlockNode' for the supplied 'Network'.
genesisNode :: Network -> BlockNode
genesisNode :: Network -> BlockNode
genesisNode net :: Network
net =
    $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode
        { nodeHeader :: BlockHeader
nodeHeader = Network -> BlockHeader
getGenesisHeader Network
net
        , nodeHeight :: BlockHeight
nodeHeight = 0
        , nodeWork :: BlockWork
nodeWork = BlockHeader -> BlockWork
headerWork (Network -> BlockHeader
getGenesisHeader Network
net)
        , nodeSkip :: BlockHash
nodeSkip = BlockHeader -> BlockHash
headerHash (Network -> BlockHeader
getGenesisHeader Network
net)
        }

-- | Validate a list of continuous block headers and import them to the
-- block chain. Return 'Left' on failure with error information.
connectBlocks :: BlockHeaders m
              => Network
              -> Timestamp       -- ^ current time
              -> [BlockHeader]
              -> m (Either String [BlockNode])
connectBlocks :: Network
-> BlockHeight -> [BlockHeader] -> m (Either String [BlockNode])
connectBlocks _ _ [] = Either String [BlockNode] -> m (Either String [BlockNode])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [BlockNode] -> m (Either String [BlockNode]))
-> Either String [BlockNode] -> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> Either String [BlockNode]
forall a b. b -> Either a b
Right []
connectBlocks net :: Network
net t :: BlockHeight
t bhs :: [BlockHeader]
bhs@(bh :: BlockHeader
bh:_) =
    ExceptT String m [BlockNode] -> m (Either String [BlockNode])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m [BlockNode] -> m (Either String [BlockNode]))
-> ExceptT String m [BlockNode] -> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ do
        Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([BlockHeader] -> Bool
chained [BlockHeader]
bhs) (ExceptT String m () -> ExceptT String m ())
-> ExceptT String m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Blocks to connect do not form a chain"
        BlockNode
par <-
            String -> MaybeT m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT
                "Could not get parent block"
                (m (Maybe BlockNode) -> MaybeT m BlockNode
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BlockHeader -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeader -> m (Maybe BlockNode)
parentBlock BlockHeader
bh))
        [BlockNode]
pars <- m [BlockNode] -> ExceptT String m [BlockNode]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [BlockNode] -> ExceptT String m [BlockNode])
-> m [BlockNode] -> ExceptT String m [BlockNode]
forall a b. (a -> b) -> a -> b
$ Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 10 BlockNode
par
        BlockNode
bb <- m BlockNode -> ExceptT String m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
        BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go BlockNode
par [] BlockNode
bb BlockNode
par [BlockNode]
pars [BlockHeader]
bhs ExceptT String m [BlockNode]
-> ([BlockNode] -> ExceptT String m [BlockNode])
-> ExceptT String m [BlockNode]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            bns :: [BlockNode]
bns@(bn :: BlockNode
bn:_) -> do
                m () -> ExceptT String m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> m ()
forall (m :: * -> *). BlockHeaders m => [BlockNode] -> m ()
addBlockHeaders [BlockNode]
bns
                let bb' :: BlockNode
bb' = BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bn BlockNode
bb
                Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb' BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bb) (ExceptT String m () -> ExceptT String m ())
-> ExceptT String m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ m () -> ExceptT String m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader BlockNode
bb'
                [BlockNode] -> ExceptT String m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
bns
            _ -> ExceptT String m [BlockNode]
forall a. HasCallStack => a
undefined
  where
    chained :: [BlockHeader] -> Bool
chained (h1 :: BlockHeader
h1:h2 :: BlockHeader
h2:hs :: [BlockHeader]
hs) = BlockHeader -> BlockHash
headerHash BlockHeader
h1 BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeader -> BlockHash
prevBlock BlockHeader
h2 Bool -> Bool -> Bool
&& [BlockHeader] -> Bool
chained (BlockHeader
h2 BlockHeader -> [BlockHeader] -> [BlockHeader]
forall a. a -> [a] -> [a]
: [BlockHeader]
hs)
    chained _          = Bool
True
    skipit :: BlockNode -> [BlockNode] -> BlockNode -> t m BlockNode
skipit lbh :: BlockNode
lbh ls :: [BlockNode]
ls par :: BlockNode
par
        | BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode -> BlockHeight
nodeHeight BlockNode
lbh = BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
lbh
        | BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockNode -> BlockHeight
nodeHeight BlockNode
lbh = do
            Maybe BlockNode
skM <- m (Maybe BlockNode) -> t m (Maybe BlockNode)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe BlockNode) -> t m (Maybe BlockNode))
-> m (Maybe BlockNode) -> t m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
sh BlockNode
lbh
            case Maybe BlockNode
skM of
                Just sk :: BlockNode
sk -> BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sk
                Nothing ->
                    String -> t m BlockNode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> t m BlockNode) -> String -> t m BlockNode
forall a b. (a -> b) -> a -> b
$
                    "BUG: Could not get skip for block " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
par)
        | Bool
otherwise = do
            let sn :: BlockNode
sn = [BlockNode]
ls [BlockNode] -> Int -> BlockNode
forall a. [a] -> Int -> a
!! BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
sh)
            Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode -> BlockHeight
nodeHeight BlockNode
sn BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockHeight
sh) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
                String -> t m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "BUG: Node height not right in skip"
            BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sn
      where
        sh :: BlockHeight
sh = BlockHeight -> BlockHeight
skipHeight (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1)
    go :: BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go _ acc :: [BlockNode]
acc _ _ _ [] = [BlockNode] -> ExceptT String m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
    go lbh :: BlockNode
lbh acc :: [BlockNode]
acc bb :: BlockNode
bb par :: BlockNode
par pars :: [BlockNode]
pars (h :: BlockHeader
h:hs :: [BlockHeader]
hs) = do
        BlockNode
sk <- BlockNode -> [BlockNode] -> BlockNode -> ExceptT String m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, BlockHeaders m, MonadError String (t m)) =>
BlockNode -> [BlockNode] -> BlockNode -> t m BlockNode
skipit BlockNode
lbh [BlockNode]
acc BlockNode
par
        BlockNode
bn <- m (Either String BlockNode) -> ExceptT String m BlockNode
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String BlockNode) -> ExceptT String m BlockNode)
-> (Either String BlockNode -> m (Either String BlockNode))
-> Either String BlockNode
-> ExceptT String m BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String BlockNode -> m (Either String BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String BlockNode -> ExceptT String m BlockNode)
-> Either String BlockNode -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$ Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock Network
net BlockHeight
t BlockNode
bb BlockNode
par [BlockNode]
pars BlockHeader
h BlockNode
sk
        BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go BlockNode
lbh (BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) (BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bn BlockNode
bb) BlockNode
bn (Int -> [BlockNode] -> [BlockNode]
forall a. Int -> [a] -> [a]
take 10 ([BlockNode] -> [BlockNode]) -> [BlockNode] -> [BlockNode]
forall a b. (a -> b) -> a -> b
$ BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars) [BlockHeader]
hs

-- | Block's parent. If the block header is in the store, its parent must also
-- be there. No block header get deleted or pruned from the store.
parentBlock :: BlockHeaders m
            => BlockHeader
            -> m (Maybe BlockNode)
parentBlock :: BlockHeader -> m (Maybe BlockNode)
parentBlock bh :: BlockHeader
bh = BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHeader -> BlockHash
prevBlock BlockHeader
bh)

-- | Validate and connect single block header to the block chain. Return 'Left'
-- if fails to be validated.
connectBlock ::
       BlockHeaders m
    => Network
    -> Timestamp -- ^ current time
    -> BlockHeader
    -> m (Either String BlockNode)
connectBlock :: Network
-> BlockHeight -> BlockHeader -> m (Either String BlockNode)
connectBlock net :: Network
net t :: BlockHeight
t bh :: BlockHeader
bh =
    ExceptT String m BlockNode -> m (Either String BlockNode)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m BlockNode -> m (Either String BlockNode))
-> ExceptT String m BlockNode -> m (Either String BlockNode)
forall a b. (a -> b) -> a -> b
$ do
        BlockNode
par <-
            String -> MaybeT m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT
                "Could not get parent block"
                (m (Maybe BlockNode) -> MaybeT m BlockNode
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BlockHeader -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeader -> m (Maybe BlockNode)
parentBlock BlockHeader
bh))
        [BlockNode]
pars <- m [BlockNode] -> ExceptT String m [BlockNode]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [BlockNode] -> ExceptT String m [BlockNode])
-> m [BlockNode] -> ExceptT String m [BlockNode]
forall a b. (a -> b) -> a -> b
$ Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 10 BlockNode
par
        Maybe BlockNode
skM <- m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode))
-> m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockHeight -> BlockHeight
skipHeight (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1)) BlockNode
par
        BlockNode
sk <-
            case Maybe BlockNode
skM of
                Just sk :: BlockNode
sk -> BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sk
                Nothing ->
                    String -> ExceptT String m BlockNode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String m BlockNode)
-> String -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$
                    "BUG: Could not get skip for block " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
par)
        BlockNode
bb <- m BlockNode -> ExceptT String m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
        BlockNode
bn <- m (Either String BlockNode) -> ExceptT String m BlockNode
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String BlockNode) -> ExceptT String m BlockNode)
-> (Either String BlockNode -> m (Either String BlockNode))
-> Either String BlockNode
-> ExceptT String m BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String BlockNode -> m (Either String BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String BlockNode -> ExceptT String m BlockNode)
-> Either String BlockNode -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$ Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock Network
net BlockHeight
t BlockNode
bb BlockNode
par [BlockNode]
pars BlockHeader
bh BlockNode
sk
        let bb' :: BlockNode
bb' = BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bb BlockNode
bn
        m () -> ExceptT String m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader BlockNode
bn
        Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bb') (ExceptT String m () -> ExceptT String m ())
-> (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ExceptT String m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader BlockNode
bb'
        BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bn

-- | Validate this block header. Build a 'BlockNode' if successful.
validBlock :: Network
           -> Timestamp     -- ^ current time
           -> BlockNode     -- ^ best block
           -> BlockNode     -- ^ immediate parent
           -> [BlockNode]   -- ^ 10 parents above
           -> BlockHeader   -- ^ header to validate
           -> BlockNode     -- ^ skip node (black magic)
           -> Either String BlockNode
validBlock :: Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock net :: Network
net t :: BlockHeight
t bb :: BlockNode
bb par :: BlockNode
par pars :: [BlockNode]
pars bh :: BlockHeader
bh sk :: BlockNode
sk = do
    let mt :: BlockHeight
mt = [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight)
-> ([BlockNode] -> [BlockHeight]) -> [BlockNode] -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) ([BlockNode] -> BlockHeight) -> [BlockNode] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars
        nt :: BlockHeight
nt = BlockHeader -> BlockHeight
blockTimestamp BlockHeader
bh
        hh :: BlockHash
hh = BlockHeader -> BlockHash
headerHash BlockHeader
bh
        nv :: BlockHeight
nv = BlockHeader -> BlockHeight
blockVersion BlockHeader
bh
        ng :: BlockHeight
ng = BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1
        aw :: BlockWork
aw = BlockNode -> BlockWork
nodeWork BlockNode
par BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockHeader -> BlockWork
headerWork BlockHeader
bh
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeader -> Bool
isValidPOW Network
net BlockHeader
bh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Proof of work failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash BlockHeader
bh)
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockHeight
nt BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
t BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 2 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 60 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 60) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Invalid header timestamp: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nt
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockHeight
nt BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
mt) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Block timestamp too early: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nt
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHeight -> Bool
afterLastCP Network
net (BlockNode -> BlockHeight
nodeHeight BlockNode
bb) BlockHeight
ng) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Rewriting pre-checkpoint chain: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
ng
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHash -> Bool
validCP Network
net BlockHeight
ng BlockHash
hh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Rejected checkpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
ng
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHash -> Bool
bip34 Network
net BlockHeight
ng BlockHash
hh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Rejected BIP-34 block: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show BlockHash
hh
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHeight -> Bool
validVersion Network
net BlockHeight
ng BlockHeight
nv) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "Invalid block version: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nv
    BlockNode -> Either String BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode { nodeHeader :: BlockHeader
nodeHeader = BlockHeader
bh
                     , nodeHeight :: BlockHeight
nodeHeight = BlockHeight
ng
                     , nodeWork :: BlockWork
nodeWork = BlockWork
aw
                     , nodeSkip :: BlockHash
nodeSkip = BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
sk
                     }

-- | Return the median of all provided timestamps. Can be unsorted. Error on
-- empty list.
medianTime :: [Timestamp] -> Timestamp
medianTime :: [BlockHeight] -> BlockHeight
medianTime ts :: [BlockHeight]
ts
    | [BlockHeight] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockHeight]
ts = String -> BlockHeight
forall a. HasCallStack => String -> a
error "Cannot compute median time of empty header list"
    | Bool
otherwise = [BlockHeight] -> [BlockHeight]
forall a. Ord a => [a] -> [a]
sort [BlockHeight]
ts [BlockHeight] -> Int -> BlockHeight
forall a. [a] -> Int -> a
!! ([BlockHeight] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeight]
ts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2)

-- | Calculate the height of the skip (magic) block that corresponds to the
-- given height. The block hash of the ancestor at that height will be placed on
-- the 'BlockNode' structure to help locate ancestors at any height quickly.
skipHeight :: BlockHeight -> BlockHeight
skipHeight :: BlockHeight -> BlockHeight
skipHeight height :: BlockHeight
height
    | BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = 0
    | BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Bits a => a -> a -> a
.&. 1 BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 = BlockHeight -> BlockHeight
invertLowestOne (BlockHeight -> BlockHeight
invertLowestOne (BlockHeight -> BlockHeight) -> BlockHeight -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 1) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1
    | Bool
otherwise = BlockHeight -> BlockHeight
invertLowestOne BlockHeight
height

-- | Part of the skip black magic calculation.
invertLowestOne :: BlockHeight -> BlockHeight
invertLowestOne :: BlockHeight -> BlockHeight
invertLowestOne height :: BlockHeight
height = BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Bits a => a -> a -> a
.&. (BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 1)

-- | Get a number of parents for the provided block.
getParents :: BlockHeaders m
           => Int
           -> BlockNode
           -> m [BlockNode]   -- ^ starts from immediate parent
getParents :: Int -> BlockNode -> m [BlockNode]
getParents = [BlockNode] -> Int -> BlockNode -> m [BlockNode]
forall t (m :: * -> *).
(Eq t, Num t, BlockHeaders m) =>
[BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars []
  where
    getpars :: [BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars acc :: [BlockNode]
acc 0 _ = [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse [BlockNode]
acc
    getpars acc :: [BlockNode]
acc n :: t
n BlockNode{..}
      | BlockHeight
nodeHeight BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse [BlockNode]
acc
      | Bool
otherwise = do
        Maybe BlockNode
parM <- BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHash -> m (Maybe BlockNode))
-> BlockHash -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
prevBlock BlockHeader
nodeHeader
        case Maybe BlockNode
parM of
            Just bn :: BlockNode
bn -> [BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars (BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) (t
n t -> t -> t
forall a. Num a => a -> a -> a
- 1) BlockNode
bn
            Nothing -> String -> m [BlockNode]
forall a. HasCallStack => String -> a
error "BUG: All non-genesis blocks should have a parent"

-- | Verify that checkpoint location is valid.
validCP :: Network
        -> BlockHeight  -- ^ new child height
        -> BlockHash    -- ^ new child hash
        -> Bool
validCP :: Network -> BlockHeight -> BlockHash -> Bool
validCP net :: Network
net height :: BlockHeight
height newChildHash :: BlockHash
newChildHash =
    case BlockHeight -> [(BlockHeight, BlockHash)] -> Maybe BlockHash
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BlockHeight
height (Network -> [(BlockHeight, BlockHash)]
getCheckpoints Network
net) of
        Just cpHash :: BlockHash
cpHash -> BlockHash
cpHash BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
newChildHash
        Nothing     -> Bool
True

-- | New block height above the last checkpoint imported. Used to prevent a
-- reorg below the highest checkpoint that was already imported.
afterLastCP :: Network
            -> BlockHeight  -- ^ best height
            -> BlockHeight  -- ^ new imported block height
            -> Bool
afterLastCP :: Network -> BlockHeight -> BlockHeight -> Bool
afterLastCP net :: Network
net bestHeight :: BlockHeight
bestHeight newChildHeight :: BlockHeight
newChildHeight =
    case Maybe BlockHeight
lM of
        Just l :: BlockHeight
l  -> BlockHeight
l BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
newChildHeight
        Nothing -> Bool
True
  where
    lM :: Maybe BlockHeight
lM =
        [BlockHeight] -> Maybe BlockHeight
forall a. [a] -> Maybe a
listToMaybe ([BlockHeight] -> Maybe BlockHeight)
-> ([BlockHeight] -> [BlockHeight])
-> [BlockHeight]
-> Maybe BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockHeight] -> [BlockHeight]
forall a. [a] -> [a]
reverse ([BlockHeight] -> Maybe BlockHeight)
-> [BlockHeight] -> Maybe BlockHeight
forall a b. (a -> b) -> a -> b
$
        [BlockHeight
c | (c :: BlockHeight
c, _) <- Network -> [(BlockHeight, BlockHash)]
getCheckpoints Network
net, BlockHeight
c BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
bestHeight]

-- | This block should be at least version 2 (BIP34). Block height must be
-- included in the coinbase transaction to prevent non-unique transaction
-- hashes.
bip34 :: Network
      -> BlockHeight  -- ^ new child height
      -> BlockHash    -- ^ new child hash
      -> Bool
bip34 :: Network -> BlockHeight -> BlockHash -> Bool
bip34 net :: Network
net height :: BlockHeight
height hsh :: BlockHash
hsh
    | (BlockHeight, BlockHash) -> BlockHeight
forall a b. (a, b) -> a
fst (Network -> (BlockHeight, BlockHash)
getBip34Block Network
net) BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Bool
True
    | (BlockHeight, BlockHash) -> BlockHeight
forall a b. (a, b) -> a
fst (Network -> (BlockHeight, BlockHash)
getBip34Block Network
net) BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
height = (BlockHeight, BlockHash) -> BlockHash
forall a b. (a, b) -> b
snd (Network -> (BlockHeight, BlockHash)
getBip34Block Network
net) BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
hsh
    | Bool
otherwise = Bool
True

-- | Check if the provided block height and version are valid.
validVersion :: Network
             -> BlockHeight  -- ^ new child height
             -> Word32       -- ^ new child version
             -> Bool
validVersion :: Network -> BlockHeight -> BlockHeight -> Bool
validVersion net :: Network
net height :: BlockHeight
height version :: BlockHeight
version
    | BlockHeight
version BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< (BlockHeight, BlockHash) -> BlockHeight
forall a b. (a, b) -> a
fst (Network -> (BlockHeight, BlockHash)
getBip34Block Network
net)
    | BlockHeight
version BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 3 = BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< Network -> BlockHeight
getBip66Height Network
net
    | BlockHeight
version BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 4 = BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< Network -> BlockHeight
getBip65Height Network
net
    | Bool
otherwise = Bool
True

-- | Find last block with normal, as opposed to minimum difficulty (for test
-- networks).
lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode
lastNoMinDiff :: Network -> BlockNode -> m BlockNode
lastNoMinDiff _ bn :: BlockNode
bn@BlockNode {nodeHeight :: BlockNode -> BlockHeight
nodeHeight = BlockHeight
0} = BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bn
lastNoMinDiff net :: Network
net bn :: BlockNode
bn@BlockNode {..} = do
    let i :: Bool
i = BlockHeight
nodeHeight BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
        c :: BlockHeight
c = BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net)
        l :: Bool
l = BlockHeader -> BlockHeight
blockBits BlockHeader
nodeHeader BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
c
        e1 :: a
e1 =
            String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
            "Could not get block header for parent of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
            BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash BlockHeader
nodeHeader)
    if Bool
i Bool -> Bool -> Bool
&& Bool
l
        then do
            BlockNode
bn' <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHeader -> BlockHash
prevBlock BlockHeader
nodeHeader)
            Network -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> m BlockNode
lastNoMinDiff Network
net BlockNode
bn'
        else BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
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
                 => Network
                 -> BlockNode
                 -> BlockHeader
                 -> m Word32
nextWorkRequired :: Network -> BlockNode -> BlockHeader -> m BlockHeight
nextWorkRequired net :: Network
net par :: BlockNode
par bh :: BlockHeader
bh = do
    Maybe BlockNode
ma <- Network -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> m (Maybe BlockNode)
getAsertAnchor Network
net
    case Maybe BlockNode
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (m :: * -> *) (m :: * -> *).
(Alternative m, BlockHeaders m, Monad m) =>
m BlockNode -> m (BlockNode -> BlockHeader -> m BlockHeight)
asert Maybe BlockNode
ma Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
daa Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
eda Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
pow of
        Just f :: BlockNode -> BlockHeader -> m BlockHeight
f  -> BlockNode -> BlockHeader -> m BlockHeight
f BlockNode
par BlockHeader
bh
        Nothing -> String -> m BlockHeight
forall a. HasCallStack => String -> a
error "Could not determine difficulty algorithm"
  where
    asert :: m BlockNode -> m (BlockNode -> BlockHeader -> m BlockHeight)
asert ma :: m BlockNode
ma = do
        BlockNode
anchor <- m BlockNode
ma
        Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode -> BlockHeight
nodeHeight BlockNode
anchor)
        (BlockNode -> BlockHeader -> m BlockHeight)
-> m (BlockNode -> BlockHeader -> m BlockHeight)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> m (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> m (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
nextAsertWorkRequired Network
net BlockNode
anchor
    daa :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
daa = do
        BlockHeight
daa_height <- Network -> Maybe BlockHeight
getDaaBlockHeight Network
net
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
daa_height)
        (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextDaaWorkRequired Network
net
    eda :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
eda = do
        BlockHeight
eda_height <- Network -> Maybe BlockHeight
getEdaBlockHeight Network
net
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
eda_height)
        (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextEdaWorkRequired Network
net
    pow :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
pow = (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextPowWorkRequired Network
net

-- | Find out the next amount of work required according to the Emergency
-- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash.
nextEdaWorkRequired ::
       BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextEdaWorkRequired :: Network -> BlockNode -> BlockHeader -> m BlockHeight
nextEdaWorkRequired net :: Network
net par :: BlockNode
par bh :: BlockHeader
bh
    | BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1 BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== 0 =
        Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextWorkRequired Network
net BlockNode
par BlockHeader
bh
    | Bool
minDifficulty = BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net))
    | BlockHeader -> BlockHeight
blockBits (BlockNode -> BlockHeader
nodeHeader BlockNode
par) BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net) =
        BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net))
    | Bool
otherwise = do
        BlockNode
par6 <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 6) BlockNode
par
        [BlockNode]
pars <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 10 BlockNode
par
        [BlockNode]
pars6 <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 10 BlockNode
par6
        let par6med :: BlockHeight
par6med =
                [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight) -> [BlockHeight] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) (BlockNode
par6 BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars6)
            parmed :: BlockHeight
parmed = [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight) -> [BlockHeight] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) (BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars)
            mtp6 :: BlockHeight
mtp6 = BlockHeight
parmed BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
par6med
        if BlockHeight
mtp6 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 12 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 3600
            then BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits (BlockNode -> BlockHeader
nodeHeader BlockNode
par)
            else BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$
                 let (diff :: BlockWork
diff, _) = BlockHeight -> (BlockWork, Bool)
decodeCompact (BlockHeader -> BlockHeight
blockBits (BlockNode -> BlockHeader
nodeHeader BlockNode
par))
                     ndiff :: BlockWork
ndiff = BlockWork
diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ (BlockWork
diff BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` 2)
                  in if Network -> BlockWork
getPowLimit Network
net BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockWork
ndiff
                         then BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net)
                         else BlockWork -> BlockHeight
encodeCompact BlockWork
ndiff
  where
    minDifficulty :: Bool
minDifficulty =
        BlockHeader -> BlockHeight
blockTimestamp BlockHeader
bh BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>
        BlockHeader -> BlockHeight
blockTimestamp (BlockNode -> BlockHeader
nodeHeader BlockNode
par) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ Network -> BlockHeight
getTargetSpacing Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 2
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error "Could not get seventh ancestor of block"

-- | Find the next amount of work required according to the Difficulty
-- Adjustment Algorithm (DAA) from Bitcoin Cash.
nextDaaWorkRequired ::
       BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextDaaWorkRequired :: Network -> BlockNode -> BlockHeader -> m BlockHeight
nextDaaWorkRequired net :: Network
net par :: BlockNode
par bh :: BlockHeader
bh
    | Bool
minDifficulty = BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net))
    | Bool
otherwise = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= Network -> BlockHeight
diffInterval Network
net) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> m ()
forall a. HasCallStack => String -> a
error "Block height below difficulty interval"
        BlockNode
l <- BlockNode -> m BlockNode
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock BlockNode
par
        BlockNode
par144 <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 144) BlockNode
par
        BlockNode
f <- BlockNode -> m BlockNode
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock BlockNode
par144
        let nextTarget :: BlockWork
nextTarget = Network -> BlockNode -> BlockNode -> BlockWork
computeTarget Network
net BlockNode
f BlockNode
l
        if BlockWork
nextTarget BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network -> BlockWork
getPowLimit Network
net
            then BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net)
            else BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact BlockWork
nextTarget
  where
    height :: BlockHeight
height = BlockNode -> BlockHeight
nodeHeight BlockNode
par
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error "Cannot get ancestor at parent - 144 height"
    minDifficulty :: Bool
minDifficulty =
        BlockHeader -> BlockHeight
blockTimestamp BlockHeader
bh BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>
        BlockHeader -> BlockHeight
blockTimestamp (BlockNode -> BlockHeader
nodeHeader BlockNode
par) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ Network -> BlockHeight
getTargetSpacing Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 2

mtp :: BlockHeaders m => BlockNode -> m Timestamp
mtp :: BlockNode -> m BlockHeight
mtp bn :: BlockNode
bn
    | BlockNode -> BlockHeight
nodeHeight BlockNode
bn BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return 0
    | Bool
otherwise = do
        [BlockNode]
pars <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 11 BlockNode
bn
        BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ [BlockHeight] -> BlockHeight
medianTime ((BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) [BlockNode]
pars)

firstGreaterOrEqual :: BlockHeaders m
                    => Network
                    -> (BlockNode -> m Ordering)
                    -> m (Maybe BlockNode)
firstGreaterOrEqual :: Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
firstGreaterOrEqual = Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch Bool
False

lastSmallerOrEqual :: BlockHeaders m
                   => Network
                   -> (BlockNode -> m Ordering)
                   -> m (Maybe BlockNode)
lastSmallerOrEqual :: Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
lastSmallerOrEqual = Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch Bool
True

binSearch :: BlockHeaders m
          => Bool
          -> Network
          -> (BlockNode -> m Ordering)
          -> m (Maybe BlockNode)
binSearch :: Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch top :: Bool
top net :: Network
net f :: BlockNode -> m Ordering
f = MaybeT m BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m BlockNode -> m (Maybe BlockNode))
-> MaybeT m BlockNode -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ do
    (a :: BlockNode
a, b :: BlockNode
b) <- m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode))
-> m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode)
forall a b. (a -> b) -> a -> b
$ Network -> m (BlockNode, BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> m (BlockNode, BlockNode)
extremes Network
net
    BlockNode -> BlockNode -> MaybeT m BlockNode
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadPlus (t m)) =>
BlockNode -> BlockNode -> t m BlockNode
go BlockNode
a BlockNode
b
  where
    go :: BlockNode -> BlockNode -> t m BlockNode
go a :: BlockNode
a b :: BlockNode
b = do
        BlockNode
m <- m BlockNode -> t m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m BlockNode -> t m BlockNode) -> m BlockNode -> t m BlockNode
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
middleBlock BlockNode
a BlockNode
b
        Ordering
a' <- m Ordering -> t m Ordering
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
a
        Ordering
b' <- m Ordering -> t m Ordering
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
b
        Ordering
m' <- m Ordering -> t m Ordering
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
m
        (BlockNode, Ordering)
-> (BlockNode, Ordering) -> (BlockNode, Ordering) -> t m BlockNode
r (BlockNode
a, Ordering
a') (BlockNode
b, Ordering
b') (BlockNode
m, Ordering
m')
    r :: (BlockNode, Ordering)
-> (BlockNode, Ordering) -> (BlockNode, Ordering) -> t m BlockNode
r (a :: BlockNode
a, a' :: Ordering
a') (b :: BlockNode
b, b' :: Ordering
b') (m :: BlockNode
m, m' :: Ordering
m')
        | Ordering -> Ordering -> Bool
out_of_bounds Ordering
a' Ordering
b' = t m BlockNode
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        | Ordering -> Bool
select_first Ordering
a' = BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
a
        | Ordering -> Bool
select_last Ordering
b' = BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
        | BlockNode -> BlockNode -> Bool
no_middle BlockNode
a BlockNode
b = BlockNode -> BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => a -> a -> m a
choose_one BlockNode
a BlockNode
b
        | Ordering -> Ordering -> Bool
is_between Ordering
a' Ordering
m' = BlockNode -> BlockNode -> t m BlockNode
go BlockNode
a BlockNode
m
        | Ordering -> Ordering -> Bool
is_between Ordering
m' Ordering
b' = BlockNode -> BlockNode -> t m BlockNode
go BlockNode
m BlockNode
b
        | Bool
otherwise = t m BlockNode
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    select_first :: Ordering -> Bool
select_first a' :: Ordering
a'
        | Bool -> Bool
not Bool
top = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
        | Bool
otherwise = Bool
False
    select_last :: Ordering -> Bool
select_last b' :: Ordering
b'
        | Bool
top = Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
        | Bool
otherwise = Bool
False
    out_of_bounds :: Ordering -> Ordering -> Bool
out_of_bounds a' :: Ordering
a' b' :: Ordering
b'
        | Bool
top = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
        | Bool
otherwise = Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT
    no_middle :: BlockNode -> BlockNode -> Bool
no_middle a :: BlockNode
a b :: BlockNode
b = BlockNode -> BlockHeight
nodeHeight BlockNode
b BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockNode -> BlockHeight
nodeHeight BlockNode
a BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= 1
    is_between :: Ordering -> Ordering -> Bool
is_between a' :: Ordering
a' b' :: Ordering
b' = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT Bool -> Bool -> Bool
&& Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
    choose_one :: a -> a -> m a
choose_one a :: a
a b :: a
b
        | Bool
top = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        | Bool
otherwise = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b

extremes :: BlockHeaders m => Network -> m (BlockNode, BlockNode)
extremes :: Network -> m (BlockNode, BlockNode)
extremes net :: Network
net = do
    BlockNode
b <- m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
    (BlockNode, BlockNode) -> m (BlockNode, BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Network -> BlockNode
genesisNode Network
net, BlockNode
b)

middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode
middleBlock :: BlockNode -> BlockNode -> m BlockNode
middleBlock a :: BlockNode
a b :: BlockNode
b =
    BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
b m (Maybe BlockNode)
-> (Maybe BlockNode -> m BlockNode) -> m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> String -> m BlockNode
forall a. HasCallStack => String -> a
error "You fell into a pit full of mud and snakes"
        Just x :: BlockNode
x  -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
  where
    h :: BlockHeight
h = BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
middleOf (BlockNode -> BlockHeight
nodeHeight BlockNode
a) (BlockNode -> BlockHeight
nodeHeight BlockNode
b)

middleOf :: Integral a => a -> a -> a
middleOf :: a -> a -> a
middleOf a :: a
a b :: a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
a) a -> a -> a
forall a. Integral a => a -> a -> a
`div` 2)

-- TODO: Use known anchor after fork
getAsertAnchor :: BlockHeaders m => Network -> m (Maybe BlockNode)
getAsertAnchor :: Network -> m (Maybe BlockNode)
getAsertAnchor net :: Network
net =
    case Network -> Maybe BlockHeight
getAsertActivationTime Network
net of
        Nothing  -> Maybe BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockNode
forall a. Maybe a
Nothing
        Just act :: BlockHeight
act -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
firstGreaterOrEqual Network
net (BlockHeight -> BlockNode -> m Ordering
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m Ordering
f BlockHeight
act)
  where
    f :: BlockHeight -> BlockNode -> m Ordering
f act :: BlockHeight
act bn :: BlockNode
bn = do
        BlockHeight
m <- BlockNode -> m BlockHeight
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockHeight
mtp BlockNode
bn
        Ordering -> m Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Ordering -> m Ordering) -> Ordering -> m Ordering
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare BlockHeight
m BlockHeight
act

-- | Find the next amount of work required according to the aserti3-2d algorithm.
nextAsertWorkRequired :: BlockHeaders m
                      => Network
                      -> BlockNode
                      -> BlockNode
                      -> BlockHeader
                      -> m Word32
nextAsertWorkRequired :: Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
nextAsertWorkRequired net :: Network
net anchor :: BlockNode
anchor par :: BlockNode
par bh :: BlockHeader
bh = do
    BlockNode
anchor_parent <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e_fork (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                      BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHeader -> BlockHash
prevBlock (BlockNode -> BlockHeader
nodeHeader BlockNode
anchor))
    let anchor_parent_time :: BlockWork
anchor_parent_time = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger (BlockHeight -> BlockWork) -> BlockHeight -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
anchor_parent
        time_diff :: BlockWork
time_diff = BlockWork
current_time BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
anchor_parent_time
    BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight -> BlockWork -> BlockWork -> BlockHeight
computeAsertBits BlockWork
halflife BlockHeight
anchor_bits BlockWork
time_diff BlockWork
height_diff
  where
    halflife :: BlockWork
halflife = Network -> BlockWork
getAsertHalfLife Network
net
    anchor_height :: BlockWork
anchor_height = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger (BlockHeight -> BlockWork) -> BlockHeight -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeight
nodeHeight BlockNode
anchor
    anchor_bits :: BlockHeight
anchor_bits = BlockHeader -> BlockHeight
blockBits (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
anchor
    current_height :: BlockWork
current_height = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger (BlockNode -> BlockHeight
nodeHeight BlockNode
par) BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 1
    height_diff :: BlockWork
height_diff = BlockWork
current_height BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
anchor_height
    current_time :: BlockWork
current_time = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger (BlockHeight -> BlockWork) -> BlockHeight -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockTimestamp BlockHeader
bh
    e_fork :: a
e_fork = String -> a
forall a. HasCallStack => String -> a
error "Could not get fork block header"

idealBlockTime :: Integer
idealBlockTime :: BlockWork
idealBlockTime = 10 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* 60

rBits :: Int
rBits :: Int
rBits = 16

radix :: Integer
radix :: BlockWork
radix = 1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` Int
rBits

maxBits :: Word32
maxBits :: BlockHeight
maxBits = 0x1d00ffff

maxTarget :: Integer
maxTarget :: BlockWork
maxTarget = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeight
maxBits

computeAsertBits
    :: Integer
    -> Word32
    -> Integer
    -> Integer
    -> Word32
computeAsertBits :: BlockWork -> BlockHeight -> BlockWork -> BlockWork -> BlockHeight
computeAsertBits halflife :: BlockWork
halflife anchor_bits :: BlockHeight
anchor_bits time_diff :: BlockWork
time_diff height_diff :: BlockWork
height_diff =
    if BlockWork
e2 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& BlockWork
e2 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
< 65536
    then if BlockWork
g4 BlockWork -> BlockWork -> Bool
forall a. Eq a => a -> a -> Bool
== 0
         then BlockWork -> BlockHeight
encodeCompact 1
         else if BlockWork
g4 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockWork
maxTarget
              then BlockHeight
maxBits
              else BlockWork -> BlockHeight
encodeCompact BlockWork
g4
    else String -> BlockHeight
forall a. HasCallStack => String -> a
error (String -> BlockHeight) -> String -> BlockHeight
forall a b. (a -> b) -> a -> b
$ "Exponent not in range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockWork -> String
forall a. Show a => a -> String
show BlockWork
e2
  where
    g1 :: BlockWork
g1 = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst (BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeight
anchor_bits)
    e1 :: BlockWork
e1 = ((BlockWork
time_diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
idealBlockTime BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* (BlockWork
height_diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 1)) BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
radix)
         BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`quot`
         BlockWork
halflife
    s :: BlockWork
s = BlockWork
e1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int
rBits
    e2 :: BlockWork
e2 = BlockWork
e1 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
s BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
radix
    g2 :: BlockWork
g2 = BlockWork
g1 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* (BlockWork
radix BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+
               ((195766423245049BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
*BlockWork
e2 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 971821376BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
*BlockWork
e2BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^2 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 5127BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
*BlockWork
e2BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^3 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 2BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^47)
                BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR`
                (Int
rBitsInt -> Int -> Int
forall a. Num a => a -> a -> a
*3)))
    g3 :: BlockWork
g3 = if BlockWork
s BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
< 0
         then BlockWork
g2 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int -> Int
forall a. Num a => a -> a
negate (BlockWork -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
s)
         else BlockWork
g2 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` BlockWork -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
s
    g4 :: BlockWork
g4 = BlockWork
g3 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int
rBits


-- | Compute Bitcoin Cash DAA target for a new block.
computeTarget :: Network -> BlockNode -> BlockNode -> Integer
computeTarget :: Network -> BlockNode -> BlockNode -> BlockWork
computeTarget net :: Network
net f :: BlockNode
f l :: BlockNode
l =
    let work :: BlockWork
work = (BlockNode -> BlockWork
nodeWork BlockNode
l BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockNode -> BlockWork
nodeWork BlockNode
f) BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Network -> BlockHeight
getTargetSpacing Network
net)
        actualTimespan :: BlockHeight
actualTimespan =
            BlockHeader -> BlockHeight
blockTimestamp (BlockNode -> BlockHeader
nodeHeader BlockNode
l) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeader -> BlockHeight
blockTimestamp (BlockNode -> BlockHeader
nodeHeader BlockNode
f)
        actualTimespan' :: BlockHeight
actualTimespan'
            | BlockHeight
actualTimespan BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> 288 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* Network -> BlockHeight
getTargetSpacing Network
net =
                288 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* Network -> BlockHeight
getTargetSpacing Network
net
            | BlockHeight
actualTimespan BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< 72 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* Network -> BlockHeight
getTargetSpacing Network
net =
                72 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* Network -> BlockHeight
getTargetSpacing Network
net
            | Bool
otherwise = BlockHeight
actualTimespan
        work' :: BlockWork
work' = BlockWork
work BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
actualTimespan'
     in 2 BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^ (256 :: Integer) BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` BlockWork
work'

-- | Get suitable block for Bitcoin Cash DAA computation.
getSuitableBlock :: BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock :: BlockNode -> m BlockNode
getSuitableBlock par :: BlockNode
par = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= 3) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. HasCallStack => String -> a
error "Block height is less than three"
    [BlockNode]
blocks <- (BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
:) ([BlockNode] -> [BlockNode]) -> m [BlockNode] -> m [BlockNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents 2 BlockNode
par
    BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockNode -> m BlockNode) -> BlockNode -> m BlockNode
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockNode -> Ordering) -> [BlockNode] -> [BlockNode]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockHeight -> BlockHeight -> Ordering)
-> (BlockNode -> BlockHeight) -> BlockNode -> BlockNode -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) [BlockNode]
blocks [BlockNode] -> Int -> BlockNode
forall a. [a] -> Int -> a
!! 1

-- | Returns the work required on a block header given the previous block. This
-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.
nextPowWorkRequired ::
       BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextPowWorkRequired :: Network -> BlockNode -> BlockHeader -> m BlockHeight
nextPowWorkRequired net :: Network
net par :: BlockNode
par bh :: BlockHeader
bh
    | BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ 1 BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 =
        if Network -> Bool
getAllowMinDifficultyBlocks Network
net
            then if BlockHeight
ht BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockHeight
pt BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
delta
                     then BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net)
                     else do
                         BlockNode
d <- Network -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> m BlockNode
lastNoMinDiff Network
net BlockNode
par
                         BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
d
            else BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
par
    | Bool
otherwise = do
        let rh :: BlockHeight
rh = BlockNode -> BlockHeight
nodeHeight BlockNode
par BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- (Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 1)
        BlockNode
a <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
rh BlockNode
par
        let t :: BlockHeight
t = BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
a
        BlockHeight -> m BlockHeight
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ Network -> BlockHeader -> BlockHeight -> BlockHeight
calcNextWork Network
net (BlockNode -> BlockHeader
nodeHeader BlockNode
par) BlockHeight
t
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error "Could not get ancestor for block header"
    pt :: BlockHeight
pt = BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
par
    ht :: BlockHeight
ht = BlockHeader -> BlockHeight
blockTimestamp BlockHeader
bh
    delta :: BlockHeight
delta = Network -> BlockHeight
getTargetSpacing Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 2

-- | Computes the work required for the first block in a new retarget period.
calcNextWork :: Network
             -> BlockHeader  -- ^ last block in previous retarget (parent)
             -> Timestamp    -- ^ timestamp of first block in previous retarget
             -> Word32
calcNextWork :: Network -> BlockHeader -> BlockHeight -> BlockHeight
calcNextWork net :: Network
net header :: BlockHeader
header time :: BlockHeight
time
    | Network -> Bool
getPowNoRetargetting Network
net = BlockHeader -> BlockHeight
blockBits BlockHeader
header
    | BlockWork
new BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network -> BlockWork
getPowLimit Network
net = BlockWork -> BlockHeight
encodeCompact (Network -> BlockWork
getPowLimit Network
net)
    | Bool
otherwise = BlockWork -> BlockHeight
encodeCompact BlockWork
new
  where
    s :: BlockHeight
s = BlockHeader -> BlockHeight
blockTimestamp BlockHeader
header BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
time
    n :: BlockHeight
n | BlockHeight
s BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< Network -> BlockHeight
getTargetTimespan Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` 4 = Network -> BlockHeight
getTargetTimespan Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` 4
      | BlockHeight
s BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> Network -> BlockHeight
getTargetTimespan Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 4 = Network -> BlockHeight
getTargetTimespan Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 4
      | Bool
otherwise = BlockHeight
s
    l :: BlockWork
l = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact (BlockHeight -> (BlockWork, Bool))
-> BlockHeight -> (BlockWork, Bool)
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits BlockHeader
header
    new :: BlockWork
new = BlockWork
l BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
n BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Network -> BlockHeight
getTargetTimespan Network
net)

-- | Returns True if the difficulty target (bits) of the header is valid and the
-- proof of work of the header matches the advertised difficulty target. This
-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in
-- @main.cpp@.
isValidPOW :: Network -> BlockHeader -> Bool
isValidPOW :: Network -> BlockHeader -> Bool
isValidPOW net :: Network
net h :: BlockHeader
h
    | BlockWork
target BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| Bool
over Bool -> Bool -> Bool
|| BlockWork
target BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network -> BlockWork
getPowLimit Network
net = Bool
False
    | Bool
otherwise = BlockHash -> BlockWork
blockPOW (BlockHeader -> BlockHash
headerHash BlockHeader
h) BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockWork -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
target
  where
    (target :: BlockWork
target, over :: Bool
over) = BlockHeight -> (BlockWork, Bool)
decodeCompact (BlockHeight -> (BlockWork, Bool))
-> BlockHeight -> (BlockWork, Bool)
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits BlockHeader
h

-- | Returns the proof of work of a block header hash as an 'Integer' number.
blockPOW :: BlockHash -> Integer
blockPOW :: BlockHash -> BlockWork
blockPOW =  ByteString -> BlockWork
bsToInteger (ByteString -> BlockWork)
-> (BlockHash -> ByteString) -> BlockHash -> BlockWork
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.reverse (ByteString -> ByteString)
-> (BlockHash -> ByteString) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (BlockHash -> Put) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize

-- | Returns the work represented by this block. Work is defined as the number
-- of tries needed to solve a block in the average case with respect to the
-- target.
headerWork :: BlockHeader -> Integer
headerWork :: BlockHeader -> BlockWork
headerWork bh :: BlockHeader
bh = BlockWork
largestHash BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` (BlockWork
target BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ 1)
  where
    target :: BlockWork
target      = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact (BlockHeight -> (BlockWork, Bool))
-> BlockHeight -> (BlockWork, Bool)
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockBits BlockHeader
bh
    largestHash :: BlockWork
largestHash = 1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` 256

-- | Number of blocks on average between difficulty cycles (2016 blocks).
diffInterval :: Network -> Word32
diffInterval :: Network -> BlockHeight
diffInterval net :: Network
net = Network -> BlockHeight
getTargetTimespan Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` Network -> BlockHeight
getTargetSpacing Network
net

-- | Compare two blocks to get the best.
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest b1 :: BlockNode
b1 b2 :: BlockNode
b2 | BlockNode -> BlockWork
nodeWork BlockNode
b1 BlockWork -> BlockWork -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode -> BlockWork
nodeWork BlockNode
b2 =
                       if BlockNode -> BlockHeight
nodeHeight BlockNode
b1 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockNode -> BlockHeight
nodeHeight BlockNode
b2
                       then BlockNode
b1
                       else BlockNode
b2
                 | BlockNode -> BlockWork
nodeWork BlockNode
b1 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode -> BlockWork
nodeWork BlockNode
b2 = BlockNode
b1
                 | Bool
otherwise = BlockNode
b2

-- | Get list of blocks for a block locator.
blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode]
blockLocatorNodes :: BlockNode -> m [BlockNode]
blockLocatorNodes best :: BlockNode
best =
    [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse ([BlockNode] -> [BlockNode]) -> m [BlockNode] -> m [BlockNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
[BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go [] BlockNode
best 1
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error "Could not get ancestor"
    go :: [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go loc :: [BlockNode]
loc bn :: BlockNode
bn n :: BlockHeight
n =
        let loc' :: [BlockNode]
loc' = BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
loc
            n' :: BlockHeight
n' = if [BlockNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockNode]
loc' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10
                 then BlockHeight
n BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* 2
                 else 1
        in if BlockNode -> BlockHeight
nodeHeight BlockNode
bn BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
n'
           then do BlockNode
a <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor 0 BlockNode
bn
                   [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ BlockNode
a BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
loc'
           else do let h :: BlockHeight
h = BlockNode -> BlockHeight
nodeHeight BlockNode
bn BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
n'
                   BlockNode
bn' <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
bn
                   [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go [BlockNode]
loc' BlockNode
bn' BlockHeight
n'

-- | Get block locator.
blockLocator :: BlockHeaders m => BlockNode -> m BlockLocator
blockLocator :: BlockNode -> m BlockLocator
blockLocator bn :: BlockNode
bn = (BlockNode -> BlockHash) -> [BlockNode] -> BlockLocator
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) ([BlockNode] -> BlockLocator) -> m [BlockNode] -> m BlockLocator
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockNode -> m [BlockNode]
forall (m :: * -> *). BlockHeaders m => BlockNode -> m [BlockNode]
blockLocatorNodes BlockNode
bn

-- | Become rich beyond your wildest dreams.
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
mineBlock :: Network -> BlockHeight -> BlockHeader -> BlockHeader
mineBlock net :: Network
net seed :: BlockHeight
seed h :: BlockHeader
h =
    [BlockHeader] -> BlockHeader
forall a. [a] -> a
head
        [ BlockHeader
j
        | BlockHeight
i <- (BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
seed) (BlockHeight -> BlockHeight) -> [BlockHeight] -> [BlockHeight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [0 .. BlockHeight
forall a. Bounded a => a
maxBound]
        , let j :: BlockHeader
j = BlockHeader
h {bhNonce :: BlockHeight
bhNonce = BlockHeight
i}
        , Network -> BlockHeader -> Bool
isValidPOW Network
net BlockHeader
j
        ]

-- | Generate and append new blocks (mining). Only practical in regtest network.
appendBlocks ::
       Network
    -> Word32 -- ^ random seed
    -> BlockHeader
    -> Int
    -> [BlockHeader]
appendBlocks :: Network -> BlockHeight -> BlockHeader -> Int -> [BlockHeader]
appendBlocks _ _ _ 0 = []
appendBlocks net :: Network
net seed :: BlockHeight
seed bh :: BlockHeader
bh i :: Int
i =
    BlockHeader
bh' BlockHeader -> [BlockHeader] -> [BlockHeader]
forall a. a -> [a] -> [a]
: Network -> BlockHeight -> BlockHeader -> Int -> [BlockHeader]
appendBlocks Network
net BlockHeight
seed BlockHeader
bh' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
  where
    bh' :: BlockHeader
bh' = Network -> BlockHeight -> BlockHeader -> BlockHeader
mineBlock Network
net BlockHeight
seed BlockHeader
bh
        { prevBlock :: BlockHash
prevBlock = BlockHeader -> BlockHash
headerHash BlockHeader
bh
          -- Just to make it different in every header
        , merkleRoot :: Hash256
merkleRoot = ByteString -> Hash256
forall b. ByteArrayAccess b => b -> Hash256
sha256 (ByteString -> Hash256) -> ByteString -> Hash256
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ BlockHeight -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize BlockHeight
seed
        }

-- | Find the last common block ancestor between provided block headers.
splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode
splitPoint :: BlockNode -> BlockNode -> m BlockNode
splitPoint l :: BlockNode
l r :: BlockNode
r = do
    let h :: BlockHeight
h = BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
min (BlockNode -> BlockHeight
nodeHeight BlockNode
l) (BlockNode -> BlockHeight
nodeHeight BlockNode
r)
    BlockNode
ll <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
l
    BlockNode
lr <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
r
    BlockNode -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
f BlockNode
ll BlockNode
lr
  where
    e :: a
e = String -> a
forall a. HasCallStack => String -> a
error "BUG: Could not get ancestor at lowest height"
    f :: BlockNode -> BlockNode -> m BlockNode
f ll :: BlockNode
ll lr :: BlockNode
lr =
        if BlockNode
ll BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode
lr
            then BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
lr
            else do
                let h :: BlockHeight
h = BlockNode -> BlockHeight
nodeHeight BlockNode
ll BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- 1
                BlockNode
pl <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
ll
                BlockNode
pr <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall a. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
lr
                BlockNode -> BlockNode -> m BlockNode
f BlockNode
pl BlockNode
pr

-- | Generate the entire Genesis block for 'Network'.
genesisBlock :: Network -> Block
genesisBlock :: Network -> Block
genesisBlock net :: Network
net = BlockHeader -> [Tx] -> Block
Block (Network -> BlockHeader
getGenesisHeader Network
net) [Tx
genesisTx]

-- | Compute block subsidy at particular height.
computeSubsidy :: Network -> BlockHeight -> Word64
computeSubsidy :: Network -> BlockHeight -> ShortBlockHash
computeSubsidy net :: Network
net height :: BlockHeight
height =
    let halvings :: BlockHeight
halvings = BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` Network -> BlockHeight
getHalvingInterval Network
net
        ini :: ShortBlockHash
ini = 50 ShortBlockHash -> ShortBlockHash -> ShortBlockHash
forall a. Num a => a -> a -> a
* 100 ShortBlockHash -> ShortBlockHash -> ShortBlockHash
forall a. Num a => a -> a -> a
* 1000 ShortBlockHash -> ShortBlockHash -> ShortBlockHash
forall a. Num a => a -> a -> a
* 1000
     in if BlockHeight
halvings BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= 64
            then 0
            else ShortBlockHash
ini ShortBlockHash -> Int -> ShortBlockHash
forall a. Bits a => a -> Int -> a
`shiftR` BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
halvings