haskoin-store 0.29.1 → 0.29.3
raw patch · 11 files changed
+298/−390 lines, 11 filesdep ~haskoin-store-data
Dependency ranges changed: haskoin-store-data
Files
- app/Main.hs +7/−6
- haskoin-store.cabal +6/−6
- src/Haskoin/Store/BlockStore.hs +16/−16
- src/Haskoin/Store/Common.hs +22/−43
- src/Haskoin/Store/Database/Memory.hs +1/−1
- src/Haskoin/Store/Database/Reader.hs +18/−9
- src/Haskoin/Store/Database/Types.hs +36/−2
- src/Haskoin/Store/Database/Writer.hs +24/−35
- src/Haskoin/Store/Logic.hs +101/−224
- src/Haskoin/Store/Web.hs +62/−45
- test/Haskoin/StoreSpec.hs +5/−3
app/Main.hs view
@@ -27,7 +27,7 @@ option, progDesc, short, showDefault, strOption, switch, value) import Paths_haskoin_store as P-import System.Exit (die, exitSuccess)+import System.Exit (exitSuccess) import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe)@@ -59,7 +59,7 @@ defPort = 3000 defNetwork :: Network-defNetwork = btc+defNetwork = bch netNames :: String netNames = intercalate "|" (map getNetworkName allNets)@@ -220,13 +220,14 @@ when (configVersion conf) . liftIO $ do putStrLn $ showVersion P.version exitSuccess- when (null (configPeers conf) && not (configDiscover conf)) . liftIO $- die "ERROR: Specify peers to connect or enable peer discovery."- run conf+ if (null (configPeers conf) && not (configDiscover conf))+ then liftIO (run conf {configDiscover = True})+ else liftIO (run conf) where opts = info (helper <*> config) $- fullDesc <> progDesc "Blockchain store and API" <>+ fullDesc <>+ progDesc "Bitcoin (BCH & BTC) block chain index with HTTP API" <> Options.Applicative.header ("haskoin-store version " <> showVersion P.version)
haskoin-store.cabal view
@@ -1,13 +1,13 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: b813ab65689ab034b88aea9ae3e0c2745ba68a5df6f022afb2162a18d3ac88d7+-- hash: 4ffff37a722093203606f8826bb28c483e66a5abf4c685c832720a61901889a9 name: haskoin-store-version: 0.29.1+version: 0.29.3 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format.@@ -57,7 +57,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0- , haskoin-store-data ==0.29.1+ , haskoin-store-data ==0.29.3 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -99,7 +99,7 @@ , haskoin-core >=0.13.3 , haskoin-node >=0.13.0 , haskoin-store- , haskoin-store-data ==0.29.1+ , haskoin-store-data ==0.29.3 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -149,7 +149,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.3 , haskoin-node >=0.13.0- , haskoin-store-data ==0.29.1+ , haskoin-store-data ==0.29.3 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store/BlockStore.hs view
@@ -30,6 +30,8 @@ import Control.Applicative ((<|>)) import Control.Monad (forM, forM_, forever, mzero, unless, void, when)+import Control.Monad.Except (ExceptT, MonadError (..),+ runExceptT) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS, logWarnS) import Control.Monad.Reader (MonadReader, ReaderT (..), asks)@@ -68,13 +70,13 @@ managerPeerText) import Haskoin.Store.Common (StoreEvent (..), StoreRead (..), sortTxs)-import Haskoin.Store.Data (TxData (..), TxRef (..),+import Haskoin.Store.Data (TxRef (..), TxData (..), UnixTime, Unspent (..)) import Haskoin.Store.Database.Reader (DatabaseReader) import Haskoin.Store.Database.Writer (DatabaseWriter, runDatabaseWriter) import Haskoin.Store.Logic (ImportException (TxOrphan),- delTx, getOldMempool,+ deleteTx, getOldMempool, importBlock, initBest, newMempoolTx, revertBlock) import Network.Socket (SockAddr)@@ -84,10 +86,9 @@ import System.Random (randomRIO) import UnliftIO (Exception, MonadIO, MonadUnliftIO, STM, TVar,- atomically, catch, liftIO,- modifyTVar, newTVarIO, readTVar,- readTVarIO, throwIO, try,- withAsync, writeTVar)+ atomically, liftIO, modifyTVar,+ newTVarIO, readTVar, readTVarIO,+ throwIO, withAsync, writeTVar) import UnliftIO.Concurrent (threadDelay) -- | Messages for block store actor.@@ -165,18 +166,18 @@ type BlockT m = ReaderT BlockRead m runImport ::- (MonadLoggerIO m, MonadUnliftIO m)- => ReaderT DatabaseWriter m a+ MonadLoggerIO m+ => ReaderT DatabaseWriter (ExceptT ImportException m) a -> ReaderT BlockRead m (Either ImportException a) runImport f =- ReaderT $ \r -> try (runDatabaseWriter (blockConfDB (myConfig r)) f)+ ReaderT $ \r -> runExceptT (runDatabaseWriter (blockConfDB (myConfig r)) f) runRocksDB :: ReaderT DatabaseReader m a -> ReaderT BlockRead m a runRocksDB f = ReaderT $ \BlockRead {myConfig = BlockStoreConfig {blockConfDB = db}} -> runReaderT f db -instance MonadUnliftIO m => StoreRead (ReaderT BlockRead m) where+instance MonadIO m => StoreRead (ReaderT BlockRead m) where getMaxGap = runRocksDB getMaxGap getInitialGap = runRocksDB getInitialGap getNetwork = runRocksDB getNetwork@@ -218,7 +219,7 @@ "Wiping mempool tx " <> cs (show i) <> "/" <> cs (show n) <> ": " <> txHashToHex (txRefHash tx)- delTx (txRefHash tx)+ deleteTx True False (txRefHash tx) wipeit x n txs = do let (txs1, txs2) = splitAt 1000 txs case txs1 of@@ -462,7 +463,7 @@ case x of Just ls -> Right (th, ls) Nothing -> Left Nothing- catch f (h p)+ catchError f (h p) case output of Left e -> do $(logErrorS) "BlockStore" $@@ -587,11 +588,10 @@ deletetxs old = do forM_ (zip [(1 :: Int) ..] old) $ \(i, txid) -> do $(logInfoS) "BlockStore" $- "Removing old mempool tx " <> cs (show i) <> "/" <>- cs (show (length old)) <>- ": " <>+ "Removing " <> cs (show i) <> "/" <> cs (show (length old)) <>+ " old mempool tx " <> txHashToHex txid- runImport (delTx txid) >>= \case+ runImport (deleteTx True False txid) >>= \case Left _ -> return () Right txids -> do listener <- asks (blockConfListener . myConfig)
src/Haskoin/Store/Common.hs view
@@ -51,14 +51,13 @@ txHash) import Haskoin.Node (Peer) import Haskoin.Store.Data (Balance (..), BlockData (..),- DeriveType (..), Spender,- Transaction, TxData, TxRef (..),+ TxRef (..), DeriveType (..),+ Spender, Transaction, TxData, UnixTime, Unspent (..), XPubBal (..), XPubSpec (..), XPubSummary (..), XPubUnspent (..), nullBalance, toTransaction) import Network.Socket (SockAddr)-import UnliftIO (MonadUnliftIO, async, wait) type DeriveAddr = XPubKey -> KeyIndex -> Address @@ -86,7 +85,7 @@ instance Default Limits where def = defaultLimits -class MonadUnliftIO m =>+class Monad m => StoreRead m where getNetwork :: m Network@@ -111,13 +110,13 @@ xPubBals :: XPubSpec -> m [XPubBal] xPubBals xpub = do igap <- getInitialGap- gap <- fromIntegral <$> getMaxGap- ext1 <- go gap 0 0 0 [] (take (fromIntegral igap) (aderiv 0 0))+ gap <- getMaxGap+ ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0)) if all (nullBalance . xPubBal) ext1 then return [] else do- ext2 <- go gap 0 igap 0 [] (aderiv 0 igap)- chg <- go gap 1 0 0 [] (aderiv 1 0)+ ext2 <- derive_until_gap gap 0 (aderiv 0 igap)+ chg <- derive_until_gap gap 1 (aderiv 1 0) return (ext1 <> ext2 <> chg) where aderiv m n =@@ -125,22 +124,15 @@ (deriveFunction (xPubDeriveType xpub)) (pubSubKey (xPubSpecKey xpub) m) n- xbal m n b = XPubBal {xPubBalPath = [m, n], xPubBal = b}- go _gap _m _n _z [] [] = return []- go gap m n z ls as- | z >= gap = return []- | not (null as) && length ls < gap = do- let (as1, as2) = splitAt (gap - length ls) as- ls2 <- mapM (async . getBalance) (map snd as1)- go gap m n z (ls <> ls2) as2- | otherwise = do- let (l:ls2) = ls- b <- wait l- let z' =- if nullBalance b- then z + 1- else 0- (xbal m n b :) <$> go gap m (n + 1) z' ls2 as+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ _ [] = return []+ derive_until_gap gap m as = do+ let (as1, as2) = splitAt (fromIntegral gap) as+ bs <- getBalances (map snd as1)+ let xbs = zipWith (xbalance m) bs (map fst as1)+ if all nullBalance bs+ then return xbs+ else (xbs <>) <$> derive_until_gap gap m as2 xPubSummary :: XPubSpec -> m XPubSummary xPubSummary xpub = do bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub@@ -171,37 +163,24 @@ xPubUnspents :: XPubSpec -> Limits -> m [XPubUnspent] xPubUnspents xpub limits = do xs <- filter positive <$> xPubBals xpub- as <-- mapM- (async .- (`getAddressUnspents` deOffset limits) .- balanceAddress . xPubBal)- xs- sortBy (compare `on` unsblock) . applyLimits limits <$> go (zip xs as)+ sortBy (compare `on` unsblock) . applyLimits limits <$> go xs where unsblock = unspentBlock . xPubUnspent positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0 go [] = return []- go ((xbal, a'):xs) = do- uns <- wait a'+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a (deOffset limits) let xuns = map (\t ->- XPubUnspent- { xPubUnspentPath = xPubBalPath xbal- , xPubUnspent = t- })+ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}) uns (xuns <>) <$> go xs xPubTxs :: XPubSpec -> Limits -> m [TxRef] xPubTxs xpub limits = do bs <- xPubBals xpub- as <-- mapM- (async .- (`getAddressTxs` deOffset limits) . balanceAddress . xPubBal)- bs- ts <- concat <$> mapM wait as+ let as = map (balanceAddress . xPubBal) bs+ ts <- concat <$> mapM (\a -> getAddressTxs a (deOffset limits)) as let ts' = sortBy (flip compare `on` txRefBlock) (nub' ts) return $ applyLimits limits ts' getMaxGap :: m Word32
src/Haskoin/Store/Database/Memory.hs view
@@ -222,7 +222,7 @@ (hUnspent db) } -instance MonadUnliftIO m => StoreRead (ReaderT MemoryState m) where+instance MonadIO m => StoreRead (ReaderT MemoryState m) where getBestBlock = do v <- R.asks memoryDatabase >>= readTVarIO return $ getBestBlockH v
src/Haskoin/Store/Database/Reader.hs view
@@ -30,17 +30,18 @@ StoreRead (..), applyLimits, applyLimitsC, deOffset, nub') import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), Spender,- TxData (..), TxRef (..),+ BlockRef (..), TxRef (..),+ Spender, TxData (..), Unspent (..), zeroBalance) import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), BalKey (..), BestKey (..), BlockKey (..), HeightKey (..),- MemKey (..), SpenderKey (..),- TxKey (..), UnspentKey (..),- VersionKey (..), toUnspent,- valToBalance, valToUnspent)-import UnliftIO (MonadUnliftIO, MonadIO, liftIO)+ MemKey (..), OldMemKey (..),+ SpenderKey (..), TxKey (..),+ UnspentKey (..), VersionKey (..),+ toUnspent, valToBalance,+ valToUnspent)+import UnliftIO (MonadIO, liftIO) type DatabaseReaderT = ReaderT DatabaseReader @@ -83,18 +84,26 @@ withDatabaseReader = flip runReaderT initRocksDB :: MonadIO m => DatabaseReader -> m ()-initRocksDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do+initRocksDB bdb@DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do e <- runExceptT $ retrieve db opts VersionKey >>= \case Just v | v == dataVersion -> return ()+ | v == 15 -> migrate15to16 bdb >> initRocksDB bdb | otherwise -> throwError "Incorrect RocksDB database version" Nothing -> setInitRocksDB db case e of Left s -> error s Right () -> return () +migrate15to16 :: MonadIO m => DatabaseReader -> m ()+migrate15to16 DatabaseReader {databaseReadOptions = opts, databaseHandle = db} = do+ xs <- liftIO $ matchingAsList db opts OldMemKeyS+ let ys = map (\(OldMemKey t h, ()) -> (t, h)) xs+ insert db MemKey ys+ insert db VersionKey (16 :: Word32)+ setInitRocksDB :: MonadIO m => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion @@ -224,7 +233,7 @@ matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a b) _ -> matching db opts (AddrOutKeyA a) -instance MonadUnliftIO m => StoreRead (DatabaseReaderT m) where+instance MonadIO m => StoreRead (DatabaseReaderT m) where getNetwork = asks databaseNetwork getBestBlock = ask >>= getBestDatabaseReader getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h
src/Haskoin/Store/Database/Types.hs view
@@ -10,6 +10,7 @@ , BalKey(..) , HeightKey(..) , MemKey(..)+ , OldMemKey(..) , SpenderKey(..) , TxKey(..) , UnspentKey(..)@@ -41,8 +42,9 @@ OutPoint (..), TxHash, eitherToMaybe, scriptToAddressBS) import Haskoin.Store.Data (Balance (..), BlockData, BlockRef,- Spender, TxData, TxRef (..), UnixTime,- Unspent (..))+ TxRef (..), Spender, TxData,+ UnixTime, Unspent (..), getUnixTime,+ putUnixTime) -- | Database key for an address transaction. data AddrTxKey@@ -316,6 +318,38 @@ instance Key VersionKey instance KeyValue VersionKey Word32+++-- | Old mempool transaction database key.+data OldMemKey+ = OldMemKey+ { memTime :: !UnixTime+ , memKey :: !TxHash+ }+ | OldMemKeyT+ { memTime :: !UnixTime+ }+ | OldMemKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OldMemKey where+ -- 0x07 · UnixTime · TxHash+ put (OldMemKey t h) = do+ putWord8 0x07+ putUnixTime t+ put h+ -- 0x07 · UnixTime+ put (OldMemKeyT t) = do+ putWord8 0x07+ putUnixTime t+ -- 0x07+ put OldMemKeyS = putWord8 0x07+ get = do+ guard . (== 0x07) =<< getWord8+ OldMemKey <$> getUnixTime <*> get++instance Key OldMemKey+instance KeyValue OldMemKey () data BalVal = BalVal { balValAmount :: !Word64
src/Haskoin/Store/Database/Writer.hs view
@@ -9,6 +9,7 @@ import Control.Applicative ((<|>)) import Control.Monad (join)+import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -25,8 +26,8 @@ OutPoint (..), TxHash) import Haskoin.Store.Common (StoreRead (..), StoreWrite (..)) import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), Spender, TxData,- TxRef (..), Unspent,+ BlockRef (..), TxRef (..),+ Spender, TxData, Unspent, nullBalance, zeroBalance) import Haskoin.Store.Database.Memory (MemoryDatabase (..), MemoryState (..),@@ -43,8 +44,7 @@ OutVal, SpenderKey (..), TxKey (..), UnspentKey (..), UnspentVal (..))-import UnliftIO (MonadIO, MonadUnliftIO,- newTVarIO, readTVarIO)+import UnliftIO (MonadIO, newTVarIO, readTVarIO) data DatabaseWriter = DatabaseWriter { databaseWriterReader :: !DatabaseReader@@ -52,7 +52,7 @@ } runDatabaseWriter ::- MonadIO m+ (MonadIO m, MonadError e m) => DatabaseReader -> ReaderT DatabaseWriter m a -> m a@@ -219,58 +219,48 @@ setMempoolI :: MonadIO m => [TxRef] -> DatabaseWriter -> m () setMempoolI xs DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setMempool xs -getBestBlockI :: MonadUnliftIO m => DatabaseWriter -> m (Maybe BlockHash)+getBestBlockI :: MonadIO m => DatabaseWriter -> m (Maybe BlockHash) getBestBlockI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = runMaybeT $ MaybeT f <|> MaybeT g where f = withMemoryDatabase hm getBestBlock g = withDatabaseReader db getBestBlock -getBlocksAtHeightI ::- MonadUnliftIO m => BlockHeight -> DatabaseWriter -> m [BlockHash]-getBlocksAtHeightI bh DatabaseWriter { databaseWriterState = hm- , databaseWriterReader = db- } = do+getBlocksAtHeightI :: MonadIO m => BlockHeight -> DatabaseWriter -> m [BlockHash]+getBlocksAtHeightI bh DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = do xs <- withMemoryDatabase hm $ getBlocksAtHeight bh ys <- withDatabaseReader db $ getBlocksAtHeight bh return . nub $ xs <> ys -getBlockI ::- MonadUnliftIO m => BlockHash -> DatabaseWriter -> m (Maybe BlockData)-getBlockI bh DatabaseWriter { databaseWriterReader = db- , databaseWriterState = hm- } = runMaybeT $ MaybeT f <|> MaybeT g+getBlockI :: MonadIO m => BlockHash -> DatabaseWriter -> m (Maybe BlockData)+getBlockI bh DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ runMaybeT $ MaybeT f <|> MaybeT g where f = withMemoryDatabase hm $ getBlock bh g = withDatabaseReader db $ getBlock bh -getTxDataI :: MonadUnliftIO m => TxHash -> DatabaseWriter -> m (Maybe TxData)-getTxDataI th DatabaseWriter { databaseWriterReader = db- , databaseWriterState = hm- } = runMaybeT $ MaybeT f <|> MaybeT g+getTxDataI ::+ MonadIO m => TxHash -> DatabaseWriter -> m (Maybe TxData)+getTxDataI th DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ runMaybeT $ MaybeT f <|> MaybeT g where f = withMemoryDatabase hm $ getTxData th g = withDatabaseReader db $ getTxData th -getSpenderI ::- MonadUnliftIO m => OutPoint -> DatabaseWriter -> m (Maybe Spender)-getSpenderI op DatabaseWriter { databaseWriterReader = db- , databaseWriterState = hm- } = fmap join . runMaybeT $ MaybeT f <|> MaybeT g+getSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Spender)+getSpenderI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ fmap join . runMaybeT $ MaybeT f <|> MaybeT g where f = getSpenderH op <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getSpender op) -getSpendersI ::- MonadUnliftIO m => TxHash -> DatabaseWriter -> m (IntMap Spender)-getSpendersI t DatabaseWriter { databaseWriterReader = db- , databaseWriterState = hm- } = do+getSpendersI :: MonadIO m => TxHash -> DatabaseWriter -> m (IntMap Spender)+getSpendersI t DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = do hsm <- getSpendersH t <$> readTVarIO (memoryDatabase hm) dsm <- I.map Just <$> withDatabaseReader db (getSpenders t) return . I.map fromJust . I.filter isJust $ hsm <> dsm -getBalanceI :: MonadUnliftIO m => Address -> DatabaseWriter -> m Balance+getBalanceI :: MonadIO m => Address -> DatabaseWriter -> m Balance getBalanceI a DatabaseWriter { databaseWriterReader = db , databaseWriterState = hm } =@@ -295,8 +285,7 @@ setBalanceI b DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setBalance b -getUnspentI ::- MonadUnliftIO m => OutPoint -> DatabaseWriter -> m (Maybe Unspent)+getUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Unspent) getUnspentI op DatabaseWriter { databaseWriterReader = db , databaseWriterState = hm } = fmap join . runMaybeT $ MaybeT f <|> MaybeT g@@ -313,7 +302,7 @@ withMemoryDatabase hm $ deleteUnspent p getMempoolI ::- MonadUnliftIO m+ MonadIO m => DatabaseWriter -> m [TxRef] getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =@@ -321,7 +310,7 @@ Just xs -> return xs Nothing -> withDatabaseReader db getMempool -instance MonadUnliftIO m => StoreRead (ReaderT DatabaseWriter m) where+instance MonadIO m => StoreRead (ReaderT DatabaseWriter m) where getInitialGap = R.asks (databaseInitialGap . databaseWriterReader) getNetwork = R.asks (databaseNetwork . databaseWriterReader) getBestBlock = R.ask >>= getBestBlockI
src/Haskoin/Store/Logic.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Haskoin.Store.Logic ( ImportException (..)@@ -11,22 +10,20 @@ , revertBlock , importBlock , newMempoolTx- , delTx+ , deleteTx ) where import Control.Monad (forM, forM_, guard, unless, void, when, zipWithM_)-import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS,+import Control.Monad.Except (MonadError (..))+import Control.Monad.Logger (MonadLogger, logDebugS, logErrorS, logWarnS) import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short import Data.Either (rights)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet import qualified Data.IntMap.Strict as I-import Data.List (nub, sort)-import Data.Maybe (catMaybes, fromMaybe, isNothing)+import Data.List (sort, nub)+import Data.Maybe (fromMaybe, isNothing) import Data.Serialize (encode) import Data.String (fromString) import Data.String.Conversions (cs)@@ -45,13 +42,11 @@ import Haskoin.Store.Common (StoreRead (..), StoreWrite (..), nub', sortTxs) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), Prev (..),- Spender (..), TxData (..), TxRef (..),+ BlockRef (..), TxRef (..),+ Prev (..), Spender (..), TxData (..), UnixTime, Unspent (..), confirmed, nullBalance)-import UnliftIO (Async, Exception, MonadUnliftIO, TVar,- async, atomically, modifyTVar,- newTVarIO, readTVarIO, throwIO, wait)+import UnliftIO (Exception) data ImportException = PrevBlockNotBest !Text@@ -77,74 +72,11 @@ | DuplicatePrevOutput !Text deriving (Show, Read, Eq, Ord, Exception) -data BlockAccel =- BlockAccel- { utxas :: !(TVar (HashMap OutPoint (Async (Maybe Unspent))))- , balas :: !(TVar (HashMap Address (Async Balance)))- }--accelTxs :: (MonadUnliftIO m, StoreRead m) => [Tx] -> m BlockAccel-accelTxs txs = do- utxas' <-- fmap HashMap.fromList $- forM inops $ \op -> do- a <- async (getUnspent op)- return (op, a)- let f tx = map g (txOut tx)- g to =- case scriptToAddressBS (scriptOutput to) of- Left _ -> Nothing- Right a -> Just a- oaddrs = catMaybes (concatMap f txs)- balas' <-- fmap HashMap.fromList $- forM oaddrs $ \a -> do- a' <- async (getBalance a)- return (a, a')- utxas <- newTVarIO utxas'- balas <- newTVarIO balas'- return BlockAccel {..}- where- newops = HashSet.fromList (map txHash txs)- inops =- filter- (not . (`HashSet.member` newops) . outPointHash)- (concatMap- (filter (not . (== nullOutPoint)) . map prevOutput . txIn)- txs)--getAccelBalance ::- (MonadUnliftIO m, StoreRead m) => BlockAccel -> Address -> m Balance-getAccelBalance BlockAccel {..} a = do- balas' <- readTVarIO balas- case HashMap.lookup a balas' of- Nothing -> getBalance a- Just a' -> wait a'--delAccelBalance :: (MonadUnliftIO m) => BlockAccel -> Address -> m ()-delAccelBalance BlockAccel {..} a =- atomically $ modifyTVar balas (HashMap.delete a)--getAccelUnspent ::- (MonadUnliftIO m, StoreRead m)- => BlockAccel- -> OutPoint- -> m (Maybe Unspent)-getAccelUnspent BlockAccel {..} op = do- utxas' <- readTVarIO utxas- case HashMap.lookup op utxas' of- Nothing -> getUnspent op- Just a -> wait a--delAccelUnspent :: (MonadUnliftIO m) => BlockAccel -> OutPoint -> m ()-delAccelUnspent BlockAccel {..} op =- atomically $ modifyTVar utxas (HashMap.delete op)- initBest :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m ) => m () initBest = do@@ -160,11 +92,7 @@ getMempool newMempoolTx ::- ( StoreRead m- , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m- )+ (StoreRead m, StoreWrite m, MonadLogger m, MonadError ImportException m) => Tx -> UnixTime -> m (Maybe [TxHash])@@ -176,15 +104,13 @@ $(logDebugS) "BlockStore" $ "Transaction already in store: " <> txHashToHex (txHash tx) return Nothing- _ -> do- accel <- accelTxs [tx]- Just <$> importTx accel (MemRef w) w tx+ _ -> Just <$> importTx (MemRef w) w tx revertBlock :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m ) => BlockHash -> m [TxHash]@@ -193,24 +119,23 @@ getBestBlock >>= \case Nothing -> do $(logErrorS) "BlockStore" "Best block unknown"- throwIO BestBlockUnknown+ throwError BestBlockUnknown Just h -> getBlock h >>= \case Nothing -> do $(logErrorS) "BlockStore" "Best block not found"- throwIO (BestBlockNotFound (blockHashToHex h))+ throwError (BestBlockNotFound (blockHashToHex h)) Just b | h == bh -> return b | otherwise -> do $(logErrorS) "BlockStore" $ "Cannot delete block that is not head: " <> blockHashToHex h- throwIO (BlockNotBest (blockHashToHex bh))+ throwError (BlockNotBest (blockHashToHex bh)) txs <- mapM (fmap txData . getImportTxData) (blockDataTxs bd)- accel <- accelTxs txs ths <- nub' . concat <$>- mapM (deleteTx accel False False . txHash . snd) (reverse (sortTxs txs))+ mapM (deleteTx False False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} return ths@@ -218,8 +143,8 @@ importBlock :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m ) => Block -> BlockNode@@ -233,17 +158,16 @@ $(logErrorS) "BlockStore" $ "Cannot import non-genesis block at this point: " <> blockHashToHex (headerHash (blockHeader b))- throwIO BestBlockUnknown+ throwError BestBlockUnknown Just h | prevBlock (blockHeader b) == h -> return () | otherwise -> do $(logErrorS) "BlockStore" $ "Block does not build on head: " <> blockHashToHex (headerHash (blockHeader b))- throwIO $+ throwError $ PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n))) net <- getNetwork- accel <- accelTxs (blockTxns b) let subsidy = computeSubsidy net (nodeHeight n) insertBlock BlockData@@ -262,25 +186,26 @@ , blockDataOutputs = ts_out_val } bs <- getBlocksAtHeight (nodeHeight n)- setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n)+ setBlocksAtHeight+ (nub (headerHash (nodeHeader n) : bs))+ (nodeHeight n) setBest (headerHash (nodeHeader n)) ths <- nub' . concat <$>- mapM (uncurry (import_or_confirm accel mp)) (sortTxs (blockTxns b))+ mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b)) return ths where bths = map txHash (blockTxns b)- import_or_confirm accel mp x tx =+ import_or_confirm mp x tx = if txHash tx `elem` mp then getTxData (txHash tx) >>= \case- Just td -> confirmTx accel td (br x) tx >> return []+ Just td -> confirmTx td (br x) tx >> return [] Nothing -> do $(logErrorS) "BlockStore" $ "Cannot get data for mempool tx: " <> txHashToHex (txHash tx)- throwIO $ TxNotFound (txHashToHex (txHash tx))+ throwError $ TxNotFound (txHashToHex (txHash tx)) else importTx- accel (br x) (fromIntegral (blockTimestamp (nodeHeader n))) tx@@ -298,15 +223,14 @@ importTx :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> BlockRef+ => BlockRef -> Word64 -- ^ unix time -> Tx -> m [TxHash] -- ^ deleted transactions-importTx accel br tt tx = do+importTx br tt tx = do unless (confirmed br) $ do $(logDebugS) "BlockStore" $ "Importing transaction " <> txHashToHex (txHash tx)@@ -314,12 +238,12 @@ $(logErrorS) "BlockStore" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx)- throwIO (DuplicatePrevOutput (txHashToHex (txHash tx)))+ throwError (DuplicatePrevOutput (txHashToHex (txHash tx))) when iscb $ do $(logErrorS) "BlockStore" $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx)- throwIO (UnconfirmedCoinbase (txHashToHex (txHash tx)))+ throwError (UnconfirmedCoinbase (txHashToHex (txHash tx))) us' <- if iscb then return []@@ -331,15 +255,15 @@ sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do $(logErrorS) "BlockStore" $ "Insufficient funds for tx: " <> txHashToHex (txHash tx)- throwIO (InsufficientFunds (txHashToHex th))+ throwError (InsufficientFunds (txHashToHex th)) rbf <- isRBF br tx commit rbf us return ths where commit rbf us = do- zipWithM_ (spendOutput accel br (txHash tx)) [0 ..] us+ zipWithM_ (spendOutput br (txHash tx)) [0 ..] us zipWithM_- (\i o -> newOutput accel br (OutPoint (txHash tx) i) o)+ (\i o -> newOutput br (OutPoint (txHash tx) i) o) [0 ..] (txOut tx) let ps =@@ -357,10 +281,10 @@ , txDataTime = tt } insertTx d- updateAddressCounts accel (txDataAddresses d) (+ 1)+ updateAddressCounts (txDataAddresses d) (+ 1) unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br) uns op =- getAccelUnspent accel op >>= \case+ getUnspent op >>= \case Just u -> return (u, []) Nothing -> do $(logWarnS) "BlockStore" $@@ -377,13 +301,13 @@ fromString (show (outPointIndex op)) $(logErrorS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx)- throwIO (TxOrphan (txHashToHex (txHash tx)))+ throwError (TxOrphan (txHashToHex (txHash tx))) Just Spender {spenderHash = s} -> do $(logWarnS) "BlockStore" $ "Deleting transaction " <> txHashToHex s <> " because it conflicts with " <> txHashToHex (txHash tx)- ths <- deleteTx accel True (not (confirmed br)) s+ ths <- deleteTx True (not (confirmed br)) s getUnspent op >>= \case Nothing -> do $(logErrorS) "BlockStore" $@@ -391,7 +315,7 @@ txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))- throwIO (OutputSpent (cs (show op)))+ throwError (OutputSpent (cs (show op))) Just u -> return (u, ths) th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx))@@ -400,15 +324,14 @@ confirmTx :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> TxData+ => TxData -> BlockRef -> Tx -> m ()-confirmTx accel t br tx = do+confirmTx t br tx = do forM_ (txDataPrevs t) $ \p -> case scriptToAddressBS (prevScript p) of Left _ -> return ()@@ -425,7 +348,6 @@ s <- getSpender (OutPoint (txHash tx) n) when (isNothing s) $ do deleteUnspent op- delAccelUnspent accel op insertUnspent Unspent { unspentBlock = br@@ -468,8 +390,8 @@ eitherToMaybe (scriptToAddressBS (scriptOutput o)) }- reduceBalance accel False False a (outValue o)- increaseBalance accel True False a (outValue o)+ reduceBalance False False a (outValue o)+ increaseBalance True False a (outValue o) insertTx t {txDataBlock = br} deleteFromMempool (txHash tx) @@ -484,46 +406,22 @@ setMempool . reverse . sort $ TxRef {txRefBlock = MemRef unixtime, txRefHash = th} : mp -delTx ::- ( StoreRead m- , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m- )- => TxHash- -> m [TxHash] -- ^ deleted transactions-delTx th =- getTxData th >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot find tx to delete: " <> txHashToHex th- throwIO (TxNotFound (txHashToHex th))- Just t- | txDataDeleted t -> do- $(logWarnS) "BlockStore" $- "Already deleted tx: " <> txHashToHex th- return []- | otherwise -> do- accel <- accelTxs [txData t]- deleteTx accel True False th- deleteTx :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> Bool -- ^ only delete transaction if unconfirmed+ => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ do RBF check before deleting transaction -> TxHash -> m [TxHash] -- ^ deleted transactions-deleteTx accel memonly rbfcheck txhash = do+deleteTx memonly rbfcheck txhash = do getTxData txhash >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex txhash- throwIO (TxNotFound (txHashToHex txhash))+ throwError (TxNotFound (txHashToHex txhash)) Just t | txDataDeleted t -> do $(logWarnS) "BlockStore" $@@ -532,7 +430,7 @@ | memonly && confirmed (txDataBlock t) -> do $(logErrorS) "BlockStore" $ "Will not delete confirmed tx: " <> txHashToHex txhash- throwIO (TxConfirmed (txHashToHex txhash))+ throwError (TxConfirmed (txHashToHex txhash)) | rbfcheck -> isRBF (txDataBlock t) (txData t) >>= \case True -> go t@@ -540,7 +438,7 @@ $(logErrorS) "BlockStore" $ "Delete non-RBF transaction attempted: " <> txHashToHex txhash- throwIO $ CannotDeleteNonRBF (txHashToHex txhash)+ throwError $ CannotDeleteNonRBF (txHashToHex txhash) | otherwise -> go t where go t = do@@ -554,19 +452,19 @@ "Deleting descendant " <> txHashToHex s <> " to delete parent " <> txHashToHex txhash- deleteTx accel True rbfcheck s+ deleteTx True rbfcheck s forM_ (take (length (txOut (txData t))) [0 ..]) $ \n ->- delOutput accel (OutPoint txhash n)+ delOutput (OutPoint txhash n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ (unspendOutput accel) ps+ mapM_ unspendOutput ps unless (confirmed (txDataBlock t)) $ deleteFromMempool txhash insertTx t {txDataDeleted = True}- updateAddressCounts accel (txDataAddresses t) (subtract 1)+ updateAddressCounts (txDataAddresses t) (subtract 1) return $ nub' (txhash : ths) isRBF ::- (StoreRead m, MonadLoggerIO m)+ (StoreRead m, MonadLogger m, MonadError ImportException m) => BlockRef -> Tx -> m Bool@@ -589,7 +487,7 @@ Nothing -> do $(logErrorS) "BlockStore" $ "Transaction not found: " <> txHashToHex h- throwIO (TxNotFound (txHashToHex h))+ throwError (TxNotFound (txHashToHex h)) Just t | confirmed (txDataBlock t) -> ck hs' | txDataRBF t -> return True@@ -599,16 +497,13 @@ newOutput :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m )- => BlockAccel- -> BlockRef+ => BlockRef -> OutPoint -> TxOut -> m ()-newOutput accel br op to = do- delAccelUnspent accel op+newOutput br op to = do insertUnspent u case scriptToAddressBS (scriptOutput to) of Left _ -> return ()@@ -617,7 +512,7 @@ insertAddrTx a TxRef {txRefHash = outPointHash op, txRefBlock = br}- increaseBalance accel (confirmed br) True a (outValue to)+ increaseBalance (confirmed br) True a (outValue to) where u = Unspent@@ -632,13 +527,12 @@ delOutput :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> OutPoint+ => OutPoint -> m ()-delOutput accel op = do+delOutput op = do t <- getImportTxData (outPointHash op) u <- case getTxOut (outPointIndex op) (txData t) of@@ -648,8 +542,7 @@ "Output out of range: " <> txHashToHex (txHash (txData t)) <> " " <> fromString (show (outPointIndex op))- throwIO . OutputOutOfRange . cs $ show op- delAccelUnspent accel op+ throwError . OutputOutOfRange . cs $ show op deleteUnspent op case scriptToAddressBS (scriptOutput u) of Left _ -> return ()@@ -670,21 +563,21 @@ { txRefHash = outPointHash op , txRefBlock = txDataBlock t }- reduceBalance accel (confirmed (txDataBlock t)) True a (outValue u)+ reduceBalance (confirmed (txDataBlock t)) True a (outValue u) getImportTxData ::- (StoreRead m, MonadLoggerIO m)+ (StoreRead m, MonadLogger m, MonadError ImportException m) => TxHash -> m TxData getImportTxData th = getTxData th >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th- throwIO $ TxNotFound (txHashToHex th)+ throwError $ TxNotFound (txHashToHex th) Just d | txDataDeleted d -> do $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th- throwIO $ TxDeleted (txHashToHex th)+ throwError $ TxDeleted (txHashToHex th) | otherwise -> return d getTxOut@@ -698,48 +591,44 @@ spendOutput :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> BlockRef+ => BlockRef -> TxHash -> Word32 -> Unspent -> m ()-spendOutput accel br th ix u = do+spendOutput br th ix u = do insertSpender (unspentPoint u) Spender {spenderHash = th, spenderIndex = ix} case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do reduceBalance- accel (confirmed (unspentBlock u)) False a (unspentAmount u) deleteAddrUnspent a u insertAddrTx a TxRef {txRefHash = th, txRefBlock = br}- delAccelUnspent accel (unspentPoint u) deleteUnspent (unspentPoint u) unspendOutput :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> OutPoint+ => OutPoint -> m ()-unspendOutput accel op = do+unspendOutput op = do t <- getImportTxData (outPointHash op) o <- case getTxOut (outPointIndex op) (txData t) of Nothing -> do $(logErrorS) "BlockStore" $ "Output out of range: " <> cs (show op)- throwIO (OutputOutOfRange (cs (show op)))+ throwError (OutputOutOfRange (cs (show op))) Just o -> return o s <- getSpender op >>= \case@@ -748,7 +637,7 @@ "Output already unspent: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))- throwIO (AlreadyUnspent (cs (show op)))+ throwError (AlreadyUnspent (cs (show op))) Just s -> return s x <- getImportTxData (spenderHash s) deleteSpender op@@ -761,7 +650,6 @@ , unspentPoint = op , unspentAddress = m }- delAccelUnspent accel op insertUnspent u case m of Nothing -> return ()@@ -772,7 +660,6 @@ TxRef {txRefHash = spenderHash s, txRefBlock = txDataBlock x} increaseBalance- accel (confirmed (unspentBlock u)) False a@@ -781,23 +668,22 @@ reduceBalance :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m+ , MonadError ImportException m )- => BlockAccel- -> Bool -- ^ spend or delete confirmed output+ => Bool -- ^ spend or delete confirmed output -> Bool -- ^ reduce total received -> Address -> Word64 -> m ()-reduceBalance accel c t a v = do+reduceBalance c t a v = do net <- getNetwork- b <- getAccelBalance accel a+ b <- getBalance a if nullBalance b then do $(logErrorS) "BlockStore" $ "Address balance not found: " <> addrText net a- throwIO (BalanceNotFound (addrText net a))+ throwError (BalanceNotFound (addrText net a)) else do when (v > amnt b) $ do $(logErrorS) "BlockStore" $@@ -807,11 +693,10 @@ ", has: " <> cs (show (amnt b)) <> ")"- throwIO $+ throwError $ if c then InsufficientBalance (addrText net a) else InsufficientZeroBalance (addrText net a)- delAccelBalance accel a setBalance b { balanceAmount =@@ -844,18 +729,15 @@ increaseBalance :: ( StoreRead m , StoreWrite m- , MonadLoggerIO m- , MonadUnliftIO m+ , MonadLogger m )- => BlockAccel- -> Bool -- ^ add confirmed output+ => Bool -- ^ add confirmed output -> Bool -- ^ increase total received -> Address -> Word64 -> m ()-increaseBalance accel c t a v = do- b <- getAccelBalance accel a- delAccelBalance accel a+increaseBalance c t a v = do+ b <- getBalance a setBalance b { balanceAmount =@@ -877,23 +759,18 @@ } updateAddressCounts ::- ( StoreWrite m- , StoreRead m- , MonadUnliftIO m- )- => BlockAccel- -> [Address]+ (StoreWrite m, StoreRead m, Monad m, MonadError ImportException m)+ => [Address] -> (Word64 -> Word64) -> m ()-updateAddressCounts accel as f =+updateAddressCounts as f = forM_ as $ \a -> do b <- do net <- getNetwork- b <- getAccelBalance accel a+ b <- getBalance a if nullBalance b- then throwIO (BalanceNotFound (addrText net a))+ then throwError (BalanceNotFound (addrText net a)) else return b- delAccelBalance accel a setBalance b {balanceTxCount = f (balanceTxCount b)} txDataAddresses :: TxData -> [Address]
src/Haskoin/Store/Web.hs view
@@ -183,7 +183,7 @@ return StartParamTime {startParamTime = x} runInWebReader ::- MonadUnliftIO m+ MonadIO m => CacheT (DatabaseReaderT m) a -> ReaderT WebConfig m a runInWebReader f = do@@ -218,6 +218,27 @@ xPubUnspents xpub = runInWebReader . xPubUnspents xpub xPubTxs xpub = runInWebReader . xPubTxs xpub +instance (MonadUnliftIO m, MonadLoggerIO m) => StoreRead (WebT m) where+ getNetwork = lift getNetwork+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getSpender = lift . getSpender+ getSpenders = lift . getSpenders+ getUnspent = lift . getUnspent+ getBalance = lift . getBalance+ getBalances = lift . getBalances+ getMempool = lift getMempool+ getAddressesTxs as = lift . getAddressesTxs as+ getAddressesUnspents as = lift . getAddressesUnspents as+ xPubBals = lift . xPubBals+ xPubSummary = lift . xPubSummary+ xPubUnspents xpub = lift . xPubUnspents xpub+ xPubTxs xpub = lift . xPubTxs xpub+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap+ defHandler :: Monad m => Except -> WebT m () defHandler e = do proto <- setupBin@@ -277,8 +298,8 @@ proto <- setupBin bm <- runMaybeT $ do- h <- MaybeT (lift getBestBlock)- MaybeT (lift (getBlock h))+ h <- MaybeT getBestBlock+ MaybeT $ getBlock h b <- case bm of Nothing -> S.raise ThingNotFound@@ -286,7 +307,7 @@ if raw then do refuseLargeBlock limits b- lift (rawBlock b) >>= protoSerial proto+ rawBlock b >>= protoSerial proto else protoSerialNet proto blockDataToEncoding (pruneTx n b) scottyBlock :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()@@ -297,13 +318,13 @@ n <- parseNoTx proto <- setupBin b <-- lift (getBlock block) >>= \case+ getBlock block >>= \case Nothing -> S.raise ThingNotFound Just b -> return b if raw then do refuseLargeBlock limits b- lift (rawBlock b) >>= protoSerial proto+ rawBlock b >>= protoSerial proto else protoSerialNet proto blockDataToEncoding (pruneTx n b) scottyBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()@@ -313,15 +334,15 @@ height <- S.param "height" n <- parseNoTx proto <- setupBin- hs <- lift (getBlocksAtHeight height)+ hs <- getBlocksAtHeight height if raw then do- blocks <- catMaybes <$> mapM (lift . getBlock) hs+ blocks <- catMaybes <$> mapM getBlock hs mapM_ (refuseLargeBlock limits) blocks- rawblocks <- mapM (lift . rawBlock) blocks+ rawblocks <- mapM rawBlock blocks protoSerial proto rawblocks else do- blocks <- catMaybes <$> mapM (lift . getBlock) hs+ blocks <- catMaybes <$> mapM getBlock hs let blocks' = map (pruneTx n) blocks protoSerialNet proto (list . blockDataToEncoding) blocks' @@ -332,14 +353,14 @@ q <- S.param "time" n <- parseNoTx proto <- setupBin- m <- fmap (pruneTx n) <$> lift (blockAtOrBefore q)+ m <- fmap (pruneTx n) <$> blockAtOrBefore q if raw then maybeSerial proto =<< case m of Nothing -> return Nothing Just d -> do refuseLargeBlock limits d- Just <$> lift (rawBlock d)+ Just <$> rawBlock d else maybeSerialNet proto blockDataToEncoding m scottyBlockHeights :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -348,8 +369,8 @@ heights <- S.param "heights" n <- parseNoTx proto <- setupBin- bhs <- concat <$> mapM (lift . getBlocksAtHeight) (heights :: [BlockHeight])- blocks <- map (pruneTx n) . catMaybes <$> mapM (lift . getBlock) bhs+ bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])+ blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs protoSerialNet proto (list . blockDataToEncoding) blocks scottyBlockLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -357,7 +378,7 @@ setHeaders n <- parseNoTx proto <- setupBin- lift getBestBlock >>= \case+ getBestBlock >>= \case Just h -> do blocks <- reverse <$> go 100 n h protoSerialNet proto (list . blockDataToEncoding) blocks@@ -365,7 +386,7 @@ where go 0 _ _ = return [] go i n h =- lift (getBlock h) >>= \case+ getBlock h >>= \case Nothing -> return [] Just b -> let b' = pruneTx n b@@ -382,14 +403,14 @@ bhs <- map (\(MyBlockHash h) -> h) <$> S.param "blocks" n <- parseNoTx proto <- setupBin- bks <- map (pruneTx n) . catMaybes <$> mapM (lift . getBlock) (nub bhs)+ bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs) protoSerialNet proto (list . blockDataToEncoding) bks scottyMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyMempool = do setHeaders proto <- setupBin- txs <- map txRefHash <$> lift getMempool+ txs <- map txRefHash <$> getMempool protoSerial proto txs scottyTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -397,7 +418,7 @@ setHeaders MyTxHash txid <- S.param "txid" proto <- setupBin- res <- lift (getTransaction txid)+ res <- getTransaction txid maybeSerialNet proto transactionToEncoding res scottyRawTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -405,7 +426,7 @@ setHeaders MyTxHash txid <- S.param "txid" proto <- setupBin- res <- fmap transactionData <$> lift (getTransaction txid)+ res <- fmap transactionData <$> getTransaction txid maybeSerial proto res scottyTxAfterHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -414,7 +435,7 @@ MyTxHash txid <- S.param "txid" height <- S.param "height" proto <- setupBin- res <- lift (cbAfterHeight 10000 height txid)+ res <- cbAfterHeight 10000 height txid protoSerial proto res scottyTransactions :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -422,7 +443,7 @@ setHeaders txids <- map (\(MyTxHash h) -> h) <$> S.param "txids" proto <- setupBin- txs <- catMaybes <$> mapM (lift . getTransaction) (nub txids)+ txs <- catMaybes <$> mapM getTransaction (nub txids) protoSerialNet proto (list . transactionToEncoding) txs scottyBlockTransactions :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -431,11 +452,11 @@ setHeaders MyBlockHash h <- S.param "block" proto <- setupBin- lift (getBlock h) >>= \case+ getBlock h >>= \case Just b -> do refuseLargeBlock limits b let ths = blockDataTxs b- txs <- catMaybes <$> mapM (lift . getTransaction) ths+ txs <- catMaybes <$> mapM getTransaction ths protoSerialNet proto (list . transactionToEncoding) txs Nothing -> S.raise ThingNotFound @@ -445,9 +466,7 @@ setHeaders txids <- map (\(MyTxHash h) -> h) <$> S.param "txids" proto <- setupBin- txs <-- map transactionData . catMaybes <$>- mapM (lift . getTransaction) (nub txids)+ txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids) protoSerial proto txs rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block@@ -464,13 +483,11 @@ setHeaders MyBlockHash h <- S.param "block" proto <- setupBin- lift (getBlock h) >>= \case+ getBlock h >>= \case Just b -> do refuseLargeBlock limits b let ths = blockDataTxs b- txs <-- map transactionData . catMaybes <$>- mapM (lift . getTransaction) ths+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths protoSerial proto txs Nothing -> S.raise ThingNotFound @@ -482,10 +499,10 @@ proto <- setupBin if full then do- lift (getAddressTxsFull l a) >>=+ getAddressTxsFull l a >>= protoSerialNet proto (list . transactionToEncoding) else do- lift (getAddressTxsLimit l a) >>= protoSerial proto+ getAddressTxsLimit l a >>= protoSerial proto scottyAddressesTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()@@ -495,9 +512,9 @@ l <- getLimits full proto <- setupBin if full- then lift (getAddressesTxsFull l as) >>=+ then getAddressesTxsFull l as >>= protoSerialNet proto (list . transactionToEncoding)- else lift (getAddressesTxsLimit l as) >>= protoSerial proto+ else getAddressesTxsLimit l as >>= protoSerial proto scottyAddressUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyAddressUnspent = do@@ -505,7 +522,7 @@ a <- parseAddress l <- getLimits False proto <- setupBin- uns <- lift (getAddressUnspentsLimit l a)+ uns <- getAddressUnspentsLimit l a protoSerialNet proto (list . unspentToEncoding) uns scottyAddressesUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -514,7 +531,7 @@ as <- parseAddresses l <- getLimits False proto <- setupBin- uns <- lift (getAddressesUnspentsLimit l as)+ uns <- getAddressesUnspentsLimit l as protoSerialNet proto (list . unspentToEncoding) uns scottyAddressBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -522,7 +539,7 @@ setHeaders a <- parseAddress proto <- setupBin- res <- lift (getBalance a)+ res <- getBalance a protoSerialNet proto balanceToEncoding res scottyAddressesBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -530,7 +547,7 @@ setHeaders as <- parseAddresses proto <- setupBin- res <- lift (getBalances as)+ res <- getBalances as protoSerialNet proto (list . balanceToEncoding) res scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()@@ -742,16 +759,16 @@ where start_height h = return $ AtBlock h start_block h = do- b <- MaybeT $ lift (getBlock (BlockHash h))+ b <- MaybeT $ getBlock (BlockHash h) return $ AtBlock (blockDataHeight b) start_tx h = do- _ <- MaybeT $ lift (getTxData (TxHash h))+ _ <- MaybeT $ getTxData (TxHash h) return $ AtTx (TxHash h) start_time q = do- d <- MaybeT (lift getBestBlock) >>= MaybeT . lift . getBlock+ d <- MaybeT getBestBlock >>= MaybeT . getBlock if q <= fromIntegral (blockTimestamp (blockDataHeader d)) then do- b <- MaybeT (lift (blockAtOrBefore q))+ b <- MaybeT $ blockAtOrBefore q let g = blockDataHeight b return $ AtBlock g else mzero@@ -949,11 +966,11 @@ getAllowMinDifficultyBlocks net || to == 0 || td' <= to- peer_count = fmap length <$> timeout 500000 (managerGetPeers mgr)+ peer_count = fmap length <$> timeout 10000000 (managerGetPeers mgr) block_best = runMaybeT $ do h <- MaybeT getBestBlock MaybeT $ getBlock h- chain_best = timeout 500000 $ chainGetBest ch+ chain_best = timeout 10000000 $ chainGetBest ch compute_delta a b = if b > a then b - a else 0 -- | Obtain information about connected peers from peer manager process.
test/Haskoin/StoreSpec.hs view
@@ -7,6 +7,7 @@ import Conduit import Control.Monad import Control.Monad.Logger+import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Base64@@ -18,6 +19,7 @@ import Haskoin import Haskoin.Node import Haskoin.Store+import Haskoin.Store.Common import Network.Socket import NQE import System.Random@@ -115,7 +117,7 @@ fromRight (error "Could not decode blocks") $ runGet f (decodeBase64Lenient allBlocksBase64) where- f = mapM (const get) [(1 :: Int) .. 15]+ f = mapM (const get) [1..15] allBlocksBase64 :: ByteString allBlocksBase64 =@@ -191,7 +193,7 @@ forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact .| outc .| awaitForever (`send` s)- outc = mapMC $ \msg' -> return $ runPut (putMessage net msg')+ outc = mapMC $ \msg -> return $ runPut (putMessage net msg) inc = forever $ do x <- takeCE 24 .| foldC@@ -203,7 +205,7 @@ Left e -> error $ "Dummy peer could not decode payload: " <> show e- Right msg' -> yield msg'+ Right msg -> yield msg mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]