module Bitcoin.BlockChain.TxLookup where
import Control.Monad
import Data.Bits
import Data.Word
import Data.List ( find )
import Data.Maybe
import Foreign
import System.IO.Unsafe as Unsafe
import GHC.Prim
import GHC.Exts
import GHC.Int
import Data.Array
import Data.Array.IO
import Data.Array.MArray
import Data.Array.Unsafe
import Control.DeepSeq
import Bitcoin.Protocol.Hash
import Bitcoin.BlockChain.Base
import Bitcoin.BlockChain.Load
import Bitcoin.BlockChain.Chain
import Bitcoin.BlockChain.Tx
import Bitcoin.Script.Base
import Bitcoin.Script.Run ( checkTransaction )
toWord# :: Int -> Word#
toWord# !(I# i) = int2Word# i
fromWord# :: Word# -> Int
fromWord# w = I# (word2Int# w)
data CompactList
= NilList
| OneList !Word#
| TwoList !Word# !Word#
| ThrList !Word# !Word# !Word#
| FouList !Word# !Word# !Word# !Word#
| GenList !IndexList
instance NFData CompactList where
rnf cl = case cl of
NilList -> ()
OneList _ -> ()
TwoList _ _ -> ()
ThrList _ _ _ -> ()
FouList _ _ _ _ -> ()
GenList il -> rnf il
toCompactList :: [Int] -> CompactList
toCompactList xs = case xs of
[] -> NilList
[x] -> OneList (toWord# x)
[x,y] -> TwoList (toWord# x) (toWord# y)
[x,y,z] -> ThrList (toWord# x) (toWord# y) (toWord# z)
[x,y,z,w] -> FouList (toWord# x) (toWord# y) (toWord# z) (toWord# w)
_ -> GenList (toIndexList xs)
fromCompactList :: CompactList -> [Int]
fromCompactList cl = case cl of
NilList -> []
OneList u -> [ fromWord# u ]
TwoList u v -> [ fromWord# u , fromWord# v ]
ThrList u v w -> [ fromWord# u , fromWord# v , fromWord# w ]
FouList u v w z -> [ fromWord# u , fromWord# v , fromWord# w , fromWord# z ]
GenList il -> fromIndexList il
consCompactList :: Int -> CompactList -> CompactList
consCompactList x rest = case rest of
NilList -> OneList (toWord# x)
OneList y -> TwoList (toWord# x) y
TwoList y z -> ThrList (toWord# x) y z
ThrList y z w -> FouList (toWord# x) y z w
FouList {} -> GenList $ toIndexList $ (x:) $ fromCompactList rest
GenList il -> GenList $ consIndexList x il
data IndexList = IndexList !Word# IndexList
instance NFData IndexList where
rnf (IndexList !w rest) = (if not (isNullIndexList rest) then rnf rest else ()) `seq` ()
intToBool# :: Int# -> Bool
intToBool# i = case i of
0# -> False
_ -> True
nullIndexList :: IndexList
nullIndexList = IndexList (int2Word# 0xffffffff#) nullIndexList
isNullIndexList :: IndexList -> Bool
isNullIndexList (IndexList w _) = intToBool# (w `eqWord#` (int2Word# 0xffffffff#))
isSingletonIndexList :: IndexList -> Bool
isSingletonIndexList (IndexList w _) = not $ intToBool# ((w `and#` (int2Word# 0x80000000#)) `eqWord#` (int2Word# 0#))
consIndexList :: Int -> IndexList -> IndexList
consIndexList x rest =
if isNullIndexList rest
then IndexList (w0 `or#` (int2Word# 0x80000000#)) rest
else IndexList w0 rest
where
!(W# w0) = fromIntegral x
toIndexList :: [Int] -> IndexList
toIndexList = go where
go (x : xs) = IndexList w (go xs) where
!w = (w0 `or#` (if null xs then (int2Word# 0x80000000#) else (int2Word# 0#)))
!(W# w0) = fromIntegral x
go [] = nullIndexList
fromIndexList :: IndexList -> [Int]
fromIndexList il@(IndexList !w rest) =
if isNullIndexList il
then []
else go il
where
go (IndexList w rest) = if intToBool# ((w `and#` (int2Word# 0x80000000#)) `eqWord#` (int2Word# 0#))
then (fromIntegral $ W# (w )) : go rest
else (fromIntegral $ W# (w `and#` (int2Word# 0x7fffffff#))) : []
newtype TxLookup = TxLookup (IOArray Word32 CompactList)
newEmptyTxLookup :: IO TxLookup
newEmptyTxLookup = do
arr <- Data.Array.MArray.newArray (0,0xffffff) NilList
return $ TxLookup arr
insertIntoTxLookup' :: Word32 -> Int -> TxLookup -> IO ()
insertIntoTxLookup' !key_ !value (TxLookup !arr) = do
let !key = key_ .&. 0x00ffffff
!old <- readArray arr key
unless (elem value $ fromCompactList old) $ writeArray arr key $! consCompactList value old
return ()
txLookupList' :: Word32 -> TxLookup -> IO [Int]
txLookupList' key_ (TxLookup arr) = do
let key = key_ .&. 0x00ffffff
list <- readArray arr key
return $ fromCompactList list
first24Bits :: Hash256 -> Word32
first24Bits (Hash256 !w1 _ _ _) = fromIntegral (w1 .&. 0xffffff)
insertIntoTxLookup :: Hash256 -> Int -> TxLookup -> IO ()
insertIntoTxLookup !hash !blockidx !table = insertIntoTxLookup' (first24Bits hash) blockidx table
txLookupList :: Hash256 -> TxLookup -> IO [Int]
txLookupList !hash !table = txLookupList' (first24Bits hash) table
buildTxLookupTable :: ChainTable -> IO TxLookup
buildTxLookupTable chTable = do
txlkptable <- newEmptyTxLookup
let (a,b) = bounds (_tableLongest chTable)
forM_ [a..b] $ \(!blkIdx) -> do
block <- loadBlockAt $! _chainLocation (_tableLongest chTable ! blkIdx)
let txs = _blockTxs block
forM_ txs $ \(!tx) -> insertIntoTxLookup (_txHash tx) blkIdx txlkptable
return txlkptable
txLookup :: ChainTable -> TxLookup -> Hash256 -> IO (Maybe (Int, Tx RawScript RawScript))
txLookup chTable txTable hash = do
possible <- txLookupList hash txTable
results <- forM possible $ \blkIdx -> do
let loc = _chainLocation (_tableLongest chTable ! blkIdx)
block <- loadBlockAt loc
let txs = _blockTxs block
return $ case find (\tx -> hash == _txHash tx) txs of
Nothing -> Nothing
Just tx -> Just (blkIdx,tx)
case catMaybes results of
[] -> return $ Nothing
[!tx] -> return $ Just tx
_ -> error "txLookup: fatal error, multiple transactions found in with the same hash"
txLookup_ :: ChainTable -> TxLookup -> Hash256 -> IO (Maybe (Tx RawScript RawScript))
txLookup_ cht txt = liftM (liftM snd) . txLookup cht txt
loadPrevTxs :: ChainTable -> TxLookup -> Tx a b -> IO (Tx (Tx RawScript RawScript, a) b)
loadPrevTxs chTable txTable oldTx =
do
newInputs <- mapM worker (_txInputs oldTx)
return $! oldTx { _txInputs = newInputs }
where
lkp = txLookup_ chTable txTable
worker inp@(TxInput prevhash previdx script seqno) = do
mbprevtx <- lkp prevhash
let !prevtx = case mbprevtx of
Just tx -> tx
Nothing -> error $ "loadPrevTxs: fatal error: previous tx not found; hash = " ++ show prevhash
return $! inp { _txInScript = (prevtx,script) }
checkTx :: ChainTable -> TxLookup -> Tx RawScript RawScript -> IO (Either String Bool)
checkTx chTable txTable tx =
case (isCoinBaseTx tx) of
True -> return (Right True)
False -> do
txExt <- loadPrevTxs chTable txTable tx
return $ checkTransaction txExt
checkTxByHash :: ChainTable -> TxLookup -> Hash256 -> IO (Either String Bool)
checkTxByHash chTable txTable txid = do
mbtx <- txLookup_ chTable txTable txid
case mbtx of
Nothing -> error $ "checkTxByHash: tx not found (hash = " ++ show txid ++ ")"
Just tx -> checkTx chTable txTable tx