diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,9 +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.11.0 +### Changed +- Improve post transactions endpoint. + ## 0.10.1 ### Changed - Fix bug where transaction lists from multiple addresses would sort incorrectly. +- Address gap reduced to 20. ## 0.10.0 ### Removed diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -543,9 +543,17 @@ S.json (UserError "decode tx within hex fail") finish Right x -> return x - lift (publishTx (storeManager st) tx) >>= \case - True -> S.json $ object ["sent" .= True] - False -> S.json $ object ["sent" .= False] + lift (publishTx pub st db tx) >>= \case + Right () -> S.json $ object ["txid" .= txHash tx] + Left e -> do + case e of + PubNoPeers -> status status500 + PubTimeout -> status status500 + PubPeerDisconnected -> status status500 + PubNotFound -> status status500 + PubReject _ -> status status400 + S.json (UserError (show e)) + finish S.get "/dbstats" $ do cors getProperty db Stats >>= text . cs . fromJust 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: bfc8c3b39761b49a5e557e59a48179eb6e89c7c52635052adc1366326f4161b6 +-- hash: 11df7d51fa2c0041ce6388778dc0d89a549e23dff01a5a47e75df409f9b29743 name: haskoin-store -version: 0.10.1 +version: 0.11.0 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 @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} module Haskoin.Store ( Store(..) , BlockStore @@ -23,6 +24,7 @@ , PeerInformation(..) , PreciseUnixTime(..) , HealthCheck(..) + , PubExcept(..) , withStore , store , getBestBlock @@ -68,14 +70,16 @@ ) where import Conduit -import Control.Monad.Except +import 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 Data.Time.Clock.System +import Database.RocksDB as R import Haskoin import Haskoin.Node import Network.Haskoin.Store.Block @@ -83,8 +87,36 @@ import Network.Haskoin.Store.Messages import Network.Socket (SockAddr (..)) import NQE +import System.Random import UnliftIO +data PubExcept + = PubNoPeers + | PubReject RejectCode + | PubTimeout + | PubNotFound + | PubPeerDisconnected + deriving Eq + +instance Show PubExcept where + show PubNoPeers = "no peers" + show (PubReject c) = + "rejected: " <> + case c of + RejectMalformed -> "malformed" + RejectInvalid -> "invalid" + RejectObsolete -> "obsolete" + RejectDuplicate -> "duplicate" + RejectNonStandard -> "not standard" + RejectDust -> "dust" + RejectInsufficientFee -> "insufficient fee" + RejectCheckpoint -> "checkpoint" + show PubTimeout = "timeout" + show PubNotFound = "not found" + show PubPeerDisconnected = "peer disconnected" + +instance Exception PubExcept + withStore :: (MonadLoggerIO m, MonadUnliftIO m) => StoreConfig @@ -172,10 +204,19 @@ ] unless (null blocks) $ BlockNotFound p blocks `sendSTM` b -storeDispatch b _ (PeerEvent (PeerMessage p (MInv (Inv is)))) = do +storeDispatch b pub (PeerEvent (PeerMessage p (MInv (Inv is)))) = do let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx] + pub (StoreTxAvailable p txs) unless (null txs) $ BlockTxAvailable p txs `sendSTM` b +storeDispatch _ pub (PeerEvent (PeerMessage p (MReject r))) = + when (rejectMessage r == MCTx) $ + case decode (rejectData r) of + Left _ -> return () + Right th -> + pub $ + StoreTxReject p th (rejectCode r) (getVarString (rejectReason r)) + storeDispatch _ _ (PeerEvent _) = return () healthCheck :: @@ -213,14 +254,43 @@ } -- | Publish a new transaction to the network. -publishTx :: (MonadUnliftIO m, MonadLoggerIO m) => Manager -> Tx -> m Bool -publishTx mgr tx = - managerGetPeers mgr >>= \case - [] -> return False - ps -> do - forM_ ps (\OnlinePeer {onlinePeerMailbox = p} -> MTx tx `sendMessage` p) - return True - +publishTx :: + (MonadUnliftIO m, MonadLoggerIO m) + => Publisher StoreEvent + -> Store + -> DB + -> Tx + -> m (Either PubExcept ()) +publishTx pub st db tx = + withSubscription pub $ \s -> do + let d = (db, defaultReadOptions) + getTransaction d (txHash tx) >>= \case + Just _ -> return $ Right () + Nothing -> + runExceptT $ + managerGetPeers (storeManager st) >>= \case + [] -> throwError PubNoPeers + OnlinePeer {onlinePeerMailbox = p}:_ -> do + MTx tx `sendMessage` p + MMempool `sendMessage` p + f p s + where + t = 15 * 1000 * 1000 + f p s = do + n <- liftIO randomIO + MPing (Ping n) `sendMessage` p + liftIO (timeout t (runExceptT (g p s n))) >>= \case + Nothing -> throwError PubTimeout + Just e -> E.liftEither e + g p s n = + receive s >>= \case + StoreTxReject p' h' c _ + | p == p' && h' == txHash tx -> throwError $ PubReject c + StorePeerDisconnected p' _ + | p == p' -> throwError PubPeerDisconnected + StoreMempoolNew h' + | h' == txHash tx -> return () + _ -> g p s n -- | Obtain information about connected peers from peer manager process. getPeersInformation :: MonadIO m => Manager -> m [PeerInformation] diff --git a/src/Network/Haskoin/Store/Messages.hs b/src/Network/Haskoin/Store/Messages.hs --- a/src/Network/Haskoin/Store/Messages.hs +++ b/src/Network/Haskoin/Store/Messages.hs @@ -4,8 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Haskoin.Store.Messages where +import Data.ByteString (ByteString) import Data.Word -import Database.RocksDB (DB) +import Database.RocksDB (DB) import Haskoin import Haskoin.Node import Network.Socket @@ -16,11 +17,11 @@ -- | Store mailboxes. data Store = Store - { storeManager :: !Manager + { storeManager :: !Manager -- ^ peer manager mailbox - , storeChain :: !Chain + , storeChain :: !Chain -- ^ chain header process mailbox - , storeBlock :: !BlockStore + , storeBlock :: !BlockStore -- ^ block storage mailbox } @@ -41,15 +42,15 @@ -- | Configuration for a block store. data BlockConfig = BlockConfig - { blockConfManager :: !Manager + { blockConfManager :: !Manager -- ^ peer manager from running node - , blockConfChain :: !Chain + , blockConfChain :: !Chain -- ^ chain from a running node - , blockConfListener :: !(Listen StoreEvent) + , blockConfListener :: !(Listen StoreEvent) -- ^ listener for store events - , blockConfDB :: !DB + , blockConfDB :: !DB -- ^ RocksDB database handle - , blockConfNet :: !Network + , blockConfNet :: !Network -- ^ network constants } @@ -95,4 +96,11 @@ | StorePeerPong !Peer !Word64 -- ^ peer responded 'Ping' - + | StoreTxAvailable !Peer + ![TxHash] + -- ^ peer inv transactions + | StoreTxReject !Peer + !TxHash + !RejectCode + !ByteString + -- ^ peer rejected transaction