{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Haskoin.Block.Headers
(
BlockNode(..)
, BlockHeaders(..)
, BlockWork
, genesisNode
, genesisBlock
, isGenesis
, chooseBest
, parentBlock
, getParents
, getAncestor
, splitPoint
, connectBlocks
, connectBlock
, blockLocator
, HeaderMemory(..)
, ShortBlockHash
, BlockMap
, shortBlockHash
, initialChain
, genesisMap
, 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
type ShortBlockHash = Word64
type BlockMap = HashMap ShortBlockHash ShortByteString
type BlockWork = Integer
data BlockNode
= BlockNode
{ :: !BlockHeader
, BlockNode -> BlockHeight
nodeHeight :: !BlockHeight
, BlockNode -> BlockWork
nodeWork :: !BlockWork
, 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
data =
{ :: !BlockMap
, :: !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)
class Monad m => m where
:: BlockNode -> m ()
:: BlockHash -> m (Maybe BlockNode)
:: m BlockNode
:: BlockNode -> m ()
:: [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 }
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
}
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)))
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
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' }
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
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
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
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)
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
isGenesis :: BlockNode -> Bool
isGenesis :: BlockNode -> Bool
isGenesis BlockNode {nodeHeight :: BlockNode -> BlockHeight
nodeHeight = BlockHeight
0} = Bool
True
isGenesis _ = Bool
False
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)
}
connectBlocks :: BlockHeaders m
=> Network
-> Timestamp
-> [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
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)
connectBlock ::
BlockHeaders m
=> Network
-> Timestamp
-> 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
validBlock :: Network
-> Timestamp
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> 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
}
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)
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
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)
getParents :: BlockHeaders m
=> Int
-> BlockNode
-> m [BlockNode]
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"
validCP :: Network
-> BlockHeight
-> BlockHash
-> 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
afterLastCP :: Network
-> BlockHeight
-> BlockHeight
-> 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]
bip34 :: Network
-> BlockHeight
-> BlockHash
-> 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
validVersion :: Network
-> BlockHeight
-> Word32
-> 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
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
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
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"
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)
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
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
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'
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
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
calcNextWork :: Network
-> BlockHeader
-> Timestamp
-> 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)
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
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
headerWork :: BlockHeader -> Integer
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
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
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
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'
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
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
]
appendBlocks ::
Network
-> Word32
-> 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
, 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
}
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
genesisBlock :: Network -> Block
genesisBlock :: Network -> Block
genesisBlock net :: Network
net = BlockHeader -> [Tx] -> Block
Block (Network -> BlockHeader
getGenesisHeader Network
net) [Tx
genesisTx]
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