diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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) 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 @@ -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 diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs --- a/src/Haskoin/Store/Database/Memory.hs +++ b/src/Haskoin/Store/Database/Memory.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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] 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 @@ -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. diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -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)]