{-# 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.Bits                   (shiftL, shiftR, (.&.))
import qualified Data.ByteString             as B
import           Data.ByteString.Short       (ShortByteString, fromShort,
                                              toShort)
import           Data.Function               (on)
import           Data.Hashable
import           Data.HashMap.Strict         (HashMap)
import qualified Data.HashMap.Strict         as HashMap
import           Data.List                   (sort, sortBy)
import           Data.Maybe                  (fromMaybe, listToMaybe)
import           Data.Serialize              as S (Serialize (..), decode,
                                                   encode, get, put)
import           Data.Serialize.Get          as S
import           Data.Serialize.Put          as S
import           Data.Typeable               (Typeable)
import           Data.Word                   (Word32, Word64)
import           GHC.Generics                (Generic)
import           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 Serialize BlockNode where
    get :: Get BlockNode
get = do
        BlockHeader
nodeHeader <- Get BlockHeader
forall t. Serialize t => Get t
S.get
        BlockHeight
nodeHeight <- Get BlockHeight
getWord32le
        BlockWork
nodeWork <- Get BlockWork
forall t. Serialize t => Get t
S.get
        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 -> Get BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode {..}
            else do
                BlockHash
nodeSkip <- Get BlockHash
forall t. Serialize t => Get t
S.get
                BlockNode -> Get BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return $WBlockNode :: BlockHeader -> BlockHeight -> BlockWork -> BlockHash -> BlockNode
BlockNode {..}
    put :: Putter BlockNode
put bn :: BlockNode
bn = do
        Putter BlockHeader
forall t. Serialize t => Putter t
put Putter BlockHeader -> Putter BlockHeader
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
        Putter BlockHeight
putWord32le Putter BlockHeight -> Putter BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeight
nodeHeight BlockNode
bn
        Putter BlockWork
forall t. Serialize t => Putter t
put Putter BlockWork -> Putter BlockWork
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockWork
nodeWork BlockNode
bn
        case BlockNode -> BlockHeight
nodeHeight BlockNode
bn of
            0 -> () -> PutM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            _ -> Putter BlockHash
forall t. Serialize t => Putter t
put Putter BlockHash -> Putter BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHash
nodeSkip BlockNode
bn

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 (BlockNode -> ByteString
forall a. Serialize a => a -> ByteString
encode (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
. ByteString -> Either String BlockNode
forall a. Serialize a => ByteString -> Either String a
decode (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
. ByteString -> Either String ShortBlockHash
forall a. Serialize a => ByteString -> Either String a
decode (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
. BlockHash -> ByteString
forall a. Serialize a => a -> ByteString
encode

-- | 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
$ BlockNode -> ByteString
forall a. Serialize a => a -> ByteString
encode 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
b
        | Bool
otherwise = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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
. BlockHash -> ByteString
forall a. Serialize a => a -> ByteString
encode

-- | 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
$ BlockHeight -> ByteString
forall a. Serialize a => a -> ByteString
encode 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