diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4ffff37a722093203606f8826bb28c483e66a5abf4c685c832720a61901889a9 +-- hash: c33ef398531e66206867203d7fd8c2a0cdcd3a4e7f870313d9634c2a2818c5b2 name: haskoin-store -version: 0.29.3 +version: 0.30.0 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.3 + , haskoin-store-data ==0.30.0 , 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.3 + , haskoin-store-data ==0.30.0 , 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.3 + , haskoin-store-data ==0.30.0 , 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 @@ -427,6 +427,10 @@ Just TxData {txDataDeleted = True} -> return False Just TxData {txDataDeleted = False} -> return True +data MemImport + = MemOrphan !PendingTx + | MemImported !TxHash ![TxHash] + processMempool :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m () processMempool = do allPendingTxs >>= \txs -> @@ -444,35 +448,30 @@ Nothing -> return (Just h) Just _ -> return Nothing addPendingTx $ p {pendingDeps = ex} - go ps = do + go txs = do output <- - runImport . forM (zip [(1 :: Int) ..] ps) $ \(i, p) -> do + runImport . fmap catMaybes . forM txs $ \p -> do let tx = pendingTx p t = pendingTxTime p th = txHash tx - h x TxOrphan {} = return (Left (Just x)) - h _ _ = return (Left Nothing) - let f = do - x <- newMempoolTx tx t - $(logInfoS) "BlockStore" $ - "New mempool tx " <> cs (show i) <> "/" <> - cs (show (length ps)) <> - ": " <> - txHashToHex th - return $ - case x of - Just ls -> Right (th, ls) - Nothing -> Left Nothing - catchError f (h p) + h TxOrphan {} = return (Just (MemOrphan p)) + h _ = return Nothing + f = + newMempoolTx tx t >>= \case + Just ls -> do + $(logInfoS) "BlockStore" $ + "New mempool tx: " <> txHashToHex th + return (Just (MemImported th ls)) + Nothing -> return Nothing + catchError f h case output of Left e -> do $(logErrorS) "BlockStore" $ - "Importing mempool failed: " <> cs (show e) + "Mempool import failed: " <> cs (show e) Right xs -> do forM_ xs $ \case - Left (Just p) -> pend p - Left Nothing -> return () - Right (th, deleted) -> do + MemOrphan p -> pend p + MemImported th deleted -> do fulfillOrphans th l <- asks (blockConfListener . myConfig) atomically $ do 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 @@ -180,9 +180,7 @@ xPubTxs xpub limits = do bs <- xPubBals xpub 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' + getAddressesTxs as limits getMaxGap :: m Word32 getInitialGap :: m Word32 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 @@ -183,9 +183,13 @@ matchingSkip db opts (AddrTxKeyA a) (AddrTxKeyB a b) _ -> matching db opts (AddrTxKeyA a) Just (AtBlock bh) -> - matching db opts (AddrTxKeyB a (BlockRef bh maxBound)) + matchingSkip + db + opts + (AddrTxKeyA a) + (AddrTxKeyB a (BlockRef bh maxBound)) f AddrTxKey {addrTxKeyT = t} () = t - f _ _ = undefined + f _ _ = undefined getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent) getUnspentDB p DatabaseReader { databaseReadOptions = opts 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 @@ -13,8 +13,8 @@ import Conduit () import Control.Applicative ((<|>)) -import Control.Monad (forever, guard, mzero, unless, - when, (<=<)) +import Control.Monad (forever, guard, unless, when, + (<=<)) import Control.Monad.Logger (MonadLogger, MonadLoggerIO, askLoggerIO, logInfoS, monadLoggerLog) @@ -23,9 +23,11 @@ import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Aeson (Encoding, ToJSON (..)) -import Data.Aeson.Encoding (encodingToLazyByteString, list) +import Data.Aeson.Encoding (encodingToLazyByteString, list, + pair, pairs, unsafeToEncoding) import qualified Data.ByteString as B -import Data.ByteString.Builder (lazyByteString) +import Data.ByteString.Builder (char7, lazyByteString, + lazyByteStringHex) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C import Data.Char (isSpace) @@ -37,6 +39,7 @@ import Data.String.Conversions (cs) import Data.Text (Text) import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime, systemSeconds) @@ -66,15 +69,14 @@ StoreRead (..), blockAtOrBefore, getTransaction, nub') import Haskoin.Store.Data (BlockData (..), BlockRef (..), - TxRef (..), DeriveType (..), - Event (..), Except (..), - GenericResult (..), + DeriveType (..), Event (..), + Except (..), GenericResult (..), HealthCheck (..), PeerInformation (..), StoreInput (..), Transaction (..), TxId (..), - UnixTime, Unspent, XPubBal (..), - XPubSpec (..), + TxRef (..), UnixTime, Unspent, + XPubBal (..), XPubSpec (..), balanceToEncoding, blockDataToEncoding, isCoinbase, nullBalance, transactionData, @@ -171,14 +173,15 @@ parseParam s = maybe (Left "could not decode start") Right (h <|> g <|> t) where h = do - x <- fmap B.reverse (decodeHex (cs s)) >>= eitherToMaybe . decode + guard (TL.length s == 32 * 2) + x <- fmap B.reverse (decodeHex (TL.toStrict s)) >>= eitherToMaybe . decode return StartParamHash {startParamHash = x} g = do - x <- readMaybe (cs s) :: Maybe Integer - guard $ 0 <= x && x <= 1230768000 - return StartParamHeight {startParamHeight = fromIntegral x} + x <- readMaybe (TL.unpack s) + guard $ x <= 1230768000 + return StartParamHeight {startParamHeight = x} t = do - x <- readMaybe (cs s) + x <- readMaybe (TL.unpack s) guard $ x > 1230768000 return StartParamTime {startParamTime = x} @@ -257,9 +260,12 @@ -> Maybe a -> WebT m () maybeSerial _ Nothing = S.raise ThingNotFound -maybeSerial proto (Just x) = do - S.raw (serialAny proto x) +maybeSerial proto (Just x) = S.raw (serialAny proto x) +maybeSerialRaw :: (Monad m, Serialize a) => Bool -> Maybe a -> WebT m () +maybeSerialRaw _ Nothing = S.raise ThingNotFound +maybeSerialRaw proto (Just x) = S.raw (serialAnyRaw proto x) + maybeSerialNet :: (Monad m, Serialize a) => Bool @@ -279,6 +285,22 @@ protoSerial proto x = do S.raw (serialAny proto x) +protoSerialRaw :: + (Monad m, Serialize a) + => Bool + -> a + -> WebT m () +protoSerialRaw proto x = do + S.raw (serialAnyRaw proto x) + +protoSerialRawList :: + (Monad m, Serialize a) + => Bool + -> [a] + -> WebT m () +protoSerialRawList proto x = do + S.raw (serialAnyRawList proto x) + protoSerialNet :: (Monad m, Serialize a) => Bool @@ -307,7 +329,7 @@ if raw then do refuseLargeBlock limits b - rawBlock b >>= protoSerial proto + rawBlock b >>= protoSerialRaw proto else protoSerialNet proto blockDataToEncoding (pruneTx n b) scottyBlock :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m () @@ -324,7 +346,7 @@ if raw then do refuseLargeBlock limits b - rawBlock b >>= protoSerial proto + rawBlock b >>= protoSerialRaw proto else protoSerialNet proto blockDataToEncoding (pruneTx n b) scottyBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m () @@ -340,7 +362,7 @@ blocks <- catMaybes <$> mapM getBlock hs mapM_ (refuseLargeBlock limits) blocks rawblocks <- mapM rawBlock blocks - protoSerial proto rawblocks + protoSerialRawList proto rawblocks else do blocks <- catMaybes <$> mapM getBlock hs let blocks' = map (pruneTx n) blocks @@ -427,7 +449,7 @@ MyTxHash txid <- S.param "txid" proto <- setupBin res <- fmap transactionData <$> getTransaction txid - maybeSerial proto res + maybeSerialRaw proto res scottyTxAfterHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyTxAfterHeight = do @@ -467,7 +489,7 @@ txids <- map (\(MyTxHash h) -> h) <$> S.param "txids" proto <- setupBin txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids) - protoSerial proto txs + protoSerialRawList proto txs rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block rawBlock b = do @@ -488,7 +510,7 @@ refuseLargeBlock limits b let ths = blockDataTxs b txs <- map transactionData . catMaybes <$> mapM getTransaction ths - protoSerial proto txs + protoSerialRawList proto txs Nothing -> S.raise ThingNotFound scottyAddressTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m () @@ -757,7 +779,8 @@ StartParamHeight {startParamHeight = h} -> start_height h StartParamTime {startParamTime = q} -> start_time q where - start_height h = return $ AtBlock h + start_height h = do + return $ AtBlock h start_block h = do b <- MaybeT $ getBlock (BlockHash h) return $ AtBlock (blockDataHeight b) @@ -765,13 +788,9 @@ _ <- MaybeT $ getTxData (TxHash h) return $ AtTx (TxHash h) start_time q = do - d <- MaybeT getBestBlock >>= MaybeT . getBlock - if q <= fromIntegral (blockTimestamp (blockDataHeader d)) - then do - b <- MaybeT $ blockAtOrBefore q - let g = blockDataHeight b - return $ AtBlock g - else mzero + b <- MaybeT $ blockAtOrBefore q + let g = blockDataHeight b + return $ AtBlock g getLimits :: (MonadLoggerIO m, MonadUnliftIO m) => Bool -> WebT m Limits getLimits full = do @@ -874,6 +893,20 @@ -> L.ByteString serialAny True = runPutLazy . put serialAny False = encodingToLazyByteString . toEncoding + +serialAnyRaw :: Serialize a => Bool -> a -> L.ByteString +serialAnyRaw True x = runPutLazy (put x) +serialAnyRaw False x = encodingToLazyByteString (pairs ps) + where + ps = "result" `pair` unsafeToEncoding str + str = char7 '"' <> lazyByteStringHex (runPutLazy (put x)) <> char7 '"' + +serialAnyRawList :: Serialize a => Bool -> [a] -> L.ByteString +serialAnyRawList True x = runPutLazy (put x) +serialAnyRawList False xs = encodingToLazyByteString (list f xs) + where + f x = unsafeToEncoding (str x) + str x = char7 '"' <> lazyByteStringHex (runPutLazy (put x)) <> char7 '"' serialAnyNet :: Serialize a => Bool -> (a -> Encoding) -> a -> L.ByteString diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -7,7 +7,6 @@ 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 @@ -19,7 +18,6 @@ import Haskoin import Haskoin.Node import Haskoin.Store -import Haskoin.Store.Common import Network.Socket import NQE import System.Random @@ -117,7 +115,7 @@ fromRight (error "Could not decode blocks") $ runGet f (decodeBase64Lenient allBlocksBase64) where - f = mapM (const get) [1..15] + f = mapM (const get) [(1 :: Int) .. 15] allBlocksBase64 :: ByteString allBlocksBase64 = @@ -193,7 +191,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 @@ -205,7 +203,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)]