haskoin-store 0.10.1 → 0.11.0
raw patch · 5 files changed
+116/−25 lines, 5 files
Files
- CHANGELOG.md +5/−0
- app/Main.hs +11/−3
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +80/−10
- src/Network/Haskoin/Store/Messages.hs +18/−10
CHANGELOG.md view
@@ -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
app/Main.hs view
@@ -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
haskoin-store.cabal view
@@ -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
src/Haskoin/Store.hs view
@@ -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]
src/Network/Haskoin/Store/Messages.hs view
@@ -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