haskoin-store 0.29.3 → 0.30.0
raw patch · 6 files changed
+97/−65 lines, 6 filesdep ~haskoin-store-data
Dependency ranges changed: haskoin-store-data
Files
- haskoin-store.cabal +5/−5
- src/Haskoin/Store/BlockStore.hs +19/−20
- src/Haskoin/Store/Common.hs +1/−3
- src/Haskoin/Store/Database/Reader.hs +6/−2
- src/Haskoin/Store/Web.hs +63/−30
- test/Haskoin/StoreSpec.hs +3/−5
haskoin-store.cabal view
@@ -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
src/Haskoin/Store/BlockStore.hs view
@@ -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
src/Haskoin/Store/Common.hs view
@@ -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
src/Haskoin/Store/Database/Reader.hs view
@@ -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
src/Haskoin/Store/Web.hs view
@@ -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
test/Haskoin/StoreSpec.hs view
@@ -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)]