diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs --- a/src/Network/Haskoin/Store/Logic.hs +++ b/src/Network/Haskoin/Store/Logic.hs @@ -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 =