haskoin-store 0.59.0 → 0.60.0

raw patch · 5 files changed

+65/−59 lines, 5 filesdep ~haskoin-store-dataPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskoin-store-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• haskoin-store.cabal +4/−4
• src/Haskoin/Store/BlockStore.hs +39/−31
• src/Haskoin/Store/Database/Writer.hs +2/−1
• src/Haskoin/Store/Logic.hs +16/−23

@@ -4,6 +4,10 @@ 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.60.0+### Fixed+- Correct notifications subsystem.+ ## 0.59.0 ### Fixed - Correct internal dependency.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           haskoin-store-version:        0.59.0+version:        0.60.0 synopsis:       Storage and index for Bitcoin and Bitcoin Cash description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-store#readme> category:       Bitcoin, Finance, Network@@ -60,7 +60,7 @@     , hashable >=1.3.0.0     , haskoin-core >=0.21.0     , haskoin-node >=0.17.0-    , haskoin-store-data ==0.59.0+    , haskoin-store-data ==0.60.0     , hedis >=0.12.13     , http-types >=0.12.3     , lens >=4.18.1@@ -116,7 +116,7 @@     , haskoin-core >=0.21.0     , haskoin-node >=0.17.0     , haskoin-store-    , haskoin-store-data ==0.59.0+    , haskoin-store-data ==0.60.0     , hedis >=0.12.13     , http-types >=0.12.3     , lens >=4.18.1@@ -177,7 +177,7 @@     , haskoin-core >=0.21.0     , haskoin-node >=0.17.0     , haskoin-store-    , haskoin-store-data ==0.59.0+    , haskoin-store-data ==0.60.0     , hedis >=0.12.13     , hspec >=2.7.1     , http-types >=0.12.3

@@ -389,17 +389,18 @@     $(logDebugS) "BlockStore" $         "Processing block: " <> blockText node Nothing         <> " from peer: " <> peerText peer-    lift $ runImport (importBlock block node) >>= \case-        Left e   -> failure e-        Right ths -> success node ths+    lift . notify (Just block) $+        runImport (importBlock block node) >>= \case+            Left e   -> failure e+            Right ths -> success node   where+    exclude = map txHash $ blockTxns block     header = blockHeader block     blockhash = headerHash header     hexhash = blockHashToHex blockhash-    success node ths = do+    success node = do         $(logInfoS) "BlockStore" $             "Best block: " <> blockText node (Just block)-        notify ths         removeSyncingBlock $ headerHash $ nodeHeader node         touchPeer         isInSync >>= \case@@ -413,10 +414,6 @@             <> " from peer: " <> peerText peer <> ": "             <> cs (show e)         killPeer (PeerMisbehaving (show e)) peer-    notify ths = do-        listener <- asks (blockConfListener . myConfig)-        mapM_ ((`publish` listener) . StoreMempoolDelete) ths-        publish (StoreBestBlock blockhash) listener  setSyncingBlocks :: (MonadReader BlockStore m, MonadIO m)                  => [BlockHash] -> m ()@@ -611,57 +608,68 @@     => BlockStore     -> UTCTime     -> Tx-    -> WriterT m (Maybe (HashSet TxHash))+    -> WriterT m Bool importMempoolTx block_read time tx =     catchError new_mempool_tx handle_error   where     tx_hash = txHash tx     handle_error Orphan = do         newOrphanTx block_read time tx-        return Nothing-    handle_error _ = return Nothing+        return False+    handle_error _ = return False     seconds = floor (utcTimeToPOSIXSeconds time)     new_mempool_tx =         newMempoolTx tx seconds >>= \case-            Just set -> do+            True -> do                 $(logInfoS) "BlockStore" $                     "Import tx " <> txHashToHex (txHash tx)                     <> ": OK"                 fulfillOrphans block_read tx_hash-                return (Just set)-            Nothing -> do+                return True+            False -> do                 $(logDebugS) "BlockStore" $                     "Import tx " <> txHashToHex (txHash tx)                     <> ": Already imported"-                return Nothing+                return False +notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a+notify block go = do+    old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool+    x <- go+    new <- HashSet.fromList . map snd <$> getMempool+    l <- asks (blockConfListener . myConfig)+    forM_ (old `HashSet.difference` new) $ \h ->+        publish (StoreMempoolDelete h) l+    forM_ (new `HashSet.difference` old) $ \h ->+        publish (StoreMempoolNew h) l+    case block of+        Just b -> publish (StoreBestBlock (headerHash (blockHeader b))) l+        Nothing -> return ()+    return x+  where+    e = case block of+        Just b -> HashSet.fromList (map txHash (blockTxns b))+        Nothing -> HashSet.empty+ processMempool :: MonadLoggerIO m => BlockT m ()-processMempool = guardMempool $ do+processMempool = guardMempool . notify Nothing $ do     txs <- pendingTxs 2000     block_read <- ask-    unless (null txs) (import_txs block_read txs >>= success)+    unless (null txs) (import_txs block_read txs)   where     run_import block_read p =-        importMempoolTx-            block_read-            (pendingTxTime p)-            (pendingTx p) >>= \case-                Just set -> return $ Just (txHash (pendingTx p), set)-                Nothing -> return Nothing+        let t = pendingTx p+            h = txHash t+        in importMempoolTx block_read (pendingTxTime p) (pendingTx p)     import_txs block_read txs =         let r = mapM (run_import block_read) txs          in runImport r >>= \case-            Left e   -> report_error e >> return []-            Right ms -> return (catMaybes ms)+            Left e   -> report_error e+            Right _ -> return ()     report_error e = do         $(logErrorS) "BlockImport" $             "Error processing mempool: " <> cs (show e)         throwIO e-    success = mapM_ notify-    notify (txid, set) = do-        listener <- asks (blockConfListener . myConfig)-        mapM ((`publish` listener) . StoreMempoolDelete) (HashSet.toList set)-        publish (StoreMempoolNew txid) listener  processTxs ::        MonadLoggerIO m

@@ -146,7 +146,8 @@     mem <- runReaderT getMempool bdb     hm <- newTVarIO (newMemory mem)     x <- R.runReaderT f Writer { getReader = bdb, getState = hm }-    ops <- hashMapOps db <$> readTVarIO hm+    mem' <- readTVarIO hm+    let ops = hashMapOps db mem'     writeBatch db ops     return x 

@@ -94,20 +94,17 @@         $(logDebugS) "BlockStore" "Importing Genesis block"         importBlock (genesisBlock net) (genesisNode net) --- | If it returns 'Nothing', then transaction was not imported because it--- already exists. Otherwise tranasction was imported successfully. Any deleted--- transactions will be returned in the set (RBF only).-newMempoolTx :: MonadImport m => Tx -> UnixTime -> m (Maybe (HashSet TxHash))+newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool newMempoolTx tx w =     getActiveTxData (txHash tx) >>= \case         Just _ ->-            return Nothing+            return False         Nothing -> do-            txids <- freeOutputs True True tx+            freeOutputs True True tx             rbf <- isRBF (MemRef w) tx             checkNewTx tx             importTx (MemRef w) w rbf tx-            return (Just txids)+            return True  bestBlockData :: MonadImport m => m BlockData bestBlockData = do@@ -168,11 +165,10 @@                     <> blockHashToHex (headerHash (blockHeader b))                 throwError PrevBlockNotBest -importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m (HashSet TxHash)+importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m () importOrConfirm bn txns = do-    ths <- foldl (<>) HashSet.empty <$> mapM (freeOutputs True False . snd) (reverse txs)+    mapM_ (freeOutputs True False . snd) (reverse txs)     mapM_ (uncurry action) txs-    return ths   where     txs = sortTxs txns     br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}@@ -200,7 +196,7 @@         importTx (br i) bn_time False tx         return Nothing -importBlock :: MonadImport m => Block -> BlockNode -> m (HashSet TxHash)+importBlock :: MonadImport m => Block -> BlockNode -> m () importBlock b n = do     $(logDebugS) "BlockStore" $         "Checking new block: "@@ -230,11 +226,10 @@         (nub (headerHash (nodeHeader n) : bs))         (nodeHeight n)     setBest (headerHash (nodeHeader n))-    ths <- importOrConfirm n (blockTxns b)+    importOrConfirm n (blockTxns b)     $(logDebugS) "BlockStore" $         "Finished importing transactions for: "         <> blockHashToHex (headerHash (nodeHeader n))-    return ths   where     cb_out_val =         sum $ map outValue $ txOut $ head $ blockTxns b@@ -393,39 +388,37 @@     => Bool -- ^ only delete transaction if unconfirmed     -> Bool -- ^ only delete RBF     -> Tx-    -> m (HashSet TxHash)+    -> 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-    del <- fmap concat $ mapM (deleteTx memonly rbfcheck) $ HashSet.toList txids-    return $ HashSet.fromList del+    mapM_ (deleteTx memonly rbfcheck) $ HashSet.toList txids -deleteConfirmedTx :: MonadImport m => TxHash -> m [TxHash]+deleteConfirmedTx :: MonadImport m => TxHash -> m () deleteConfirmedTx = deleteTx False False -deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m [TxHash]+deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () deleteUnconfirmedTx rbfcheck th =     getActiveTxData th >>= \case         Just _ -> deleteTx True rbfcheck th-        Nothing -> do+        Nothing ->           $(logDebugS) "BlockStore" $-              "Not found or already deleted: " <> txHashToHex th-          return []+          "Not found or already deleted: " <> txHashToHex th  deleteTx :: MonadImport m          => Bool -- ^ only delete transaction if unconfirmed          -> Bool -- ^ only delete RBF          -> TxHash-         -> m [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+    mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain  getChain :: (MonadImport m, MonadLoggerIO m)          => Bool -- ^ only delete transaction if unconfirmed