haskoin-store-0.29.3: src/Haskoin/Store/Web.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Haskoin.Store.Web
( -- * Web
WebConfig (..)
, Except (..)
, WebLimits (..)
, WebTimeouts (..)
, runWeb
) where
import Conduit ()
import Control.Applicative ((<|>))
import Control.Monad (forever, guard, mzero, unless,
when, (<=<))
import Control.Monad.Logger (MonadLogger, MonadLoggerIO,
askLoggerIO, logInfoS,
monadLoggerLog)
import Control.Monad.Reader (ReaderT, asks, local,
runReaderT)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Aeson (Encoding, ToJSON (..))
import Data.Aeson.Encoding (encodingToLazyByteString, list)
import qualified Data.ByteString as B
import Data.ByteString.Builder (lazyByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Char (isSpace)
import Data.Default (Default (..))
import Data.List (nub)
import Data.Maybe (catMaybes, fromMaybe, isJust,
listToMaybe, mapMaybe)
import Data.Serialize as Serialize
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime,
getCurrentTime)
import Data.Time.Clock.System (getSystemTime, systemSeconds)
import Data.Version (showVersion)
import Data.Word (Word32, Word64)
import Database.RocksDB (Property (..), getProperty)
import Haskoin (Address, Block (..),
BlockHash (..),
BlockHeader (..), BlockHeight,
BlockNode (..), GetData (..),
Hash256, InvType (..),
InvVector (..), Message (..),
Network (..), OutPoint (..), Tx,
TxHash (..), VarString (..),
Version (..), decodeHex,
eitherToMaybe, headerHash,
hexToBlockHash, hexToTxHash,
stringToAddr, txHash,
xPubImport)
import Haskoin.Node (Chain, OnlinePeer (..),
PeerManager, chainGetBest,
managerGetPeers, sendMessage)
import Haskoin.Store.Cache (CacheT, evictFromCache,
withCache)
import Haskoin.Store.Common (Limits (..), PubExcept (..),
Start (..), StoreEvent (..),
StoreRead (..), blockAtOrBefore,
getTransaction, nub')
import Haskoin.Store.Data (BlockData (..), BlockRef (..),
TxRef (..), DeriveType (..),
Event (..), Except (..),
GenericResult (..),
HealthCheck (..),
PeerInformation (..),
StoreInput (..),
Transaction (..), TxId (..),
UnixTime, Unspent, XPubBal (..),
XPubSpec (..),
balanceToEncoding,
blockDataToEncoding, isCoinbase,
nullBalance, transactionData,
transactionToEncoding,
unspentToEncoding,
xPubBalToEncoding,
xPubUnspentToEncoding)
import Haskoin.Store.Database.Reader (DatabaseReader (..),
DatabaseReaderT,
withDatabaseReader)
import Haskoin.Store.Manager (Store (..))
import Network.HTTP.Types (Status (..), status400,
status403, status404, status500,
status503)
import Network.Wai (Middleware, Request (..),
responseStatus)
import NQE (Publisher, receive,
withSubscription)
import qualified Paths_haskoin_store as P (version)
import Text.Printf (printf)
import Text.Read (readMaybe)
import UnliftIO (MonadIO, MonadUnliftIO,
askRunInIO, liftIO, timeout)
import Web.Scotty.Internal.Types (ActionT)
import Web.Scotty.Trans (Parsable, ScottyError)
import qualified Web.Scotty.Trans as S
type WebT m = ActionT Except (ReaderT WebConfig m)
data WebConfig =
WebConfig
{ webPort :: !Int
, webStore :: !Store
, webMaxLimits :: !WebLimits
, webReqLog :: !Bool
, webWebTimeouts :: !WebTimeouts
}
data WebLimits =
WebLimits
{ maxLimitCount :: !Word32
, maxLimitFull :: !Word32
, maxLimitOffset :: !Word32
, maxLimitDefault :: !Word32
, maxLimitGap :: !Word32
, maxLimitInitialGap :: !Word32
}
deriving (Eq, Show)
instance Default WebLimits where
def =
WebLimits
{ maxLimitCount = 20000
, maxLimitFull = 5000
, maxLimitOffset = 50000
, maxLimitDefault = 2000
, maxLimitGap = 32
, maxLimitInitialGap = 20
}
data WebTimeouts =
WebTimeouts
{ txTimeout :: !Word64
, blockTimeout :: !Word64
}
deriving (Eq, Show)
instance Default WebTimeouts where
def = WebTimeouts {txTimeout = 300, blockTimeout = 7200}
newtype MyBlockHash =
MyBlockHash BlockHash
newtype MyTxHash =
MyTxHash TxHash
instance Parsable MyBlockHash where
parseParam =
maybe (Left "could not decode block hash") (Right . MyBlockHash) . hexToBlockHash . cs
instance Parsable MyTxHash where
parseParam =
maybe (Left "could not decode tx hash") (Right . MyTxHash) . hexToTxHash . cs
data StartParam
= StartParamHash
{ startParamHash :: !Hash256}
| StartParamHeight
{ startParamHeight :: !Word32}
| StartParamTime
{ startParamTime :: !UnixTime}
instance Parsable StartParam where
parseParam s = maybe (Left "could not decode start") Right (h <|> g <|> t)
where
h = do
x <- fmap B.reverse (decodeHex (cs s)) >>= eitherToMaybe . decode
return StartParamHash {startParamHash = x}
g = do
x <- readMaybe (cs s) :: Maybe Integer
guard $ 0 <= x && x <= 1230768000
return StartParamHeight {startParamHeight = fromIntegral x}
t = do
x <- readMaybe (cs s)
guard $ x > 1230768000
return StartParamTime {startParamTime = x}
runInWebReader ::
MonadIO m
=> CacheT (DatabaseReaderT m) a
-> ReaderT WebConfig m a
runInWebReader f = do
bdb <- asks (storeDB . webStore)
mc <- asks (storeCache . webStore)
lift $ withDatabaseReader bdb (withCache mc f)
runNoCache :: MonadIO m => Bool -> ReaderT WebConfig m a -> ReaderT WebConfig m a
runNoCache False f = f
runNoCache True f =
local (\s -> s {webStore = (webStore s) {storeCache = Nothing}}) f
instance (MonadUnliftIO m, MonadLoggerIO m) =>
StoreRead (ReaderT WebConfig m) where
getMaxGap = runInWebReader getMaxGap
getInitialGap = runInWebReader getInitialGap
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)
getSpenders th = runInWebReader (getSpenders th)
getUnspent op = runInWebReader (getUnspent op)
getBalance a = runInWebReader (getBalance a)
getBalances as = runInWebReader (getBalances as)
getMempool = runInWebReader getMempool
getAddressesTxs as = runInWebReader . getAddressesTxs as
getAddressesUnspents as = runInWebReader . getAddressesUnspents as
xPubBals = runInWebReader . xPubBals
xPubSummary = runInWebReader . xPubSummary
xPubUnspents xpub = runInWebReader . xPubUnspents xpub
xPubTxs xpub = runInWebReader . xPubTxs xpub
instance (MonadUnliftIO m, MonadLoggerIO m) => StoreRead (WebT m) where
getNetwork = lift getNetwork
getBestBlock = lift getBestBlock
getBlocksAtHeight = lift . getBlocksAtHeight
getBlock = lift . getBlock
getTxData = lift . getTxData
getSpender = lift . getSpender
getSpenders = lift . getSpenders
getUnspent = lift . getUnspent
getBalance = lift . getBalance
getBalances = lift . getBalances
getMempool = lift getMempool
getAddressesTxs as = lift . getAddressesTxs as
getAddressesUnspents as = lift . getAddressesUnspents as
xPubBals = lift . xPubBals
xPubSummary = lift . xPubSummary
xPubUnspents xpub = lift . xPubUnspents xpub
xPubTxs xpub = lift . xPubTxs xpub
getMaxGap = lift getMaxGap
getInitialGap = lift getInitialGap
defHandler :: Monad m => Except -> WebT m ()
defHandler e = do
proto <- setupBin
case e of
ThingNotFound -> S.status status404
BadRequest -> S.status status400
UserError _ -> S.status status400
StringError _ -> S.status status400
ServerError -> S.status status500
BlockTooLarge -> S.status status403
protoSerial proto e
maybeSerial ::
(Monad m, ToJSON a, Serialize a)
=> Bool -- ^ binary
-> Maybe a
-> WebT m ()
maybeSerial _ Nothing = S.raise ThingNotFound
maybeSerial proto (Just x) = do
S.raw (serialAny proto x)
maybeSerialNet ::
(Monad m, Serialize a)
=> Bool
-> (Network -> a -> Encoding)
-> Maybe a
-> WebT m ()
maybeSerialNet _ _ Nothing = S.raise ThingNotFound
maybeSerialNet proto f (Just x) = do
net <- lift $ asks (storeNetwork . webStore)
S.raw (serialAnyNet proto (f net) x)
protoSerial ::
(Monad m, ToJSON a, Serialize a)
=> Bool
-> a
-> WebT m ()
protoSerial proto x = do
S.raw (serialAny proto x)
protoSerialNet ::
(Monad m, Serialize a)
=> Bool
-> (Network -> a -> Encoding)
-> a
-> WebT m ()
protoSerialNet proto f x = do
net <- lift $ asks (storeNetwork . webStore)
S.raw (serialAnyNet proto (f net) x)
scottyBestBlock ::
(MonadUnliftIO m, MonadLoggerIO m, MonadIO m) => Bool -> WebT m ()
scottyBestBlock raw = do
limits <- lift $ asks webMaxLimits
setHeaders
n <- parseNoTx
proto <- setupBin
bm <-
runMaybeT $ do
h <- MaybeT getBestBlock
MaybeT $ getBlock h
b <-
case bm of
Nothing -> S.raise ThingNotFound
Just b -> return b
if raw
then do
refuseLargeBlock limits b
rawBlock b >>= protoSerial proto
else protoSerialNet proto blockDataToEncoding (pruneTx n b)
scottyBlock :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyBlock raw = do
limits <- lift $ asks webMaxLimits
setHeaders
MyBlockHash block <- S.param "block"
n <- parseNoTx
proto <- setupBin
b <-
getBlock block >>= \case
Nothing -> S.raise ThingNotFound
Just b -> return b
if raw
then do
refuseLargeBlock limits b
rawBlock b >>= protoSerial proto
else protoSerialNet proto blockDataToEncoding (pruneTx n b)
scottyBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyBlockHeight raw = do
limits <- lift $ asks webMaxLimits
setHeaders
height <- S.param "height"
n <- parseNoTx
proto <- setupBin
hs <- getBlocksAtHeight height
if raw
then do
blocks <- catMaybes <$> mapM getBlock hs
mapM_ (refuseLargeBlock limits) blocks
rawblocks <- mapM rawBlock blocks
protoSerial proto rawblocks
else do
blocks <- catMaybes <$> mapM getBlock hs
let blocks' = map (pruneTx n) blocks
protoSerialNet proto (list . blockDataToEncoding) blocks'
scottyBlockTime :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyBlockTime raw = do
limits <- lift $ asks webMaxLimits
setHeaders
q <- S.param "time"
n <- parseNoTx
proto <- setupBin
m <- fmap (pruneTx n) <$> blockAtOrBefore q
if raw
then maybeSerial proto =<<
case m of
Nothing -> return Nothing
Just d -> do
refuseLargeBlock limits d
Just <$> rawBlock d
else maybeSerialNet proto blockDataToEncoding m
scottyBlockHeights :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBlockHeights = do
setHeaders
heights <- S.param "heights"
n <- parseNoTx
proto <- setupBin
bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])
blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs
protoSerialNet proto (list . blockDataToEncoding) blocks
scottyBlockLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBlockLatest = do
setHeaders
n <- parseNoTx
proto <- setupBin
getBestBlock >>= \case
Just h -> do
blocks <- reverse <$> go 100 n h
protoSerialNet proto (list . blockDataToEncoding) blocks
Nothing -> S.raise ThingNotFound
where
go 0 _ _ = return []
go i n h =
getBlock h >>= \case
Nothing -> return []
Just b ->
let b' = pruneTx n b
i' = i - 1 :: Int
prev = prevBlock (blockDataHeader b)
in if blockDataHeight b <= 0
then return []
else (b' :) <$> go i' n prev
scottyBlocks :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBlocks = do
setHeaders
bhs <- map (\(MyBlockHash h) -> h) <$> S.param "blocks"
n <- parseNoTx
proto <- setupBin
bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs)
protoSerialNet proto (list . blockDataToEncoding) bks
scottyMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyMempool = do
setHeaders
proto <- setupBin
txs <- map txRefHash <$> getMempool
protoSerial proto txs
scottyTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyTransaction = do
setHeaders
MyTxHash txid <- S.param "txid"
proto <- setupBin
res <- getTransaction txid
maybeSerialNet proto transactionToEncoding res
scottyRawTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyRawTransaction = do
setHeaders
MyTxHash txid <- S.param "txid"
proto <- setupBin
res <- fmap transactionData <$> getTransaction txid
maybeSerial proto res
scottyTxAfterHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyTxAfterHeight = do
setHeaders
MyTxHash txid <- S.param "txid"
height <- S.param "height"
proto <- setupBin
res <- cbAfterHeight 10000 height txid
protoSerial proto res
scottyTransactions :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyTransactions = do
setHeaders
txids <- map (\(MyTxHash h) -> h) <$> S.param "txids"
proto <- setupBin
txs <- catMaybes <$> mapM getTransaction (nub txids)
protoSerialNet proto (list . transactionToEncoding) txs
scottyBlockTransactions :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyBlockTransactions = do
limits <- lift $ asks webMaxLimits
setHeaders
MyBlockHash h <- S.param "block"
proto <- setupBin
getBlock h >>= \case
Just b -> do
refuseLargeBlock limits b
let ths = blockDataTxs b
txs <- catMaybes <$> mapM getTransaction ths
protoSerialNet proto (list . transactionToEncoding) txs
Nothing -> S.raise ThingNotFound
scottyRawTransactions ::
(MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyRawTransactions = do
setHeaders
txids <- map (\(MyTxHash h) -> h) <$> S.param "txids"
proto <- setupBin
txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids)
protoSerial proto txs
rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block
rawBlock b = do
let h = blockDataHeader b
ths = blockDataTxs b
txs <- map transactionData . catMaybes <$> mapM getTransaction ths
return Block {blockHeader = h, blockTxns = txs}
scottyRawBlockTransactions ::
(MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyRawBlockTransactions = do
limits <- lift $ asks webMaxLimits
setHeaders
MyBlockHash h <- S.param "block"
proto <- setupBin
getBlock h >>= \case
Just b -> do
refuseLargeBlock limits b
let ths = blockDataTxs b
txs <- map transactionData . catMaybes <$> mapM getTransaction ths
protoSerial proto txs
Nothing -> S.raise ThingNotFound
scottyAddressTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyAddressTxs full = do
setHeaders
a <- parseAddress
l <- getLimits full
proto <- setupBin
if full
then do
getAddressTxsFull l a >>=
protoSerialNet proto (list . transactionToEncoding)
else do
getAddressTxsLimit l a >>= protoSerial proto
scottyAddressesTxs ::
(MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyAddressesTxs full = do
setHeaders
as <- parseAddresses
l <- getLimits full
proto <- setupBin
if full
then getAddressesTxsFull l as >>=
protoSerialNet proto (list . transactionToEncoding)
else getAddressesTxsLimit l as >>= protoSerial proto
scottyAddressUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyAddressUnspent = do
setHeaders
a <- parseAddress
l <- getLimits False
proto <- setupBin
uns <- getAddressUnspentsLimit l a
protoSerialNet proto (list . unspentToEncoding) uns
scottyAddressesUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyAddressesUnspent = do
setHeaders
as <- parseAddresses
l <- getLimits False
proto <- setupBin
uns <- getAddressesUnspentsLimit l as
protoSerialNet proto (list . unspentToEncoding) uns
scottyAddressBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyAddressBalance = do
setHeaders
a <- parseAddress
proto <- setupBin
res <- getBalance a
protoSerialNet proto balanceToEncoding res
scottyAddressesBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyAddressesBalances = do
setHeaders
as <- parseAddresses
proto <- setupBin
res <- getBalances as
protoSerialNet proto (list . balanceToEncoding) res
scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyXpubBalances = do
setHeaders
nocache <- parseNoCache
xpub <- parseXpub
proto <- setupBin
res <-
filter (not . nullBalance . xPubBal) <$>
lift (runNoCache nocache (xPubBals xpub))
protoSerialNet proto (list . xPubBalToEncoding) res
scottyXpubTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()
scottyXpubTxs full = do
setHeaders
nocache <- parseNoCache
xpub <- parseXpub
l <- getLimits full
proto <- setupBin
txs <- lift . runNoCache nocache $ xPubTxs xpub l
if full
then do
txs' <-
fmap catMaybes . lift . runNoCache nocache $
mapM (getTransaction . txRefHash) txs
protoSerialNet proto (list . transactionToEncoding) txs'
else protoSerial proto txs
scottyXpubEvict :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyXpubEvict =
lift (asks (storeCache . webStore)) >>= \cache -> do
setHeaders
xpub <- parseXpub
proto <- setupBin
lift . withCache cache $ evictFromCache [xpub]
protoSerial proto (GenericResult True)
scottyXpubUnspents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyXpubUnspents = do
setHeaders
nocache <- parseNoCache
xpub <- parseXpub
proto <- setupBin
l <- getLimits False
uns <- lift . runNoCache nocache $ xPubUnspents xpub l
protoSerialNet proto (list . xPubUnspentToEncoding) uns
scottyXpubSummary :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
scottyXpubSummary = do
setHeaders
nocache <- parseNoCache
xpub <- parseXpub
proto <- setupBin
res <- lift . runNoCache nocache $ xPubSummary xpub
protoSerial proto res
scottyPostTx ::
(MonadUnliftIO m, MonadLoggerIO m)
=> WebT m ()
scottyPostTx = do
net <- lift $ asks (storeNetwork . webStore)
pub <- lift $ asks (storePublisher . webStore)
mgr <- lift $ asks (storeManager . webStore)
setHeaders
proto <- setupBin
b <- S.body
let bin = eitherToMaybe . Serialize.decode
hex = bin <=< decodeHex . cs . C.filter (not . isSpace)
tx <-
case hex b <|> bin (L.toStrict b) of
Nothing -> S.raise $ UserError "decode tx fail"
Just x -> return x
lift (publishTx net pub mgr tx) >>= \case
Right () -> do
protoSerial proto (TxId (txHash tx))
Left e -> do
case e of
PubNoPeers -> S.status status500
PubTimeout -> S.status status500
PubPeerDisconnected -> S.status status500
PubReject _ -> S.status status400
protoSerial proto (UserError (show e))
S.finish
scottyDbStats :: MonadLoggerIO m => WebT m ()
scottyDbStats = do
setHeaders
db <- lift $ asks (databaseHandle . storeDB . webStore)
stats <- lift (getProperty db Stats)
case stats of
Nothing -> do
S.text "Could not get stats"
Just txt -> do
S.text $ cs txt
scottyEvents :: MonadLoggerIO m => WebT m ()
scottyEvents = do
pub <- lift $ asks (storePublisher . webStore)
setHeaders
proto <- setupBin
S.stream $ \io flush' ->
withSubscription pub $ \sub ->
forever $
flush' >> receive sub >>= \se -> do
let me =
case se of
StoreBestBlock b -> Just (EventBlock b)
StoreMempoolNew t -> Just (EventTx t)
StoreTxDeleted t -> Just (EventTx t)
StoreBlockReverted b -> Just (EventBlock b)
_ -> Nothing
case me of
Nothing -> return ()
Just e ->
let bs =
serialAny proto e <>
if proto
then mempty
else "\n"
in io (lazyByteString bs)
scottyPeers :: MonadLoggerIO m => WebT m ()
scottyPeers = do
mgr <- lift $ asks (storeManager . webStore)
setHeaders
proto <- setupBin
ps <- getPeersInformation mgr
protoSerial proto ps
scottyHealth ::
(MonadUnliftIO m, MonadLoggerIO m)
=> WebT m ()
scottyHealth = do
net <- lift $ asks (storeNetwork . webStore)
mgr <- lift $ asks (storeManager . webStore)
chn <- lift $ asks (storeChain . webStore)
tos <- lift $ asks webWebTimeouts
setHeaders
proto <- setupBin
h <- lift $ healthCheck net mgr chn tos
when (not (healthOK h) || not (healthSynced h)) $ S.status status503
protoSerial proto h
runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m ()
runWeb cfg@WebConfig {webPort = port, webReqLog = reqlog} = do
req_logger <-
if reqlog
then Just <$> logIt
else return Nothing
runner <- askRunInIO
S.scottyT port (runner . (`runReaderT` cfg)) $ do
case req_logger of
Just m -> S.middleware m
Nothing -> return ()
S.defaultHandler defHandler
S.get "/block/best" $ scottyBestBlock False
S.get "/block/best/raw" $ scottyBestBlock True
S.get "/block/:block" $ scottyBlock False
S.get "/block/:block/raw" $ scottyBlock True
S.get "/block/height/:height" $ scottyBlockHeight False
S.get "/block/height/:height/raw" $ scottyBlockHeight True
S.get "/block/time/:time" $ scottyBlockTime False
S.get "/block/time/:time/raw" $ scottyBlockTime True
S.get "/block/heights" scottyBlockHeights
S.get "/block/latest" scottyBlockLatest
S.get "/blocks" scottyBlocks
S.get "/mempool" scottyMempool
S.get "/transaction/:txid" scottyTransaction
S.get "/transaction/:txid/raw" scottyRawTransaction
S.get "/transaction/:txid/after/:height" scottyTxAfterHeight
S.get "/transactions" scottyTransactions
S.get "/transactions/raw" scottyRawTransactions
S.get "/transactions/block/:block" scottyBlockTransactions
S.get "/transactions/block/:block/raw" scottyRawBlockTransactions
S.get "/address/:address/transactions" $ scottyAddressTxs False
S.get "/address/:address/transactions/full" $ scottyAddressTxs True
S.get "/address/transactions" $ scottyAddressesTxs False
S.get "/address/transactions/full" $ scottyAddressesTxs True
S.get "/address/:address/unspent" scottyAddressUnspent
S.get "/address/unspent" scottyAddressesUnspent
S.get "/address/:address/balance" scottyAddressBalance
S.get "/address/balances" scottyAddressesBalances
S.get "/xpub/:xpub/balances" scottyXpubBalances
S.get "/xpub/:xpub/transactions" $ scottyXpubTxs False
S.get "/xpub/:xpub/transactions/full" $ scottyXpubTxs True
S.get "/xpub/:xpub/unspent" scottyXpubUnspents
S.get "/xpub/:xpub/evict" scottyXpubEvict
S.get "/xpub/:xpub" scottyXpubSummary
S.post "/transactions" scottyPostTx
S.get "/dbstats" scottyDbStats
S.get "/events" scottyEvents
S.get "/peers" scottyPeers
S.get "/health" scottyHealth
S.notFound $ S.raise ThingNotFound
getStart :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m (Maybe Start)
getStart =
runMaybeT $ do
s <-
MaybeT $
(Just <$> S.param "height") `S.rescue` const (return Nothing)
do case s of
StartParamHash {startParamHash = h} ->
start_tx h <|> start_block h
StartParamHeight {startParamHeight = h} -> start_height h
StartParamTime {startParamTime = q} -> start_time q
where
start_height h = return $ AtBlock h
start_block h = do
b <- MaybeT $ getBlock (BlockHash h)
return $ AtBlock (blockDataHeight b)
start_tx h = do
_ <- MaybeT $ getTxData (TxHash h)
return $ AtTx (TxHash h)
start_time q = do
d <- MaybeT getBestBlock >>= MaybeT . getBlock
if q <= fromIntegral (blockTimestamp (blockDataHeader d))
then do
b <- MaybeT $ blockAtOrBefore q
let g = blockDataHeight b
return $ AtBlock g
else mzero
getLimits :: (MonadLoggerIO m, MonadUnliftIO m) => Bool -> WebT m Limits
getLimits full = do
o <- getOffset
l <- getLimit full
s <- getStart
return Limits {limit = l, offset = o, start = s}
getOffset :: Monad m => WebT m Word32
getOffset = do
limits <- lift $ asks webMaxLimits
o <- S.param "offset" `S.rescue` const (return 0)
when (maxLimitOffset limits > 0 && o > maxLimitOffset limits) .
S.raise . UserError $
"offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)
return o
getLimit ::
Monad m
=> Bool
-> WebT m Word32
getLimit full = do
limits <- lift $ asks webMaxLimits
l <- (Just <$> S.param "limit") `S.rescue` const (return Nothing)
let m =
if full
then if maxLimitFull limits > 0
then maxLimitFull limits
else maxLimitCount limits
else maxLimitCount limits
let d = maxLimitDefault limits
return $
case l of
Nothing ->
if d > 0 || m > 0
then (min m d)
else 0
Just n ->
if m > 0
then (min m n)
else n
parseAddress :: Monad m => WebT m Address
parseAddress = do
net <- lift $ asks (storeNetwork . webStore)
address <- S.param "address"
case stringToAddr net address of
Nothing -> S.next
Just a -> return a
parseAddresses :: Monad m => WebT m [Address]
parseAddresses = do
net <- lift $ asks (storeNetwork . webStore)
addresses <- S.param "addresses"
let as = mapMaybe (stringToAddr net) addresses
unless (length as == length addresses) S.next
return as
parseXpub :: Monad m => WebT m XPubSpec
parseXpub = do
net <- lift $ asks (storeNetwork . webStore)
t <- S.param "xpub"
d <- parseDeriveAddrs
case xPubImport net t of
Nothing -> S.next
Just x -> return XPubSpec {xPubSpecKey = x, xPubDeriveType = d}
parseDeriveAddrs ::
Monad m => WebT m DeriveType
parseDeriveAddrs =
lift (asks (storeNetwork . webStore)) >>= \case
net
| getSegWit net -> do
t <- S.param "derive" `S.rescue` const (return "standard")
return $
case (t :: Text) of
"segwit" -> DeriveP2WPKH
"compat" -> DeriveP2SH
_ -> DeriveNormal
| otherwise -> return DeriveNormal
parseNoCache :: (Monad m, ScottyError e) => ActionT e m Bool
parseNoCache = S.param "nocache" `S.rescue` const (return False)
parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool
parseNoTx = S.param "notx" `S.rescue` const (return False)
pruneTx :: Bool -> BlockData -> BlockData
pruneTx False b = b
pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)}
setHeaders :: (Monad m, ScottyError e) => ActionT e m ()
setHeaders = do
S.setHeader "Access-Control-Allow-Origin" "*"
serialAny ::
(ToJSON a, Serialize a)
=> Bool -- ^ binary
-> a
-> L.ByteString
serialAny True = runPutLazy . put
serialAny False = encodingToLazyByteString . toEncoding
serialAnyNet ::
Serialize a => Bool -> (a -> Encoding) -> a -> L.ByteString
serialAnyNet True _ = runPutLazy . put
serialAnyNet False f = encodingToLazyByteString . f
setupBin :: Monad m => ActionT Except m Bool
setupBin =
let p = do
S.setHeader "Content-Type" "application/octet-stream"
return True
j = do
S.setHeader "Content-Type" "application/json"
return False
in S.header "accept" >>= \case
Nothing -> j
Just x ->
if is_binary x
then p
else j
where
is_binary = (== "application/octet-stream")
instance MonadLoggerIO m => MonadLoggerIO (WebT m) where
askLoggerIO = lift askLoggerIO
instance MonadLogger m => MonadLogger (WebT m) where
monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl
healthCheck ::
(MonadUnliftIO m, StoreRead m)
=> Network
-> PeerManager
-> Chain
-> WebTimeouts
-> m HealthCheck
healthCheck net mgr ch tos = do
cb <- chain_best
bb <- block_best
pc <- peer_count
tm <- get_current_time
ml <- get_mempool_last
let ck = block_ok cb
bk = block_ok bb
pk = peer_count_ok pc
bd = block_time_delta tm cb
td = tx_time_delta tm bd ml
lk = timeout_ok (blockTimeout tos) bd
tk = timeout_ok (txTimeout tos) td
sy = in_sync bb cb
ok = ck && bk && pk && lk && (tk || not sy)
return
HealthCheck
{ healthBlockBest = block_hash <$> bb
, healthBlockHeight = block_height <$> bb
, healthHeaderBest = node_hash <$> cb
, healthHeaderHeight = node_height <$> cb
, healthPeers = pc
, healthNetwork = getNetworkName net
, healthOK = ok
, healthSynced = sy
, healthLastBlock = bd
, healthLastTx = td
, healthVersion = showVersion P.version
}
where
block_hash = headerHash . blockDataHeader
block_height = blockDataHeight
node_hash = headerHash . nodeHeader
node_height = nodeHeight
get_mempool_last = listToMaybe <$> getMempool
get_current_time = fromIntegral . systemSeconds <$> liftIO getSystemTime
peer_count_ok pc = fromMaybe 0 pc > 0
block_ok = isJust
node_timestamp = fromIntegral . blockTimestamp . nodeHeader
in_sync bb cb = fromMaybe False $ do
bh <- blockDataHeight <$> bb
nh <- nodeHeight <$> cb
return $ compute_delta bh nh <= 1
block_time_delta tm cb = do
bt <- node_timestamp <$> cb
return $ compute_delta bt tm
tx_time_delta tm bd ml = do
bd' <- bd
tt <- memRefTime . txRefBlock <$> ml <|> bd
return $ min (compute_delta tt tm) bd'
timeout_ok to td = fromMaybe False $ do
td' <- td
return $
getAllowMinDifficultyBlocks net ||
to == 0 ||
td' <= to
peer_count = fmap length <$> timeout 10000000 (managerGetPeers mgr)
block_best = runMaybeT $ do
h <- MaybeT getBestBlock
MaybeT $ getBlock h
chain_best = timeout 10000000 $ chainGetBest ch
compute_delta a b = if b > a then b - a else 0
-- | Obtain information about connected peers from peer manager process.
getPeersInformation :: MonadIO m => PeerManager -> m [PeerInformation]
getPeersInformation mgr = mapMaybe toInfo <$> managerGetPeers mgr
where
toInfo op = do
ver <- onlinePeerVersion op
let as = onlinePeerAddress op
ua = getVarString $ userAgent ver
vs = version ver
sv = services ver
rl = relay ver
return
PeerInformation
{ peerUserAgent = ua
, peerAddress = show as
, peerVersion = vs
, peerServices = sv
, peerRelay = rl
}
-- | 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, StoreRead m)
=> Int -- ^ how many ancestors to test before giving up
-> BlockHeight
-> TxHash
-> m (GenericResult (Maybe Bool))
cbAfterHeight d h t
| d <= 0 = return $ GenericResult Nothing
| otherwise = do
x <- fmap snd <$> tst d t
return $ GenericResult x
where
tst e x
| e <= 0 = return Nothing
| otherwise = do
let e' = e - 1
getTransaction x >>= \case
Nothing -> return Nothing
Just tx ->
if any isCoinbase (transactionInputs tx)
then return $
Just (e', blockRefHeight (transactionBlock tx) > h)
else case transactionBlock tx of
BlockRef {blockRefHeight = b}
| b <= h -> return $ Just (e', False)
_ ->
r e' . nub' $
map
(outPointHash . inputPoint)
(transactionInputs tx)
r e [] = return $ Just (e, False)
r e (n:ns) =
tst e n >>= \case
Nothing -> return Nothing
Just (e', s) ->
if s
then return $ Just (e', True)
else r e' ns
getAddressTxsLimit ::
(Monad m, StoreRead m)
=> Limits
-> Address
-> m [TxRef]
getAddressTxsLimit limits addr = getAddressTxs addr limits
getAddressTxsFull ::
(Monad m, StoreRead m)
=> Limits
-> Address
-> m [Transaction]
getAddressTxsFull limits addr = do
txs <- getAddressTxsLimit limits addr
catMaybes <$> mapM (getTransaction . txRefHash) txs
getAddressesTxsLimit ::
(Monad m, StoreRead m)
=> Limits
-> [Address]
-> m [TxRef]
getAddressesTxsLimit limits addrs = getAddressesTxs addrs limits
getAddressesTxsFull ::
(Monad m, StoreRead m)
=> Limits
-> [Address]
-> m [Transaction]
getAddressesTxsFull limits addrs =
fmap catMaybes $
getAddressesTxsLimit limits addrs >>=
mapM (getTransaction . txRefHash)
getAddressUnspentsLimit ::
(Monad m, StoreRead m)
=> Limits
-> Address
-> m [Unspent]
getAddressUnspentsLimit limits addr = getAddressUnspents addr limits
getAddressesUnspentsLimit ::
(Monad m, StoreRead m)
=> Limits
-> [Address]
-> m [Unspent]
getAddressesUnspentsLimit limits addrs = getAddressesUnspents addrs limits
-- | Publish a new transaction to the network.
publishTx ::
(MonadUnliftIO m, StoreRead m)
=> Network
-> Publisher StoreEvent
-> PeerManager
-> Tx
-> m (Either PubExcept ())
publishTx net pub mgr tx =
withSubscription pub $ \s ->
getTransaction (txHash tx) >>= \case
Just _ -> return $ Right ()
Nothing -> go s
where
go s =
managerGetPeers mgr >>= \case
[] -> return $ Left PubNoPeers
OnlinePeer {onlinePeerMailbox = p}:_ -> do
MTx tx `sendMessage` p
let v =
if getSegWit net
then InvWitnessTx
else InvTx
sendMessage
(MGetData (GetData [InvVector v (getTxHash (txHash tx))]))
p
f p s
t = 5 * 1000 * 1000
f p s =
liftIO (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
logIt :: (MonadUnliftIO m, MonadLoggerIO m) => m Middleware
logIt = do
runner <- askRunInIO
return $ \app req respond -> do
t1 <- getCurrentTime
app req $ \res -> do
t2 <- getCurrentTime
let d = diffUTCTime t2 t1
s = responseStatus res
runner $
$(logInfoS) "Web" $
fmtReq req <> " [" <> fmtStatus s <> " / " <> fmtDiff d <> "]"
respond res
fmtReq :: Request -> Text
fmtReq req =
let m = requestMethod req
v = httpVersion req
p = rawPathInfo req
q = rawQueryString req
in T.decodeUtf8 $ m <> " " <> p <> q <> " " <> cs (show v)
fmtDiff :: NominalDiffTime -> Text
fmtDiff d =
cs (printf "%0.3f" (realToFrac (d * 1000) :: Double) :: String) <> " ms"
fmtStatus :: Status -> Text
fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
refuseLargeBlock :: Monad m => WebLimits -> BlockData -> ActionT Except m ()
refuseLargeBlock WebLimits {maxLimitFull = f} BlockData {blockDataTxs = txs} =
when (length txs > fromIntegral f) $ S.raise BlockTooLarge