haskoin-store 0.15.1 → 0.15.2
raw patch · 10 files changed
+211/−87 lines, 10 files
Files
- CHANGELOG.md +9/−0
- haskoin-store.cabal +2/−2
- src/Network/Haskoin/Store/Block.hs +11/−4
- src/Network/Haskoin/Store/Data.hs +4/−0
- src/Network/Haskoin/Store/Data/ImportDB.hs +35/−5
- src/Network/Haskoin/Store/Data/KeyValue.hs +25/−1
- src/Network/Haskoin/Store/Data/RocksDB.hs +16/−3
- src/Network/Haskoin/Store/Data/STM.hs +21/−2
- src/Network/Haskoin/Store/Logic.hs +87/−69
- src/Network/Haskoin/Store/Messages.hs +1/−1
CHANGELOG.md view
@@ -4,6 +4,15 @@ 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.15.2+### Added+- Internal data types to support orphan transactions.++### Changed+- Do not spam block actor with pings.+- Fix balance/unspent cache not reverting when importing fails.+- Fix transaction sorting algorithm not including transaction position information.+ ## 0.15.1 ### Changed - Fix duplicate coinbase transaction id bug.
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e7b8e1136ee2c05c5f2395b5c1b3b5cf6375e519fce16db05a7d0d3df7c487f5+-- hash: f789909b15a88fd2b0d4a03016ad5b760ac4a7b2a246a8c19e133598c5940dc0 name: haskoin-store-version: 0.15.1+version: 0.15.2 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/Block.hs view
@@ -163,6 +163,11 @@ runExceptT (runImportDB db um bm $ importBlock net b n) >>= \case Right () -> do l <- blockConfListener <$> asks myConfig+ $(logInfoS) "Block" $+ "Best block indexed: " <>+ blockHashToHex (headerHash (blockHeader b)) <>+ " at height " <>+ cs (show (nodeHeight n)) atomically $ l (StoreBestBlock (headerHash (blockHeader b))) lift $ isSynced >>= \x -> when x (mempool p) when (nodeHeight n `mod` 1000 == 0) (lift pruneCache)@@ -183,7 +188,9 @@ if nodeHeader h == blockHeader b then resetPeer else do- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ now <-+ fromIntegral . systemSeconds <$>+ liftIO getSystemTime asks myPeer >>= atomically . (`writeTVar` Just s {syncingTime = now})@@ -448,11 +455,11 @@ processBlockMessage (BlockNotFound p bs) = processNoBlocks p bs processBlockMessage (BlockTxReceived p tx) = processTx p tx processBlockMessage (BlockTxAvailable p ts) = processTxs p ts-processBlockMessage BlockPing = checkTime+processBlockMessage (BlockPing r) = checkTime >> atomically (r ()) processBlockMessage PurgeMempool = purgeMempool pingMe :: MonadLoggerIO m => Mailbox BlockMessage -> m () pingMe mbox = forever $ do threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000))- $(logDebugS) "Block" "Pinging block"- BlockPing `send` mbox+ $(logDebugS) "BlockTimer" "Pinging block"+ BlockPing `query` mbox
src/Network/Haskoin/Store/Data.hs view
@@ -63,6 +63,7 @@ getBlocksAtHeight :: BlockHeight -> m [BlockHash] getBlock :: BlockHash -> m (Maybe BlockData) getTxData :: TxHash -> m (Maybe TxData)+ getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx)) getSpenders :: TxHash -> m (IntMap Spender) getSpender :: OutPoint -> m (Maybe Spender) @@ -75,6 +76,7 @@ class StoreStream m where getMempool :: Maybe UnixTime -> ConduitT () (UnixTime, TxHash) m ()+ getOrphans :: ConduitT () (UnixTime, Tx) m () getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT () Unspent m () getAddressTxs :: Address -> Maybe BlockRef -> ConduitT () BlockTx m () @@ -92,6 +94,8 @@ removeAddrUnspent :: Address -> Unspent -> m () insertMempoolTx :: TxHash -> UnixTime -> m () deleteMempoolTx :: TxHash -> UnixTime -> m ()+ insertOrphanTx :: Tx -> UnixTime -> m ()+ deleteOrphanTx :: TxHash -> m () -- | Serialize such that ordering is inverted. putUnixTime w = putWord64be $ maxBound - w
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} module Network.Haskoin.Store.Data.ImportDB where import Conduit@@ -41,17 +41,22 @@ -> m a runImportDB db um bm f = do hm <- newTVarIO emptyHashMapDB+ um' <- atomically $ readTVar um >>= newTVar+ bm' <- atomically $ readTVar bm >>= newTVar x <- R.runReaderT f ImportDB { importRocksDB = (defaultReadOptions, db) , importHashMap = hm- , importUnspentMap = um- , importBalanceMap = bm+ , importUnspentMap = um'+ , importBalanceMap = bm' } ops <- hashMapOps <$> readTVarIO hm writeBatch db ops+ atomically $ do+ readTVar um' >>= writeTVar um+ readTVar bm' >>= writeTVar bm return x hashMapOps :: HashMapDB -> [BatchOp]@@ -65,6 +70,7 @@ addrTxOps (hAddrTx db) <> addrOutOps (hAddrOut db) <> mempoolOps (hMempool db) <>+ orphanOps (hOrphans db) <> unspentOps (hUnspent db) bestBlockOp :: Maybe BlockHash -> [BatchOp]@@ -148,6 +154,12 @@ g u t True = insertOp (MemKey u t) () g u t False = deleteOp (MemKey u t) +orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp]+orphanOps = map (uncurry f) . M.toList+ where+ f h (Just x) = insertOp (OrphanKey h) x+ f h Nothing = deleteOp (OrphanKey h)+ unspentOps :: HashMap TxHash (IntMap (Maybe Unspent)) -> [BatchOp] unspentOps = concatMap (uncurry f) . M.toList where@@ -219,6 +231,14 @@ deleteMempoolTxI t p ImportDB {importHashMap = hm} = atomically . withBlockSTM hm $ deleteMempoolTx t p +insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> ImportDB -> m ()+insertOrphanTxI t p ImportDB {importHashMap = hm} =+ atomically . withBlockSTM hm $ insertOrphanTx t p++deleteOrphanTxI :: MonadIO m => TxHash -> ImportDB -> m ()+deleteOrphanTxI t ImportDB {importHashMap = hm} =+ atomically . withBlockSTM hm $ deleteOrphanTx t+ getBestBlockI :: MonadIO m => ImportDB -> m (Maybe BlockHash) getBestBlockI ImportDB {importHashMap = hm, importRocksDB = db} = runMaybeT $ MaybeT f <|> MaybeT g@@ -247,6 +267,13 @@ f = atomically . withBlockSTM hm $ getTxData th g = uncurry withBlockDB db $ getTxData th +getOrphanTxI :: MonadIO m => TxHash -> ImportDB -> m (Maybe (UnixTime, Tx))+getOrphanTxI h ImportDB {importRocksDB = db, importHashMap = hm} =+ fmap join . runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = getOrphanTxH h <$> readTVarIO hm+ g = Just <$> uncurry withBlockDB db (getOrphanTx h)+ getSpenderI :: MonadIO m => OutPoint -> ImportDB -> m (Maybe Spender) getSpenderI op ImportDB {importRocksDB = db, importHashMap = hm} = getSpenderH op <$> readTVarIO hm >>= \case@@ -311,6 +338,7 @@ getTxData t = R.ask >>= getTxDataI t getSpender p = R.ask >>= getSpenderI p getSpenders t = R.ask >>= getSpendersI t+ getOrphanTx h = R.ask >>= getOrphanTxI h instance (MonadIO m) => StoreWrite (ReaderT ImportDB m) where setInit = R.ask >>= setInitI@@ -326,6 +354,8 @@ removeAddrUnspent a u = R.ask >>= removeAddrUnspentI a u insertMempoolTx t p = R.ask >>= insertMempoolTxI t p deleteMempoolTx t p = R.ask >>= deleteMempoolTxI t p+ insertOrphanTx t p = R.ask >>= insertOrphanTxI t p+ deleteOrphanTx t = R.ask >>= deleteOrphanTxI t instance (MonadIO m) => UnspentRead (ReaderT ImportDB m) where getUnspent a = R.ask >>= getUnspentI a
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -193,11 +193,12 @@ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize MemKey where- -- 0x07 · TxHash+ -- 0x07 · UnixTime · TxHash put (MemKey t h) = do putWord8 0x07 putUnixTime t put h+ -- 0x07 · UnixTime put (MemKeyT t) = do putWord8 0x07 putUnixTime t@@ -209,6 +210,29 @@ instance R.Key MemKey instance R.KeyValue MemKey ()++-- | Orphan pool transaction database key.+data OrphanKey+ = OrphanKey+ { orphanKey :: !TxHash+ }+ | OrphanKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OrphanKey+ -- 0x08 · TxHash+ where+ put (OrphanKey h) = do+ putWord8 0x08+ put h+ -- 0x08+ put OrphanKeyS = putWord8 0x08+ get = do+ guard . (== 0x08) =<< getWord8+ OrphanKey <$> get++instance R.Key OrphanKey+instance R.KeyValue OrphanKey (UnixTime, Tx) -- | Block entry database key. newtype BlockKey = BlockKey
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.RocksDB where @@ -100,6 +100,17 @@ f (MemKey u t) () = (u, t) f _ _ = undefined +getOrphansDB ::+ (MonadIO m, MonadResource m)+ => ReadOptions+ -> DB+ -> ConduitT () (UnixTime, Tx) m ()+getOrphansDB opts db = matching db opts OrphanKeyS .| mapC snd++getOrphanTxDB ::+ MonadIO m => TxHash -> ReadOptions -> DB -> m (Maybe (UnixTime, Tx))+getOrphanTxDB h opts db = retrieve db opts (OrphanKey h)+ getAddressTxsDB :: (MonadIO m, MonadResource m) => Address@@ -162,10 +173,12 @@ getTxData t = R.ask >>= uncurry (getTxDataDB t) getSpenders p = R.ask >>= uncurry (getSpendersDB p) getSpender p = R.ask >>= uncurry (getSpenderDB p)+ getOrphanTx h = R.ask >>= uncurry (getOrphanTxDB h) instance (MonadIO m, MonadResource m) => StoreStream (ReaderT BlockDB m) where getMempool p = lift R.ask >>= uncurry (getMempoolDB p)+ getOrphans = lift R.ask >>= uncurry getOrphansDB getAddressTxs a b = R.ask >>= uncurry (getAddressTxsDB a b) getAddressUnspents a b = R.ask >>= uncurry (getAddressUnspentsDB a b)
src/Network/Haskoin/Store/Data/STM.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.STM where @@ -46,6 +46,7 @@ , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))) , hMempool :: !(HashMap UnixTime (HashMap TxHash Bool))+ , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx))) , hInit :: !Bool } deriving (Eq, Show) @@ -62,6 +63,7 @@ , hAddrTx = M.empty , hAddrOut = M.empty , hMempool = M.empty+ , hOrphans = M.empty , hInit = False } @@ -118,6 +120,12 @@ hMempool db in yieldMany [(u, h) | (u, hs) <- ls, h <- hs] +getOrphansH :: Monad m => HashMapDB -> ConduitT () (UnixTime, Tx) m ()+getOrphansH = yieldMany . catMaybes . M.elems . hOrphans++getOrphanTxH :: TxHash -> HashMapDB -> Maybe (Maybe (UnixTime, Tx))+getOrphanTxH h = M.lookup h . hOrphans+ getAddressTxsH :: Address -> Maybe BlockRef -> HashMapDB -> [BlockTx] getAddressTxsH a mbr db = dropWhile h .@@ -264,6 +272,13 @@ let s = M.singleton u (M.singleton h False) in db {hMempool = M.unionWith M.union s (hMempool db)} +insertOrphanTxH :: Tx -> UnixTime -> HashMapDB -> HashMapDB+insertOrphanTxH tx u db =+ db {hOrphans = M.insert (txHash tx) (Just (u, tx)) (hOrphans db)}++deleteOrphanTxH :: TxHash -> HashMapDB -> HashMapDB+deleteOrphanTxH h db = db {hOrphans = M.insert h Nothing (hOrphans db)}+ getUnspentH :: OutPoint -> HashMapDB -> Maybe (Maybe Unspent) getUnspentH op db = do m <- M.lookup (outPointHash op) (hUnspent db)@@ -305,6 +320,7 @@ fmap (I.map fromJust . I.filter isJust . getSpendersH t) . lift . readTVar =<< R.ask+ getOrphanTx h = fmap (join . getOrphanTxH h) . lift . readTVar =<< R.ask instance BalanceRead BlockSTM where getBalance a = fmap (getBalanceH a) . lift . readTVar =<< R.ask@@ -318,6 +334,7 @@ instance StoreStream BlockSTM where getMempool m = getMempoolH m =<< lift . lift . readTVar =<< lift R.ask+ getOrphans = getOrphansH =<< lift . lift . readTVar =<< lift R.ask getAddressTxs a m = yieldMany . getAddressTxsH a m =<< lift . lift . readTVar =<< lift R.ask getAddressUnspents a m =@@ -340,6 +357,8 @@ lift . (`modifyTVar` removeAddrUnspentH a u) =<< R.ask insertMempoolTx h t = lift . (`modifyTVar` insertMempoolTxH h t) =<< R.ask deleteMempoolTx h t = lift . (`modifyTVar` deleteMempoolTxH h t) =<< R.ask+ deleteOrphanTx h = lift . (`modifyTVar` deleteOrphanTxH h) =<< R.ask+ insertOrphanTx t u = lift . (`modifyTVar` insertOrphanTxH t u) =<< R.ask instance UnspentWrite BlockSTM where addUnspent h = lift . (`modifyTVar` addUnspentH h) =<< R.ask
src/Network/Haskoin/Store/Logic.hs view
@@ -179,7 +179,7 @@ blockHashToHex h throwError (BlockNotBest bh) txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd)- mapM_ (deleteTx net False . txHash) (reverse (sortTxs txs))+ mapM_ (deleteTx net False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} @@ -233,14 +233,22 @@ } insertAtHeight (headerHash (nodeHeader n)) (nodeHeight n) setBest (headerHash (nodeHeader n))- zipWithM_ import_or_confirm [0 ..] (sortTxs (blockTxns b))+ $(logDebugS) "Block" $ "Importing or confirming block transactions..."+ mapM_ (uncurry import_or_confirm) (sortTxs (blockTxns b))+ $(logDebugS) "Block" $+ "Done importing transactions for block " <>+ blockHashToHex (headerHash (nodeHeader n)) where import_or_confirm x tx = getTxData (txHash tx) >>= \case Just t- | x > 0 && not (txDataDeleted t) -> confirmTx net t (br x) tx- _ ->- importTx net (br x) (fromIntegral (blockTimestamp (nodeHeader n))) tx+ | x > 0 && not (txDataDeleted t) -> do confirmTx net t (br x) tx+ _ -> do+ importTx+ net+ (br x)+ (fromIntegral (blockTimestamp (nodeHeader n)))+ tx subsidy = computeSubsidy net cb_out_val = sum (map outValue (txOut (head (blockTxns b)))) ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b)))@@ -256,14 +264,18 @@ x = B.length (encode b) in s * 3 + x -sortTxs :: [Tx] -> [Tx]-sortTxs [] = []-sortTxs txs = is <> sortTxs ds+sortTxs :: [Tx] -> [(Word32, Tx)]+sortTxs txs = go $ zip [0 ..] txs where- (is, ds) =- partition- (all ((`notElem` map txHash txs) . outPointHash . prevOutput) . txIn)- txs+ go [] = []+ go ts =+ let (is, ds) =+ partition+ (all ((`notElem` map (txHash . snd) ts) .+ outPointHash . prevOutput) .+ txIn . snd)+ ts+ in is <> go ds importTx :: ( MonadError ImportException m@@ -291,7 +303,6 @@ txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHash tx)) us <-- fromMaybe [] . sequence <$> if iscb then return [] else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op@@ -302,7 +313,7 @@ "Insufficient funds: " <> txHashToHex (txHash tx) throwError (InsufficientFunds th) zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us- zipWithM_ (newOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx)+ zipWithM_ (newOutput net br . OutPoint (txHash tx)) [0 ..] (txOut tx) rbf <- getrbf let t = Transaction@@ -325,13 +336,31 @@ where uns op = getUnspent op >>= \case+ Just u -> return u Nothing -> do- $(logErrorS) "BlockLogic" $+ $(logWarnS) "BlockLogic" $ "No unspent output: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))- throwError (NoUnspent op)- Just u -> return $ Just u+ getSpender op >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "No spent or unspent output: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (NoUnspent op)+ Just Spender {spenderHash = s} -> do+ deleteTx net True s+ getUnspent op >>= \case+ Nothing -> do+ $(logErrorS) "BlockLogic" $+ "Could not unspend output: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (NoUnspent op)+ Just u -> return u th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) ws = map Just (txWitness tx) <> repeat Nothing@@ -387,31 +416,14 @@ -> Tx -> m () confirmTx net t br tx = do- $(logDebugS) "BlockLogic" $- "Confirming tx " <> txHashToHex (txHash tx) <> " previously on " <>- cs (show (txDataBlock t)) <>- " and now on " <>- cs (show br) forM_ (txDataPrevs t) $ \p -> case scriptToAddressBS (prevScript p) of Left _ -> return () Right a -> do- $(logDebugS) "BlockLogic" $- "Removing tx " <> txHashToHex (txHash tx) <>- " from address " <>- fromMaybe "???" (addrToString net a) <>- " on " <>- cs (show (txDataBlock t)) removeAddrTx a BlockTx {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}- $(logDebugS) "BlockLogic" $ "Inserting tx " <>- txHashToHex (txHash tx) <>- " for address " <>- fromMaybe "???" (addrToString net a) <>- " on " <>- cs (show br) insertAddrTx a BlockTx {blockTxBlock = br, blockTxHash = txHash tx}@@ -430,22 +442,10 @@ case scriptToAddressBS (scriptOutput o) of Left _ -> return () Right a -> do- $(logDebugS) "BlockLogic" $- "Removing tx " <> txHashToHex (txHash tx) <>- " from address " <>- fromMaybe "???" (addrToString net a) <>- " on " <>- cs (show (txDataBlock t)) removeAddrTx a BlockTx {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}- $(logDebugS) "BlockLogic" $ "Inserting tx " <>- txHashToHex (txHash tx) <>- " for address " <>- fromMaybe "???" (addrToString net a) <>- " on " <>- cs (show br) insertAddrTx a BlockTx {blockTxBlock = br, blockTxHash = txHash tx}@@ -467,7 +467,7 @@ , unspentScript = B.Short.toShort (scriptOutput o) } reduceBalance net False False a (outValue o)- increaseBalance True False a (outValue o)+ increaseBalance net True False a (outValue o) insertTx t {txDataBlock = br} deleteMempoolTx (txHash tx) (memRefTime (txDataBlock t)) @@ -521,7 +521,7 @@ forM_ (take (length (txOut (txData t))) [0 ..]) $ \n -> delOutput net (OutPoint h n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ unspendOutput ps+ mapM_ (unspendOutput net) ps unless (confirmed (txDataBlock t)) $ deleteMempoolTx h (memRefTime (txDataBlock t)) insertTx t {txDataDeleted = True}@@ -598,11 +598,12 @@ , BalanceWrite m , MonadLogger m )- => BlockRef+ => Network+ -> BlockRef -> OutPoint -> TxOut -> m ()-newOutput br op to = do+newOutput net br op to = do addUnspent u case scriptToAddressBS (scriptOutput to) of Left _ -> return ()@@ -614,7 +615,7 @@ { blockTxHash = outPointHash op , blockTxBlock = br }- increaseBalance (confirmed br) True a (outValue to)+ increaseBalance net (confirmed br) True a (outValue to) where u = Unspent@@ -751,9 +752,10 @@ , BalanceWrite m , MonadLogger m )- => OutPoint+ => Network+ -> OutPoint -> m ()-unspendOutput op = do+unspendOutput net op = do t <- getImportTx (outPointHash op) o <- getTxOutput (outPointIndex op) t s <-@@ -786,6 +788,7 @@ , blockTxBlock = transactionBlock x } increaseBalance+ net (confirmed (unspentBlock u)) False a@@ -805,24 +808,20 @@ -> Address -> Word64 -> m ()-reduceBalance net c t a v =+reduceBalance net c t a v = do getBalance a >>= \case Nothing -> do- $(logErrorS) "BlockLogic" $ "Balance not found: " <> addrText net a+ $(logErrorS) "BlockLogic" $+ "Balance not found for address " <> addrText net a throwError (BalanceNotFound a) Just b -> do- when- (v >- if c- then balanceAmount b- else balanceZero b) $ do+ when (v > amnt b) $ do $(logErrorS) "BlockLogic" $- "Insufficient " <>- (if c- then "confirmed "- else "unconfirmed ") <>- "balance: " <>- addrText net a+ "Insufficient " <> conf <> " balance: " <> addrText net a <>+ " (needs: " <>+ cs (show v) <>+ ", has: " <>+ cs (show (amnt b)) <> ")" throwError $ if c then InsufficientBalance a@@ -846,6 +845,19 @@ then v else 0 }+ where+ amnt =+ if c+ then balanceAmount+ else balanceZero+ conf =+ if c+ then "confirmed"+ else "unconfirmed"+ addr =+ case addrToString net a of+ Nothing -> "???"+ Just x -> x increaseBalance :: ( MonadError ImportException m@@ -855,12 +867,13 @@ , BalanceWrite m , MonadLogger m )- => Bool -- ^ add confirmed output+ => Network+ -> Bool -- ^ add confirmed output -> Bool -- ^ increase total received -> Address -> Word64 -> m ()-increaseBalance c t a v = do+increaseBalance _net c t a v = do b <- getBalance a >>= \case Nothing ->@@ -893,6 +906,11 @@ then v else 0 }+ where+ conf =+ if c+ then "confirmed"+ else "unconfirmed" updateAddressCounts :: (MonadError ImportException m, BalanceWrite m, BalanceRead m)@@ -921,4 +939,4 @@ map (scriptToAddressBS . scriptOutput) (txOut (txData t)) addrText :: Network -> Address -> Text-addrText net a = fromMaybe "[unreprestable]" $ addrToString net a+addrText net a = fromMaybe "???" $ addrToString net a
src/Network/Haskoin/Store/Messages.hs view
@@ -76,7 +76,7 @@ | BlockTxAvailable !Peer ![TxHash] -- ^ peer has transactions available- | BlockPing+ | BlockPing !(Listen ()) -- ^ internal housekeeping ping | PurgeMempool -- ^ purge mempool transactions