diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,13 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) +## 0.52.5 +### Added +- Support for Blockchain.info export-history endpoint. + +### Fixed +- Use strict bytestring decoder for HTTP API client. + ## 0.52.4 ### Fixed - Use Base58 addresses by default in Blockchain.info balance querios. 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: c16fdfbfaeb6b0c31ab673c5c9bb78d75c36fb522954b9d2675fcabff47dd2ed +-- hash: 0c15a0b65526707734b070de3a84432ae82ec165726454c0b956cbb1754fb5ab name: haskoin-store -version: 0.52.4 +version: 0.52.5 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -61,7 +61,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.52.0 + , haskoin-store-data ==0.52.5 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -115,7 +115,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.52.0 + , haskoin-store-data ==0.52.5 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -174,7 +174,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.52.0 + , haskoin-store-data ==0.52.5 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 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 @@ -20,6 +20,7 @@ , getSpenders , getTransaction , getNumTransaction + , blockAtOrAfter , blockAtOrBefore , blockAtOrAfterMTP , deOffset @@ -268,6 +269,18 @@ sm <- getSpenders (txHash (txData d)) return $ toTransaction d sm +blockAtOrAfter :: (MonadIO m, StoreReadExtra m) + => Chain + -> UnixTime + -> m (Maybe BlockData) +blockAtOrAfter ch q = runMaybeT $ do + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) + where + f x = let t = fromIntegral (blockTimestamp (nodeHeader x)) + in return $ t `compare` q + blockAtOrBefore :: (MonadIO m, StoreReadExtra m) => Chain -> UnixTime @@ -277,9 +290,8 @@ x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch MaybeT $ getBlock (headerHash (nodeHeader x)) where - f x = - let t = fromIntegral (blockTimestamp (nodeHeader x)) - in return $ t `compare` q + f x = let t = fromIntegral (blockTimestamp (nodeHeader x)) + in return $ t `compare` q blockAtOrAfterMTP :: (MonadIO m, StoreReadExtra m) => Chain 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 @@ -19,14 +19,15 @@ ) where import Conduit (ConduitT, await, - dropC, dropWhileC, - mapC, runConduit, - sinkList, takeC, + concatMapMC, dropC, + dropWhileC, mapC, + runConduit, sinkList, + takeC, takeWhileC, yield, (.|)) import Control.Applicative ((<|>)) import Control.Arrow (second) import Control.Concurrent.STM (check) -import Control.Lens ((^.)) +import Control.Lens ((.~), (^.)) import Control.Monad (forM, forever, unless, when, (<=<)) import Control.Monad.Logger (MonadLoggerIO, @@ -217,6 +218,7 @@ , balanceStat :: !StatDist , unspentStat :: !StatDist , rawtxStat :: !StatDist + , historyStat :: !StatDist , peerStat :: !StatDist , healthStat :: !StatDist , dbStatsStat :: !StatDist @@ -247,6 +249,7 @@ multiaddrStat <- d "multiaddr" balanceStat <- d "balance" rawtxStat <- d "rawtx" + historyStat <- d "history" unspentStat <- d "unspent" peerStat <- d "peer" healthStat <- d "health" @@ -387,6 +390,22 @@ opts = def {S.settings = settings defaultSettings} settings = setPort port . setHost (fromString host) +getRates :: (MonadUnliftIO m, MonadLoggerIO m) + => Network -> Text -> [Word64] -> m [BinfoRate] +getRates net currency times = do + handleAny err $ do + r <- liftIO $ Wreq.asJSON =<< Wreq.postWith opts url body + return $ r ^. Wreq.responseBody + where + err e = do + $(logErrorS) "Web" "Could not get historic prices" + return [] + body = toJSON times + base = Wreq.defaults & + Wreq.param "base" .~ [T.toUpper (T.pack (getNetworkName net))] + opts = base & Wreq.param "quote" .~ [currency] + url = "https://api.blockchain.info/price/index-series" + price :: (MonadUnliftIO m, MonadLoggerIO m) => Network -> Int @@ -662,6 +681,8 @@ S.get "/blockchain/rawtx/:txid" scottyBinfoTx S.get "/blockchain/rawblock/:block" scottyBinfoBlock S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight + S.get "/blockchain/export-history" scottyBinfoHistory + S.post "/blockchain/export-history" scottyBinfoHistory where json_list f net = toJSONList . map (f net) @@ -1307,8 +1328,9 @@ getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight -getChainHeight = - fmap H.nodeHeight $ chainGetBest =<< lift (asks (storeChain . webStore . webConfig)) +getChainHeight = do + ch <- lift $ asks (storeChain . webStore . webConfig) + fmap H.nodeHeight $ chainGetBest ch scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyBinfoUnspent = @@ -1449,13 +1471,96 @@ getCashAddr :: Monad m => WebT m Bool getCashAddr = S.param "cashaddr" `S.rescue` const (return False) +scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoHistory = + getBinfoActive historyStat >>= \(xspecs, addrs) -> + get_dates >>= \(startM, endM) -> do + setMetrics historyStat (HashSet.size addrs + HashMap.size xspecs) + (code, price) <- getPrice + xpubs <- mapM (\x -> (,) x <$> xPubBals x) (HashMap.elems xspecs) + let xaddrs = HashSet.fromList $ concatMap (map get_addr . snd) xpubs + aaddrs = xaddrs <> addrs + cur = binfoTicker15m price + cs = conduits xpubs addrs endM + txs <- lift . runConduit $ + joinDescStreams cs + .| takeWhileC (is_newer startM) + .| concatMapMC get_transaction + .| sinkList + let times = map transactionTime txs + net <- lift $ asks (storeNetwork . webStore . webConfig) + rates <- map binfoRatePrice <$> lift (getRates net code times) + let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) + setHeaders + streamEncoding $ toEncoding hs + where + is_newer (Just BlockData{..}) TxRef{txRefBlock = BlockRef{..}} = + blockRefHeight >= blockDataHeight + is_newer _ _ = True + get_addr = balanceAddress . xPubBal + get_transaction TxRef{txRefHash = h, txRefBlock = BlockRef{..}} = + getTransaction h + convert cur addrs tx rate = + let ins = transactionInputs tx + outs = transactionOutputs tx + fins = filter (input_addr addrs) ins + fouts = filter (output_addr addrs) outs + vin = fromIntegral . sum $ map inputAmount fins + vout = fromIntegral . sum $ map outputAmount fouts + v = vout - vin + t = transactionTime tx + h = txHash $ transactionData tx + in toBinfoHistory v t rate cur h + input_addr addrs' StoreInput{inputAddress = Just a} = + a `HashSet.member` addrs' + input_addr _ _ = False + output_addr addrs' StoreOutput{outputAddr = Just a} = + a `HashSet.member` addrs' + output_addr _ _ = False + get_dates = do + BinfoDate start <- S.param "start" + BinfoDate end' <- S.param "end" + let end = end' + 24 * 60 * 60 + ch <- lift $ asks (storeChain . webStore . webConfig) + startM <- blockAtOrAfter ch start + endM <- blockAtOrBefore ch end + return (startM, endM) + conduits xpubs addrs endM = + map (uncurry (xpub_c endM)) xpubs + <> + map (addr_c endM) (HashSet.toList addrs) + addr_c endM a = + streamThings (getAddressTxs a) + (Just txRefHash) + def{ limit = 50 + , start = AtBlock . blockDataHeight <$> endM + } + xpub_c endM x bs = + streamThings + (xPubTxs x bs) + (Just txRefHash) + def{ limit = 50 + , start = AtBlock . blockDataHeight <$> endM + } + +getPrice :: MonadIO m => WebT m (Text, BinfoTicker) +getPrice = do + code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD") + ticker <- lift $ asks webTicker + prices <- readTVarIO ticker + case HashMap.lookup code prices of + Nothing -> return (code, def) + Just p -> return (code, p) + +getSymbol :: MonadIO m => WebT m BinfoSymbol +getSymbol = uncurry binfoTickerToSymbol <$> getPrice + scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyMultiAddr = get_addrs >>= \(addrs', xpubs, saddrs, sxpubs, xspecs) -> getNumTxId >>= \numtxid -> getCashAddr >>= \cashaddr -> - lift (asks webTicker) >>= \ticker -> - get_price ticker >>= \local -> + getSymbol >>= \local -> get_offset >>= \offset -> get_count >>= \n -> get_prune >>= \prune -> @@ -1683,7 +1788,7 @@ getBinfoActive balanceStat >>= \(xspecs, addrs) -> getCashAddr >>= \cashaddr -> getNumTxId >>= \numtxid -> do - setMetrics balanceStat (hl addrs + ml xspecs) + setMetrics balanceStat (HashSet.size addrs + HashMap.size xspecs) net <- lift $ asks (storeNetwork . webStore . webConfig) abals <- catMaybes <$> mapM (get_addr_balance net cashaddr) (HashSet.toList addrs) @@ -1692,8 +1797,6 @@ setHeaders streamEncoding $ toEncoding res where - hl = HashSet.size - ml = HashMap.size to_short_bal Balance{..} = BinfoShortBal {