haskoin-store-0.20.1: src/Network/Haskoin/Store/Web.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Haskoin.Store.Web where
import Conduit ()
import Control.Applicative ((<|>))
import Control.Monad (forever, guard, mzero,
unless, when, (<=<))
import Control.Monad.Logger (Loc, LogLevel, LogSource,
LogStr, MonadLogger,
MonadLoggerIO, askLoggerIO,
logInfoS, monadLoggerLog)
import Control.Monad.Reader (ReaderT, ask)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson.Encoding (encodingToLazyByteString)
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.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 as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as T.Lazy
import Data.Time.Clock (NominalDiffTime,
diffUTCTime,
getCurrentTime)
import Data.Time.Clock.System (getSystemTime,
systemSeconds)
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,
sockToHostAddress,
stringToAddr, txHash,
xPubImport)
import Haskoin.Node (Chain, Manager,
OnlinePeer (..),
chainGetBest,
managerGetPeers,
sendMessage)
import Network.Haskoin.Store.Common (BinSerial (..),
BlockDB (..),
BlockData (..),
BlockRef (..),
BlockTx (..),
DeriveType (..),
Event (..),
HealthCheck (..),
JsonSerial (..), Limit,
Offset,
PeerInformation (..),
PubExcept (..), Store (..),
StoreEvent (..),
StoreInput (..),
StoreRead (..),
Transaction (..),
TxAfterHeight (..),
TxData (..), TxId (..),
UnixTime, Unspent,
XPubSpec (..), applyOffset,
blockAtOrBefore,
getTransaction, isCoinbase,
transactionData)
import Network.Haskoin.Store.Data.RocksDB (withRocksDB)
import Network.HTTP.Types (Status (..), status400,
status403, status404,
status500, status503)
import Network.Wai (Middleware, Request (..),
responseStatus)
import NQE (Publisher, receive,
withSubscription)
import Text.Printf (printf)
import Text.Read (readMaybe)
import UnliftIO (Exception, 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 LoggerIO = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
type WebT m = ActionT Except (ReaderT BlockDB m)
data Except
= ThingNotFound
| ServerError
| BadRequest
| UserError String
| StringError String
| BlockTooLarge
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"
show BlockTooLarge = "block too large"
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
BlockTooLarge -> putWord8 5
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 :: !BlockDB
, webPublisher :: !(Publisher StoreEvent)
, webStore :: !Store
, webMaxLimits :: !MaxLimits
, webReqLog :: !Bool
, webTimeouts :: !Timeouts
}
data MaxLimits =
MaxLimits
{ maxLimitCount :: !Word32
, maxLimitFull :: !Word32
, maxLimitOffset :: !Word32
, maxLimitDefault :: !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 MonadLoggerIO m => StoreRead (WebT m) where
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
getBalances = lift . getBalances
getMempool = lift getMempool
getAddressesTxs addrs start limit =
lift (getAddressesTxs addrs start limit)
getAddressesUnspents addrs start limit =
lift (getAddressesUnspents addrs start limit)
getOrphans = lift getOrphans
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
BlockTooLarge -> S.status status403
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 ::
(MonadLoggerIO m, MonadIO m) => Network -> MaxLimits -> Bool -> WebT m ()
scottyBestBlock net limits 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 do
refuseLargeBlock limits b
rawBlock b >>= protoSerial net proto
else protoSerial net proto (pruneTx n b)
scottyBlock :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()
scottyBlock net limits 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 do
refuseLargeBlock limits b
rawBlock b >>= protoSerial net proto
else protoSerial net proto (pruneTx n b)
scottyBlockHeight :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()
scottyBlockHeight net limits raw = do
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 net proto rawblocks
else do
blocks <- catMaybes <$> mapM getBlock hs
let blocks' = map (pruneTx n) blocks
protoSerial net proto blocks'
scottyBlockTime :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()
scottyBlockTime net limits 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 -> do
refuseLargeBlock limits d
Just <$> rawBlock d
else maybeSerial net proto m
scottyBlockHeights :: MonadLoggerIO m => Network -> WebT m ()
scottyBlockHeights net = do
setHeaders
heights <- S.param "heights"
n <- parseNoTx
proto <- setupBin
bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])
blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs
protoSerial net proto blocks
scottyBlockLatest :: MonadLoggerIO m => Network -> WebT m ()
scottyBlockLatest net = do
setHeaders
n <- parseNoTx
proto <- setupBin
getBestBlock >>= \case
Just h -> do
blocks <- reverse <$> go 100 n h
protoSerial net proto 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 :: MonadLoggerIO m => Network -> WebT m ()
scottyBlocks net = do
setHeaders
bhs <- map myBlockHash <$> S.param "blocks"
n <- parseNoTx
proto <- setupBin
bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs)
protoSerial net proto bks
scottyMempool :: MonadLoggerIO m => Network -> WebT m ()
scottyMempool net = do
setHeaders
proto <- setupBin
txs <- map blockTxHash <$> 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 => Network -> WebT m ()
scottyTransactions net = do
setHeaders
txids <- map myTxHash <$> S.param "txids"
proto <- setupBin
txs <- catMaybes <$> mapM getTransaction (nub txids)
protoSerial net proto txs
scottyBlockTransactions :: MonadLoggerIO m => Network -> MaxLimits -> WebT m ()
scottyBlockTransactions net limits = do
setHeaders
h <- myBlockHash <$> S.param "block"
proto <- setupBin
getBlock h >>= \case
Just b -> do
refuseLargeBlock limits b
let ths = blockDataTxs b
txs <- catMaybes <$> mapM getTransaction ths
protoSerial net proto txs
Nothing -> S.raise ThingNotFound
scottyRawTransactions ::
MonadLoggerIO m => Network -> WebT m ()
scottyRawTransactions net = do
setHeaders
txids <- map myTxHash <$> S.param "txids"
proto <- setupBin
txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids)
protoSerial net 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 ::
MonadLoggerIO m => Network -> MaxLimits -> WebT m ()
scottyRawBlockTransactions net limits = do
setHeaders
h <- myBlockHash <$> 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 net proto txs
Nothing -> S.raise ThingNotFound
scottyAddressTxs :: MonadLoggerIO 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
if full
then do
getAddressTxsFull o l s a >>= protoSerial net proto
else do
getAddressTxsLimit o l s a >>= protoSerial net proto
scottyAddressesTxs ::
MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()
scottyAddressesTxs net limits full = do
setHeaders
as <- parseAddresses net
s <- getStart
l <- getLimit limits full
proto <- setupBin
if full
then getAddressesTxsFull l s as >>= protoSerial net proto
else getAddressesTxsLimit l s as >>= protoSerial net proto
scottyAddressUnspent :: MonadLoggerIO m => Network -> MaxLimits -> WebT m ()
scottyAddressUnspent net limits = do
setHeaders
a <- parseAddress net
s <- getStart
o <- getOffset limits
l <- getLimit limits False
proto <- setupBin
uns <- getAddressUnspentsLimit o l s a
protoSerial net proto uns
scottyAddressesUnspent :: MonadLoggerIO m => Network -> MaxLimits -> WebT m ()
scottyAddressesUnspent net limits = do
setHeaders
as <- parseAddresses net
s <- getStart
l <- getLimit limits False
proto <- setupBin
uns <- getAddressesUnspentsLimit l s as
protoSerial net proto uns
scottyAddressBalance :: MonadLoggerIO m => Network -> WebT m ()
scottyAddressBalance net = do
setHeaders
a <- parseAddress net
proto <- setupBin
res <- getBalance a
protoSerial net proto res
scottyAddressesBalances :: MonadLoggerIO m => Network -> WebT m ()
scottyAddressesBalances net = do
setHeaders
as <- parseAddresses net
proto <- setupBin
res <- getBalances as
protoSerial net proto res
scottyXpubBalances :: MonadLoggerIO m => Network -> WebT m ()
scottyXpubBalances net = do
setHeaders
xpub <- parseXpub net
proto <- setupBin
res <- xPubBals xpub
protoSerial net proto res
scottyXpubTxs :: MonadLoggerIO m => Network -> MaxLimits -> Bool -> WebT m ()
scottyXpubTxs net limits full = do
setHeaders
xpub <- parseXpub net
start <- getStart
limit <- getLimit limits full
proto <- setupBin
txs <- xPubTxs xpub start 0 limit
if full
then do
txs' <- catMaybes <$> mapM (getTransaction . blockTxHash) txs
protoSerial net proto txs'
else protoSerial net proto txs
scottyXpubUnspents :: MonadLoggerIO m => Network -> MaxLimits -> WebT m ()
scottyXpubUnspents net limits = do
setHeaders
xpub <- parseXpub net
proto <- setupBin
start <- getStart
limit <- getLimit limits False
uns <- xPubUnspents xpub start 0 limit
protoSerial net proto uns
scottyXpubSummary :: MonadLoggerIO m => Network -> WebT m ()
scottyXpubSummary net = do
setHeaders
xpub <- parseXpub net
proto <- setupBin
res <- xPubSummary xpub
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
BlockDB {blockDB = db} <- lift ask
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 => 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 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 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 ::
(MonadUnliftIO m, MonadLoggerIO m)
=> Network
-> Store
-> Timeouts
-> WebT m ()
scottyHealth net st tos = do
setHeaders
proto <- setupBin
h <- lift $ 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 = bdb
, 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 . withRocksDB bdb) $ do
case req_logger of
Just m -> S.middleware m
Nothing -> return ()
S.defaultHandler (defHandler net)
S.get "/block/best" $ scottyBestBlock net limits False
S.get "/block/best/raw" $ scottyBestBlock net limits True
S.get "/block/:block" $ scottyBlock net limits False
S.get "/block/:block/raw" $ scottyBlock net limits True
S.get "/block/height/:height" $ scottyBlockHeight net limits False
S.get "/block/height/:height/raw" $ scottyBlockHeight net limits True
S.get "/block/time/:time" $ scottyBlockTime net limits False
S.get "/block/time/:time/raw" $ scottyBlockTime net limits 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 limits
S.get "/transactions/block/:block/raw" $
scottyRawBlockTransactions net limits
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
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
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 :: MonadLoggerIO 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 XPubSpec
parseXpub net = do
t <- S.param "xpub"
d <- parseDeriveAddrs net
case xPubImport net t of
Nothing -> S.next
Just x -> return XPubSpec {xPubSpecKey = x, xPubDeriveType = d}
parseDeriveAddrs ::
(Monad m, ScottyError e) => Network -> ActionT e m DeriveType
parseDeriveAddrs 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
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
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
-> 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 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
}
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 . blockTxBlock <$> 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 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 = sockToHostAddress 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 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, StoreRead m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> m [BlockTx]
getAddressTxsLimit offset limit start addr =
applyOffset offset <$> getAddressTxs addr start limit
getAddressTxsFull ::
(Monad m, StoreRead m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> m [Transaction]
getAddressTxsFull offset limit start addr = do
txs <- getAddressTxsLimit offset limit start addr
catMaybes <$> mapM (getTransaction . blockTxHash) txs
getAddressesTxsLimit ::
(Monad m, StoreRead m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> m [BlockTx]
getAddressesTxsLimit limit start addrs =
getAddressesTxs addrs start limit
getAddressesTxsFull ::
(Monad m, StoreRead m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> m [Transaction]
getAddressesTxsFull limit start addrs =
fmap catMaybes $
getAddressesTxsLimit limit start addrs >>=
mapM (getTransaction . blockTxHash)
getAddressUnspentsLimit ::
(Monad m, StoreRead m)
=> Offset
-> Maybe Limit
-> Maybe BlockRef
-> Address
-> m [Unspent]
getAddressUnspentsLimit offset limit start addr =
applyOffset offset <$> getAddressUnspents addr start limit
getAddressesUnspentsLimit ::
(Monad m, StoreRead m)
=> Maybe Limit
-> Maybe BlockRef
-> [Address]
-> m [Unspent]
getAddressesUnspentsLimit limit start addrs =
getAddressesUnspents addrs start limit
-- | 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 :: (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 => MaxLimits -> BlockData -> ActionT Except m ()
refuseLargeBlock MaxLimits {maxLimitFull = f} BlockData {blockDataTxs = txs} =
when (length txs > fromIntegral f) $ S.raise BlockTooLarge