diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,11 @@ 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.62.0 +### Added +- Configurable Blockchain price URLs. +- Reuse HTTP connections with wreq sessions. + ## 0.61.1 ### Changed - Upstream improvements on Base58 performance. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -80,6 +80,8 @@ , configStatsdPort :: !Int , configStatsdPrefix :: !String , configWebPriceGet :: !Int + , configWebTickerURL :: !String + , configWebHistoryURL :: !String } instance Default Config where @@ -112,6 +114,8 @@ , configStatsdPort = defStatsdPort , configStatsdPrefix = defStatsdPrefix , configWebPriceGet = defWebPriceGet + , configWebTickerURL = defWebTickerURL + , configWebHistoryURL = defWebHistoryURL } defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a @@ -273,6 +277,17 @@ defEnv "WEB_PRICE_GET" (90 * 1000 * 1000) readMaybe {-# NOINLINE defWebPriceGet #-} +defWebTickerURL :: String +defWebTickerURL = unsafePerformIO $ + defEnv "PRICE_TICKER_URL" "https://api.blockchain.info/ticker" pure +{-# NOINLINE defWebTickerURL #-} + + +defWebHistoryURL :: String +defWebHistoryURL = unsafePerformIO $ + defEnv "PRICE_HISTORY_URL" "https://api.blockchain.info/price/index-series" pure +{-# NOINLINE defWebHistoryURL #-} + defStatsdPrefix :: String defStatsdPrefix = unsafePerformIO $ @@ -536,6 +551,20 @@ <> help "How often to retrieve price information" <> showDefault <> value (configWebPriceGet def) + configWebTickerURL <- + strOption $ + metavar "URL" + <> long "price-ticker-url" + <> help "Blockchain.info price ticker URL" + <> showDefault + <> value (configWebTickerURL def) + configWebHistoryURL <- + strOption $ + metavar "URL" + <> long "price-history-url" + <> help "Blockchain.info price history URL" + <> showDefault + <> value (configWebHistoryURL def) pure Config { configWebLimits = WebLimits {..} @@ -614,6 +643,8 @@ , configStatsdPort = statsdport , configStatsdPrefix = statsdpfx , configWebPriceGet = wpget + , configWebTickerURL = wturl + , configWebHistoryURL = whurl } = runStderrLoggingT . filterLogger l . with_stats $ \stats -> do net <- case networkReader net_str of @@ -662,6 +693,8 @@ , webNoMempool = nomem , webStats = stats , webPriceGet = wpget + , webTickerURL = wturl + , webHistoryURL = whurl } where with_stats go diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 0.61.1 +version: 0.62.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -60,7 +60,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.61.1 + , haskoin-store-data ==0.62.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -116,7 +116,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.61.1 + , haskoin-store-data ==0.62.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -177,7 +177,7 @@ , haskoin-core >=0.21.1 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.61.1 + , haskoin-store-data ==0.62.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 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 @@ -140,6 +140,8 @@ sendTextData) import qualified Network.WebSockets as WebSockets import qualified Network.Wreq as Wreq +import Network.Wreq.Session as Wreq (Session) +import qualified Network.Wreq.Session as Wreq.Session import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.Metrics as Metrics import qualified System.Metrics.Gauge as Metrics (Gauge) @@ -195,12 +197,15 @@ , webNoMempool :: !Bool , webStats :: !(Maybe Metrics.Store) , webPriceGet :: !Int + , webTickerURL :: !String + , webHistoryURL :: !String } data WebState = WebState - { webConfig :: !WebConfig - , webTicker :: !(TVar (HashMap Text BinfoTicker)) - , webMetrics :: !(Maybe WebMetrics) + { webConfig :: !WebConfig + , webTicker :: !(TVar (HashMap Text BinfoTicker)) + , webMetrics :: !(Maybe WebMetrics) + , webWreqSession :: !Wreq.Session } data WebMetrics = WebMetrics @@ -453,35 +458,38 @@ , webStore = store' , webStats = stats , webPriceGet = pget + , webTickerURL = turl , webMaxLimits = WebLimits{..} } = do ticker <- newTVarIO HashMap.empty metrics <- mapM createMetrics stats + session <- liftIO Wreq.Session.newAPISession let st = WebState { webConfig = cfg , webTicker = ticker , webMetrics = metrics + , webWreqSession = session } net = storeNetwork store' - withAsync (price net pget ticker) $ \_ -> do - reqLogger <- logIt metrics - runner <- askRunInIO - S.scottyOptsT opts (runner . (`runReaderT` st)) $ do - S.middleware (webSocketEvents st) - S.middleware reqLogger - S.middleware (reqSizeLimit maxLimitBody) - S.defaultHandler defHandler - handlePaths - S.notFound $ raise ThingNotFound + withAsync (price net session turl pget ticker) $ const $ do + reqLogger <- logIt metrics + runner <- askRunInIO + S.scottyOptsT opts (runner . (`runReaderT` st)) $ do + S.middleware (webSocketEvents st) + S.middleware reqLogger + S.middleware (reqSizeLimit maxLimitBody) + S.defaultHandler defHandler + handlePaths + S.notFound $ raise ThingNotFound where 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 + => Network -> Wreq.Session -> String -> Text -> [Word64] -> m [BinfoRate] +getRates net session url currency times = do handleAny err $ do - r <- liftIO $ Wreq.asJSON =<< Wreq.postWith opts url body + r <- liftIO $ Wreq.asJSON =<< Wreq.Session.postWith opts session url body return $ r ^. Wreq.responseBody where err _ = do @@ -491,28 +499,30 @@ 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 + -> Wreq.Session + -> String -> Int -> TVar (HashMap Text BinfoTicker) -> m () -price net pget v = - forM_ code go +price net session url pget v = forM_ purl $ \u -> forever $ do + let err e = $(logErrorS) "Price" $ cs (show e) + handleAny err $ do + r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u + atomically . writeTVar v $ r ^. Wreq.responseBody + threadDelay pget where - code | net == btc = Just "btc" - | net == bch = Just "bch" - | otherwise = Nothing - go s = forever $ do - let err e = $(logErrorS) "Price" $ cs (show e) - url = "https://api.blockchain.info/ticker" <> "?" <> - "base" <> "=" <> s - handleAny err $ do - r <- liftIO $ Wreq.asJSON =<< Wreq.get url - atomically . writeTVar v $ r ^. Wreq.responseBody - threadDelay pget + purl = case code of + Nothing -> Nothing + Just x -> Just (url <> "?base=" <> x) + where + code | net == btc = Just "btc" + | net == bch = Just "bch" + | otherwise = Nothing + raise :: MonadIO m => Except -> WebT m a raise err = lift (asks webMetrics) >>= \case Nothing -> S.raise err @@ -1668,7 +1678,9 @@ .| sinkList let times = map transactionTime txs net <- lift $ asks (storeNetwork . webStore . webConfig) - rates <- map binfoRatePrice <$> lift (getRates net code times) + url <- lift $ asks (webHistoryURL . webConfig) + session <- lift $ asks webWreqSession + rates <- map binfoRatePrice <$> lift (getRates net session url code times) let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) setHeaders streamEncoding $ toEncoding hs