haskoin-store-0.19.4: src/Network/Haskoin/Store/Web.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Network.Haskoin.Store.Web where
import Conduit hiding (runResourceT)
import Control.Applicative ((<|>))
import Control.Exception ()
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.Reader as R
import Control.Monad.Trans.Maybe
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson.Encoding (encodingToLazyByteString,
fromEncoding)
import qualified Data.ByteString as B
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Char
import Data.Function
import qualified Data.HashMap.Strict as H
import Data.List
import Data.Maybe
import Data.Serialize as Serialize
import Data.String.Conversions
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as T.Lazy
import Data.Time.Clock
import Data.Time.Clock.System
import Data.Word
import Database.RocksDB as R
import Haskoin
import Haskoin.Node
import Network.Haskoin.Store.Data
import Network.Haskoin.Store.Data.Cached
import Network.Haskoin.Store.Messages
import Network.HTTP.Types
import Network.Wai
import NQE
import Text.Printf
import Text.Read (readMaybe)
import UnliftIO
import UnliftIO.Resource
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 LayeredDB m)
type DeriveAddrs = XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)]
type Offset = Word32
type Limit = Word32
data Except
= ThingNotFound
| ServerError
| BadRequest
| UserError String
| StringError String
deriving Eq
instance Show Except where
show ThingNotFound = "not found"
show ServerError = "you made me kill a unicorn"
show BadRequest = "bad request"
show (UserError s) = s
show (StringError _) = "you killed the dragon with your bare hands"
instance Exception Except
instance ScottyError Except where
stringError = StringError
showError = T.Lazy.pack . show
instance ToJSON Except where
toJSON e = object ["error" .= T.pack (show e)]
instance JsonSerial Except where
jsonSerial _ = toEncoding
jsonValue _ = toJSON
instance BinSerial Except where
binSerial _ ex =
case ex of
ThingNotFound -> putWord8 0
ServerError -> putWord8 1
BadRequest -> putWord8 2
UserError s -> putWord8 3 >> Serialize.put s
StringError s -> putWord8 4 >> Serialize.put s
binDeserial _ =
getWord8 >>= \case
0 -> return ThingNotFound
1 -> return ServerError
2 -> return BadRequest
3 -> UserError <$> Serialize.get
4 -> StringError <$> Serialize.get
_ -> mzero
data WebConfig =
WebConfig
{ webPort :: !Int
, webNetwork :: !Network
, webDB :: !LayeredDB
, webPublisher :: !(Publisher StoreEvent)
, webStore :: !Store
, webMaxLimits :: !MaxLimits
, webReqLog :: !Bool
, webTimeouts :: !Timeouts
}
data MaxLimits =
MaxLimits
{ maxLimitCount :: !Word32
, maxLimitFull :: !Word32
, maxLimitOffset :: !Word32
, maxLimitDefault :: !Word32
, maxLimitGap :: !Word32
}
deriving (Eq, Show)
data Timeouts =
Timeouts
{ txTimeout :: !Word64
, blockTimeout :: !Word64
}
deriving (Eq, Show)
newtype MyBlockHash = MyBlockHash {myBlockHash :: BlockHash}
newtype MyTxHash = 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}
instance MonadIO m => StoreRead (WebT m) where
isInitialized = lift isInitialized
getBestBlock = lift getBestBlock
getBlocksAtHeight = lift . getBlocksAtHeight
getBlock = lift . getBlock
getTxData = lift . getTxData
getSpender = lift . getSpender
getSpenders = lift . getSpenders
getOrphanTx = lift . getOrphanTx
getUnspent = lift . getUnspent
getBalance = lift . getBalance
getMempool = lift getMempool
askDB :: Monad m => WebT m LayeredDB
askDB = lift R.ask
runStream :: MonadUnliftIO m => s -> ReaderT s (ResourceT m) a -> m a
runStream s f = runResourceT (R.runReaderT f s)
defHandler :: Monad m => Network -> Except -> WebT m ()
defHandler net 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
protoSerial net proto e
maybeSerial ::
(Monad m, JsonSerial a, BinSerial a)
=> Network
-> Bool -- ^ binary
-> Maybe a
-> WebT m ()
maybeSerial _ _ Nothing = S.raise ThingNotFound
maybeSerial net proto (Just x) = S.raw $ serialAny net proto x
protoSerial ::
(Monad m, JsonSerial a, BinSerial a)
=> Network
-> Bool
-> a
-> WebT m ()
protoSerial net proto = S.raw . serialAny net proto
scottyBestBlock :: MonadUnliftIO m => Network -> Bool -> WebT m ()
scottyBestBlock net raw = do
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 rawBlock b >>= protoSerial net proto
else protoSerial net proto (pruneTx n b)
scottyBlock :: MonadUnliftIO m => Network -> Bool -> WebT m ()
scottyBlock net raw = do
setHeaders
block <- myBlockHash <$> S.param "block"
n <- parseNoTx
proto <- setupBin
b <-
getBlock block >>= \case
Nothing -> S.raise ThingNotFound
Just b -> return b
if raw
then rawBlock b >>= protoSerial net proto
else protoSerial net proto (pruneTx n b)
scottyBlockHeight ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()
scottyBlockHeight net raw = do
setHeaders
height <- S.param "height"
n <- parseNoTx
proto <- setupBin
hs <- getBlocksAtHeight height
db <- askDB
if raw
then S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany hs .| concatMapMC getBlock .| mapMC rawBlock .|
streamAny net proto io
flush'
else S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany hs .| concatMapMC getBlock .| mapC (pruneTx n) .|
streamAny net proto io
flush'
scottyBlockTime ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m ()
scottyBlockTime net raw = do
setHeaders
q <- S.param "time"
n <- parseNoTx
proto <- setupBin
m <- fmap (pruneTx n) <$> blockAtOrBefore q
if raw
then maybeSerial net proto =<<
case m of
Nothing -> return Nothing
Just d -> Just <$> rawBlock d
else maybeSerial net proto m
scottyBlockHeights :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyBlockHeights net = do
setHeaders
heights <- S.param "heights"
n <- parseNoTx
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (nub heights) .| concatMapMC getBlocksAtHeight .|
concatMapMC getBlock .|
mapC (pruneTx n) .|
streamAny net proto io
flush'
scottyBlockLatest :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyBlockLatest net = do
setHeaders
n <- parseNoTx
proto <- setupBin
db <- askDB
getBestBlock >>= \case
Just h ->
S.stream $ \io flush' -> do
runStream db . runConduit $ f n h 100 .| streamAny net proto io
flush'
Nothing -> S.raise ThingNotFound
where
f :: (Monad m, StoreRead m)
=> Bool
-> BlockHash
-> Int
-> ConduitT () BlockData m ()
f _ _ 0 = return ()
f n h i =
lift (getBlock h) >>= \case
Nothing -> return ()
Just b -> do
yield $ pruneTx n b
if blockDataHeight b <= 0
then return ()
else f n (prevBlock (blockDataHeader b)) (i - 1)
scottyBlocks :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyBlocks net = do
setHeaders
blocks <- map myBlockHash <$> S.param "blocks"
n <- parseNoTx
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (nub blocks) .| concatMapMC getBlock .| mapC (pruneTx n) .|
streamAny net proto io
flush'
scottyMempool :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyMempool net = do
setHeaders
proto <- setupBin
txs <- map snd <$> getMempool
protoSerial net proto txs
scottyTransaction :: MonadLoggerIO m => Network -> WebT m ()
scottyTransaction net = do
setHeaders
txid <- myTxHash <$> S.param "txid"
proto <- setupBin
res <- getTransaction txid
maybeSerial net proto res
scottyRawTransaction :: MonadLoggerIO m => Network -> WebT m ()
scottyRawTransaction net = do
setHeaders
txid <- myTxHash <$> S.param "txid"
proto <- setupBin
res <- fmap transactionData <$> getTransaction txid
maybeSerial net proto res
scottyTxAfterHeight :: MonadLoggerIO m => Network -> WebT m ()
scottyTxAfterHeight net = do
setHeaders
txid <- myTxHash <$> S.param "txid"
height <- S.param "height"
proto <- setupBin
res <- cbAfterHeight 10000 height txid
protoSerial net proto res
scottyTransactions :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyTransactions net = do
setHeaders
txids <- map myTxHash <$> S.param "txids"
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (nub txids) .| concatMapMC getTransaction .|
streamAny net proto io
flush'
scottyBlockTransactions ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyBlockTransactions net = do
setHeaders
h <- myBlockHash <$> S.param "block"
proto <- setupBin
db <- askDB
getBlock h >>= \case
Just b ->
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|
streamAny net proto io
flush'
Nothing -> S.raise ThingNotFound
scottyRawTransactions ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyRawTransactions net = do
setHeaders
txids <- map myTxHash <$> S.param "txids"
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (nub txids) .| concatMapMC getTransaction .|
mapC transactionData .|
streamAny net proto io
flush'
rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block
rawBlock b = do
let h = blockDataHeader b
txs <-
runConduit $
yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|
mapC transactionData .|
sinkList
return Block {blockHeader = h, blockTxns = txs}
scottyRawBlockTransactions ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyRawBlockTransactions net = do
setHeaders
h <- myBlockHash <$> S.param "block"
proto <- setupBin
db <- askDB
getBlock h >>= \case
Just b ->
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany (blockDataTxs b) .| concatMapMC getTransaction .|
mapC transactionData .|
streamAny net proto io
flush'
Nothing -> S.raise ThingNotFound
scottyAddressTxs ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Network
-> MaxLimits
-> Bool
-> WebT m ()
scottyAddressTxs net limits full = do
setHeaders
a <- parseAddress net
s <- getStart
o <- getOffset limits
l <- getLimit limits full
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $ f proto o l s a io
flush'
where
f proto o l s a io
| full = getAddressTxsFull o l s a .| streamAny net proto io
| otherwise = getAddressTxsLimit o l s a .| streamAny net proto io
scottyAddressesTxs ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Network
-> MaxLimits
-> Bool
-> WebT m ()
scottyAddressesTxs net limits full = do
setHeaders
as <- parseAddresses net
s <- getStart
l <- getLimit limits full
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $ f proto l s as io
flush'
where
f proto l s as io
| full = getAddressesTxsFull l s as .| streamAny net proto io
| otherwise = getAddressesTxsLimit l s as .| streamAny net proto io
scottyAddressUnspent ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()
scottyAddressUnspent net limits = do
setHeaders
a <- parseAddress net
s <- getStart
o <- getOffset limits
l <- getLimit limits False
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
getAddressUnspentsLimit o l s a .| streamAny net proto io
flush'
scottyAddressesUnspent ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()
scottyAddressesUnspent net limits = do
setHeaders
as <- parseAddresses net
s <- getStart
l <- getLimit limits False
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
getAddressesUnspentsLimit l s as .| streamAny net proto io
flush'
scottyAddressBalance :: MonadLoggerIO m => Network -> WebT m ()
scottyAddressBalance net = do
setHeaders
a <- parseAddress net
proto <- setupBin
res <-
getBalance a >>= \case
Just b -> return b
Nothing ->
return
Balance
{ balanceAddress = a
, balanceAmount = 0
, balanceUnspentCount = 0
, balanceZero = 0
, balanceTxCount = 0
, balanceTotalReceived = 0
}
protoSerial net proto res
scottyAddressesBalances ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()
scottyAddressesBalances net = do
setHeaders
as <- parseAddresses net
proto <- setupBin
let f a Nothing =
Balance
{ balanceAddress = a
, balanceAmount = 0
, balanceUnspentCount = 0
, balanceZero = 0
, balanceTxCount = 0
, balanceTotalReceived = 0
}
f _ (Just b) = b
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
yieldMany as .| mapMC (\a -> f a <$> getBalance a) .|
streamAny net proto io
flush'
scottyXpubBalances ::
(MonadUnliftIO m, MonadLoggerIO m)
=> Network
-> MaxLimits
-> WebT m ()
scottyXpubBalances net max_limits = do
setHeaders
xpub <- parseXpub net
proto <- setupBin
derive <- parseDeriveAddrs net
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
xpubBals max_limits derive xpub .| streamAny net proto io
flush'
scottyXpubTxs ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Network
-> MaxLimits
-> Bool
-> WebT m ()
scottyXpubTxs net limits full = do
setHeaders
x <- parseXpub net
s <- getStart
l <- getLimit limits full
derive <- parseDeriveAddrs net
proto <- setupBin
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $ f proto l s derive io x
flush'
where
f proto l s derive io x
| full =
xpubTxs limits s l derive x .|
concatMapMC (getTransaction . blockTxHash) .|
streamAny net proto io
| otherwise = xpubTxs limits s l derive x .| streamAny net proto io
xpubTxs ::
(Monad m, StoreRead m, StoreStream m)
=> MaxLimits
-> Maybe BlockRef
-> Maybe Limit
-> DeriveAddrs
-> XPubKey
-> ConduitT i BlockTx m ()
xpubTxs max_limits start limit derive xpub = do
ts <-
fmap (nub . sortBy (flip compare `on` blockTxBlock)) $
(go 0 >> go 1) .| sinkList
forM_ ts yield .| applyLimit limit
where
go m = yieldMany (addrs m) .| txs .| gap
addrs m = map (\(a, _, _) -> a) (derive (pubSubKey xpub m) 0)
txs =
awaitForever $ \a -> do
ts <- getAddressTxs a start .| applyLimit limit .| sinkList
yield ts
gap =
let r 0 = return ()
r i =
await >>= \case
Nothing -> return ()
Just [] -> r (i - 1)
Just xs -> yieldMany xs >> r (maxLimitGap max_limits)
in r (maxLimitGap max_limits)
scottyXpubUnspents ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()
scottyXpubUnspents net limits = do
setHeaders
x <- parseXpub net
proto <- setupBin
s <- getStart
l <- getLimit limits False
derive <- parseDeriveAddrs net
db <- askDB
S.stream $ \io flush' -> do
runStream db . runConduit $
xpubUnspentLimit net limits l s derive x .| streamAny net proto io
flush'
scottyXpubSummary ::
(MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m ()
scottyXpubSummary net max_limits = do
setHeaders
x <- parseXpub net
derive <- parseDeriveAddrs net
proto <- setupBin
db <- askDB
res <- liftIO . runStream db $ xpubSummary max_limits derive x
protoSerial net proto res
scottyPostTx ::
(MonadUnliftIO m, MonadLoggerIO m)
=> Network
-> Store
-> Publisher StoreEvent
-> WebT m ()
scottyPostTx net st pub = do
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 st tx) >>= \case
Right () -> do
protoSerial net 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 net proto (UserError (show e))
S.finish
scottyDbStats :: MonadLoggerIO m => WebT m ()
scottyDbStats = do
setHeaders
LayeredDB {layeredDB = BlockDB {blockDB = db}} <- askDB
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, MonadUnliftIO m)
=> Network
-> Publisher StoreEvent
-> WebT m ()
scottyEvents net pub = do
setHeaders
proto <- setupBin
S.stream $ \io flush' ->
withSubscription pub $ \sub ->
forever $
flush' >> receive sub >>= \se -> do
let me =
case se of
StoreBestBlock block_hash ->
Just (EventBlock block_hash)
StoreMempoolNew tx_hash -> Just (EventTx tx_hash)
_ -> Nothing
case me of
Nothing -> return ()
Just e ->
let bs =
serialAny net proto e <>
if proto
then mempty
else "\n"
in io (lazyByteString bs)
scottyPeers :: MonadLoggerIO m => Network -> Store -> WebT m ()
scottyPeers net st = do
setHeaders
proto <- setupBin
ps <- getPeersInformation (storeManager st)
protoSerial net proto ps
scottyHealth ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Network
-> Store
-> Timeouts
-> WebT m ()
scottyHealth net st tos = do
setHeaders
proto <- setupBin
db <- askDB
h <-
liftIO . runStream db $
healthCheck net (storeManager st) (storeChain st) tos
when (not (healthOK h) || not (healthSynced h)) $ S.status status503
protoSerial net proto h
runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m ()
runWeb WebConfig { webDB = db
, webPort = port
, webNetwork = net
, webStore = st
, webPublisher = pub
, webMaxLimits = limits
, webReqLog = reqlog
, webTimeouts = tos
} = do
req_logger <-
if reqlog
then Just <$> logIt
else return Nothing
runner <- askRunInIO
S.scottyT port (runner . withLayeredDB db) $ do
case req_logger of
Just m -> S.middleware m
Nothing -> return ()
S.defaultHandler (defHandler net)
S.get "/block/best" $ scottyBestBlock net False
S.get "/block/best/raw" $ scottyBestBlock net True
S.get "/block/:block" $ scottyBlock net False
S.get "/block/:block/raw" $ scottyBlock net True
S.get "/block/height/:height" $ scottyBlockHeight net False
S.get "/block/height/:height/raw" $ scottyBlockHeight net True
S.get "/block/time/:time" $ scottyBlockTime net False
S.get "/block/time/:time/raw" $ scottyBlockTime net True
S.get "/block/heights" $ scottyBlockHeights net
S.get "/block/latest" $ scottyBlockLatest net
S.get "/blocks" $ scottyBlocks net
S.get "/mempool" $ scottyMempool net
S.get "/transaction/:txid" $ scottyTransaction net
S.get "/transaction/:txid/raw" $ scottyRawTransaction net
S.get "/transaction/:txid/after/:height" $ scottyTxAfterHeight net
S.get "/transactions" $ scottyTransactions net
S.get "/transactions/raw" $ scottyRawTransactions net
S.get "/transactions/block/:block" $ scottyBlockTransactions net
S.get "/transactions/block/:block/raw" $ scottyRawBlockTransactions net
S.get "/address/:address/transactions" $
scottyAddressTxs net limits False
S.get "/address/:address/transactions/full" $
scottyAddressTxs net limits True
S.get "/address/transactions" $ scottyAddressesTxs net limits False
S.get "/address/transactions/full" $ scottyAddressesTxs net limits True
S.get "/address/:address/unspent" $ scottyAddressUnspent net limits
S.get "/address/unspent" $ scottyAddressesUnspent net limits
S.get "/address/:address/balance" $ scottyAddressBalance net
S.get "/address/balances" $ scottyAddressesBalances net
S.get "/xpub/:xpub/balances" $ scottyXpubBalances net limits
S.get "/xpub/:xpub/transactions" $ scottyXpubTxs net limits False
S.get "/xpub/:xpub/transactions/full" $ scottyXpubTxs net limits True
S.get "/xpub/:xpub/unspent" $ scottyXpubUnspents net limits
S.get "/xpub/:xpub" $ scottyXpubSummary net limits
S.post "/transactions" $ scottyPostTx net st pub
S.get "/dbstats" scottyDbStats
S.get "/events" $ scottyEvents net pub
S.get "/peers" $ scottyPeers net st
S.get "/health" $ scottyHealth net st tos
S.notFound $ S.raise ThingNotFound
getStart :: MonadUnliftIO m => WebT m (Maybe BlockRef)
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 $ BlockRef h maxBound
start_block h = do
b <- MaybeT $ getBlock (BlockHash h)
let g = blockDataHeight b
return $ BlockRef g maxBound
start_tx h = do
t <- MaybeT $ getTxData (TxHash h)
return $ txDataBlock t
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 $ BlockRef g maxBound
else return $ MemRef q
getOffset :: Monad m => MaxLimits -> ActionT Except m Offset
getOffset limits = do
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
=> MaxLimits
-> Bool
-> ActionT Except m (Maybe Limit)
getLimit limits full = do
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 Just (min m d)
else Nothing
Just n ->
if m > 0
then Just (min m n)
else Just n
parseAddress :: (Monad m, ScottyError e) => Network -> ActionT e m Address
parseAddress net = do
address <- S.param "address"
case stringToAddr net address of
Nothing -> S.next
Just a -> return a
parseAddresses :: (Monad m, ScottyError e) => Network -> ActionT e m [Address]
parseAddresses net = do
addresses <- S.param "addresses"
let as = mapMaybe (stringToAddr net) addresses
unless (length as == length addresses) S.next
return as
parseXpub :: (Monad m, ScottyError e) => Network -> ActionT e m XPubKey
parseXpub net = do
t <- S.param "xpub"
case xPubImport net t of
Nothing -> S.next
Just x -> return x
parseDeriveAddrs :: (Monad m, ScottyError e) => Network -> ActionT e m DeriveAddrs
parseDeriveAddrs net
| getSegWit net = do
t <- S.param "derive" `S.rescue` const (return "standard")
return $ case (t :: Text) of
"segwit" -> deriveWitnessAddrs
"compat" -> deriveCompatWitnessAddrs
_ -> deriveAddrs
| otherwise = return deriveAddrs
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 ::
(JsonSerial a, BinSerial a)
=> Network
-> Bool -- ^ binary
-> a
-> L.ByteString
serialAny net True = runPutLazy . binSerial net
serialAny net False = encodingToLazyByteString . jsonSerial net
streamAny ::
(JsonSerial i, BinSerial i, MonadIO m)
=> Network
-> Bool -- ^ protobuf
-> (Builder -> IO ())
-> ConduitT i o m ()
streamAny net True io = binConduit net .| mapC lazyByteString .| streamConduit io
streamAny net False io = jsonListConduit net .| streamConduit io
jsonListConduit :: (JsonSerial a, Monad m) => Network -> ConduitT a Builder m ()
jsonListConduit net =
yield "[" >> mapC (fromEncoding . jsonSerial net) .| intersperseC "," >> yield "]"
binConduit :: (BinSerial i, Monad m) => Network -> ConduitT i L.ByteString m ()
binConduit net = mapC (runPutLazy . binSerial net)
streamConduit :: MonadIO m => (i -> IO ()) -> ConduitT i o m ()
streamConduit io = mapM_C (liftIO . io)
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, StoreStream m)
=> Network
-> Manager
-> Chain
-> Timeouts
-> 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 cb ml
lk = timeout_ok (blockTimeout tos) bd
tk = timeout_ok (txTimeout tos) td
ok = ck && bk && pk && lk && tk
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 = in_sync bb cb
, healthLastBlock = bd
, healthLastTx = td
}
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 cb ml = do
tt <- fst <$> ml <|> node_timestamp <$> cb
return $ compute_delta tt tm
timeout_ok to td = fromMaybe False $ do
td' <- td
return $
getAllowMinDifficultyBlocks net ||
to == 0 ||
td' <= to
peer_count = fmap length <$> timeout 500000 (managerGetPeers mgr)
block_best = runMaybeT $ do
h <- MaybeT getBestBlock
MaybeT $ getBlock h
chain_best = timeout 500000 $ 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 => Manager -> 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 = as
, peerVersion = vs
, peerServices = sv
, peerRelay = rl
}
xpubBals ::
(MonadResource m, MonadUnliftIO m, StoreRead m)
=> MaxLimits
-> DeriveAddrs
-> XPubKey
-> ConduitT i XPubBal m ()
xpubBals limits derive xpub = go 0 >> go 1
where
go m =
yieldMany (addrs m) .| mapMC (uncurry bal) .| gap (maxLimitGap limits)
bal a p =
getBalance a >>= \case
Nothing -> return Nothing
Just b' -> return $ Just XPubBal {xPubBalPath = p, xPubBal = b'}
addrs m =
map (\(a, _, n') -> (a, [m, n'])) (derive (pubSubKey xpub m) 0)
gap n =
let r 0 = return ()
r i =
await >>= \case
Just (Just b) -> yield b >> r n
Just Nothing -> r (i - 1)
Nothing -> return ()
in r n
xpubUnspent ::
( MonadResource m
, MonadUnliftIO m
, StoreStream m
, StoreRead m
)
=> Network
-> MaxLimits
-> Maybe BlockRef
-> DeriveAddrs
-> XPubKey
-> ConduitT i XPubUnspent m ()
xpubUnspent _net max_limits start derive xpub =
xpubBals max_limits derive xpub .| go
where
go =
awaitForever $ \XPubBal {xPubBalPath = p, xPubBal = b} ->
getAddressUnspents (balanceAddress b) start .|
mapC (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})
xpubUnspentLimit ::
( MonadResource m
, MonadUnliftIO m
, StoreStream m
, StoreRead m
)
=> Network
-> MaxLimits
-> Maybe Limit
-> Maybe BlockRef
-> DeriveAddrs
-> XPubKey
-> ConduitT i XPubUnspent m ()
xpubUnspentLimit net max_limits limit start derive xpub =
xpubUnspent net max_limits start derive xpub .| applyLimit limit
xpubSummary ::
(MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m)
=> MaxLimits
-> DeriveAddrs
-> XPubKey
-> m XPubSummary
xpubSummary max_limits derive x = do
bs <- runConduit $ xpubBals max_limits derive x .| sinkList
let f XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}} =
(a, p)
pm = H.fromList $ map f bs
ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]
ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]
uc =
sum
[ c
| XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <- bs
]
xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]
rx =
sum
[ r
| XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <- xt
]
return
XPubSummary
{ xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)
, xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)
, xPubSummaryReceived = rx
, xPubUnspentCount = uc
, xPubSummaryPaths = pm
, xPubChangeIndex = ch
, xPubExternalIndex = ex
}
-- | 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 TxAfterHeight
cbAfterHeight d h t
| d <= 0 = return $ TxAfterHeight Nothing
| otherwise = do
x <- fmap snd <$> tst d t
return $ TxAfterHeight 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, StoreStream m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> ConduitT i BlockTx m ()
getAddressTxsLimit offset limit start addr =
getAddressTxs addr start .| applyOffsetLimit offset limit
getAddressTxsFull ::
(Monad m, StoreStream m, StoreRead m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> ConduitT i Transaction m ()
getAddressTxsFull offset limit start addr =
getAddressTxsLimit offset limit start addr .|
concatMapMC (getTransaction . blockTxHash)
getAddressesTxsLimit ::
(MonadResource m, MonadUnliftIO m, StoreStream m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> ConduitT i BlockTx m ()
getAddressesTxsLimit limit start addrs = do
ts <-
fmap (nub . sortBy (flip compare `on` blockTxBlock)) $
get_txs .| sinkList
forM_ ts yield .| applyLimit limit
where
get_txs = mapM_ (\a -> getAddressTxs a start .| applyLimit limit) addrs
getAddressesTxsFull ::
(MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> ConduitT i Transaction m ()
getAddressesTxsFull limit start addrs =
getAddressesTxsLimit limit start addrs .|
concatMapMC (getTransaction . blockTxHash)
getAddressUnspentsLimit ::
(Monad m, StoreStream m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> ConduitT i Unspent m ()
getAddressUnspentsLimit offset limit start addr =
getAddressUnspents addr start .| applyOffsetLimit offset limit
getAddressesUnspentsLimit ::
(Monad m, StoreStream m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> ConduitT i Unspent m ()
getAddressesUnspentsLimit limit start addrs = do
uns <-
fmap (nub . sortBy (flip compare `on` unspentBlock)) $
get_uns .| sinkList
forM_ uns yield .| applyLimit limit
where
get_uns = mapM_ (\a -> getAddressUnspents a start .| applyLimit limit) addrs
applyOffsetLimit :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()
applyOffsetLimit offset limit = applyOffset offset >> applyLimit limit
applyOffset :: Monad m => Offset -> ConduitT i i m ()
applyOffset = dropC . fromIntegral
applyLimit :: Monad m => Maybe Limit -> ConduitT i i m ()
applyLimit Nothing = mapC id
applyLimit (Just l) = takeC (fromIntegral l)
conduitToQueue :: MonadIO m => TBQueue (Maybe a) -> ConduitT a Void m ()
conduitToQueue q =
await >>= \case
Just x -> atomically (writeTBQueue q (Just x)) >> conduitToQueue q
Nothing -> atomically $ writeTBQueue q Nothing
queueToConduit :: MonadIO m => TBQueue (Maybe a) -> ConduitT i a m ()
queueToConduit q =
atomically (readTBQueue q) >>= \case
Just x -> yield x >> queueToConduit q
Nothing -> return ()
dedup :: (Eq i, Monad m) => ConduitT i i m ()
dedup =
let dd Nothing =
await >>= \case
Just x -> do
yield x
dd (Just x)
Nothing -> return ()
dd (Just x) =
await >>= \case
Just y
| x == y -> dd (Just x)
| otherwise -> do
yield y
dd (Just y)
Nothing -> return ()
in dd Nothing
-- | Publish a new transaction to the network.
publishTx ::
(MonadUnliftIO m, StoreRead m)
=> Network
-> Publisher StoreEvent
-> Store
-> Tx
-> m (Either PubExcept ())
publishTx net pub st tx =
withSubscription pub $ \s ->
getTransaction (txHash tx) >>= \case
Just _ -> return $ Right ()
Nothing -> go s
where
go s =
managerGetPeers (storeManager st) >>= \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 :: (MonadLoggerIO m, MonadUnliftIO 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)