haskoin-store 0.1.2 → 0.1.3
raw patch · 4 files changed
+49/−32 lines, 4 files
Files
- CHANGELOG.md +5/−0
- haskoin-store.cabal +2/−2
- src/Network/Haskoin/Store/Block.hs +35/−23
- test/Spec.hs +7/−7
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.1.3+### Changed+- Fix a bug with transaction notifications.+- Improve handling orphan transactions.+ ## 0.1.2 ### Changed - Specify dependencies better.
haskoin-store.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 442574c9fb9fd4f77a405ea25fb02aaa96975831e68bd95b0e472c1e06caac2c+-- hash: 31ec5e381f6c17e7be976119ac20f85b6f6598508e24a47b1c22c09e4fe59ec6 name: haskoin-store-version: 0.1.2+version: 0.1.3 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
@@ -112,11 +112,15 @@ } where update_database = do- oops <- purgeOrphanOps ops <-- (<> oops) . concat <$>+ concat <$> sequence- [getBlockOps, getBalanceOps, getDeleteTxOps, getInsertTxOps]+ [ getBlockOps+ , getBalanceOps+ , getDeleteTxOps+ , getInsertTxOps+ , purgeOrphanOps+ ] db <- asks myBlockDB writeBatch db ops l <- asks myListener@@ -125,6 +129,8 @@ atomically (l (BestBlock (headerHash blockHeader))) Just RevertBlock -> $(logWarnS) "Block" "Reverted best block" _ -> return ()+ gets newTxs >>= \ths ->+ forM_ (M.keys ths) $ \tx -> atomically (l (MempoolNew tx)) blockStore :: (MonadUnliftIO m, MonadLoggerIO m) => BlockConfig -> m () blockStore BlockConfig {..} = do@@ -691,7 +697,6 @@ matching db Nothing OrphanKey .| mapC (\(k, Tx {}) -> deleteOp k) .| sinkList - getSimpleTx :: MonadBlock m => TxHash -> m Tx getSimpleTx tx_hash = getTxRecord tx_hash >>= \case@@ -988,21 +993,13 @@ cs (blockHashToHex hash) <> " error: " <> fromString e- Right () -> syncBlocks >> syncMempool p+ Right () -> importOrphans >> syncBlocks >> syncMempool p processBlockMessage (TxReceived _ tx) = isAtHeight >>= \x -> when x $ do _ <- runMonadImport $ importTransaction tx Nothing- import_orphans- where- import_orphans = do- db <- asks myBlockDB- ret <-- runResourceT . runConduit $- matching db Nothing OrphanKey .| mapMC (import_tx . snd) .| anyC id- when ret import_orphans- import_tx tx' = runMonadImport $ importTransaction tx' Nothing+ importOrphans processBlockMessage (TxPublished tx) = void . runMonadImport $ importTransaction tx Nothing@@ -1036,22 +1033,27 @@ pstr <- peerString p $(logDebugS) "Block" $ "Received " <> cs (show (length ts)) <>- " tx inventory from peer " <> pstr+ " tx inventory from peer " <>+ pstr net <- asks myNetwork db <- asks myBlockDB has <- fmap catMaybes . forM ts $ \t ->- retrieve db Nothing (MempoolTx t) >>= \case- Nothing -> return Nothing- Just () -> return (Just t)- ors <-- map (\(OrphanTxKey k, Tx {}) -> k) <$>- liftIO (matchingAsList db Nothing OrphanKey)- let new = (ts \\ has) \\ ors+ let mem =+ retrieve db Nothing (MempoolTx t) >>= \case+ Nothing -> return Nothing+ Just () -> return (Just t)+ orp =+ retrieve db Nothing (OrphanTxKey t) >>= \case+ Nothing -> return Nothing+ Just Tx {} -> return (Just t)+ in runMaybeT $ MaybeT mem <|> MaybeT orp+ let new = ts \\ has unless (null new) $ do $(logDebugS) "Block" $ "Requesting " <> cs (show (length new)) <>- " new txs from peer " <> pstr+ " new txs from peer " <>+ pstr peerGetTxs net p new processBlockMessage (PongReceived p n) = do@@ -1059,6 +1061,16 @@ $(logDebugS) "Block" $ "Pong received with nonce " <> cs (show n) <> " from peer " <> pstr asks myListener >>= atomically . ($ PeerPong p n)++importOrphans :: (MonadUnliftIO m, MonadBlock m) => m ()+importOrphans = do+ db <- asks myBlockDB+ ret <-+ runResourceT . runConduit $+ matching db Nothing OrphanKey .| mapMC (import_tx . snd) .| anyC id+ when ret importOrphans+ where+ import_tx tx' = runMonadImport $ importTransaction tx' Nothing getAddrOutputs :: (MonadResource m, MonadUnliftIO m)
test/Spec.hs view
@@ -41,14 +41,14 @@ bestHeight `shouldBe` 8 it "get a block and its transactions" $ withTestStore net "get-block-txs" $ \TestStore {..} -> do- bs <-- replicateM 382 $- receiveMatch testStoreEvents $ \case- BestBlock b -> Just b- _ -> Nothing+ let get_the_block h =+ receive testStoreEvents >>= \case+ BestBlock b | h == 0 -> return b+ | otherwise -> get_the_block ((h :: Int) - 1)+ _ -> get_the_block h+ bh <- get_the_block 381 withAsync (dummyEventHandler testStoreEvents) $ \_ -> do- let blockHash = last bs- m <- getBlock blockHash testStoreDB Nothing+ m <- getBlock bh testStoreDB Nothing let BlockValue {..} = fromMaybe (error "Could not get block") m blockValueHeight `shouldBe` 381