Logic.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Haskoin.Store.Logic
  ( ImportException (..),
    MonadImport,
    initBest,
    revertBlock,
    importBlock,
    newMempoolTx,
    deleteUnconfirmedTx,
  )
where

import Control.Monad
  ( forM,
    forM_,
    guard,
    unless,
    void,
    when,
    zipWithM_,
    (<=<),
  )
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Logger
  ( MonadLoggerIO (..),
    logDebugS,
    logErrorS,
  )
import qualified Data.ByteString as B
import Data.Either (rights)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.IntMap.Strict as I
import Data.List (nub)
import Data.Maybe
  ( catMaybes,
    fromMaybe,
    isJust,
    isNothing,
  )
import Data.Serialize (encode)
import Data.String.Conversions (cs)
import Data.Word (Word32, Word64)
import Haskoin
  ( Address,
    Block (..),
    BlockHash,
    BlockHeader (..),
    BlockNode (..),
    Network (..),
    OutPoint (..),
    Tx (..),
    TxHash,
    TxIn (..),
    TxOut (..),
    blockHashToHex,
    computeSubsidy,
    eitherToMaybe,
    genesisBlock,
    genesisNode,
    headerHash,
    isGenesis,
    nullOutPoint,
    scriptToAddressBS,
    txHash,
    txHashToHex,
  )
import Haskoin.Store.Common
import Haskoin.Store.Data
  ( Balance (..),
    BlockData (..),
    BlockRef (..),
    Prev (..),
    Spender (..),
    TxData (..),
    TxRef (..),
    UnixTime,
    Unspent (..),
    confirmed,
  )
import UnliftIO (Exception)

type MonadImport m =
  ( MonadError ImportException m,
    MonadLoggerIO m,
    StoreReadBase m,
    StoreWrite m
  )

data ImportException
  = PrevBlockNotBest
  | Orphan
  | UnexpectedCoinbase
  | BestBlockNotFound
  | BlockNotBest
  | TxNotFound
  | DoubleSpend
  | TxConfirmed
  | InsufficientFunds
  | DuplicatePrevOutput
  | TxSpent
  deriving (Eq, Ord, Exception)

instance Show ImportException where
  show PrevBlockNotBest = "Previous block not best"
  show Orphan = "Orphan"
  show UnexpectedCoinbase = "Unexpected coinbase"
  show BestBlockNotFound = "Best block not found"
  show BlockNotBest = "Block not best"
  show TxNotFound = "Transaction not found"
  show DoubleSpend = "Double spend"
  show TxConfirmed = "Transaction confirmed"
  show InsufficientFunds = "Insufficient funds"
  show DuplicatePrevOutput = "Duplicate previous output"
  show TxSpent = "Transaction is spent"

initBest :: MonadImport m => m ()
initBest = do
  $(logDebugS) "BlockStore" "Initializing best block"
  net <- getNetwork
  m <- getBestBlock
  when (isNothing m) . void $ do
    $(logDebugS) "BlockStore" "Importing Genesis block"
    importBlock (genesisBlock net) (genesisNode net)

newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx tx w =
  getActiveTxData (txHash tx) >>= \case
    Just _ ->
      return False
    Nothing -> do
      freeOutputs True True tx
      rbf <- isRBF (MemRef w) tx
      checkNewTx tx
      importTx (MemRef w) w rbf tx
      return True

bestBlockData :: MonadImport m => m BlockData
bestBlockData = do
  h <-
    getBestBlock >>= \case
      Nothing -> do
        $(logErrorS) "BlockStore" "Best block unknown"
        throwError BestBlockNotFound
      Just h -> return h
  getBlock h >>= \case
    Nothing -> do
      $(logErrorS) "BlockStore" "Best block not found"
      throwError BestBlockNotFound
    Just b -> return b

revertBlock :: MonadImport m => BlockHash -> m ()
revertBlock bh = do
  bd <-
    bestBlockData >>= \b ->
      if headerHash (blockDataHeader b) == bh
        then return b
        else do
          $(logErrorS) "BlockStore" $
            "Cannot revert non-head block: " <> blockHashToHex bh
          throwError BlockNotBest
  $(logDebugS) "BlockStore" $
    "Obtained block data for " <> blockHashToHex bh
  tds <- mapM getImportTxData (blockDataTxs bd)
  $(logDebugS) "BlockStore" $
    "Obtained import tx data for block " <> blockHashToHex bh
  setBest (prevBlock (blockDataHeader bd))
  $(logDebugS) "BlockStore" $
    "Set parent as best block "
      <> blockHashToHex (prevBlock (blockDataHeader bd))
  insertBlock bd {blockDataMainChain = False}
  $(logDebugS) "BlockStore" $
    "Updated as not in main chain: " <> blockHashToHex bh
  forM_ (tail tds) unConfirmTx
  $(logDebugS) "BlockStore" $
    "Unconfirmed " <> cs (show (length tds)) <> " transactions"
  deleteConfirmedTx (txHash (txData (head tds)))
  $(logDebugS) "BlockStore" $
    "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds)))

checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()
checkNewBlock b n =
  getBestBlock >>= \case
    Nothing
      | isGenesis n -> return ()
      | otherwise -> do
        $(logErrorS) "BlockStore" $
          "Cannot import non-genesis block: "
            <> blockHashToHex (headerHash (blockHeader b))
        throwError BestBlockNotFound
    Just h
      | prevBlock (blockHeader b) == h -> return ()
      | otherwise -> do
        $(logErrorS) "BlockStore" $
          "Block does not build on head: "
            <> blockHashToHex (headerHash (blockHeader b))
        throwError PrevBlockNotBest

importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m ()
importOrConfirm bn txns = do
  mapM_ (freeOutputs True False . snd) (reverse txs)
  mapM_ (uncurry action) txs
  where
    txs = sortTxs txns
    br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}
    bn_time = fromIntegral . blockTimestamp $ nodeHeader bn
    action i tx =
      testPresent tx >>= \case
        False -> import_it i tx
        True -> confirm_it i tx
    confirm_it i tx =
      getActiveTxData (txHash tx) >>= \case
        Just t -> do
          $(logDebugS) "BlockStore" $
            "Confirming tx: "
              <> txHashToHex (txHash tx)
          confirmTx t (br i)
          return Nothing
        Nothing -> do
          $(logErrorS) "BlockStore" $
            "Cannot find tx to confirm: "
              <> txHashToHex (txHash tx)
          throwError TxNotFound
    import_it i tx = do
      $(logDebugS) "BlockStore" $
        "Importing tx: " <> txHashToHex (txHash tx)
      importTx (br i) bn_time False tx
      return Nothing

importBlock :: MonadImport m => Block -> BlockNode -> m ()
importBlock b n = do
  $(logDebugS) "BlockStore" $
    "Checking new block: "
      <> blockHashToHex (headerHash (nodeHeader n))
  checkNewBlock b n
  $(logDebugS) "BlockStore" "Passed check"
  net <- getNetwork
  let subsidy = computeSubsidy net (nodeHeight n)
  bs <- getBlocksAtHeight (nodeHeight n)
  $(logDebugS) "BlockStore" $
    "Inserting block entries for: "
      <> blockHashToHex (headerHash (nodeHeader n))
  insertBlock
    BlockData
      { blockDataHeight = nodeHeight n,
        blockDataMainChain = True,
        blockDataWork = nodeWork n,
        blockDataHeader = nodeHeader n,
        blockDataSize = fromIntegral (B.length (encode b)),
        blockDataTxs = map txHash (blockTxns b),
        blockDataWeight = if getSegWit net then w else 0,
        blockDataSubsidy = subsidy,
        blockDataFees = cb_out_val - subsidy,
        blockDataOutputs = ts_out_val
      }
  setBlocksAtHeight
    (nub (headerHash (nodeHeader n) : bs))
    (nodeHeight n)
  setBest (headerHash (nodeHeader n))
  importOrConfirm n (blockTxns b)
  $(logDebugS) "BlockStore" $
    "Finished importing transactions for: "
      <> blockHashToHex (headerHash (nodeHeader n))
  where
    cb_out_val =
      sum $ map outValue $ txOut $ head $ blockTxns b
    ts_out_val =
      sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b
    w =
      let f t = t {txWitness = []}
          b' = b {blockTxns = map f (blockTxns b)}
          x = B.length (encode b)
          s = B.length (encode b')
       in fromIntegral $ s * 3 + x

checkNewTx :: MonadImport m => Tx -> m ()
checkNewTx tx = do
  when (unique_inputs < length (txIn tx)) $ do
    $(logErrorS) "BlockStore" $
      "Transaction spends same output twice: "
        <> txHashToHex (txHash tx)
    throwError DuplicatePrevOutput
  us <- getUnspentOutputs tx
  when (any isNothing us) $ do
    $(logErrorS) "BlockStore" $
      "Orphan: " <> txHashToHex (txHash tx)
    throwError Orphan
  when (isCoinbase tx) $ do
    $(logErrorS) "BlockStore" $
      "Coinbase cannot be imported into mempool: "
        <> txHashToHex (txHash tx)
    throwError UnexpectedCoinbase
  when (length (prevOuts tx) > length us) $ do
    $(logErrorS) "BlockStore" $
      "Orphan: " <> txHashToHex (txHash tx)
    throwError Orphan
  when (outputs > unspents us) $ do
    $(logErrorS) "BlockStore" $
      "Insufficient funds for tx: " <> txHashToHex (txHash tx)
    throwError InsufficientFunds
  where
    unspents = sum . map unspentAmount . catMaybes
    outputs = sum (map outValue (txOut tx))
    unique_inputs = length (nub' (map prevOutput (txIn tx)))

getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs tx = mapM getUnspent (prevOuts tx)

prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData
prepareTxData rbf br tt tx us =
  TxData
    { txDataBlock = br,
      txData = tx,
      txDataPrevs = ps,
      txDataDeleted = False,
      txDataRBF = rbf,
      txDataTime = tt
    }
  where
    mkprv u = Prev (unspentScript u) (unspentAmount u)
    ps = I.fromList $ zip [0 ..] $ map mkprv us

importTx ::
  MonadImport m =>
  BlockRef ->
  -- | unix time
  Word64 ->
  -- | RBF
  Bool ->
  Tx ->
  m ()
importTx br tt rbf tx = do
  mus <- getUnspentOutputs tx
  us <- forM mus $ \case
    Nothing -> do
      $(logErrorS) "BlockStore" $
        "Attempted to import a tx missing UTXO: "
          <> txHashToHex (txHash tx)
      throwError Orphan
    Just u -> return u
  let td = prepareTxData rbf br tt tx us
  commitAddTx td

unConfirmTx :: MonadImport m => TxData -> m ()
unConfirmTx t = confTx t Nothing

confirmTx :: MonadImport m => TxData -> BlockRef -> m ()
confirmTx t br = confTx t (Just br)

replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx t new = forM_ (txDataAddresses t) $ \a -> do
  deleteAddrTx
    a
    TxRef
      { txRefBlock = txDataBlock t,
        txRefHash = txHash (txData t)
      }
  insertAddrTx
    a
    TxRef
      { txRefBlock = new,
        txRefHash = txHash (txData t)
      }

adjustAddressOutput ::
  MonadImport m =>
  OutPoint ->
  TxOut ->
  BlockRef ->
  BlockRef ->
  m ()
adjustAddressOutput op o old new = do
  let pk = scriptOutput o
  getUnspent op >>= \case
    Nothing -> return ()
    Just u -> do
      unless (unspentBlock u == old) $
        error $ "Existing unspent block bad for output: " <> show op
      replace_unspent pk
  where
    replace_unspent pk = do
      let ma = eitherToMaybe (scriptToAddressBS pk)
      deleteUnspent op
      insertUnspent
        Unspent
          { unspentBlock = new,
            unspentPoint = op,
            unspentAmount = outValue o,
            unspentScript = pk,
            unspentAddress = ma
          }
      forM_ ma $ replace_addr_unspent pk
    replace_addr_unspent pk a = do
      deleteAddrUnspent
        a
        Unspent
          { unspentBlock = old,
            unspentPoint = op,
            unspentAmount = outValue o,
            unspentScript = pk,
            unspentAddress = Just a
          }
      insertAddrUnspent
        a
        Unspent
          { unspentBlock = new,
            unspentPoint = op,
            unspentAmount = outValue o,
            unspentScript = pk,
            unspentAddress = Just a
          }
      decreaseBalance (confirmed old) a (outValue o)
      increaseBalance (confirmed new) a (outValue o)

confTx :: MonadImport m => TxData -> Maybe BlockRef -> m ()
confTx t mbr = do
  replaceAddressTx t new
  forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do
    let op = OutPoint (txHash (txData t)) n
    adjustAddressOutput op o old new
  rbf <- isRBF new (txData t)
  let td = t {txDataBlock = new, txDataRBF = rbf}
  insertTx td
  updateMempool td
  where
    new = fromMaybe (MemRef (txDataTime t)) mbr
    old = txDataBlock t

freeOutputs ::
  MonadImport m =>
  -- | only delete transaction if unconfirmed
  Bool ->
  -- | only delete RBF
  Bool ->
  Tx ->
  m ()
freeOutputs memonly rbfcheck tx = do
  let prevs = prevOuts tx
  unspents <- mapM getUnspent prevs
  let spents = [p | (p, Nothing) <- zip prevs unspents]
  spndrs <- catMaybes <$> mapM getSpender spents
  let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs
  mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids

deleteConfirmedTx :: MonadImport m => TxHash -> m ()
deleteConfirmedTx = deleteTx False False

deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx rbfcheck th =
  getActiveTxData th >>= \case
    Just _ -> deleteTx True rbfcheck th
    Nothing ->
      $(logDebugS) "BlockStore" $
        "Not found or already deleted: " <> txHashToHex th

deleteTx ::
  MonadImport m =>
  -- | only delete transaction if unconfirmed
  Bool ->
  -- | only delete RBF
  Bool ->
  TxHash ->
  m ()
deleteTx memonly rbfcheck th = do
  chain <- getChain memonly rbfcheck th
  $(logDebugS) "BlockStore" $
    "Deleting " <> cs (show (length chain))
      <> " txs from chain leading to "
      <> txHashToHex th
  mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain

getChain ::
  (MonadImport m, MonadLoggerIO m) =>
  -- | only delete transaction if unconfirmed
  Bool ->
  -- | only delete RBF
  Bool ->
  TxHash ->
  m [Tx]
getChain memonly rbfcheck th' = do
  $(logDebugS) "BlockStore" $
    "Getting chain for tx " <> txHashToHex th'
  sort_clean <$> go HashSet.empty (HashSet.singleton th')
  where
    sort_clean = reverse . map snd . sortTxs
    get_tx th =
      getActiveTxData th >>= \case
        Nothing -> do
          $(logDebugS) "BlockStore" $
            "Transaction not found: " <> txHashToHex th
          return Nothing
        Just td
          | memonly && confirmed (txDataBlock td) -> do
            $(logErrorS) "BlockStore" $
              "Transaction already confirmed: "
                <> txHashToHex th
            throwError TxConfirmed
          | rbfcheck ->
            isRBF (txDataBlock td) (txData td) >>= \case
              True -> return $ Just $ txData td
              False -> do
                $(logErrorS) "BlockStore" $
                  "Double-spending transaction: "
                    <> txHashToHex th
                throwError DoubleSpend
          | otherwise -> return $ Just $ txData td
    go txs pdg = do
      txs1 <- HashSet.fromList . catMaybes <$> mapM get_tx (HashSet.toList pdg)
      pdg1 <-
        HashSet.fromList . concatMap (map spenderHash . I.elems)
          <$> mapM getSpenders (HashSet.toList pdg)
      let txs' = txs1 <> txs
          pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs'
      if HashSet.null pdg'
        then return $ HashSet.toList txs'
        else go txs' pdg'

deleteSingleTx :: MonadImport m => TxHash -> m ()
deleteSingleTx th =
  getActiveTxData th >>= \case
    Nothing -> do
      $(logErrorS) "BlockStore" $
        "Already deleted: " <> txHashToHex th
      throwError TxNotFound
    Just td -> do
      $(logDebugS) "BlockStore" $
        "Deleting tx: " <> txHashToHex th
      getSpenders th >>= \case
        m
          | I.null m -> commitDelTx td
          | otherwise -> do
            $(logErrorS) "BlockStore" $
              "Tried to delete spent tx: "
                <> txHashToHex th
            throwError TxSpent

commitDelTx :: MonadImport m => TxData -> m ()
commitDelTx = commitModTx False

commitAddTx :: MonadImport m => TxData -> m ()
commitAddTx = commitModTx True

commitModTx :: MonadImport m => Bool -> TxData -> m ()
commitModTx add tx_data = do
  mapM_ mod_addr_tx (txDataAddresses td)
  mod_outputs
  mod_unspent
  insertTx td
  updateMempool td
  where
    tx = txData td
    br = txDataBlock td
    td = tx_data {txDataDeleted = not add}
    tx_ref = TxRef br (txHash tx)
    mod_addr_tx a
      | add = do
        insertAddrTx a tx_ref
        modAddressCount add a
      | otherwise = do
        deleteAddrTx a tx_ref
        modAddressCount add a
    mod_unspent
      | add = spendOutputs tx
      | otherwise = unspendOutputs tx
    mod_outputs
      | add = addOutputs br tx
      | otherwise = delOutputs br tx

updateMempool :: MonadImport m => TxData -> m ()
updateMempool td@TxData {txDataDeleted = True} =
  deleteFromMempool (txHash (txData td))
updateMempool td@TxData {txDataBlock = MemRef t} =
  addToMempool (txHash (txData td)) t
updateMempool td@TxData {txDataBlock = BlockRef {}} =
  deleteFromMempool (txHash (txData td))

spendOutputs :: MonadImport m => Tx -> m ()
spendOutputs tx =
  zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx)

addOutputs :: MonadImport m => BlockRef -> Tx -> m ()
addOutputs br tx =
  zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx)

isRBF ::
  StoreReadBase m =>
  BlockRef ->
  Tx ->
  m Bool
isRBF br tx
  | confirmed br = return False
  | otherwise =
    getNetwork >>= \net ->
      if getReplaceByFee net
        then go
        else return False
  where
    go
      | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True
      | otherwise = carry_on
    carry_on =
      let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)
          ck [] = return False
          ck (h : hs') =
            getActiveTxData h >>= \case
              Nothing -> return False
              Just t
                | confirmed (txDataBlock t) -> ck hs'
                | txDataRBF t -> return True
                | otherwise -> ck hs'
       in ck hs

addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
addOutput = modOutput True

delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
delOutput = modOutput False

modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput add br op o = do
  mod_unspent
  forM_ ma $ \a -> do
    mod_addr_unspent a u
    modBalance (confirmed br) add a (outValue o)
    modifyReceived a v
  where
    v
      | add = (+ outValue o)
      | otherwise = subtract (outValue o)
    ma = eitherToMaybe (scriptToAddressBS (scriptOutput o))
    u =
      Unspent
        { unspentScript = scriptOutput o,
          unspentBlock = br,
          unspentPoint = op,
          unspentAmount = outValue o,
          unspentAddress = ma
        }
    mod_unspent
      | add = insertUnspent u
      | otherwise = deleteUnspent op
    mod_addr_unspent
      | add = insertAddrUnspent
      | otherwise = deleteAddrUnspent

delOutputs :: MonadImport m => BlockRef -> Tx -> m ()
delOutputs br tx =
  forM_ (zip [0 ..] (txOut tx)) $ \(i, o) -> do
    let op = OutPoint (txHash tx) i
    delOutput br op o

getImportTxData :: MonadImport m => TxHash -> m TxData
getImportTxData th =
  getActiveTxData th >>= \case
    Nothing -> do
      $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th
      throwError TxNotFound
    Just d -> return d

getTxOut :: Word32 -> Tx -> Maybe TxOut
getTxOut i tx = do
  guard (fromIntegral i < length (txOut tx))
  return $ txOut tx !! fromIntegral i

spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()
spendOutput th ix op = do
  u <-
    getUnspent op >>= \case
      Just u -> return u
      Nothing -> error $ "Could not find UTXO to spend: " <> show op
  deleteUnspent op
  insertSpender op (Spender th ix)
  let pk = unspentScript u
  forM_ (scriptToAddressBS pk) $ \a -> do
    decreaseBalance
      (confirmed (unspentBlock u))
      a
      (unspentAmount u)
    deleteAddrUnspent a u

unspendOutputs :: MonadImport m => Tx -> m ()
unspendOutputs = mapM_ unspendOutput . prevOuts

unspendOutput :: MonadImport m => OutPoint -> m ()
unspendOutput op = do
  t <-
    getActiveTxData (outPointHash op) >>= \case
      Nothing -> error $ "Could not find tx data: " <> show (outPointHash op)
      Just t -> return t
  let o =
        fromMaybe
          (error ("Could not find output: " <> show op))
          (getTxOut (outPointIndex op) (txData t))
      m = eitherToMaybe (scriptToAddressBS (scriptOutput o))
      u =
        Unspent
          { unspentAmount = outValue o,
            unspentBlock = txDataBlock t,
            unspentScript = scriptOutput o,
            unspentPoint = op,
            unspentAddress = m
          }
  deleteSpender op
  insertUnspent u
  forM_ m $ \a -> do
    insertAddrUnspent a u
    increaseBalance (confirmed (unspentBlock u)) a (outValue o)

modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m ()
modifyReceived a f = do
  b <- getDefaultBalance a
  setBalance b {balanceTotalReceived = f (balanceTotalReceived b)}

decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()
decreaseBalance conf = modBalance conf False

increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()
increaseBalance conf = modBalance conf True

modBalance ::
  MonadImport m =>
  -- | confirmed
  Bool ->
  -- | add
  Bool ->
  Address ->
  Word64 ->
  m ()
modBalance conf add a val = do
  b <- getDefaultBalance a
  setBalance $ (g . f) b
  where
    g b = b {balanceUnspentCount = m 1 (balanceUnspentCount b)}
    f b
      | conf = b {balanceAmount = m val (balanceAmount b)}
      | otherwise = b {balanceZero = m val (balanceZero b)}
    m
      | add = (+)
      | otherwise = subtract

modAddressCount :: MonadImport m => Bool -> Address -> m ()
modAddressCount add a = do
  b <- getDefaultBalance a
  setBalance b {balanceTxCount = f (balanceTxCount b)}
  where
    f
      | add = (+ 1)
      | otherwise = subtract 1

txOutAddrs :: [TxOut] -> [Address]
txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)

txInAddrs :: [Prev] -> [Address]
txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript)

txDataAddresses :: TxData -> [Address]
txDataAddresses t =
  nub' $ txInAddrs prevs <> txOutAddrs outs
  where
    prevs = I.elems (txDataPrevs t)
    outs = txOut (txData t)

isCoinbase :: Tx -> Bool
isCoinbase = all ((== nullOutPoint) . prevOutput) . txIn

prevOuts :: Tx -> [OutPoint]
prevOuts tx = filter (/= nullOutPoint) (map prevOutput (txIn tx))

testPresent :: StoreReadBase m => Tx -> m Bool
testPresent tx = isJust <$> getActiveTxData (txHash tx)