haskoin-store 1.2.2 → 1.2.3
raw patch · 6 files changed
+31/−108 lines, 6 filesdep ~nqe
Dependency ranges changed: nqe
Files
- haskoin-store.cabal +4/−4
- src/Haskoin/Store.hs +1/−4
- src/Haskoin/Store/Cache.hs +2/−8
- src/Haskoin/Store/Common.hs +1/−34
- src/Haskoin/Store/Web.hs +16/−48
- test/Haskoin/StoreSpec.hs +7/−10
haskoin-store.cabal view
@@ -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 <https://github.com/haskoin/haskoin-store#readme> 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
src/Haskoin/Store.hs view
@@ -27,10 +27,7 @@ getTransaction, getDefaultBalance, getActiveTxData,- blockAtOrBefore,-- -- * Other Data- PubExcept (..),+ blockAtOrBefore ) where
src/Haskoin/Store/Cache.hs view
@@ -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
src/Haskoin/Store/Common.hs view
@@ -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
src/Haskoin/Store/Web.hs view
@@ -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 --
test/Haskoin/StoreSpec.hs view
@@ -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 }