haskoin-store 0.6.0 → 0.6.1
raw patch · 3 files changed
+190/−68 lines, 3 files
Files
- CHANGELOG.md +5/−0
- haskoin-store.cabal +2/−2
- src/Network/Haskoin/Store/Logic.hs +183/−66
CHANGELOG.md view
@@ -4,6 +4,11 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.6.1+### Changed+- Compatibility with Bitcoin Cash hard fork.+- Various bug fixes.+ ## 0.6.0 ### Added - Address balance cache in memory.
haskoin-store.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 922627e06c3369774ef7b05e763944bc0e2305abe21a0ff6628093fcfe5a2ccb+-- hash: 000d7faccd7304a6bb84be2d645f5a137ec8ab18d40df450dbf1cab072c2d93e name: haskoin-store-version: 0.6.0+version: 0.6.1 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network
src/Network/Haskoin/Store/Logic.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-} module Network.Haskoin.Store.Logic where import Conduit@@ -33,6 +34,7 @@ | OrphanTx !TxHash | TxNotFound !TxHash | NoUnspent !OutPoint+ | TxInvalidOp !TxHash | TxDeleted !TxHash | TxDoubleSpend !TxHash | AlreadyUnspent !OutPoint@@ -101,10 +103,10 @@ orp <- any isNothing <$> mapM (getTxData i . outPointHash . prevOutput) (txIn tx)- when orp $- $(logErrorS) "BlockLogic" $- "Transaction is orphan: " <> txHashToHex (txHash tx)- unless orp f+ if orp+ then $(logErrorS) "BlockLogic" $+ "Transaction is orphan: " <> txHashToHex (txHash tx)+ else f f = do us <- forM (txIn tx) $ \TxIn {prevOutput = op} -> do@@ -231,24 +233,19 @@ } insertAtHeight i (headerHash (nodeHeader n)) (nodeHeight n) setBest i (headerHash (nodeHeader n))- txs <- concat <$> mapM (getRecursiveTx i . txHash) (tail (blockTxns b))- mapM_ (deleteTx net i False . txHash . transactionData) (reverse txs)- zipWithM_ (\x t -> importTx net i (br x) t) [0 ..] (blockTxns b)- forM_ txs $ \tr -> do- let tx = transactionData tr- th = txHash tx- when (th `notElem` hs) $- case transactionBlock tr of- MemRef t -> newMempoolTx net i tx t- BlockRef {} -> do- $(logErrorS) "BlockLogic" $- "Expected mempool transaction but found confirmed: " <>- txHashToHex (txHash tx)- throwError (TxConfirmed (txHash tx))+ zipWithM_ (\x t -> importTx net i (br x) t) [0 ..] (sortTxs (blockTxns b)) where- hs = map txHash (blockTxns b) br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos} +sortTxs :: [Tx] -> [Tx]+sortTxs [] = []+sortTxs txs = is <> sortTxs ds+ where+ (is, ds) =+ partition+ (all ((`notElem` map txHash txs) . outPointHash . prevOutput) . txIn)+ txs+ importTx :: ( MonadError ImportException m , StoreRead i m@@ -269,40 +266,53 @@ $(logErrorS) "BlockLogic" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwError (DuplicatePrevOutput (txHash tx))- us <-- if iscb- then return []- else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op when (iscb && not (confirmed br)) $ do $(logErrorS) "BlockLogic" $ "Attempting to import coinbase to the mempool: " <> txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHash tx))- unless iscb $ do- when (sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do- $(logErrorS) "BlockLogic" $- "Insufficient funds: " <> txHashToHex (txHash tx)- throwError (InsufficientFunds th)- zipWithM_ (spendOutput net i br (txHash tx)) [0 ..] us- zipWithM_ (newOutput net i br . OutPoint (txHash tx)) [0 ..] (txOut tx)- rbf <- getrbf- let (d, _) =- fromTransaction- Transaction- { transactionBlock = br- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionInputs =- if iscb- then zipWith mkcb (txIn tx) ws- else zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = False- , transactionRBF = rbf- }- insertTx i d- unless (confirmed br) $- insertMempoolTx i (txHash tx) (memRefTime br)+ -- If unspent is nothing this transaction exists already+ us <-+ fromMaybe [] . sequence <$>+ if iscb+ then return []+ else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op+ when+ (not (confirmed br) &&+ sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do+ $(logErrorS) "BlockLogic" $+ "Insufficient funds: " <> txHashToHex (txHash tx)+ throwError (InsufficientFunds th)+ zipWithM_ (spendOutput net i br (txHash tx)) [0 ..] us+ if | iscb || not (null us) ->+ do zipWithM_+ (newOutput net i br . OutPoint (txHash tx))+ [0 ..]+ (txOut tx)+ rbf <- getrbf+ let (d, _) =+ fromTransaction+ Transaction+ { transactionBlock = br+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs =+ if iscb+ then zipWith mkcb (txIn tx) ws+ else zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = False+ , transactionRBF = rbf+ }+ insertTx i d+ unless (confirmed br) $+ insertMempoolTx i (txHash tx) (memRefTime br)+ | null us && confirmed br -> confirmTx net i br tx+ | otherwise ->+ do $(logErrorS) "BlockLogic" $+ "Invalid operation required for transaction: " <>+ txHashToHex (txHash tx)+ throwError (TxInvalidOp (txHash tx)) where uns op = getUnspent i op >>= \case@@ -321,25 +331,27 @@ " " <> fromString (show (outPointIndex op)) throwError (OrphanTx (txHash tx))- Just s -> do- $(logWarnS) "BlockLogic" $- "Deleting conflicting transaction: " <>- txHashToHex (spenderHash s)- deleteTx net i True (spenderHash s)- getUnspent i op >>= \case- Nothing -> do- $(logErrorS) "BlockLogic" $- "Transaction double-spend detected: " <>- txHashToHex (txHash tx)- throwError (TxDoubleSpend (txHash tx))- Just u -> return u+ Just s+ | spenderHash s == txHash tx -> return Nothing+ | otherwise -> do+ $(logWarnS) "BlockLogic" $+ "Deleting conflicting transaction: " <>+ txHashToHex (spenderHash s)+ deleteTx net i True (spenderHash s)+ getUnspent i op >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Transaction double-spend detected: " <>+ txHashToHex (txHash tx)+ throwError (TxDoubleSpend (txHash tx))+ Just u -> return $ Just u | otherwise -> do $(logErrorS) "BlockLogic" $ "No unspent output: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op)) throwError (NoUnspent op)- Just u -> return u+ Just u -> return $ Just u th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) ws = map Just (txWitness tx) <> repeat Nothing@@ -379,6 +391,102 @@ , outputSpender = Nothing } +confirmTx ::+ ( MonadError ImportException m+ , StoreRead i m+ , StoreWrite i m+ , BalanceRead i m+ , BalanceWrite i m+ , UnspentRead i m+ , UnspentWrite i m+ , MonadLogger m+ )+ => Network+ -> i+ -> BlockRef+ -> Tx+ -> m ()+confirmTx net i br tx =+ getTxData i (txHash tx) >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Transaction not found: " <> txHashToHex (txHash tx)+ throwError (TxNotFound (txHash tx))+ Just t -> do+ forM_ (txDataPrevs t) $ \p ->+ case scriptToAddressBS (prevScript p) of+ Left _ -> return ()+ Right a -> do+ removeAddrTx+ i+ AddressTx+ { addressTxAddress = a+ , addressTxBlock = txDataBlock t+ , addressTxHash = txHash tx+ }+ insertAddrTx+ i+ AddressTx+ { addressTxAddress = a+ , addressTxBlock = br+ , addressTxHash = txHash tx+ }+ forM_ (zip [0 ..] (txOut tx)) $ \(n, o) -> do+ let op = OutPoint (txHash tx) n+ s <- getSpender i (OutPoint (txHash tx) n)+ when (isNothing s) $ do+ delUnspent i op+ addUnspent+ i+ Unspent+ { unspentBlock = br+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort (scriptOutput o)+ }+ case scriptToAddressBS (scriptOutput o) of+ Left _ -> return ()+ Right a -> do+ removeAddrTx+ i+ AddressTx+ { addressTxAddress = a+ , addressTxBlock = txDataBlock t+ , addressTxHash = txHash tx+ }+ insertAddrTx+ i+ AddressTx+ { addressTxAddress = a+ , addressTxBlock = br+ , addressTxHash = txHash tx+ }+ when (isNothing s) $ do+ removeAddrUnspent+ i+ a+ Unspent+ { unspentBlock = txDataBlock t+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript =+ B.Short.toShort (scriptOutput o)+ }+ insertAddrUnspent+ i+ a+ Unspent+ { unspentBlock = br+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript =+ B.Short.toShort (scriptOutput o)+ }+ reduceBalance net i False a (outValue o)+ increaseBalance net i True a (outValue o)+ insertTx i t {txDataBlock = br}+ deleteMempoolTx i (txHash tx) (memRefTime (txDataBlock t))+ getRecursiveTx :: (Monad m, StoreRead i m, MonadLogger m) => i -> TxHash -> m [Transaction] getRecursiveTx i th =@@ -415,7 +523,7 @@ throwError (TxNotFound h) Just t | txDataDeleted t -> do- $(logErrorS) "BlockLogic" $+ $(logWarnS) "BlockLogic" $ "Transaction already deleted: " <> txHashToHex h return () | mo && confirmed (txDataBlock t) -> do@@ -427,10 +535,10 @@ go t = do ss <- nub . map spenderHash . I.elems <$> getSpenders i h mapM_ (deleteTx net i True) ss- let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ (unspendOutput net i) ps forM_ (take (length (txOut (txData t))) [0 ..]) $ \n -> delOutput net i (OutPoint h n)+ let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))+ mapM_ (unspendOutput net i) ps unless (confirmed (txDataBlock t)) $ deleteMempoolTx i h (memRefTime (txDataBlock t)) insertTx i t {txDataDeleted = True}@@ -733,9 +841,18 @@ (v > if c then balanceAmount b- else balanceZero b) $+ else balanceZero b) $ do $(logErrorS) "BlockLogic" $- "Insufficient balance: " <> addrToString net a+ "Insufficient " <>+ (if c+ then "confirmed "+ else "unconfirmed ") <>+ "balance: " <>+ addrToString net a+ throwError $+ if c+ then InsufficientBalance a+ else InsufficientZeroBalance a setBalance i $ b { balanceAmount =