module Bitcoin.BlockChain.Chain where
import Data.Array
import Data.Word
import Data.Ord
import Data.List ( sort , group , unfoldr , maximumBy , foldl' )
import Data.Maybe
import Data.Set (Set) ; import qualified Data.Set as Set
import Data.Map (Map) ; import qualified Data.Map as Map
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Binary.Get
import Data.Binary.Put
import System.Mem ( performGC )
import Bitcoin.BlockChain.Base
import Bitcoin.BlockChain.Parser
import Bitcoin.BlockChain.Load
import Bitcoin.BlockChain.Checkpoint
import Bitcoin.Script.Base
import Bitcoin.Protocol.Hash
import Bitcoin.Protocol.Difficulty
data Chain = Chain
{ _chainPrev :: Maybe Chain
, _chainHeader :: !BlockHeader
, _chainLocation :: !BlockLocation
, _chainHeight :: !Int
, _chainTotalDiff :: !Double
}
deriving (Eq,Show)
instance Ord Chain where
compare ch1 ch2 = compare (chainBlockHash ch1) (chainBlockHash ch2)
chainBlockHash :: Chain -> Hash256
chainBlockHash = _blkBlockHash . _chainHeader
chainPrevHash :: Chain -> Hash256
chainPrevHash = _blkPrevBlock . _chainHeader
data ChainTable = ChainTable
{ _tablePrev :: !(Map Hash256 Hash256)
, _tableNext :: !(Map Hash256 [Hash256])
, _tableBlock :: !(Map Hash256 Chain)
, _tableHeight :: !(Map Hash256 Int)
, _tableLongest :: !(Array Int Chain)
}
deriving Show
buildChainTable :: IO ChainTable
buildChainTable = blockDirectory >>= buildChainTable'
buildChainTable' :: FilePath -> IO ChainTable
buildChainTable' dir = do
fnames <- blockFiles dir
pre_chains <- liftM concat $ forM fnames $ \fn -> do
raw <- L.readFile fn
let blockheaders = runGet getBlockHeadersOnly raw
return [ Chain Nothing hdr (BlockLocation fn pos) 0 0 | (!pos,!hdr) <- blockheaders ]
let pre_table = Map.fromList
[ c `seq` this `seq` (this, c)
| c <- pre_chains
, let this = chainBlockHash c
]
let prevtable :: Map Hash256 Hash256
prevtable = Map.fromList
[ prev `seq` this `seq` (this,prev)
| chain <- pre_chains
, let this = chainBlockHash chain
, let prev = chainPrevHash chain
]
let nexttable :: Map Hash256 [Hash256]
nexttable = buildMap (:[]) (:)
[ this `seq` prev `seq` (prev,this)
| chain <- pre_chains
, let this = chainBlockHash chain
, let prev = chainPrevHash chain
]
let chainWorker :: Int -> Map Hash256 Chain -> [Chain] -> Map Hash256 Chain
chainWorker !height !table ![] = table
chainWorker !height !table !active = forceList_ active `seq` chainWorker height' table' active' where
height' = height + 1
table' = foldl' add table active
active' = concatMap h active
h !c = let almosth = Map.findWithDefault [] (chainBlockHash c) nexttable :: [Hash256]
almostc = map (\h -> fromJust $ Map.lookup h pre_table) almosth
in map ( \d -> d { _chainHeight = height'
, _chainPrev = Just c
, _chainTotalDiff = _chainTotalDiff c + decimalDifficulty (_blkDifficulty (_chainHeader d))
} ) almostc
add !old !chain = Map.insert (chainBlockHash chain) chain old
let genesis :: Chain
genesis = case Map.lookup zeroHash256 nexttable of
Just [h] -> if h == theGenesisBlock
then let c0 = fromJust $ Map.lookup h pre_table
in c0 { _chainTotalDiff = decimalDifficulty (_blkDifficulty (_chainHeader c0)) }
else error "buildChainTables': genesis block hash does not match"
Just [] -> error "buildChainTables'/genesis: shouldn't happen"
Nothing -> error "buildChainTables'/genesis: no genesis block candidate found"
Just _ -> error "buildChainTables'/genesis: more than one genesis block candidate found"
let fulltable = chainWorker 0 (Map.singleton (chainBlockHash genesis) genesis) [genesis]
let findLongestChain :: [Chain] -> Chain
findLongestChain active =
forceList_ active `seq` if all isLeft active'
then maximumBy (comparing _chainTotalDiff) (map fromLeft active')
else findLongestChain (concatMap ei active')
where
active' :: [Either Chain [Chain]]
active' = map worker active
worker :: Chain -> Either Chain [Chain]
worker !ch = case Map.lookup (chainBlockHash ch) nexttable of
Nothing -> Left ch
Just [] -> error "buildChainTables'/longestChain: shouldn't happen"
Just hs -> Right $ map (\h -> fromJust (Map.lookup h fulltable)) hs
ei (Left !x ) = [x]
ei (Right !ys) = ys
isLeft (Left _) = True
isLeft _ = False
fromLeft (Left !x) = x
fromLeft _ = error "buildChainTables'/longestChain/fromLeft: Right"
let longest_head = findLongestChain [genesis]
longest_list = (longest_head : unfoldr' f longest_head) where
f !c = case _chainPrev c of
Just !c' -> Just (c',c')
Nothing -> Nothing
longest_lkp = Map.fromList
[ height `seq` this `seq` (this,height)
| c <- longest_list
, let this = chainBlockHash c
, let height = _chainHeight c
]
longest_arr = array (0, _chainHeight longest_head)
[ c `seq` height `seq` (height, c)
| c <- longest_list
, let height = _chainHeight c
]
let final = (Map.size prevtable) `seq`
(Map.size nexttable) `seq`
(Map.size fulltable) `seq`
(Map.size longest_lkp) `seq`
longest_arr `seq`
ChainTable prevtable nexttable fulltable longest_lkp longest_arr
final `seq` System.Mem.performGC `seq` (return final)
forAllBlocks_ :: ChainTable -> (Int -> Block (Tx RawScript RawScript) -> IO ()) -> IO ()
forAllBlocks_ chTable userAction = do
let (a,b) = bounds (_tableLongest chTable)
forM_ [a..b] $ \(!blkIdx) -> do
block <- loadBlockAt $! _chainLocation (_tableLongest chTable ! blkIdx)
block `seq` userAction blkIdx block
forAllBlocks :: ChainTable -> (Int -> Block (Tx RawScript RawScript) -> IO a) -> IO [a]
forAllBlocks chTable userAction = do
let (a,b) = bounds (_tableLongest chTable)
forM [a..b] $ \(!blkIdx) -> do
block <- loadBlockAt $! _chainLocation (_tableLongest chTable ! blkIdx)
block `seq` userAction blkIdx block
buildMap :: Ord k => (b -> a) -> (b -> a -> a) -> [(k,b)] -> Map k a
buildMap f g xs = foldl worker Map.empty xs where
worker old (k,y) = Map.alter h k old where
h mb = case mb of
Nothing -> Just (f y)
Just x -> Just (g y x)
sortNub :: Ord a => [a] -> [a]
sortNub = map head . group . sort
setNub :: Ord a => [a] -> [a]
setNub xs = Set.toList (go Set.empty xs) where
go !old [] = old
go !old (x:xs) = go (Set.insert x old) xs
forceList_ :: [a] -> ()
forceList_ (x:xs) = x `seq` forceList_ xs
forceList_ [] = ()
unfoldr' :: (b -> Maybe (a, b)) -> b -> [a]
unfoldr' f = go where
go !b = case f b of
Just (!a,!b') -> a : go b'
Nothing -> []