diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -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] diff --git a/src/Network/Haskoin/Store/Data.hs b/src/Network/Haskoin/Store/Data.hs --- a/src/Network/Haskoin/Store/Data.hs +++ b/src/Network/Haskoin/Store/Data.hs @@ -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