haskoin-store 0.14.6 → 0.14.7
raw patch · 5 files changed
+80/−27 lines, 5 files
Files
- CHANGELOG.md +8/−0
- app/Main.hs +10/−2
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +59/−22
- src/Network/Haskoin/Store/Data.hs +1/−1
CHANGELOG.md view
@@ -4,6 +4,14 @@ 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.14.7+### Added+- Debug information for `publishTx`.++### Changed+- Transaction publishing no longer requests mempool.+- Fixed serialization for `TxId` freezing the entire program by infinitely recursing.+ ## 0.14.6 ### Changed - Enable full threading again as it was deemed not responsible for the freezing behaviour.
app/Main.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Conduit import Control.Arrow@@ -479,8 +480,11 @@ case hex b <|> bin (L.toStrict b) of Nothing -> raise (UserError "decode tx fail") Just x -> return x- lift (publishTx pub st db tx) >>= \case- Right () -> S.raw $ serialAny net proto (TxId (txHash tx))+ lift (publishTx net pub st db tx) >>= \case+ Right () -> do+ S.raw $ serialAny net proto (TxId (txHash tx))+ lift $ $(logDebugS) "Main" $+ "Success publishing tx " <> txHashToHex (txHash tx) Left e -> do case e of PubNoPeers -> status status500@@ -489,6 +493,10 @@ PubNotFound -> status status500 PubReject _ -> status status400 S.raw $ serialAny net proto (UserError (show e))+ lift $ $(logErrorS) "Main" $+ "Error publishing tx " <> txHashToHex (txHash tx) <>+ ": " <>+ cs (show e) finish S.get "/dbstats" $ do cors
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 62d173a5a1362912d57d4dc760ed57ae81131f353cabb67bb8ecd36bdc67770b+-- hash: 3151dea78baf97f4ea210484402ef8e6b12a1b131e8820f8832e6372e28ac36f name: haskoin-store-version: 0.14.6+version: 0.14.7 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/Haskoin/Store.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Haskoin.Store ( Store(..) , BlockStore@@ -65,15 +66,16 @@ import Conduit import Control.Monad-import qualified Control.Monad.Except as E+import qualified Control.Monad.Except as E import Control.Monad.Logger import Control.Monad.Trans.Maybe import Data.Foldable import Data.Function import Data.List import Data.Maybe-import Data.Serialize (decode)-import Database.RocksDB as R+import Data.Serialize (decode)+import qualified Data.Text as T+import Database.RocksDB as R import Haskoin import Haskoin.Node import Network.Haskoin.Store.Block@@ -81,7 +83,7 @@ import Network.Haskoin.Store.Data.RocksDB import Network.Haskoin.Store.Data.STM import Network.Haskoin.Store.Messages-import Network.Socket (SockAddr (..))+import Network.Socket (SockAddr (..)) import NQE import System.Random import UnliftIO@@ -248,33 +250,68 @@ -- | Publish a new transaction to the network. publishTx :: (MonadUnliftIO m, MonadLoggerIO m)- => Publisher StoreEvent+ => Network+ -> Publisher StoreEvent -> Store -> DB -> Tx -> m (Either PubExcept ())-publishTx pub st db tx =- withSubscription pub $ \s ->+publishTx net pub st db tx = do+ $(logDebugS) "PubTx" $+ "Preparing to publish tx: " <> txHashToHex (txHash tx)+ e <- withSubscription pub $ \s -> withBlockDB defaultReadOptions db $ getTransaction (txHash tx) >>= \case- Just _ -> return $ Right ()+ Just _ -> do+ $(logErrorS) "PubTx" $+ "Tx already in DB: " <> txHashToHex (txHash tx)+ return $ Right () Nothing ->- E.runExceptT $- managerGetPeers (storeManager st) >>= \case- [] -> E.throwError PubNoPeers- OnlinePeer {onlinePeerMailbox = p}:_ -> do- MTx tx `sendMessage` p- MMempool `sendMessage` p- f p s+ E.runExceptT $ do+ $(logDebugS) "PubTx" $ "Getting peers from manager..."+ managerGetPeers (storeManager st) >>= \case+ [] -> do+ $(logErrorS) "PubTx" $ "No peers connected."+ E.throwError PubNoPeers+ OnlinePeer { onlinePeerMailbox = p+ , onlinePeerAddress = a+ }:_ -> do+ $(logDebugS) "PubTx" $+ "Sending tx " <> txHashToHex (txHash tx) <>+ " to peer " <>+ T.pack (show a)+ MTx tx `sendMessage` p+ let t =+ if getSegWit net+ then InvWitnessTx+ else InvTx+ sendMessage+ (MGetData+ (GetData+ [InvVector t (getTxHash (txHash tx))]))+ p+ f p s+ $(logDebugS) "PubTx" $ "Finished for tx: " <> txHashToHex (txHash tx)+ return e where t = 15 * 1000 * 1000 f p s = do- n <- liftIO randomIO- MPing (Ping n) `sendMessage` p- liftIO (timeout t (E.runExceptT (g p s n))) >>= \case- Nothing -> E.throwError PubTimeout- Just e -> E.liftEither e- g p s n =+ $(logDebugS) "PubTx" $+ "Waiting for peer to relay tx " <> txHashToHex (txHash tx)+ liftIO (timeout t (E.runExceptT (g p s))) >>= \case+ Nothing -> do+ $(logErrorS) "PubTx" $+ "Peer did not relay tx " <> txHashToHex (txHash tx)+ E.throwError PubTimeout+ Just (Left e) -> do+ $(logErrorS) "PubTx" $+ "Error publishing tx " <> txHashToHex (txHash tx) <>+ T.pack (show e)+ E.throwError e+ Just (Right ()) -> do+ $(logDebugS) "PubTx" $+ "Success publishing tx " <> txHashToHex (txHash tx)+ g p s = receive s >>= \case StoreTxReject p' h' c _ | p == p' && h' == txHash tx -> E.throwError $ PubReject c@@ -282,7 +319,7 @@ | p == p' -> E.throwError PubPeerDisconnected StoreMempoolNew h' | h' == txHash tx -> return ()- _ -> g p s n+ _ -> g p s -- | Obtain information about connected peers from peer manager process. getPeersInformation :: MonadIO m => Manager -> m [PeerInformation]
src/Network/Haskoin/Store/Data.hs view
@@ -928,7 +928,7 @@ newtype TxId = TxId TxHash deriving (Show, Eq, Generic) instance ToJSON TxId where- toJSON h = object ["txid" .= h]+ toJSON (TxId h) = object ["txid" .= h] instance JsonSerial TxId where jsonSerial _ = toEncoding