{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

module Haskoin.Store.Web
  ( -- * Web
    WebConfig (..),
    Except (..),
    WebLimits (..),
    WebTimeouts (..),
    runWeb,
  )
where

import Conduit
  ( ConduitT,
    await,
    concatMapC,
    concatMapMC,
    dropC,
    dropWhileC,
    headC,
    iterMC,
    mapC,
    runConduit,
    sinkList,
    takeC,
    takeWhileC,
    yield,
    (.|),
  )
import Control.Applicative ((<|>))
import Control.Arrow (second)
import Control.Lens ((.~), (^.))
import Control.Monad
  ( forM_,
    forever,
    join,
    unless,
    when,
    (<=<),
    (>=>),
  )
import Control.Monad.Logger
  ( MonadLoggerIO,
    logDebugS,
    logErrorS,
    logWarnS,
  )
import Control.Monad.Reader
  ( ReaderT,
    asks,
    local,
    runReaderT,
  )
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Control (liftWith, restoreT)
import Control.Monad.Trans.Maybe
  ( MaybeT (..),
    runMaybeT,
  )
import Data.Aeson
  ( Encoding,
    ToJSON (..),
    Value,
  )
import Data.Aeson qualified as A
import Data.Aeson.Encode.Pretty
  ( Config (..),
    defConfig,
    encodePretty',
  )
import Data.Aeson.Encoding
  ( encodingToLazyByteString,
    list,
  )
import Data.Aeson.Text (encodeToLazyText)
import Data.Base16.Types (assertBase16)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Base16 (decodeBase16, isBase16)
import Data.ByteString.Builder (byteString, lazyByteString)
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as L
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Char (isSpace)
import Data.Default (Default (..))
import Data.Function ((&))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.Int (Int64)
import Data.List (nub)
import Data.Maybe
  ( catMaybes,
    fromJust,
    fromMaybe,
    isJust,
    mapMaybe,
    maybeToList,
  )
import Data.Proxy (Proxy (..))
import Data.Serialize (decode)
import Data.String (fromString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy qualified as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Time.Clock.System
  ( getSystemTime,
    systemSeconds,
    systemToUTCTime,
  )
import Data.Vault.Lazy qualified as V
import Data.Word (Word32, Word64)
import Database.RocksDB
  ( Property (..),
    getProperty,
  )
import GHC.RTS.Flags (ConcFlags (ConcFlags))
import Haskoin.Address
import Haskoin.Block qualified as H
import Haskoin.Crypto.Hash (Hash160 (..))
import Haskoin.Crypto.Keys
import Haskoin.Network
import Haskoin.Node
  ( Chain,
    OnlinePeer (..),
    PeerMgr,
    chainGetAncestor,
    chainGetBest,
    getPeers,
    sendMessage,
  )
import Haskoin.Script
import Haskoin.Store.BlockStore
import Haskoin.Store.Cache
import Haskoin.Store.Common
import Haskoin.Store.Data
import Haskoin.Store.Database.Reader
import Haskoin.Store.Manager
import Haskoin.Store.Stats
import Haskoin.Store.WebCommon
import Haskoin.Transaction
import Haskoin.Util
import NQE
  ( Inbox,
    Publisher,
    receive,
    withSubscription,
  )
import Network.HTTP.Types
  ( Status (..),
    hContentType,
    requestEntityTooLarge413,
    status400,
    status404,
    status409,
    status413,
    status500,
    status503,
    statusIsClientError,
    statusIsServerError,
    statusIsSuccessful,
  )
import Network.Wai
  ( Middleware,
    Request (..),
    Response,
    getRequestBodyChunk,
    responseLBS,
    responseStatus,
  )
import Network.Wai qualified as S
import Network.Wai.Handler.Warp
  ( defaultSettings,
    setHost,
    setPort,
  )
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.Wai.Middleware.RequestSizeLimit
import Network.Wai.Middleware.Timeout
import Network.WebSockets
  ( ServerApp,
    acceptRequest,
    defaultConnectionOptions,
    pendingRequest,
    rejectRequestWith,
    requestPath,
    sendTextData,
  )
import Network.WebSockets qualified as WebSockets
import Network.Wreq qualified as Wreq
import Network.Wreq.Session as Wreq (Session)
import Network.Wreq.Session qualified as Wreq.Session
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Metrics qualified as Metrics
import System.Metrics.Gauge qualified as Metrics (Gauge)
import System.Metrics.Gauge qualified as Metrics.Gauge
import UnliftIO
  ( MonadIO,
    MonadUnliftIO,
    TVar,
    askRunInIO,
    atomically,
    bracket,
    bracket_,
    handleAny,
    liftIO,
    modifyTVar,
    newTVarIO,
    readTVarIO,
    timeout,
    withAsync,
    withRunInIO,
    writeTVar,
  )
import UnliftIO.Concurrent (threadDelay)
import Web.Scotty.Internal.Types (ActionT)
import Web.Scotty.Trans qualified as S

type WebT m = ActionT Except (ReaderT WebState m)

data WebLimits = WebLimits
  { maxItemCount :: !Word32,
    maxFullItemCount :: !Word32,
    maxOffset :: !Word32,
    defItemCount :: !Word32,
    xpubGap :: !Word32,
    xpubGapInit :: !Word32,
    maxBodySize :: !Word32,
    requestTimeout :: !Word32
  }
  deriving (Eq, Show)

instance Default WebLimits where
  def =
    WebLimits
      { maxItemCount = 200000,
        maxFullItemCount = 5000,
        maxOffset = 50000,
        defItemCount = 100,
        xpubGap = 32,
        xpubGapInit = 20,
        maxBodySize = 1024 * 1024,
        requestTimeout = 0
      }

data WebConfig = WebConfig
  { host :: !String,
    port :: !Int,
    store :: !Store,
    maxLaggingBlocks :: !Int,
    maxPendingTxs :: !Int,
    minPeers :: !Int,
    limits :: !WebLimits,
    timeouts :: !WebTimeouts,
    version :: !String,
    noMempool :: !Bool,
    statsStore :: !(Maybe Metrics.Store),
    tickerRefresh :: !Int,
    tickerURL :: !String,
    priceHistoryURL :: !String,
    noSlow :: !Bool,
    noBlockchainInfo :: !Bool,
    healthCheckInterval :: !Int
  }

data WebState = WebState
  { config :: !WebConfig,
    ticker :: !(TVar (HashMap Text BinfoTicker)),
    metrics :: !(Maybe WebMetrics),
    session :: !Wreq.Session,
    health :: !(TVar HealthCheck)
  }

data WebMetrics = WebMetrics
  { all :: !StatDist,
    -- Addresses
    addressTx :: !StatDist,
    addressTxFull :: !StatDist,
    addressBalance :: !StatDist,
    addressUnspent :: !StatDist,
    xpub :: !StatDist,
    xpubDelete :: !StatDist,
    xpubTxFull :: !StatDist,
    xpubTx :: !StatDist,
    xpubBalance :: !StatDist,
    xpubUnspent :: !StatDist,
    -- Transactions
    tx :: !StatDist,
    txRaw :: !StatDist,
    txAfter :: !StatDist,
    txBlock :: !StatDist,
    txBlockRaw :: !StatDist,
    txPost :: !StatDist,
    mempool :: !StatDist,
    -- Blocks
    block :: !StatDist,
    blockRaw :: !StatDist,
    -- Blockchain
    binfoMultiaddr :: !StatDist,
    binfoBalance :: !StatDist,
    binfoAddressRaw :: !StatDist,
    binfoUnspent :: !StatDist,
    binfoTxRaw :: !StatDist,
    binfoBlock :: !StatDist,
    binfoBlockHeight :: !StatDist,
    binfoBlockLatest :: !StatDist,
    binfoBlockRaw :: !StatDist,
    binfoMempool :: !StatDist,
    binfoExportHistory :: !StatDist,
    -- Blockchain /q endpoints
    binfoQaddresstohash :: !StatDist,
    binfoQhashtoaddress :: !StatDist,
    binfoQaddrpubkey :: !StatDist,
    binfoQpubkeyaddr :: !StatDist,
    binfoQhashpubkey :: !StatDist,
    binfoQgetblockcount :: !StatDist,
    binfoQlatesthash :: !StatDist,
    binfoQbcperblock :: !StatDist,
    binfoQtxtotalbtcoutput :: !StatDist,
    binfoQtxtotalbtcinput :: !StatDist,
    binfoQtxfee :: !StatDist,
    binfoQtxresult :: !StatDist,
    binfoQgetreceivedbyaddress :: !StatDist,
    binfoQgetsentbyaddress :: !StatDist,
    binfoQaddressbalance :: !StatDist,
    binfoQaddressfirstseen :: !StatDist,
    -- Others
    health :: !StatDist,
    peers :: !StatDist,
    db :: !StatDist,
    events :: !Metrics.Gauge.Gauge,
    -- Request
    key :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))
  }

createMetrics :: (MonadIO m) => Metrics.Store -> m WebMetrics
createMetrics s = liftIO $ do
  all <- d "all"

  -- Addresses
  addressTx <- d "address_transactions"
  addressTxFull <- d "address_transactions_full"
  addressBalance <- d "address_balance"
  addressUnspent <- d "address_unspent"
  xpub <- d "xpub"
  xpubDelete <- d "xpub_delete"
  xpubTxFull <- d "xpub_transactions_full"
  xpubTx <- d "xpub_transactions"
  xpubBalance <- d "xpub_balances"
  xpubUnspent <- d "xpub_unspent"

  -- Transactions
  tx <- d "transaction"
  txRaw <- d "transaction_raw"
  txAfter <- d "transaction_after"
  txPost <- d "transaction_post"
  txBlock <- d "transactions_block"
  txBlockRaw <- d "transactions_block_raw"
  mempool <- d "mempool"

  -- Blocks
  block <- d "block"
  blockRaw <- d "block_raw"

  -- Blockchain
  binfoMultiaddr <- d "blockchain_multiaddr"
  binfoBalance <- d "blockchain_balance"
  binfoAddressRaw <- d "blockchain_rawaddr"
  binfoUnspent <- d "blockchain_unspent"
  binfoTxRaw <- d "blockchain_rawtx"
  binfoBlock <- d "blockchain_blocks"
  binfoBlockHeight <- d "blockchain_block_height"
  binfoBlockLatest <- d "blockchain_latestblock"
  binfoBlockRaw <- d "blockchain_rawblock"
  binfoMempool <- d "blockchain_mempool"
  binfoExportHistory <- d "blockchain_export_history"

  -- Blockchain /q endpoints
  binfoQaddresstohash <- d "blockchain_q_addresstohash"
  binfoQhashtoaddress <- d "blockchain_q_hashtoaddress"
  binfoQaddrpubkey <- d "blockckhain_q_addrpubkey"
  binfoQpubkeyaddr <- d "blockchain_q_pubkeyaddr"
  binfoQhashpubkey <- d "blockchain_q_hashpubkey"
  binfoQgetblockcount <- d "blockchain_q_getblockcount"
  binfoQlatesthash <- d "blockchain_q_latesthash"
  binfoQbcperblock <- d "blockchain_q_bcperblock"
  binfoQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput"
  binfoQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput"
  binfoQtxfee <- d "blockchain_q_txfee"
  binfoQtxresult <- d "blockchain_q_txresult"
  binfoQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress"
  binfoQgetsentbyaddress <- d "blockchain_q_getsentbyaddress"
  binfoQaddressbalance <- d "blockchain_q_addressbalance"
  binfoQaddressfirstseen <- d "blockchain_q_addressfirstseen"

  -- Others
  health <- d "health"
  peers <- d "peers"
  db <- d "dbstats"

  events <- g "events_connected"
  key <- V.newKey
  return WebMetrics {..}
  where
    d x = createStatDist ("web." <> x) s
    g x = Metrics.createGauge ("web." <> x) s

withGaugeIO :: (MonadUnliftIO m) => Metrics.Gauge -> m a -> m a
withGaugeIO g =
  bracket_
    (liftIO $ Metrics.Gauge.inc g)
    (liftIO $ Metrics.Gauge.dec g)

withGaugeIncrease ::
  (MonadUnliftIO m) =>
  (WebMetrics -> Metrics.Gauge) ->
  WebT m a ->
  WebT m a
withGaugeIncrease gf go =
  lift (asks (.metrics)) >>= \case
    Nothing -> go
    Just m -> do
      s <- liftWith $ \run -> withGaugeIO (gf m) (run go)
      restoreT $ return s

setMetrics :: (MonadUnliftIO m) => (WebMetrics -> StatDist) -> WebT m ()
setMetrics df =
  asks (.metrics) >>= mapM_ go
  where
    go m = do
      req <- S.request
      let t = fromMaybe e $ V.lookup m.key (vault req)
      atomically $ writeTVar t (Just df)
    e = error "the ways of the warrior are yet to be mastered"

addItemCount :: (MonadUnliftIO m) => Int -> WebT m ()
addItemCount i =
  asks (.metrics) >>= mapM_ \m -> do
    addStatItems m.all (fromIntegral i)
    req <- S.request
    forM_ (V.lookup m.key (vault req)) $
      readTVarIO >=> mapM_ \s -> addStatItems (s m) (fromIntegral i)

getItemCounter :: (MonadIO m, MonadIO n) => WebT m (Int -> n ())
getItemCounter =
  fromMaybe (\_ -> return ()) <$> runMaybeT do
    q <- lift S.request
    m <- MaybeT $ asks (.metrics)
    t <- MaybeT . return $ V.lookup m.key (vault q)
    s <- MaybeT $ readTVarIO t
    return $ addStatItems (s m) . fromIntegral

data WebTimeouts = WebTimeouts
  { tx :: !Word64,
    block :: !Word64
  }
  deriving (Eq, Show)

data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON
  deriving (Eq, Show)

instance Default WebTimeouts where
  def = WebTimeouts {tx = 3600 `div` 2, block = 4 * 3600}

instance
  (MonadUnliftIO m, MonadLoggerIO m) =>
  StoreReadBase (ReaderT WebState m)
  where
  getCtx = runInWebReader getCtx
  getNetwork = runInWebReader getNetwork
  getBestBlock = runInWebReader getBestBlock
  getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height)
  getBlock bh = runInWebReader (getBlock bh)
  getTxData th = runInWebReader (getTxData th)
  getSpender op = runInWebReader (getSpender op)
  getUnspent op = runInWebReader (getUnspent op)
  getBalance a = runInWebReader (getBalance a)
  getMempool = runInWebReader getMempool

instance
  (MonadUnliftIO m, MonadLoggerIO m) =>
  StoreReadExtra (ReaderT WebState m)
  where
  getMaxGap = runInWebReader getMaxGap
  getInitialGap = runInWebReader getInitialGap
  getBalances as = runInWebReader (getBalances as)
  getAddressesTxs as = runInWebReader . getAddressesTxs as
  getAddressTxs a = runInWebReader . getAddressTxs a
  getAddressUnspents a = runInWebReader . getAddressUnspents a
  getAddressesUnspents as = runInWebReader . getAddressesUnspents as
  xPubBals = runInWebReader . xPubBals
  xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals
  xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals
  xPubTxCount xpub = runInWebReader . xPubTxCount xpub
  getNumTxData = runInWebReader . getNumTxData

instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where
  getCtx = lift getCtx
  getNetwork = lift getNetwork
  getBestBlock = lift getBestBlock
  getBlocksAtHeight = lift . getBlocksAtHeight
  getBlock = lift . getBlock
  getTxData = lift . getTxData
  getSpender = lift . getSpender
  getUnspent = lift . getUnspent
  getBalance = lift . getBalance
  getMempool = lift getMempool

instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadExtra (WebT m) where
  getBalances = lift . getBalances
  getAddressesTxs as = lift . getAddressesTxs as
  getAddressTxs a = lift . getAddressTxs a
  getAddressUnspents a = lift . getAddressUnspents a
  getAddressesUnspents as = lift . getAddressesUnspents as
  xPubBals = lift . xPubBals
  xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals
  xPubTxs xpub xbals = lift . xPubTxs xpub xbals
  xPubTxCount xpub = lift . xPubTxCount xpub
  getMaxGap = lift getMaxGap
  getInitialGap = lift getInitialGap
  getNumTxData = lift . getNumTxData

-------------------
-- Path Handlers --
-------------------

runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => WebConfig -> m ()
runWeb config = do
  ticker <- newTVarIO HashMap.empty
  metrics <- mapM createMetrics config.statsStore
  session <- liftIO Wreq.Session.newAPISession
  health <- runHealthCheck >>= newTVarIO
  let state = WebState {..}
  withAsync (priceUpdater session ticker) $ \_a1 ->
    withAsync (healthCheckLoop health) $ \_a2 -> do
      logger <- logIt metrics
      runner <- askRunInIO
      S.scottyOptsT opts (runner . flip runReaderT state) $ do
        S.middleware $ webSocketEvents state
        S.middleware logger
        S.middleware $ reqSizeLimit config.limits.maxBodySize
        timeoutMiddleware
        S.defaultHandler defHandler
        handlePaths config
        S.notFound $ raise ThingNotFound
  where
    priceUpdater session =
      unless (config.noSlow || config.noBlockchainInfo)
        . price
          config.store.net
          session
          config.tickerURL
          config.tickerRefresh
    timeoutMiddleware =
      when (config.limits.requestTimeout > 0) $
        S.middleware $
          reqTimeout config.limits.requestTimeout
    runHealthCheck = runReaderT (healthCheck config) config.store.db
    healthCheckLoop v = forever $ do
      threadDelay (config.healthCheckInterval * 1000 * 1000)
      runHealthCheck >>= atomically . writeTVar v
    opts = def {S.settings = settings defaultSettings}
    settings = setPort config.port . setHost (fromString config.host)

getRates ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  Network ->
  Wreq.Session ->
  String ->
  Text ->
  [Word64] ->
  m [BinfoRate]
getRates net session url currency times = do
  handleAny err $ do
    r <-
      liftIO $
        Wreq.asJSON
          =<< Wreq.Session.postWith opts session url body
    return $ r ^. Wreq.responseBody
  where
    err _ = do
      $(logErrorS) "Web" "Could not get historic prices"
      return []
    body = toJSON times
    base =
      Wreq.defaults
        & Wreq.param "base" .~ [T.toUpper $ T.pack net.name]
    opts = base & Wreq.param "quote" .~ [currency]

price ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  Network ->
  Wreq.Session ->
  String ->
  Int ->
  TVar (HashMap Text BinfoTicker) ->
  m ()
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
    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 (.metrics)) >>= \case
    Nothing -> S.raise err
    Just m -> do
      req <- S.request
      mM <- case V.lookup m.key (vault req) of
        Nothing -> return Nothing
        Just t -> readTVarIO t
      let status = errStatus err
      if
          | statusIsClientError status ->
              liftIO $ do
                addClientError m.all
                forM_ mM $ \f -> addClientError (f m)
          | statusIsServerError status ->
              liftIO $ do
                addServerError m.all
                forM_ mM $ \f -> addServerError (f m)
          | otherwise ->
              return ()
      S.raise err

errStatus :: Except -> Status
errStatus ThingNotFound = status404
errStatus BadRequest = status400
errStatus UserError {} = status400
errStatus StringError {} = status400
errStatus ServerError = status500
errStatus TxIndexConflict {} = status409
errStatus ServerTimeout = status500
errStatus RequestTooLarge = status413

defHandler :: (Monad m) => Except -> WebT m ()
defHandler e = do
  setHeaders
  S.status $ errStatus e
  S.json e

handlePaths ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  WebConfig ->
  S.ScottyT Except (ReaderT WebState m) ()
handlePaths WebConfig {..} = do
  -- Block Paths
  pathCompact
    (GetBlock <$> paramLazy <*> paramDef)
    scottyBlock
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetBlockBest <$> paramDef)
    scottyBlockBest
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetBlockHeight <$> paramLazy <*> paramDef)
    (fmap SerialList . scottyBlockHeight)
    (list (marshalEncoding net) . (.get))
    (json_list (marshalValue net) . (.get))
  pathCompact
    (GetBlockTime <$> paramLazy <*> paramDef)
    scottyBlockTime
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetBlockMTP <$> paramLazy <*> paramDef)
    scottyBlockMTP
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetTx <$> paramLazy)
    scottyTx
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetTxRaw <$> paramLazy)
    scottyTxRaw
    toEncoding
    toJSON
  pathCompact
    (PostTx <$> parseBody)
    scottyPostTx
    toEncoding
    toJSON
  pathCompact
    (GetMempool <$> paramOptional <*> parseOffset)
    (fmap SerialList . scottyMempool)
    toEncoding
    toJSON
  pathCompact
    (GetAddrTxs <$> paramLazy <*> parseLimits)
    (fmap SerialList . scottyAddrTxs)
    toEncoding
    toJSON
  pathCompact
    (GetAddrBalance <$> paramLazy)
    scottyAddrBalance
    (marshalEncoding net)
    (marshalValue net)
  pathCompact
    (GetAddrUnspent <$> paramLazy <*> parseLimits)
    (fmap SerialList . scottyAddrUnspent)
    (list (marshalEncoding net) . (.get))
    (json_list (marshalValue net) . (.get))
  pathCompact
    (GetPeers & return)
    (fmap SerialList . scottyPeers)
    toEncoding
    toJSON
  pathCompact
    (GetHealth & return)
    scottyHealth
    toEncoding
    toJSON
  S.get "/events" scottyEvents
  S.get "/dbstats" scottyDbStats
  unless noSlow $ do
    pathCompact
      (GetBlocks <$> param <*> paramDef)
      (fmap SerialList . scottyBlocks)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetBlockRaw <$> paramLazy)
      scottyBlockRaw
      toEncoding
      toJSON
    pathCompact
      (GetBlockBestRaw & return)
      scottyBlockBestRaw
      toEncoding
      toJSON
    pathCompact
      (GetBlockLatest <$> paramDef)
      (fmap SerialList . scottyBlockLatest)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetBlockHeights <$> param <*> paramDef)
      (fmap SerialList . scottyBlockHeights)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetBlockHeightRaw <$> paramLazy)
      scottyBlockHeightRaw
      toEncoding
      toJSON
    pathCompact
      (GetBlockTimeRaw <$> paramLazy)
      scottyBlockTimeRaw
      toEncoding
      toJSON
    pathCompact
      (GetBlockMTPRaw <$> paramLazy)
      scottyBlockMTPRaw
      toEncoding
      toJSON
    pathCompact
      (GetTxs <$> param)
      (fmap SerialList . scottyTxs)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetTxsRaw <$> param)
      scottyTxsRaw
      toEncoding
      toJSON
    pathCompact
      (GetTxsBlock <$> paramLazy)
      (fmap SerialList . scottyTxsBlock)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetTxsBlockRaw <$> paramLazy)
      scottyTxsBlockRaw
      toEncoding
      toJSON
    pathCompact
      (GetTxAfter <$> paramLazy <*> paramLazy)
      scottyTxAfter
      toEncoding
      toJSON
    pathCompact
      (GetAddrsTxs <$> param <*> parseLimits)
      (fmap SerialList . scottyAddrsTxs)
      toEncoding
      toJSON
    pathCompact
      (GetAddrTxsFull <$> paramLazy <*> parseLimits)
      (fmap SerialList . scottyAddrTxsFull)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetAddrsTxsFull <$> param <*> parseLimits)
      (fmap SerialList . scottyAddrsTxsFull)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetAddrsBalance <$> param)
      (fmap SerialList . scottyAddrsBalance)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetAddrsUnspent <$> param <*> parseLimits)
      (fmap SerialList . scottyAddrsUnspent)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetXPub <$> paramLazy <*> paramDef <*> paramDef)
      scottyXPub
      toEncoding
      toJSON
    pathCompact
      (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)
      (fmap SerialList . scottyXPubTxs)
      toEncoding
      toJSON
    pathCompact
      (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)
      (fmap SerialList . scottyXPubTxsFull)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef)
      (fmap SerialList . scottyXPubBalances)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)
      (fmap SerialList . scottyXPubUnspent)
      (list (marshalEncoding net) . (.get))
      (json_list (marshalValue net) . (.get))
    pathCompact
      (DelCachedXPub <$> paramLazy <*> paramDef)
      scottyDelXPub
      toEncoding
      toJSON
    unless noBlockchainInfo $ do
      S.post "/blockchain/multiaddr" scottyMultiAddr
      S.get "/blockchain/multiaddr" scottyMultiAddr
      S.get "/blockchain/balance" scottyShortBal
      S.post "/blockchain/balance" scottyShortBal
      S.get "/blockchain/rawaddr/:addr" scottyRawAddr
      S.get "/blockchain/address/:addr" scottyRawAddr
      S.get "/blockchain/xpub/:addr" scottyRawAddr
      S.post "/blockchain/unspent" scottyBinfoUnspent
      S.get "/blockchain/unspent" scottyBinfoUnspent
      S.get "/blockchain/rawtx/:txid" scottyBinfoTx
      S.get "/blockchain/rawblock/:block" scottyBinfoBlock
      S.get "/blockchain/latestblock" scottyBinfoLatest
      S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool
      S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight
      S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay
      S.get "/blockchain/export-history" scottyBinfoHistory
      S.post "/blockchain/export-history" scottyBinfoHistory
      S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash
      S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr
      S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey
      S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr
      S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey
      S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount
      S.get "/blockchain/q/latesthash" scottyBinfoLatestHash
      S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy
      S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut
      S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput
      S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees
      S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult
      S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived
      S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent
      S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance
      S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen
  where
    json_list f = toJSONList . map f
    net = store.net

pathCompact ::
  (ApiResource a b, MonadIO m) =>
  WebT m a ->
  (a -> WebT m b) ->
  (b -> Encoding) ->
  (b -> Value) ->
  S.ScottyT Except (ReaderT WebState m) ()
pathCompact parser action encJson encValue =
  pathCommon parser action encJson encValue False

pathCommon ::
  (ApiResource a b, MonadIO m) =>
  WebT m a ->
  (a -> WebT m b) ->
  (b -> Encoding) ->
  (b -> Value) ->
  Bool ->
  S.ScottyT Except (ReaderT WebState m) ()
pathCommon parser action encJson encValue pretty =
  S.addroute (resourceMethod proxy) (capturePath proxy) $ do
    setHeaders
    proto <- setupContentType pretty
    apiRes <- parser
    res <- action apiRes
    S.raw $ protoSerial proto encJson encValue res
  where
    toProxy :: WebT m a -> Proxy a
    toProxy = const Proxy
    proxy = toProxy parser

streamEncoding :: (Monad m) => Encoding -> WebT m ()
streamEncoding e = do
  S.setHeader "Content-Type" "application/json; charset=utf-8"
  S.raw (encodingToLazyByteString e)

protoSerial ::
  (Serial a) =>
  SerialAs ->
  (a -> Encoding) ->
  (a -> Value) ->
  a ->
  L.ByteString
protoSerial SerialAsBinary _ _ = runPutL . serialize
protoSerial SerialAsJSON f _ = encodingToLazyByteString . f
protoSerial SerialAsPrettyJSON _ g =
  encodePretty' defConfig {confTrailingNewline = True} . g

setHeaders :: (Monad m, S.ScottyError e) => ActionT e m ()
setHeaders = S.setHeader "Access-Control-Allow-Origin" "*"

waiExcept :: Status -> Except -> Response
waiExcept s e =
  responseLBS s hs e'
  where
    hs =
      [ ("Access-Control-Allow-Origin", "*"),
        ("Content-Type", "application/json")
      ]
    e' = A.encode e

setupJSON :: (Monad m) => Bool -> ActionT Except m SerialAs
setupJSON pretty = do
  S.setHeader "Content-Type" "application/json"
  p <- S.param "pretty" `S.rescue` const (return pretty)
  return $ if p then SerialAsPrettyJSON else SerialAsJSON

setupBinary :: (Monad m) => ActionT Except m SerialAs
setupBinary = do
  S.setHeader "Content-Type" "application/octet-stream"
  return SerialAsBinary

setupContentType :: (Monad m) => Bool -> ActionT Except m SerialAs
setupContentType pretty = do
  accept <- S.header "accept"
  maybe (setupJSON pretty) setType accept
  where
    setType "application/octet-stream" = setupBinary
    setType _ = setupJSON pretty

-- GET Block / GET Blocks --

scottyBlock ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData
scottyBlock (GetBlock h (NoTx noTx)) = do
  setMetrics (.block)
  getBlock h >>= \case
    Nothing ->
      raise ThingNotFound
    Just b -> do
      addItemCount 1
      return $ pruneTx noTx b

getBlocks ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  [H.BlockHash] ->
  Bool ->
  WebT m [BlockData]
getBlocks hs notx =
  (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs)

scottyBlocks ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData]
scottyBlocks (GetBlocks hs (NoTx notx)) = do
  setMetrics (.block)
  bs <- getBlocks hs notx
  addItemCount (length bs)
  return bs

pruneTx :: Bool -> BlockData -> BlockData
pruneTx False b = b
pruneTx True BlockData {..} = BlockData {txs = take 1 txs, ..}

-- GET BlockRaw --

scottyBlockRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockRaw ->
  WebT m (RawResult H.Block)
scottyBlockRaw (GetBlockRaw h) = do
  setMetrics (.blockRaw)
  b <- getRawBlock h
  addItemCount (1 + length b.txs)
  return $ RawResult b

getRawBlock ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  H.BlockHash ->
  WebT m H.Block
getRawBlock h = do
  b <- getBlock h >>= maybe (raise ThingNotFound) return
  lift (toRawBlock b)

toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block
toRawBlock b = do
  let ths = b.txs
  txs <- mapM f ths
  return H.Block {header = b.header, txs}
  where
    f x = withRunInIO $ \run ->
      unsafeInterleaveIO . run $
        getTransaction x >>= \case
          Nothing -> undefined
          Just t -> return $ transactionData t

-- GET BlockBest / BlockBestRaw --

scottyBlockBest ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData
scottyBlockBest (GetBlockBest (NoTx notx)) = do
  setMetrics (.block)
  getBestBlock >>= \case
    Nothing -> raise ThingNotFound
    Just bb ->
      getBlock bb >>= \case
        Nothing -> raise ThingNotFound
        Just b -> do
          addItemCount 1
          return $ pruneTx notx b

scottyBlockBestRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockBestRaw ->
  WebT m (RawResult H.Block)
scottyBlockBestRaw _ = do
  setMetrics (.blockRaw)
  getBestBlock >>= \case
    Nothing -> raise ThingNotFound
    Just bb -> do
      b <- getRawBlock bb
      addItemCount (1 + length b.txs)
      return $ RawResult b

-- GET BlockLatest --

scottyBlockLatest ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockLatest ->
  WebT m [BlockData]
scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do
  setMetrics (.block)
  blocks <-
    getBestBlock
      >>= maybe
        (raise ThingNotFound)
        (go [] <=< getBlock)
  addItemCount (length blocks)
  return blocks
  where
    go acc Nothing = return $ reverse acc
    go acc (Just b)
      | b.height <= 0 = return $ reverse acc
      | length acc == 99 = return . reverse $ pruneTx noTx b : acc
      | otherwise = go (pruneTx noTx b : acc) =<< getBlock b.header.prev

-- GET BlockHeight / BlockHeights / BlockHeightRaw --

scottyBlockHeight ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData]
scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do
  setMetrics (.block)
  blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h)
  addItemCount (length blocks)
  return blocks

scottyBlockHeights ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockHeights ->
  WebT m [BlockData]
scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do
  setMetrics (.block)
  bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights)
  blocks <- getBlocks bhs notx
  addItemCount (length blocks)
  return blocks

scottyBlockHeightRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockHeightRaw ->
  WebT m (RawResultList H.Block)
scottyBlockHeightRaw (GetBlockHeightRaw h) = do
  setMetrics (.blockRaw)
  blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h)
  addItemCount (length blocks + sum (map (length . (.txs)) blocks))
  return $ RawResultList blocks

-- GET BlockTime / BlockTimeRaw --

scottyBlockTime ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockTime ->
  WebT m BlockData
scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do
  setMetrics (.block)
  ch <- lift $ asks (.config.store.chain)
  blockAtOrBefore ch t >>= \case
    Nothing -> raise ThingNotFound
    Just b -> do
      addItemCount 1
      return $ pruneTx notx b

scottyBlockMTP ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockMTP ->
  WebT m BlockData
scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = do
  setMetrics (.block)
  ch <- lift $ asks (.config.store.chain)
  blockAtOrAfterMTP ch t >>= \case
    Nothing -> raise ThingNotFound
    Just b -> do
      addItemCount 1
      return $ pruneTx notx b

scottyBlockTimeRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockTimeRaw ->
  WebT m (RawResult H.Block)
scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do
  setMetrics (.blockRaw)
  ch <- lift $ asks (.config.store.chain)
  blockAtOrBefore ch t >>= \case
    Nothing -> raise ThingNotFound
    Just b -> do
      raw <- lift $ toRawBlock b
      addItemCount (1 + length raw.txs)
      return $ RawResult raw

scottyBlockMTPRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetBlockMTPRaw ->
  WebT m (RawResult H.Block)
scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do
  setMetrics (.blockRaw)
  ch <- lift $ asks (.config.store.chain)
  blockAtOrAfterMTP ch t >>= \case
    Nothing -> raise ThingNotFound
    Just b -> do
      raw <- lift $ toRawBlock b
      addItemCount (1 + length raw.txs)
      return $ RawResult raw

-- GET Transactions --

scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction
scottyTx (GetTx txid) = do
  setMetrics (.tx)
  getTransaction txid >>= \case
    Nothing -> raise ThingNotFound
    Just tx -> do
      addItemCount 1
      return tx

scottyTxs ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction]
scottyTxs (GetTxs txids) = do
  setMetrics (.tx)
  txs <- catMaybes <$> mapM f (nub txids)
  addItemCount (length txs)
  return txs
  where
    f x = lift $
      withRunInIO $ \run ->
        unsafeInterleaveIO . run $
          getTransaction x

scottyTxRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx)
scottyTxRaw (GetTxRaw txid) = do
  setMetrics (.txRaw)
  getTransaction txid >>= \case
    Nothing -> raise ThingNotFound
    Just tx -> do
      addItemCount 1
      return $ RawResult (transactionData tx)

scottyTxsRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetTxsRaw ->
  WebT m (RawResultList Tx)
scottyTxsRaw (GetTxsRaw txids) = do
  setMetrics (.txRaw)
  txs <- catMaybes <$> mapM f (nub txids)
  addItemCount (length txs)
  return $ RawResultList $ transactionData <$> txs
  where
    f x = lift $
      withRunInIO $ \run ->
        unsafeInterleaveIO . run $
          getTransaction x

getTxsBlock ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  H.BlockHash ->
  WebT m [Transaction]
getTxsBlock h =
  getBlock h >>= \case
    Nothing -> raise ThingNotFound
    Just b -> do
      txs <- mapM f b.txs
      addItemCount (length txs)
      return txs
  where
    f x = lift $
      withRunInIO $ \run ->
        unsafeInterleaveIO . run $
          getTransaction x >>= \case
            Nothing -> undefined
            Just t -> return t

scottyTxsBlock ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetTxsBlock ->
  WebT m [Transaction]
scottyTxsBlock (GetTxsBlock h) = do
  setMetrics (.txBlock)
  txs <- getTxsBlock h
  addItemCount (length txs)
  return txs

scottyTxsBlockRaw ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetTxsBlockRaw ->
  WebT m (RawResultList Tx)
scottyTxsBlockRaw (GetTxsBlockRaw h) = do
  setMetrics (.txBlockRaw)
  txs <- fmap transactionData <$> getTxsBlock h
  addItemCount (length txs)
  return $ RawResultList txs

-- GET TransactionAfterHeight --

scottyTxAfter ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetTxAfter ->
  WebT m (GenericResult (Maybe Bool))
scottyTxAfter (GetTxAfter txid height) = do
  setMetrics (.txAfter)
  (result, count) <- cbAfterHeight (fromIntegral height) txid
  addItemCount count
  return $ GenericResult result

-- | Check if any of the ancestors of this transaction is a coinbase after the
-- specified height. Returns 'Nothing' if answer cannot be computed before
-- hitting limits.
cbAfterHeight ::
  (MonadIO m, StoreReadBase m) =>
  H.BlockHeight ->
  TxHash ->
  m (Maybe Bool, Int)
cbAfterHeight height txid =
  inputs n HashSet.empty HashSet.empty [txid]
  where
    n = 10000
    inputs 0 _ _ [] = return (Nothing, 10000)
    inputs i is ns [] =
      let is' = HashSet.union is ns
          ns' = HashSet.empty
          ts = HashSet.toList (HashSet.difference ns is)
       in case ts of
            [] -> return (Just False, n - i)
            _ -> inputs i is' ns' ts
    inputs i is ns (t : ts) =
      getTransaction t >>= \case
        Nothing -> return (Nothing, n - i)
        Just tx
          | height_check tx ->
              if cb_check tx
                then return (Just True, n - i + 1)
                else
                  let ns' = HashSet.union (ins tx) ns
                   in inputs (i - 1) is ns' ts
          | otherwise -> inputs (i - 1) is ns ts
    cb_check = any isCoinbase . (.inputs)
    ins = HashSet.fromList . map (.outpoint.hash) . (.inputs)
    height_check tx =
      case tx.block of
        BlockRef h _ -> h > height
        MemRef _ -> True

-- POST Transaction --

scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId
scottyPostTx (PostTx tx) = do
  setMetrics (.txPost)
  addItemCount 1
  lift (asks (.config)) >>= \cfg ->
    lift (publishTx cfg tx) >>= \case
      Right () -> return (TxId (txHash tx))
      Left e@(PubReject _) -> raise $ UserError (show e)
      _ -> raise ServerError

-- | Publish a new transaction to the network.
publishTx ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  Tx ->
  m (Either PubExcept ())
publishTx cfg tx =
  withSubscription pub $ \s ->
    getTransaction (txHash tx) >>= \case
      Just _ -> return $ Right ()
      Nothing -> go s
  where
    pub = cfg.store.pub
    mgr = cfg.store.peerMgr
    net = cfg.store.net
    go s =
      getPeers mgr >>= \case
        [] -> return $ Left PubNoPeers
        OnlinePeer {mailbox = p} : _ -> do
          MTx tx `sendMessage` p
          let v =
                if net.segWit
                  then InvWitnessTx
                  else InvTx
          sendMessage
            (MGetData (GetData [InvVector v (txHash tx).get]))
            p
          f p s
    t = 5 * 1000 * 1000
    f p s
      | cfg.noMempool = return $ Right ()
      | otherwise =
          liftIO (UnliftIO.timeout t (g p s)) >>= \case
            Nothing -> return $ Left PubTimeout
            Just (Left e) -> return $ Left e
            Just (Right ()) -> return $ Right ()
    g p s =
      receive s >>= \case
        StoreTxReject p' h' c _
          | p == p' && h' == txHash tx -> return . Left $ PubReject c
        StorePeerDisconnected p'
          | p == p' -> return $ Left PubPeerDisconnected
        StoreMempoolNew h'
          | h' == txHash tx -> return $ Right ()
        _ -> g p s

-- GET Mempool / Events --

scottyMempool ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash]
scottyMempool (GetMempool limitM (OffsetParam o)) = do
  setMetrics (.mempool)
  WebLimits {..} <- lift $ asks (.config.limits)
  let wl' = WebLimits {maxItemCount = 0, ..}
      l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing
  ths <- map snd . applyLimits l <$> getMempool
  addItemCount 1
  return ths

webSocketEvents :: WebState -> Middleware
webSocketEvents s =
  websocketsOr defaultConnectionOptions events
  where
    pub = s.config.store.pub
    gauge = (.events) <$> s.metrics
    events pending = withSubscription pub $ \sub -> do
      let path = requestPath $ pendingRequest pending
      if path == "/events"
        then do
          conn <- acceptRequest pending
          forever $
            receiveEvent sub >>= \case
              Nothing -> return ()
              Just event -> sendTextData conn (A.encode event)
        else
          rejectRequestWith
            pending
            WebSockets.defaultRejectRequest
              { WebSockets.rejectBody =
                  L.toStrict $ A.encode ThingNotFound,
                WebSockets.rejectCode =
                  404,
                WebSockets.rejectMessage =
                  "Not Found",
                WebSockets.rejectHeaders =
                  [("Content-Type", "application/json")]
              }

scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyEvents =
  withGaugeIncrease (.events) $ do
    setHeaders
    proto <- setupContentType False
    pub <- lift $ asks (.config.store.pub)
    S.stream $ \io flush' ->
      withSubscription pub $ \sub ->
        forever $ do
          flush'
          receiveEvent sub >>= \case
            Nothing -> return ()
            Just msg -> io (serial proto msg)
  where
    serial proto e =
      lazyByteString $
        protoSerial proto toEncoding toJSON e <> newLine proto
    newLine SerialAsBinary = mempty
    newLine SerialAsJSON = "\n"
    newLine SerialAsPrettyJSON = mempty

receiveEvent :: Inbox StoreEvent -> IO (Maybe Event)
receiveEvent sub =
  go <$> receive sub
  where
    go = \case
      StoreBestBlock b -> Just (EventBlock b)
      StoreMempoolNew t -> Just (EventTx t)
      StoreMempoolDelete t -> Just (EventTx t)
      _ -> Nothing

-- GET Address Transactions --

scottyAddrTxs ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef]
scottyAddrTxs (GetAddrTxs addr pLimits) = do
  setMetrics (.addressTx)
  txs <- getAddressTxs addr =<< paramToLimits False pLimits
  addItemCount (length txs)
  return txs

scottyAddrsTxs ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef]
scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do
  setMetrics (.addressTx)
  txs <- getAddressesTxs addrs =<< paramToLimits False pLimits
  addItemCount (length txs)
  return txs

scottyAddrTxsFull ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetAddrTxsFull ->
  WebT m [Transaction]
scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do
  setMetrics (.addressTxFull)
  txs <- getAddressTxs addr =<< paramToLimits True pLimits
  ts <- catMaybes <$> mapM (getTransaction . (.txid)) txs
  addItemCount (length ts)
  return ts

scottyAddrsTxsFull ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetAddrsTxsFull ->
  WebT m [Transaction]
scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do
  setMetrics (.addressTxFull)
  txs <- getAddressesTxs addrs =<< paramToLimits True pLimits
  ts <- catMaybes <$> mapM (getTransaction . (.txid)) txs
  addItemCount (length ts)
  return ts

scottyAddrBalance ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetAddrBalance ->
  WebT m Balance
scottyAddrBalance (GetAddrBalance addr) = do
  setMetrics (.addressBalance)
  addItemCount 1
  getDefaultBalance addr

scottyAddrsBalance ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]
scottyAddrsBalance (GetAddrsBalance addrs) = do
  setMetrics (.addressBalance)
  balances <- getBalances addrs
  addItemCount (length balances)
  return balances

scottyAddrUnspent ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent]
scottyAddrUnspent (GetAddrUnspent addr pLimits) = do
  setMetrics (.addressUnspent)
  unspents <- getAddressUnspents addr =<< paramToLimits False pLimits
  addItemCount (length unspents)
  return unspents

scottyAddrsUnspent ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent]
scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do
  setMetrics (.addressUnspent)
  unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits
  addItemCount (length unspents)
  return unspents

-- GET XPubs --

scottyXPub ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary
scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do
  setMetrics (.xpub)
  let xspec = XPubSpec xpub deriv
  xbals <- lift . runNoCache noCache $ xPubBals xspec
  addItemCount (length xbals)
  return $ xPubSummary xspec xbals

scottyDelXPub ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  DelCachedXPub ->
  WebT m (GenericResult Bool)
scottyDelXPub (DelCachedXPub xpub deriv) = do
  setMetrics (.xpubDelete)
  let xspec = XPubSpec xpub deriv
  cacheM <- lift $ asks (.config.store.cache)
  n <- lift $ withCache cacheM (cacheDelXPubs [xspec])
  addItemCount (fromIntegral n)
  return (GenericResult (n > 0))

getXPubTxs ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  XPubKey ->
  DeriveType ->
  LimitsParam ->
  Bool ->
  WebT m [TxRef]
getXPubTxs xpub deriv plimits nocache = do
  limits <- paramToLimits False plimits
  let xspec = XPubSpec xpub deriv
  xbals <- xPubBals xspec
  addItemCount (length xbals)
  lift . runNoCache nocache $ xPubTxs xspec xbals limits

scottyXPubTxs ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]
scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do
  setMetrics (.xpubTx)
  txs <- getXPubTxs xpub deriv plimits nocache
  addItemCount (length txs)
  return txs

scottyXPubTxsFull ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetXPubTxsFull ->
  WebT m [Transaction]
scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do
  setMetrics (.xpubTxFull)
  refs <- getXPubTxs xpub deriv plimits nocache
  txs <-
    fmap catMaybes $
      lift . runNoCache nocache $
        mapM (getTransaction . (.txid)) refs
  addItemCount (length txs)
  return txs

scottyXPubBalances ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal]
scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do
  setMetrics (.xpubBalance)
  balances <- lift (runNoCache noCache (xPubBals spec))
  addItemCount (length balances)
  return balances
  where
    spec = XPubSpec xpub deriv

scottyXPubUnspent ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetXPubUnspent ->
  WebT m [XPubUnspent]
scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do
  setMetrics (.xpubUnspent)
  limits <- paramToLimits False pLimits
  let xspec = XPubSpec xpub deriv
  xbals <- xPubBals xspec
  addItemCount (length xbals)
  unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits
  addItemCount (length unspents)
  return unspents

---------------------------------------
-- Blockchain.info API Compatibility --
---------------------------------------

netBinfoSymbol :: Network -> BinfoSymbol
netBinfoSymbol net
  | net == btc =
      BinfoSymbol
        { code = "BTC",
          symbol = "BTC",
          name = "Bitcoin",
          conversion = 100 * 1000 * 1000,
          after = True,
          local = False
        }
  | net == bch =
      BinfoSymbol
        { code = "BCH",
          symbol = "BCH",
          name = "Bitcoin Cash",
          conversion = 100 * 1000 * 1000,
          after = True,
          local = False
        }
  | otherwise =
      BinfoSymbol
        { code = "XTS",
          symbol = "¤",
          name = "Test",
          conversion = 100 * 1000 * 1000,
          after = False,
          local = False
        }

binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol
binfoTickerToSymbol code BinfoTicker {..} =
  BinfoSymbol
    { code,
      symbol,
      name,
      conversion = 100 * 1000 * 1000 / fifteen, -- sat/usd
      after = False,
      local = True
    }
  where
    name = case code of
      "EUR" -> "Euro"
      "USD" -> "U.S. dollar"
      "GBP" -> "British pound"
      x -> x

getBinfoAddrsParam ::
  (MonadIO m) =>
  Text ->
  WebT m (HashSet BinfoAddr)
getBinfoAddrsParam name = do
  net <- lift $ asks (.config.store.net)
  ctx <- lift $ asks (.config.store.ctx)
  p <- S.param (cs name) `S.rescue` const (return "")
  if T.null p
    then return HashSet.empty
    else case parseBinfoAddr net ctx p of
      Nothing -> raise (UserError "invalid address")
      Just xs -> return $ HashSet.fromList xs

getBinfoActive ::
  (MonadIO m) =>
  WebT m (HashSet XPubSpec, HashSet Address)
getBinfoActive = do
  active <- getBinfoAddrsParam "active"
  p2sh <- getBinfoAddrsParam "activeP2SH"
  bech32 <- getBinfoAddrsParam "activeBech32"
  let xspec d b = (`XPubSpec` d) <$> xpub b
      xspecs =
        HashSet.fromList $
          concat
            [ mapMaybe (xspec DeriveNormal) (HashSet.toList active),
              mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh),
              mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32)
            ]
      addrs = HashSet.fromList . mapMaybe addr $ HashSet.toList active
  return (xspecs, addrs)
  where
    addr (BinfoAddr a) = Just a
    addr (BinfoXpub _) = Nothing
    xpub (BinfoXpub x) = Just x
    xpub (BinfoAddr _) = Nothing

getNumTxId :: (MonadIO m) => WebT m Bool
getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False)

getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight
getChainHeight = do
  ch <- lift $ asks (.config.store.chain)
  (.height) <$> chainGetBest ch

scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoUnspent = do
  setMetrics (.binfoUnspent)
  (xspecs, addrs) <- getBinfoActive
  numtxid <- getNumTxId
  limit <- get_limit
  min_conf <- get_min_conf
  net <- lift $ asks (.config.store.net)
  ctx <- lift $ asks (.config.store.ctx)
  height <- getChainHeight
  let mn BinfoUnspent {..} = min_conf > confirmations
  xbals <- lift $ getXBals xspecs
  addItemCount . sum . map length $ HashMap.elems xbals
  counter <- getItemCounter
  bus <-
    lift . runConduit $
      getBinfoUnspents counter numtxid height xbals xspecs addrs
        .| (dropWhileC mn >> takeC limit .| sinkList)
  setHeaders
  streamEncoding (marshalEncoding (net, ctx) (BinfoUnspents bus))
  where
    get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250)
    get_min_conf = S.param "confirmations" `S.rescue` const (return 0)

getBinfoUnspents ::
  (StoreReadExtra m, MonadIO m) =>
  (Int -> m ()) ->
  Bool ->
  H.BlockHeight ->
  HashMap XPubSpec [XPubBal] ->
  HashSet XPubSpec ->
  HashSet Address ->
  ConduitT () BinfoUnspent m ()
getBinfoUnspents counter numtxid height xbals xspecs addrs = do
  cs' <- conduits
  joinDescStreams cs' .| mapC (uncurry binfo)
  where
    binfo Unspent {..} xp =
      let conf = case block of
            MemRef _ -> 0
            BlockRef h _ -> height - h + 1
          hash = outpoint.hash
          idx = outpoint.index
          val = value
          script = script
          txi = encodeBinfoTxId numtxid hash
       in BinfoUnspent
            { txid = hash,
              index = idx,
              script,
              value = val,
              confirmations = fromIntegral conf,
              txidx = txi,
              xpub = xp
            }
    conduits = (<>) <$> xconduits <*> pure acounduits
    xconduits = lift $ do
      let f x (XPubUnspent u p) =
            let path = toSoft (listToPath p)
                xp = BinfoXPubPath x.key <$> path
             in (u, xp)
          g x = do
            let h l = do
                  us <- xPubUnspents x (xBals x xbals) l
                  counter (length us)
                  return us
                l = let Limits {..} = def in Limits {limit = 16, ..}
            return $ streamThings h Nothing l .| mapC (f x)
      mapM g (HashSet.toList xspecs)
    acounduits =
      let f u = (u, Nothing)
          h a l = do
            us <- getAddressUnspents a l
            counter (length us)
            return us
          l = let Limits {..} = def in Limits {limit = 16, ..}
          g a = streamThings (h a) Nothing l .| mapC f
       in map g (HashSet.toList addrs)

getXBals ::
  (StoreReadExtra m) =>
  HashSet XPubSpec ->
  m (HashMap XPubSpec [XPubBal])
getXBals =
  fmap HashMap.fromList . mapM f . HashSet.toList
  where
    f x = (x,) . filter (not . nullBalance . (.balance)) <$> xPubBals x

xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal]
xBals = HashMap.findWithDefault []

getBinfoTxs ::
  (StoreReadExtra m, MonadIO m) =>
  (Int -> m ()) -> -- counter
  HashMap XPubSpec [XPubBal] -> -- xpub balances
  HashMap Address (Maybe BinfoXPubPath) -> -- address book
  HashSet XPubSpec -> -- show xpubs
  HashSet Address -> -- show addrs
  HashSet Address -> -- balance addresses
  BinfoFilter ->
  Bool -> -- numtxid
  Bool -> -- prune outputs
  Int64 -> -- starting balance
  ConduitT () BinfoTx m ()
getBinfoTxs
  counter
  xbals
  abook
  sxspecs
  saddrs
  baddrs
  bfilter
  numtxid
  prune
  bal = do
    cs' <- conduits
    joinDescStreams cs' .| go bal
    where
      sxspecs_ls = HashSet.toList sxspecs
      saddrs_ls = HashSet.toList saddrs
      conduits =
        (<>)
          <$> mapM xpub_c sxspecs_ls
          <*> pure (map addr_c saddrs_ls)
      xpub_c x = do
        let f l = do
              ts <- xPubTxs x (xBals x xbals) l
              counter (length ts)
              return ts
            l = let Limits {..} = def in Limits {limit = 16, ..}
        lift . return $
          streamThings f (Just (.txid)) l
      addr_c a = do
        let f l = do
              as <- getAddressTxs a l
              counter (length as)
              return as
            l = let Limits {..} = def in Limits {limit = 16, ..}
        streamThings f (Just (.txid)) l
      binfo_tx = toBinfoTx numtxid abook prune
      compute_bal_change BinfoTx {..} =
        let ins = map (.output) inputs
            out = outputs
            f b BinfoTxOutput {..} =
              let val = fromIntegral value
               in case address of
                    Nothing -> 0
                    Just a
                      | a `HashSet.member` baddrs ->
                          if b then val else negate val
                      | otherwise -> 0
         in sum $ map (f False) ins <> map (f True) out
      go b =
        await >>= \case
          Nothing -> return ()
          Just (TxRef _ t) ->
            lift (getTransaction t) >>= \case
              Nothing -> go b
              Just x -> do
                lift $ counter 1
                let a = binfo_tx b x
                    b' = b - compute_bal_change a
                    c = isJust a.blockHeight
                    Just (d, _) = a.balance
                    r = d + fromIntegral a.fee
                case bfilter of
                  BinfoFilterAll ->
                    yield a >> go b'
                  BinfoFilterSent
                    | 0 > r -> yield a >> go b'
                    | otherwise -> go b'
                  BinfoFilterReceived
                    | r > 0 -> yield a >> go b'
                    | otherwise -> go b'
                  BinfoFilterMoved
                    | r == 0 -> yield a >> go b'
                    | otherwise -> go b'
                  BinfoFilterConfirmed
                    | c -> yield a >> go b'
                    | otherwise -> go b'
                  BinfoFilterMempool
                    | c -> return ()
                    | otherwise -> yield a >> go b'

getCashAddr :: (Monad m) => WebT m Bool
getCashAddr = S.param "cashaddr" `S.rescue` const (return False)

getAddress :: (Monad m, MonadUnliftIO m) => TL.Text -> WebT m Address
getAddress param' = do
  txt <- S.param param'
  net <- lift $ asks (.config.store.net)
  case textToAddr net txt of
    Nothing -> raise ThingNotFound
    Just a -> return a

getBinfoAddr :: (Monad m) => TL.Text -> WebT m BinfoAddr
getBinfoAddr param' = do
  txt <- S.param param'
  net <- lift $ asks (.config.store.net)
  ctx <- lift $ asks (.config.store.ctx)
  let x =
        BinfoAddr
          <$> textToAddr net txt
          <|> BinfoXpub <$> xPubImport net ctx txt
  maybe S.next return x

scottyBinfoHistory :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoHistory = do
  setMetrics (.binfoExportHistory)
  (xspecs, addrs) <- getBinfoActive
  (startM, endM) <- get_dates
  (code, price') <- getPrice
  xbals <- getXBals xspecs
  addItemCount . sum . map length $ HashMap.elems xbals
  counter <- getItemCounter
  let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals)
      aaddrs = xaddrs <> addrs
      cur = price'.fifteen
      cs' = conduits counter (HashMap.toList xbals) addrs endM
  txs <-
    lift $
      runConduit $
        joinDescStreams cs'
          .| takeWhileC (is_newer startM)
          .| concatMapMC get_transaction
          .| sinkList
  addItemCount (length txs)
  let times = map (\Transaction {..} -> timestamp) txs
  net <- lift $ asks (.config.store.net)
  url <- lift $ asks (.config.priceHistoryURL)
  session <- lift $ asks (.session)
  rates <- map (.price) <$> lift (getRates net session url code times)
  addItemCount (length rates)
  let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0)
  setHeaders
  streamEncoding $ toEncoding hs
  where
    is_newer (Just b@BlockData {}) TxRef {block = t@BlockRef {}} =
      b.height <= t.height
    is_newer Nothing TxRef {} = True
    get_addr = (.balance.address)
    get_transaction TxRef {txid = h} =
      getTransaction h
    convert cur addrs tx rate =
      let ins = tx.inputs
          outs = tx.outputs
          fins = filter (input_addr addrs) ins
          fouts = filter (output_addr addrs) outs
          vin = fromIntegral . sum $ map (.value) fins
          vout = fromIntegral . sum $ map (.value) fouts
          fee = tx.fee
          v = vout - vin
          t = tx.timestamp
          h = txHash $ transactionData tx
       in toBinfoHistory v t rate cur fee h
    input_addr addrs' StoreInput {address = Just a} =
      a `HashSet.member` addrs'
    input_addr _ _ = False
    output_addr addrs' StoreOutput {address = 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 (.config.store.chain)
      startM <- blockAtOrAfter ch start
      endM <- blockAtOrBefore ch end
      return (startM, endM)
    conduits counter xpubs addrs endM =
      map (uncurry (xpub_c counter endM)) xpubs
        <> map (addr_c counter endM) (HashSet.toList addrs)
    addr_c counter endM a = do
      let f l = do
            ts <- getAddressTxs a l
            counter (length ts)
            return ts
          l =
            let Limits {..} = def
             in Limits
                  { limit = 16,
                    start = AtBlock . (.height) <$> endM,
                    ..
                  }
      streamThings f (Just (.txid)) l
    xpub_c counter endM x bs = do
      let f l = do
            ts <- xPubTxs x bs l
            counter (length ts)
            return ts
          l =
            let Limits {..} = def
             in Limits
                  { limit = 16,
                    start = AtBlock . (.height) <$> endM,
                    ..
                  }
      streamThings f (Just (.txid)) l

getPrice :: (MonadIO m) => WebT m (Text, BinfoTicker)
getPrice = do
  code <- T.toUpper <$> S.param "currency" `S.rescue` const (return "USD")
  ticker <- lift $ asks (.ticker)
  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

scottyBinfoBlocksDay :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoBlocksDay = do
  setMetrics (.binfoBlock)
  t <- min h . (`div` 1000) <$> S.param "milliseconds"
  ch <- lift $ asks (.config.store.chain)
  m <- blockAtOrBefore ch t
  bs <- go (d t) m
  addItemCount (length bs)
  streamEncoding $ toEncoding $ map toBinfoBlockInfo bs
  where
    h = fromIntegral (maxBound :: H.Timestamp)
    d = subtract (24 * 3600)
    go _ Nothing = return []
    go t (Just b)
      | b.header.timestamp <= fromIntegral t =
          return []
      | otherwise = do
          b' <- getBlock b.header.prev
          (b :) <$> go t b'

scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyMultiAddr = do
  setMetrics (.binfoMultiaddr)
  (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs
  numtxid <- getNumTxId
  cashaddr <- getCashAddr
  local' <- getSymbol
  offset <- getBinfoOffset
  n <- getBinfoCount "n"
  prune <- get_prune
  fltr <- get_filter
  xbals <- getXBals xspecs
  addItemCount . sum . map length $ HashMap.elems xbals
  xtxns <- get_xpub_tx_count xbals xspecs
  addItemCount (length xtxns)
  let sxbals = only_show_xbals sxpubs xbals
      xabals = compute_xabals xbals
      addrs = addrs' `HashSet.difference` HashMap.keysSet xabals
  abals <- get_abals addrs
  addItemCount (length abals)
  let sxspecs = only_show_xspecs sxpubs xspecs
      sxabals = compute_xabals sxbals
      sabals = only_show_abals saddrs abals
      sallbals = sabals <> sxabals
      sbal = compute_bal sallbals
      allbals = abals <> xabals
      abook = compute_abook addrs xbals
      sxaddrs = compute_xaddrs sxbals
      salladdrs = saddrs <> sxaddrs
      bal = compute_bal allbals
      ibal = fromIntegral sbal
  counter <- getItemCounter
  ftxs <-
    lift . runConduit $
      getBinfoTxs
        counter
        xbals
        abook
        sxspecs
        saddrs
        salladdrs
        fltr
        numtxid
        prune
        ibal
        .| (dropC offset >> takeC n .| sinkList)
  net <- lift $ asks (.config.store.net)
  ctx <- lift $ asks (.config.store.ctx)
  best <- get_best_block
  addItemCount 1
  peers <- get_peers
  addItemCount (fromIntegral peers)
  let baddrs = toBinfoAddrs sabals sxbals xtxns
      abaddrs = toBinfoAddrs abals xbals xtxns
      recv = sum $ map (.received) abaddrs
      sent' = sum $ map (.sent) abaddrs
      txn = fromIntegral $ length ftxs
      wallet =
        BinfoWallet
          { balance = bal,
            txs = txn,
            filtered = txn,
            received = recv,
            sent = sent'
          }
      coin = netBinfoSymbol net
  let block =
        BinfoBlockInfo
          { hash = H.headerHash best.header,
            height = best.height,
            timestamp = best.header.timestamp,
            index = best.height
          }
  let info =
        BinfoInfo
          { connected = peers,
            conversion = 100 * 1000 * 1000,
            fiat = local',
            crypto = coin,
            head = block
          }
  let multiaddr =
        BinfoMultiAddr
          { addresses = baddrs,
            wallet = wallet,
            txs = ftxs,
            info = info,
            recommendFee = True,
            cashAddr = cashaddr
          }
  setHeaders
  streamEncoding $ marshalEncoding (net, ctx) multiaddr
  where
    get_xpub_tx_count xbals =
      fmap HashMap.fromList
        . mapM
          ( \x ->
              (x,)
                . fromIntegral
                <$> xPubTxCount x (xBals x xbals)
          )
        . HashSet.toList
    get_filter =
      S.param "filter" `S.rescue` const (return BinfoFilterAll)
    get_best_block =
      getBestBlock >>= \case
        Nothing -> raise ThingNotFound
        Just bh ->
          getBlock bh >>= \case
            Nothing -> raise ThingNotFound
            Just b -> return b
    get_prune =
      fmap not $
        S.param "no_compact"
          `S.rescue` const (return False)
    only_show_xbals sxpubs =
      HashMap.filterWithKey (\k _ -> k.key `HashSet.member` sxpubs)
    only_show_xspecs sxpubs =
      HashSet.filter (\k -> k.key `HashSet.member` sxpubs)
    only_show_abals saddrs =
      HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs)
    addr (BinfoAddr a) = Just a
    addr (BinfoXpub _) = Nothing
    xpub (BinfoXpub x) = Just x
    xpub (BinfoAddr _) = Nothing
    get_addrs = do
      (xspecs, addrs) <- getBinfoActive
      sh <- getBinfoAddrsParam "onlyShow"
      let xpubs = HashSet.map (.key) xspecs
          actives =
            HashSet.map BinfoAddr addrs
              <> HashSet.map BinfoXpub xpubs
          sh' = if HashSet.null sh then actives else sh
          saddrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList sh'
          sxpubs = HashSet.fromList $ mapMaybe xpub $ HashSet.toList sh'
      return (addrs, xpubs, saddrs, sxpubs, xspecs)
    get_abals =
      let f b = (b.address, b)
          g = HashMap.fromList . map f
       in fmap g . getBalances . HashSet.toList
    get_peers = do
      ps <- lift $ getPeersInformation =<< asks (.config.store.peerMgr)
      return (fromIntegral (length ps))
    compute_xabals =
      let f b = (b.balance.address, b.balance)
       in HashMap.fromList . concatMap (map f) . HashMap.elems
    compute_bal =
      let f b = b.confirmed + b.unconfirmed
       in sum . map f . HashMap.elems
    compute_abook addrs xbals =
      let f XPubSpec {..} XPubBal {..} =
            let a = balance.address
                e = error "lions and tigers and bears"
                s = toSoft (listToPath path)
             in (a, Just (BinfoXPubPath key (fromMaybe e s)))
          amap =
            HashMap.map (const Nothing) $
              HashSet.toMap addrs
          xmap =
            HashMap.fromList
              . concatMap (uncurry (map . f))
              $ HashMap.toList xbals
       in amap <> xmap
    compute_xaddrs =
      let f = map (.balance.address)
       in HashSet.fromList . concatMap f . HashMap.elems

getBinfoCount :: (MonadUnliftIO m, MonadLoggerIO m) => TL.Text -> WebT m Int
getBinfoCount str = do
  d <- lift $ asks (.config.limits.defItemCount)
  x <- lift $ asks (.config.limits.maxFullItemCount)
  i <- min x <$> (S.param str `S.rescue` const (return d))
  return (fromIntegral i :: Int)

getBinfoOffset ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  WebT m Int
getBinfoOffset = do
  x <- lift $ asks (.config.limits.maxOffset)
  o <- S.param "offset" `S.rescue` const (return 0)
  when (o > x) $
    raise $
      UserError $
        "offset exceeded: " <> show o <> " > " <> show x
  return (fromIntegral o :: Int)

scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyRawAddr =
  setMetrics (.binfoAddressRaw)
    >> getBinfoAddr "addr"
    >>= \case
      BinfoAddr addr -> do_addr addr
      BinfoXpub xpub -> do_xpub xpub
  where
    do_xpub xpub = do
      numtxid <- getNumTxId
      derive <- S.param "derive" `S.rescue` const (return DeriveNormal)
      let xspec = XPubSpec xpub derive
      n <- getBinfoCount "limit"
      off <- getBinfoOffset
      xbals <- getXBals $ HashSet.singleton xspec
      addItemCount . sum . map length $ HashMap.elems xbals
      net <- lift $ asks (.config.store.net)
      let summary = xPubSummary xspec (xBals xspec xbals)
          abook = compute_abook xpub (xBals xspec xbals)
          xspecs = HashSet.singleton xspec
          saddrs = HashSet.empty
          baddrs = HashMap.keysSet abook
          bfilter = BinfoFilterAll
          amnt = summary.confirmed + summary.unconfirmed
      counter <- getItemCounter
      txs <-
        lift $
          runConduit $
            getBinfoTxs
              counter
              xbals
              abook
              xspecs
              saddrs
              baddrs
              bfilter
              numtxid
              False
              (fromIntegral amnt)
              .| (dropC off >> takeC n .| sinkList)
      let ra =
            BinfoRawAddr
              { address = BinfoXpub xpub,
                balance = amnt,
                ntx = fromIntegral $ length txs,
                utxo = summary.utxo,
                received = summary.received,
                sent = fromIntegral summary.received - fromIntegral amnt,
                txs = txs
              }
      setHeaders
      ctx <- asks (.config.store.ctx)
      streamEncoding $ marshalEncoding (net, ctx) ra
    compute_abook xpub xbals =
      let f XPubBal {..} =
            let a = balance.address
                e = error "black hole swallows all your code"
                s = toSoft $ listToPath path
                m = fromMaybe e s
             in (a, Just (BinfoXPubPath xpub m))
       in HashMap.fromList $ map f xbals
    do_addr addr = do
      numtxid <- getNumTxId
      n <- getBinfoCount "limit"
      off <- getBinfoOffset
      bal <- fromMaybe (zeroBalance addr) <$> getBalance addr
      addItemCount 1
      net <- lift $ asks (.config.store.net)
      let abook = HashMap.singleton addr Nothing
          xspecs = HashSet.empty
          saddrs = HashSet.singleton addr
          bfilter = BinfoFilterAll
          amnt = bal.confirmed + bal.unconfirmed
      counter <- getItemCounter
      txs <-
        lift $
          runConduit $
            getBinfoTxs
              counter
              HashMap.empty
              abook
              xspecs
              saddrs
              saddrs
              bfilter
              numtxid
              False
              (fromIntegral amnt)
              .| (dropC off >> takeC n .| sinkList)
      let ra =
            BinfoRawAddr
              { address = BinfoAddr addr,
                balance = amnt,
                ntx = bal.txs,
                utxo = bal.utxo,
                received = bal.received,
                sent = fromIntegral bal.received - fromIntegral amnt,
                txs = txs
              }
      setHeaders
      ctx <- asks (.config.store.ctx)
      streamEncoding $ marshalEncoding (net, ctx) ra

scottyBinfoReceived :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoReceived = do
  setMetrics (.binfoQgetreceivedbyaddress)
  a <- getAddress "addr"
  b <- fromMaybe (zeroBalance a) <$> getBalance a
  setHeaders
  addItemCount 1
  S.text $ cs $ show b.received

scottyBinfoSent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoSent = do
  setMetrics (.binfoQgetsentbyaddress)
  a <- getAddress "addr"
  b <- fromMaybe (zeroBalance a) <$> getBalance a
  setHeaders
  addItemCount 1
  S.text $ cs $ show $ b.received - b.confirmed - b.unconfirmed

scottyBinfoAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoAddrBalance = do
  setMetrics (.binfoQaddressbalance)
  a <- getAddress "addr"
  b <- fromMaybe (zeroBalance a) <$> getBalance a
  setHeaders
  addItemCount 1
  S.text $ cs $ show $ b.confirmed + b.unconfirmed

scottyFirstSeen :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyFirstSeen = do
  setMetrics (.binfoQaddressfirstseen)
  a <- getAddress "addr"
  ch <- lift $ asks (.config.store.chain)
  bb <- chainGetBest ch
  let top = bb.height
      bot = 0
  i <- go ch bb a bot top
  setHeaders
  addItemCount 1
  S.text $ cs $ show i
  where
    go ch bb a bot top = do
      let mid = bot + (top - bot) `div` 2
          n = top - bot < 2
      x <- hasone a bot
      y <- hasone a mid
      z <- hasone a top
      if
          | x -> getblocktime ch bb bot
          | n -> getblocktime ch bb top
          | y -> go ch bb a bot mid
          | z -> go ch bb a mid top
          | otherwise -> return 0
    getblocktime ch bb h =
      (.header.timestamp) . fromJust <$> chainGetAncestor h bb ch
    hasone a h = do
      let l = Limits 1 0 (Just (AtBlock h))
      not . null <$> getAddressTxs a l

scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyShortBal = do
  setMetrics (.binfoBalance)
  (xspecs, addrs) <- getBinfoActive
  cashaddr <- getCashAddr
  net <- lift $ asks (.config.store.net)
  abals <-
    catMaybes
      <$> mapM
        (get_addr_balance net cashaddr)
        (HashSet.toList addrs)
  addItemCount (length abals)
  xbals <- mapM (get_xspec_balance net) (HashSet.toList xspecs)
  let res = HashMap.fromList (abals <> xbals)
  setHeaders
  streamEncoding $ toEncoding res
  where
    to_short_bal Balance {..} =
      BinfoShortBal
        { final = confirmed + unconfirmed,
          ntx = txs,
          received = received
        }
    get_addr_balance net cashaddr a =
      let net' =
            if
                | cashaddr -> net
                | net == bch -> btc
                | net == bchTest -> btcTest
                | net == bchTest4 -> btcTest
                | otherwise -> net
       in case addrToText net' a of
            Nothing -> return Nothing
            Just a' ->
              getBalance a >>= \case
                Nothing -> return $ Just (a', to_short_bal (zeroBalance a))
                Just b -> return $ Just (a', to_short_bal b)
    is_ext XPubBal {path = 0 : _} = True
    is_ext _ = False
    get_xspec_balance net xpub = do
      xbals <- xPubBals xpub
      xts <- xPubTxCount xpub xbals
      addItemCount (length xbals + 1)
      let val = sum $ map (.balance.confirmed) xbals
          zro = sum $ map (.balance.unconfirmed) xbals
          exs = filter is_ext xbals
          rcv = sum $ map (.balance.received) exs
          sbl =
            BinfoShortBal
              { final = val + zro,
                ntx = fromIntegral xts,
                received = rcv
              }
      ctx <- asks (.config.store.ctx)
      return (xPubExport net ctx xpub.key, sbl)

getBinfoHex :: (Monad m) => WebT m Bool
getBinfoHex =
  (== ("hex" :: Text))
    <$> S.param "format" `S.rescue` const (return "json")

scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoBlockHeight = do
  numtxid <- getNumTxId
  height <- S.param "height"
  setMetrics (.binfoBlockHeight)
  block_hashes <- getBlocksAtHeight height
  block_headers <- catMaybes <$> mapM getBlock block_hashes
  addItemCount (length block_headers)
  next_block_hashes <- getBlocksAtHeight (height + 1)
  next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes
  addItemCount (length next_block_headers)
  binfo_blocks <-
    mapM (get_binfo_blocks numtxid next_block_headers) block_headers
  setHeaders
  net <- lift $ asks (.config.store.net)
  ctx <- lift $ asks (.config.store.ctx)
  streamEncoding $ marshalEncoding (net, ctx) binfo_blocks
  where
    get_tx th =
      withRunInIO $ \run ->
        unsafeInterleaveIO $
          run $
            fromJust <$> getTransaction th
    get_binfo_blocks numtxid next_block_headers block_header = do
      let my_hash = H.headerHash block_header.header
          get_prev = (.header.prev)
          get_hash = H.headerHash . (.header)
      txs <- lift $ mapM get_tx block_header.txs
      addItemCount (length txs)
      let next_blocks =
            map get_hash $
              filter
                ((== my_hash) . get_prev)
                next_block_headers
          binfo_txs = map (toBinfoTxSimple numtxid) txs
          binfo_block = toBinfoBlock block_header binfo_txs next_blocks
      return binfo_block

scottyBinfoLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoLatest = do
  numtxid <- getNumTxId
  setMetrics (.binfoBlockLatest)
  best <- get_best_block
  addItemCount 1
  streamEncoding $
    toEncoding
      BinfoHeader
        { hash = H.headerHash best.header,
          timestamp = best.header.timestamp,
          index = best.height,
          height = best.height,
          txids = map (encodeBinfoTxId numtxid) best.txs
        }
  where
    get_best_block =
      getBestBlock >>= \case
        Nothing -> raise ThingNotFound
        Just bh ->
          getBlock bh >>= \case
            Nothing -> raise ThingNotFound
            Just b -> return b

scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoBlock = do
  numtxid <- getNumTxId
  hex <- getBinfoHex
  setMetrics (.binfoBlockRaw)
  S.param "block" >>= \case
    BinfoBlockHash bh -> go numtxid hex bh
    BinfoBlockIndex i ->
      getBlocksAtHeight i >>= \case
        [] -> raise ThingNotFound
        bh : _ -> go numtxid hex bh
  where
    get_tx th =
      withRunInIO $ \run ->
        unsafeInterleaveIO $
          run $
            fromJust <$> getTransaction th
    go numtxid hex bh =
      getBlock bh >>= \case
        Nothing -> raise ThingNotFound
        Just b -> do
          addItemCount 1
          txs <- lift $ mapM get_tx b.txs
          addItemCount (length txs)
          let my_hash = H.headerHash b.header
              get_prev = (.header.prev)
              get_hash = H.headerHash . (.header)
          nxt_headers <-
            fmap catMaybes $
              mapM getBlock
                =<< getBlocksAtHeight (b.height + 1)
          addItemCount (length nxt_headers)
          let nxt =
                map get_hash $
                  filter
                    ((== my_hash) . get_prev)
                    nxt_headers
          if hex
            then do
              let x = H.Block b.header (map transactionData txs)
              setHeaders
              S.text . encodeHexLazy . runPutL $ serialize x
            else do
              let btxs = map (toBinfoTxSimple numtxid) txs
                  y = toBinfoBlock b btxs nxt
              setHeaders
              net <- lift $ asks (.config.store.net)
              ctx <- lift $ asks (.config.store.ctx)
              streamEncoding $ marshalEncoding (net, ctx) y

getBinfoTx ::
  (MonadLoggerIO m, MonadUnliftIO m) =>
  BinfoTxId ->
  WebT m (Either Except Transaction)
getBinfoTx txid = do
  tx <- case txid of
    BinfoTxIdHash h -> maybeToList <$> getTransaction h
    BinfoTxIdIndex i -> getNumTransaction i
  case tx of
    [t] -> return $ Right t
    [] -> return $ Left ThingNotFound
    ts ->
      let tids = map (txHash . transactionData) ts
       in return $ Left (TxIndexConflict tids)

scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoTx = do
  numtxid <- getNumTxId
  hex <- getBinfoHex
  txid <- S.param "txid"
  setMetrics (.binfoTxRaw)
  tx <-
    getBinfoTx txid >>= \case
      Right t -> return t
      Left e -> raise e
  addItemCount 1
  if hex then hx tx else js numtxid tx
  where
    js numtxid t = do
      net <- lift $ asks (.config.store.net)
      ctx <- lift $ asks (.config.store.ctx)
      setHeaders
      streamEncoding $ marshalEncoding (net, ctx) $ toBinfoTxSimple numtxid t
    hx t = do
      setHeaders
      S.text . encodeHexLazy . runPutL . serialize $ transactionData t

scottyBinfoTotalOut :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoTotalOut = do
  txid <- S.param "txid"
  setMetrics (.binfoQtxtotalbtcoutput)
  tx <-
    getBinfoTx txid >>= \case
      Right t -> return t
      Left e -> raise e
  addItemCount 1
  S.text $ cs $ show $ sum $ map (.value) tx.outputs

scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoTxFees = do
  txid <- S.param "txid"
  setMetrics (.binfoQtxfee)
  tx <-
    getBinfoTx txid >>= \case
      Right t -> return t
      Left e -> raise e
  let i = sum $ map (.value) $ filter f $ tx.inputs
      o = sum $ map (.value) $ tx.outputs
  addItemCount 1
  S.text . cs . show $ i - o
  where
    f StoreInput {} = True
    f StoreCoinbase {} = False

scottyBinfoTxResult :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoTxResult = do
  txid <- S.param "txid"
  addr <- getAddress "addr"
  setMetrics (.binfoQtxresult)
  tx <-
    getBinfoTx txid >>= \case
      Right t -> return t
      Left e -> raise e
  let i = toInteger $ sum $ map (.value) $ filter (f addr) $ tx.inputs
      o = toInteger $ sum $ map (.value) $ filter (g addr) $ tx.outputs
  addItemCount 1
  S.text $ cs $ show $ o - i
  where
    f addr StoreInput {address = Just a} = a == addr
    f _ _ = False
    g addr StoreOutput {address = Just a} = a == addr
    g _ _ = False

scottyBinfoTotalInput :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoTotalInput = do
  txid <- S.param "txid"
  setMetrics (.binfoQtxtotalbtcinput)
  tx <-
    getBinfoTx txid >>= \case
      Right t -> return t
      Left e -> raise e
  addItemCount 1
  S.text $ cs $ show $ sum $ map (.value) $ filter f $ tx.inputs
  where
    f StoreInput {} = True
    f StoreCoinbase {} = False

scottyBinfoMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoMempool = do
  setMetrics (.binfoMempool)
  numtxid <- getNumTxId
  offset <- getBinfoOffset
  n <- getBinfoCount "limit"
  mempool <- getMempool
  let txids = map snd $ take n $ drop offset mempool
  txs <- catMaybes <$> mapM getTransaction txids
  net <- lift $ asks (.config.store.net)
  setHeaders
  let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs
  addItemCount (length txs)
  ctx <- lift $ asks (.config.store.ctx)
  streamEncoding $ marshalEncoding (net, ctx) mem

scottyBinfoGetBlockCount :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoGetBlockCount = do
  setMetrics (.binfoQgetblockcount)
  ch <- asks (.config.store.chain)
  bn <- chainGetBest ch
  setHeaders
  addItemCount 1
  S.text $ cs $ show $ bn.height

scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoLatestHash = do
  setMetrics (.binfoQlatesthash)
  ch <- asks (.config.store.chain)
  bn <- chainGetBest ch
  setHeaders
  addItemCount 1
  S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash $ bn.header

scottyBinfoSubsidy :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoSubsidy = do
  setMetrics (.binfoQbcperblock)
  ch <- asks (.config.store.chain)
  net <- asks (.config.store.net)
  bn <- chainGetBest ch
  setHeaders
  addItemCount 1
  S.text $
    cs $
      show $
        (/ (100 * 1000 * 1000 :: Double)) $
          fromIntegral $
            H.computeSubsidy net (bn.height + 1)

scottyBinfoAddrToHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoAddrToHash = do
  setMetrics (.binfoQaddresstohash)
  addr <- getAddress "addr"
  setHeaders
  addItemCount 1
  S.text $ encodeHexLazy $ runPutL $ serialize $ addr.hash160

scottyBinfoHashToAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoHashToAddr = do
  setMetrics (.binfoQhashtoaddress)
  bs <- maybe S.next return . decodeHex =<< S.param "hash"
  net <- asks (.config.store.net)
  hash <- either (const S.next) return (decode bs)
  addr <- maybe S.next return (addrToText net (PubKeyAddress hash))
  setHeaders
  addItemCount 1
  S.text $ TL.fromStrict addr

scottyBinfoAddrPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoAddrPubkey = do
  setMetrics (.binfoQaddrpubkey)
  hex <- S.param "pubkey"
  ctx <- lift $ asks (.config.store.ctx)
  pubkey <-
    maybe S.next (return . pubKeyAddr ctx) $
      eitherToMaybe . unmarshal ctx =<< decodeHex hex
  net <- lift $ asks (.config.store.net)
  setHeaders
  case addrToText net pubkey of
    Nothing -> raise ThingNotFound
    Just a -> do
      addItemCount 1
      S.text $ TL.fromStrict a

scottyBinfoPubKeyAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoPubKeyAddr = do
  setMetrics (.binfoQpubkeyaddr)
  addr <- getAddress "addr"
  mi <- strm addr
  i <- case mi of
    Nothing -> raise ThingNotFound
    Just i -> return i
  pk <- case extr addr i of
    Left e -> raise $ UserError e
    Right t -> return t
  setHeaders
  S.text $ encodeHexLazy $ L.fromStrict pk
  where
    strm addr = do
      counter <- getItemCounter
      runConduit $ do
        let f l = do
              ts <- getAddressTxs addr l
              counter (length ts)
              return ts
            l = let Limits {..} = def in Limits {limit = 8, ..}
        streamThings f (Just (.txid)) l
          .| concatMapMC (getTransaction . (.txid))
          .| iterMC (\_ -> counter 1)
          .| concatMapC (filter (inp addr) . (.inputs))
          .| headC
    inp addr StoreInput {address = Just a} = a == addr
    inp _ _ = False
    extr addr StoreInput {script, pkscript, witness} = do
      Script sig <- decode script
      Script pks <- decode pkscript
      case addr of
        PubKeyAddress {} ->
          case sig of
            [OP_PUSHDATA _ _, OP_PUSHDATA pub _] ->
              Right pub
            [OP_PUSHDATA _ _] ->
              case pks of
                [OP_PUSHDATA pub _, OP_CHECKSIG] ->
                  Right pub
                _ -> Left "Could not parse scriptPubKey"
            _ -> Left "Could not parse scriptSig"
        WitnessPubKeyAddress {} ->
          case witness of
            [_, pub] -> return pub
            _ -> Left "Could not parse scriptPubKey"
        _ -> Left "Address does not have public key"
    extr _ _ = Left "Incorrect input type"

scottyBinfoHashPubkey :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBinfoHashPubkey = do
  setMetrics (.binfoQhashpubkey)
  ctx <- lift $ asks (.config.store.ctx)
  pkm <- (eitherToMaybe . unmarshal ctx <=< decodeHex) <$> S.param "pubkey"
  addr <- case pkm of
    Nothing -> raise $ UserError "Could not decode public key"
    Just pk -> return $ pubKeyAddr ctx pk
  setHeaders
  addItemCount 1
  S.text $ encodeHexLazy $ runPutL $ serialize $ addr.hash160

-- GET Network Information --

scottyPeers ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  GetPeers ->
  WebT m [PeerInfo]
scottyPeers _ = do
  setMetrics (.peers)
  ps <- lift $ getPeersInformation =<< asks (.config.store.peerMgr)
  addItemCount (length ps)
  return ps

-- | Obtain information about connected peers from peer manager process.
getPeersInformation ::
  (MonadLoggerIO m) => PeerMgr -> m [PeerInfo]
getPeersInformation mgr =
  mapMaybe toInfo <$> getPeers mgr
  where
    toInfo op = do
      ver <- op.version
      return
        PeerInfo
          { userAgent = ver.userAgent.get,
            address = show op.address,
            version = ver.version,
            services = ver.services,
            relay = ver.relay
          }

scottyHealth ::
  (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck
scottyHealth _ = do
  setMetrics (.health)
  h <- asks (.health) >>= readTVarIO
  unless (isOK h) $ S.status status503
  addItemCount 1
  return h

blockHealthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  m BlockHealth
blockHealthCheck cfg = do
  let ch = cfg.store.chain
  headers <- (.height) <$> chainGetBest ch
  blocks <-
    maybe 0 (.height)
      <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock)
  return
    BlockHealth
      { headers,
        blocks,
        max = fromIntegral cfg.maxLaggingBlocks
      }

lastBlockHealthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  Chain ->
  WebTimeouts ->
  m TimeHealth
lastBlockHealthCheck ch tos = do
  n <- fromIntegral . systemSeconds <$> liftIO getSystemTime
  t <- fromIntegral . (.header.timestamp) <$> chainGetBest ch
  return
    TimeHealth
      { age = n - t,
        max = fromIntegral tos.block
      }

lastTxHealthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  m TimeHealth
lastTxHealthCheck WebConfig {..} = do
  n <- fromIntegral . systemSeconds <$> liftIO getSystemTime
  b <- fromIntegral . (.header.timestamp) <$> chainGetBest ch
  t <-
    getMempool >>= \case
      t : _ ->
        let x = fromIntegral $ fst t
         in return $ max x b
      [] -> return b
  return
    TimeHealth
      { age = n - t,
        max = fromIntegral to
      }
  where
    ch = store.chain
    to =
      if noMempool
        then timeouts.block
        else timeouts.tx

pendingTxsHealthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  m MaxHealth
pendingTxsHealthCheck cfg = do
  n <- blockStorePendingTxs cfg.store.block
  return
    MaxHealth
      { max = fromIntegral cfg.maxPendingTxs,
        count = fromIntegral n
      }

peerHealthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  m CountHealth
peerHealthCheck cfg = do
  count <- fromIntegral . length <$> getPeers cfg.store.peerMgr
  return CountHealth {min = fromIntegral cfg.minPeers, count}

healthCheck ::
  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>
  WebConfig ->
  m HealthCheck
healthCheck cfg = do
  blocks <- blockHealthCheck cfg
  lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.timeouts
  lastTx <- lastTxHealthCheck cfg
  pendingTxs <- pendingTxsHealthCheck cfg
  peers <- peerHealthCheck cfg
  time <- round . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime
  let check =
        HealthCheck
          { network = cfg.store.net.name,
            version = cfg.version,
            ..
          }
  unless (isOK check) $ do
    let t = toStrict $ encodeToLazyText check
    $(logErrorS) "Web" $ "Health check failed: " <> t
  return check

scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyDbStats = do
  setMetrics (.db)
  setHeaders
  db <- lift $ asks (.config.store.db.db)
  statsM <- lift (getProperty db Stats)
  addItemCount 1
  S.text $ maybe "Could not get stats" cs statsM

-----------------------
-- Parameter Parsing --
-----------------------

-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on
-- parse failure.
paramOptional :: (Param a, MonadIO m) => WebT m (Maybe a)
paramOptional = go Proxy
  where
    go :: (Param a, MonadIO m) => Proxy a -> WebT m (Maybe a)
    go proxy = do
      net <- lift $ asks (.config.store.net)
      ctx <- lift $ asks (.config.store.ctx)
      tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing)
      case tsM of
        Nothing -> return Nothing -- Parameter was not supplied
        Just ts -> maybe (raise err) (return . Just) $ parseParam net ctx ts
      where
        l = proxyLabel proxy
        p = Just <$> S.param (cs l)
        err = UserError $ "Unable to parse param " <> cs l

-- | Raises an exception if the parameter is not supplied
param :: (Param a, MonadIO m) => WebT m a
param = go Proxy
  where
    go :: (Param a, MonadIO m) => Proxy a -> WebT m a
    go proxy = do
      resM <- paramOptional
      case resM of
        Just res -> return res
        _ ->
          raise . UserError $
            "The param " <> cs (proxyLabel proxy) <> " was not defined"

-- | Returns the default value of a parameter if it is not supplied. Raises an
-- exception on parse failure.
paramDef :: (Default a, Param a, MonadIO m) => WebT m a
paramDef = fromMaybe def <$> paramOptional

-- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is
-- not supplied or if parsing fails.
paramLazy :: (Param a, MonadIO m) => WebT m a
paramLazy = do
  resM <- paramOptional `S.rescue` const (return Nothing)
  maybe S.next return resM

parseBody :: (MonadIO m, Serial a) => WebT m a
parseBody = do
  b <- L.toStrict <$> S.body
  case hex b <> bin b of
    Left _ -> raise $ UserError "Failed to parse request body"
    Right x -> return x
  where
    bin = runGetS deserialize
    hex b =
      let ns = C.filter (not . isSpace) b
       in if isBase16 ns
            then bin . decodeBase16 $ assertBase16 ns
            else Left "Invalid hex input"

parseOffset :: (MonadIO m) => WebT m OffsetParam
parseOffset = do
  res@(OffsetParam o) <- paramDef
  limits <- lift $ asks (.config.limits)
  when (limits.maxOffset > 0 && fromIntegral o > limits.maxOffset) $
    raise . UserError $
      "offset exceeded: " <> show o <> " > " <> show limits.maxOffset
  return res

parseStart ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  Maybe StartParam ->
  WebT m (Maybe Start)
parseStart Nothing = return Nothing
parseStart (Just s) =
  runMaybeT $
    case s of
      StartParamHash {hash = h} -> start_tx h <|> start_block h
      StartParamHeight {height = h} -> start_height h
      StartParamTime {time = q} -> start_time q
  where
    start_height h = return $ AtBlock $ fromIntegral h
    start_block h = do
      b <- MaybeT $ getBlock (H.BlockHash h)
      return $ AtBlock b.height
    start_tx h = do
      _ <- MaybeT $ getTxData (TxHash h)
      return $ AtTx (TxHash h)
    start_time q = do
      ch <- lift $ asks (.config.store.chain)
      b <- MaybeT $ blockAtOrBefore ch q
      return $ AtBlock b.height

parseLimits :: (MonadIO m) => WebT m LimitsParam
parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional

paramToLimits ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  Bool ->
  LimitsParam ->
  WebT m Limits
paramToLimits full (LimitsParam limitM o startM) = do
  wl <- lift $ asks (.config.limits)
  Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM

validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32
validateLimit wl full limitM =
  f m $ maybe d (fromIntegral . (.get)) limitM
  where
    m
      | full && wl.maxFullItemCount > 0 = wl.maxFullItemCount
      | otherwise = wl.maxItemCount
    d = wl.defItemCount
    f a 0 = a
    f 0 b = b
    f a b = min a b

---------------
-- Utilities --
---------------

runInWebReader ::
  (MonadIO m) =>
  CacheT (DatabaseReaderT m) a ->
  ReaderT WebState m a
runInWebReader f = do
  bdb <- asks (.config.store.db)
  mc <- asks (.config.store.cache)
  lift $ runReaderT (withCache mc f) bdb

runNoCache :: (MonadIO m) => Bool -> ReaderT WebState m a -> ReaderT WebState m a
runNoCache False f = f
runNoCache True f = local g f
  where
    g s = s {config = h s.config}
    h c = c {store = i c.store}
    i s = s {cache = Nothing}

logIt ::
  (MonadUnliftIO m, MonadLoggerIO m) =>
  Maybe WebMetrics ->
  m Middleware
logIt metrics = do
  runner <- askRunInIO
  return $ \app req respond -> do
    var <- newTVarIO B.empty
    req' <-
      let rb = req_body var (getRequestBodyChunk req)
          rq = req {requestBody = rb}
       in case metrics of
            Nothing -> return rq
            Just m -> do
              stat_var <- newTVarIO Nothing
              let vt =
                    V.insert m.key stat_var $
                      vault rq
              return rq {vault = vt}
    bracket start (end var runner req') $ \_ ->
      app req' $ \res -> do
        b <- readTVarIO var
        let s = responseStatus res
            msg = fmtReq b req' <> ": " <> fmtStatus s
        if statusIsSuccessful s
          then runner $ $(logDebugS) "Web" msg
          else runner $ $(logErrorS) "Web" msg
        respond res
  where
    start = systemToUTCTime <$> getSystemTime
    req_body var old_body = do
      b <- old_body
      unless (B.null b) . atomically $ modifyTVar var (<> b)
      return b
    add_stat d s = do
      addStatQuery s
      addStatTime s d
    end var runner req t1 = do
      t2 <- systemToUTCTime <$> getSystemTime
      let diff = round $ diffUTCTime t2 t1 * 1000
      case metrics of
        Nothing -> return ()
        Just m -> do
          let m_stat_var = V.lookup m.key (vault req)
          add_stat diff m.all
          case m_stat_var of
            Nothing -> return ()
            Just stat_var ->
              readTVarIO stat_var >>= \case
                Nothing -> return ()
                Just f -> add_stat diff (f m)
      when (diff > 10000) $ do
        b <- readTVarIO var
        runner $
          $(logWarnS) "Web" $
            "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req

reqSizeLimit :: (Integral i) => i -> Middleware
reqSizeLimit i = requestSizeLimitMiddleware lim
  where
    max_len _req = return (Just (fromIntegral i))
    lim =
      setOnLengthExceeded too_big $
        setMaxLengthForRequest
          max_len
          defaultRequestSizeLimitSettings
    too_big _ _app _req send =
      send $
        waiExcept requestEntityTooLarge413 RequestTooLarge

reqTimeout :: (Integral i) => i -> Middleware
reqTimeout = timeoutAs res . fromIntegral
  where
    err = ServerTimeout
    res = responseLBS sta [hdr] (A.encode err)
    sta = errStatus err
    hdr = (hContentType, "application/json")

fmtReq :: ByteString -> Request -> Text
fmtReq bs req =
  let m = requestMethod req
      v = httpVersion req
      p = rawPathInfo req
      q = rawQueryString req
      txt = case T.decodeUtf8' bs of
        Left _ -> " {invalid utf8}"
        Right "" -> ""
        Right t -> " [" <> t <> "]"
   in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt

fmtStatus :: Status -> Text
fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)