diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.2.2 +version: 1.2.3 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -63,7 +63,7 @@ , monad-logger >=0.3.32 , mtl >=2.2.2 , network >=3.1.1.1 - , nqe >=0.6.1 + , nqe >=0.6.5 , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 @@ -117,7 +117,7 @@ , monad-logger >=0.3.32 , mtl >=2.2.2 , network >=3.1.1.1 - , nqe >=0.6.1 + , nqe >=0.6.5 , optparse-applicative , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 @@ -177,7 +177,7 @@ , monad-logger >=0.3.32 , mtl >=2.2.2 , network >=3.1.1.1 - , nqe >=0.6.1 + , nqe >=0.6.5 , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -27,10 +27,7 @@ getTransaction, getDefaultBalance, getActiveTxData, - blockAtOrBefore, - - -- * Other Data - PubExcept (..), + blockAtOrBefore ) where diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -245,10 +245,7 @@ Right r -> return r liftIO (checkedConnect conninfo) -instance - (MonadUnliftIO m, StoreReadBase m) => - StoreReadBase (CacheX m) - where +instance (StoreReadBase m) => StoreReadBase (CacheX m) where getCtx = lift getCtx getNetwork = lift getNetwork getBestBlock = lift getBestBlock @@ -260,10 +257,7 @@ getUnspent = lift . getUnspent getMempool = lift getMempool -instance - (MonadUnliftIO m, StoreReadBase m) => - StoreReadBase (CacheT m) - where +instance (StoreReadBase m) => StoreReadBase (CacheT m) where getCtx = lift getCtx getNetwork = lift getNetwork getBestBlock = lift getBestBlock diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoFieldSelectors #-} @@ -18,7 +15,6 @@ StoreReadExtra (..), StoreWrite (..), StoreEvent (..), - PubExcept (..), getActiveBlock, getActiveTxData, getDefaultBalance, @@ -53,8 +49,6 @@ yield, ($$++), ) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans.Reader (runReaderT) @@ -64,14 +58,12 @@ import Data.Hashable (Hashable) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) -import Data.Serialize (Serialize (..)) import Data.Time.Clock.System ( getSystemTime, systemNanoseconds, systemSeconds, ) import Data.Word (Word32, Word64) -import GHC.Generics (Generic) import Haskoin import Haskoin.Node (Chain, Peer) import Haskoin.Store.Data @@ -168,7 +160,7 @@ getActiveTxData :: (StoreReadBase m) => TxHash -> m (Maybe TxData) getActiveTxData th = getTxData th >>= \case - Just td | not (td.deleted) -> return (Just td) + Just td | not td.deleted -> return (Just td) _ -> return Nothing getDefaultBalance :: (StoreReadBase m) => Address -> m Balance @@ -267,31 +259,6 @@ | StorePeerPong !Peer !Word64 | StoreTxAnnounce !Peer ![TxHash] | StoreTxReject !Peer !TxHash !RejectCode !ByteString - -data PubExcept - = PubNoPeers - | PubReject RejectCode - | PubTimeout - | PubPeerDisconnected - deriving (Eq, NFData, Generic, Serialize) - -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 = "peer timeout or silent rejection" - show PubPeerDisconnected = "peer disconnected" - -instance Exception PubExcept applyLimits :: Limits -> [a] -> [a] applyLimits Limits {..} = applyLimit limit . applyOffset offset diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -47,7 +47,7 @@ forever, unless, when, - (<=<), + (<=<), void, ) import Control.Monad.Logger ( MonadLoggerIO, @@ -203,9 +203,8 @@ liftIO, newTVarIO, readTVarIO, - timeout, withAsync, - writeTVar, + writeTVar, async, ) import UnliftIO.Concurrent (threadDelay) import Web.Scotty.Trans qualified as S @@ -1174,56 +1173,25 @@ scottyPostTx (PostTx tx) = withMetrics (.txPost) $ do cfg <- askl (.config) - lift (publishTx cfg tx) >>= \case - Right () -> return (TxId (txHash tx)) - Left e@(PubReject _) -> raise $ UserError (show e) - _ -> raise ServerError + lift (publishTx cfg tx) + return (TxId (txHash tx)) --- | Publish a new transaction to the network. +-- | Send transaction to all connected peers. publishTx :: (MonadUnliftIO m, StoreReadBase m) => WebConfig -> Tx -> - m (Either PubExcept ()) -publishTx cfg tx = - withSubscription pub $ \s -> - getTransaction (txHash tx) >>= \case - Just _ -> return $ Right () - Nothing -> go s - where - pub = cfg.store.pub - mgr = cfg.store.peerMgr - net = cfg.store.net - go s = - getPeers mgr >>= \case - [] -> return $ Left PubNoPeers - OnlinePeer {mailbox = p} : _ -> do - MTx tx `sendMessage` p - let v = - if net.segWit - then InvWitnessTx - else InvTx - sendMessage - (MGetData (GetData [InvVector v (txHash tx).get])) - p - f p s - t = 5 * 1000 * 1000 - f p s - | cfg.noMempool = return $ Right () - | otherwise = - liftIO (UnliftIO.timeout t (g p s)) >>= \case - Nothing -> return $ Left PubTimeout - Just (Left e) -> return $ Left e - Just (Right ()) -> return $ Right () - g p s = - receive s >>= \case - StoreTxReject p' h' c _ - | p == p' && h' == txHash tx -> return . Left $ PubReject c - StorePeerDisconnected p' - | p == p' -> return $ Left PubPeerDisconnected - StoreMempoolNew h' - | h' == txHash tx -> return $ Right () - _ -> g p s + m () +publishTx cfg tx = do + ps <- getPeers cfg.store.peerMgr + let c = max 1 (length ps `div` 2) + forM_ (take c ps) $ \p -> do + sendMessage (MTx tx) p.mailbox + void . async $ do + threadDelay (5 * 1000 * 1000) + let v = if cfg.store.net.segWit then InvWitnessTx else InvTx + g = MGetData (GetData [InvVector v (txHash tx).get]) + sendMessage g p.mailbox -- GET Mempool / Events -- diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -17,21 +17,18 @@ import Data.ByteString qualified as B import Data.ByteString.Base64 import Data.Either -import Data.List -import Data.Maybe +import Data.List ( find ) +import Data.Maybe ( fromJust, fromMaybe, isJust, mapMaybe ) import Data.Serialize import Data.Time.Clock.POSIX import Data.Word import Haskoin import Haskoin.Node import Haskoin.Store -import Haskoin.Util.Arbitrary import NQE import Network.Socket import System.Random import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck import UnliftIO data TestStore = TestStore @@ -113,14 +110,14 @@ stats = Nothing, redisSyncInterval = 30 } - withStore cfg $ \Store {..} -> - withSubscription pub $ \sub -> + withStore cfg $ \store -> + withSubscription store.pub $ \sub -> lift $ f TestStore - { testStoreDB = db, - testStoreBlockStore = block, - testStoreChain = chain, + { testStoreDB = store.db, + testStoreBlockStore = store.block, + testStoreChain = store.chain, testStoreEvents = sub }