haskoin-store-data-0.64.1: src/Haskoin/Store/WebCommon.hs
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Store.WebCommon where
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Bytes.Serial
import Data.Default (Default, def)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import Haskoin.Address
import Haskoin.Block (
Block,
BlockHash,
blockHashToHex,
hexToBlockHash,
)
import Haskoin.Constants
import Haskoin.Crypto (Hash256)
import Haskoin.Data
import Haskoin.Keys
import qualified Haskoin.Store.Data as Store
import Haskoin.Transaction
import Network.HTTP.Types (StdMethod (..))
import Numeric.Natural (Natural)
import Text.Read (readMaybe)
import qualified Web.Scotty.Trans as Scotty
-------------------
-- API Resources --
-------------------
class Serial b => ApiResource a b | a -> b where
resourceMethod :: Proxy a -> StdMethod
resourceMethod _ = GET
resourcePath :: Proxy a -> ([Text] -> Text)
queryParams :: a -> ([ParamBox], [ParamBox]) -- (resource, querystring)
queryParams _ = ([], [])
captureParams :: Proxy a -> [ProxyBox]
captureParams _ = []
resourceBody :: a -> Maybe PostBox
resourceBody = const Nothing
data PostBox = forall s. Serial s => PostBox !s
data ParamBox = forall p. (Eq p, Param p) => ParamBox !p
data ProxyBox = forall p. Param p => ProxyBox !(Proxy p)
--------------------
-- Resource Paths --
--------------------
-- Blocks
data GetBlock = GetBlock !BlockHash !NoTx
data GetBlocks = GetBlocks ![BlockHash] !NoTx
newtype GetBlockRaw = GetBlockRaw BlockHash
newtype GetBlockBest = GetBlockBest NoTx
data GetBlockBestRaw = GetBlockBestRaw
newtype GetBlockLatest = GetBlockLatest NoTx
data GetBlockHeight = GetBlockHeight !HeightParam !NoTx
data GetBlockHeights = GetBlockHeights !HeightsParam !NoTx
newtype GetBlockHeightRaw = GetBlockHeightRaw HeightParam
data GetBlockTime = GetBlockTime !TimeParam !NoTx
newtype GetBlockTimeRaw = GetBlockTimeRaw TimeParam
data GetBlockMTP = GetBlockMTP !TimeParam !NoTx
newtype GetBlockMTPRaw = GetBlockMTPRaw TimeParam
-- Transactions
newtype GetTx = GetTx TxHash
newtype GetTxs = GetTxs [TxHash]
newtype GetTxRaw = GetTxRaw TxHash
newtype GetTxsRaw = GetTxsRaw [TxHash]
newtype GetTxsBlock = GetTxsBlock BlockHash
newtype GetTxsBlockRaw = GetTxsBlockRaw BlockHash
data GetTxAfter = GetTxAfter !TxHash !HeightParam
newtype PostTx = PostTx Tx
data GetMempool = GetMempool !(Maybe LimitParam) !OffsetParam
data GetEvents = GetEvents
-- Address
data GetAddrTxs = GetAddrTxs !Address !LimitsParam
data GetAddrsTxs = GetAddrsTxs ![Address] !LimitsParam
data GetAddrTxsFull = GetAddrTxsFull !Address !LimitsParam
data GetAddrsTxsFull = GetAddrsTxsFull ![Address] !LimitsParam
newtype GetAddrBalance = GetAddrBalance Address
newtype GetAddrsBalance = GetAddrsBalance [Address]
data GetAddrUnspent = GetAddrUnspent !Address !LimitsParam
data GetAddrsUnspent = GetAddrsUnspent ![Address] !LimitsParam
-- XPubs
data GetXPub = GetXPub !XPubKey !Store.DeriveType !NoCache
data GetXPubTxs = GetXPubTxs !XPubKey !Store.DeriveType !LimitsParam !NoCache
data GetXPubTxsFull = GetXPubTxsFull !XPubKey !Store.DeriveType !LimitsParam !NoCache
data GetXPubBalances = GetXPubBalances !XPubKey !Store.DeriveType !NoCache
data GetXPubUnspent = GetXPubUnspent !XPubKey !Store.DeriveType !LimitsParam !NoCache
data DelCachedXPub = DelCachedXPub !XPubKey !Store.DeriveType
-- Network
data GetPeers = GetPeers
data GetHealth = GetHealth
------------
-- Blocks --
------------
instance ApiResource GetBlock Store.BlockData where
resourcePath _ = ("/block/" <:>)
queryParams (GetBlock h t) = ([ParamBox h], noDefBox t)
captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)]
instance ApiResource GetBlocks (Store.SerialList Store.BlockData) where
resourcePath _ _ = "/blocks"
queryParams (GetBlocks hs t) = ([], [ParamBox hs] <> noDefBox t)
instance ApiResource GetBlockRaw (Store.RawResult Block) where
resourcePath _ = "/block/" <+> "/raw"
queryParams (GetBlockRaw h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)]
instance ApiResource GetBlockBest Store.BlockData where
resourcePath _ _ = "/block/best"
queryParams (GetBlockBest t) = ([], noDefBox t)
instance ApiResource GetBlockBestRaw (Store.RawResult Block) where
resourcePath _ _ = "/block/best/raw"
instance ApiResource GetBlockLatest (Store.SerialList Store.BlockData) where
resourcePath _ _ = "/block/latest"
queryParams (GetBlockLatest t) = ([], noDefBox t)
instance ApiResource GetBlockHeight (Store.SerialList Store.BlockData) where
resourcePath _ = ("/block/height/" <:>)
queryParams (GetBlockHeight h t) = ([ParamBox h], noDefBox t)
captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)]
instance ApiResource GetBlockHeights (Store.SerialList Store.BlockData) where
resourcePath _ _ = "/block/heights"
queryParams (GetBlockHeights hs t) = ([], [ParamBox hs] <> noDefBox t)
instance ApiResource GetBlockHeightRaw (Store.RawResultList Block) where
resourcePath _ = "/block/height/" <+> "/raw"
queryParams (GetBlockHeightRaw h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)]
instance ApiResource GetBlockTime Store.BlockData where
resourcePath _ = ("/block/time/" <:>)
queryParams (GetBlockTime u t) = ([ParamBox u], noDefBox t)
captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)]
instance ApiResource GetBlockTimeRaw (Store.RawResult Block) where
resourcePath _ = "/block/time/" <+> "/raw"
queryParams (GetBlockTimeRaw u) = ([ParamBox u], [])
captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)]
instance ApiResource GetBlockMTP Store.BlockData where
resourcePath _ = ("/block/mtp/" <:>)
queryParams (GetBlockMTP u t) = ([ParamBox u], noDefBox t)
captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)]
instance ApiResource GetBlockMTPRaw (Store.RawResult Block) where
resourcePath _ = "/block/mtp/" <+> "/raw"
queryParams (GetBlockMTPRaw u) = ([ParamBox u], [])
captureParams _ = [ProxyBox (Proxy :: Proxy TimeParam)]
------------------
-- Transactions --
------------------
instance ApiResource GetTx Store.Transaction where
resourcePath _ = ("/transaction/" <:>)
queryParams (GetTx h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)]
instance ApiResource GetTxs (Store.SerialList Store.Transaction) where
resourcePath _ _ = "/transactions"
queryParams (GetTxs hs) = ([], [ParamBox hs])
instance ApiResource GetTxRaw (Store.RawResult Tx) where
resourcePath _ = "/transaction/" <+> "/raw"
queryParams (GetTxRaw h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)]
instance ApiResource GetTxsRaw (Store.RawResultList Tx) where
resourcePath _ _ = "/transactions/raw"
queryParams (GetTxsRaw hs) = ([], [ParamBox hs])
instance ApiResource GetTxsBlock (Store.SerialList Store.Transaction) where
resourcePath _ = ("/transactions/block/" <:>)
queryParams (GetTxsBlock h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)]
instance ApiResource GetTxsBlockRaw (Store.RawResultList Tx) where
resourcePath _ = "/transactions/block/" <+> "/raw"
queryParams (GetTxsBlockRaw h) = ([ParamBox h], [])
captureParams _ = [ProxyBox (Proxy :: Proxy BlockHash)]
instance ApiResource GetTxAfter (Store.GenericResult (Maybe Bool)) where
resourcePath _ = "/transaction/" <++> "/after/"
queryParams (GetTxAfter h i) = ([ParamBox h, ParamBox i], [])
captureParams _ =
[ ProxyBox (Proxy :: Proxy TxHash)
, ProxyBox (Proxy :: Proxy HeightParam)
]
instance ApiResource PostTx Store.TxId where
resourceMethod _ = POST
resourcePath _ _ = "/transactions"
resourceBody (PostTx tx) = Just $ PostBox tx
instance ApiResource GetMempool (Store.SerialList TxHash) where
resourcePath _ _ = "/mempool"
queryParams (GetMempool l o) = ([], noMaybeBox l <> noDefBox o)
instance ApiResource GetEvents (Store.SerialList Store.Event) where
resourcePath _ _ = "/events"
-------------
-- Address --
-------------
instance ApiResource GetAddrTxs (Store.SerialList Store.TxRef) where
resourcePath _ = "/address/" <+> "/transactions"
queryParams (GetAddrTxs a (LimitsParam l o sM)) =
([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM)
captureParams _ = [ProxyBox (Proxy :: Proxy Address)]
instance ApiResource GetAddrsTxs (Store.SerialList Store.TxRef) where
resourcePath _ _ = "/address/transactions"
queryParams (GetAddrsTxs as (LimitsParam l o sM)) =
([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM)
instance ApiResource GetAddrTxsFull (Store.SerialList Store.Transaction) where
resourcePath _ = "/address/" <+> "/transactions/full"
queryParams (GetAddrTxsFull a (LimitsParam l o sM)) =
([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM)
captureParams _ = [ProxyBox (Proxy :: Proxy Address)]
instance ApiResource GetAddrsTxsFull (Store.SerialList Store.Transaction) where
resourcePath _ _ = "/address/transactions/full"
queryParams (GetAddrsTxsFull as (LimitsParam l o sM)) =
([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM)
instance ApiResource GetAddrBalance Store.Balance where
resourcePath _ = "/address/" <+> "/balance"
queryParams (GetAddrBalance a) = ([ParamBox a], [])
captureParams _ = [ProxyBox (Proxy :: Proxy Address)]
instance ApiResource GetAddrsBalance (Store.SerialList Store.Balance) where
resourcePath _ _ = "/address/balances"
queryParams (GetAddrsBalance as) = ([], [ParamBox as])
instance ApiResource GetAddrUnspent (Store.SerialList Store.Unspent) where
resourcePath _ = "/address/" <+> "/unspent"
queryParams (GetAddrUnspent a (LimitsParam l o sM)) =
([ParamBox a], noMaybeBox l <> noDefBox o <> noMaybeBox sM)
captureParams _ = [ProxyBox (Proxy :: Proxy Address)]
instance ApiResource GetAddrsUnspent (Store.SerialList Store.Unspent) where
resourcePath _ _ = "/address/unspent"
queryParams (GetAddrsUnspent as (LimitsParam l o sM)) =
([], [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM)
-----------
-- XPubs --
-----------
instance ApiResource GetXPub Store.XPubSummary where
resourcePath _ = ("/xpub/" <:>)
queryParams (GetXPub p d n) = ([ParamBox p], noDefBox d <> noDefBox n)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
instance ApiResource GetXPubTxs (Store.SerialList Store.TxRef) where
resourcePath _ = "/xpub/" <+> "/transactions"
queryParams (GetXPubTxs p d (LimitsParam l o sM) n) =
( [ParamBox p]
, noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n
)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
instance ApiResource GetXPubTxsFull (Store.SerialList Store.Transaction) where
resourcePath _ = "/xpub/" <+> "/transactions/full"
queryParams (GetXPubTxsFull p d (LimitsParam l o sM) n) =
( [ParamBox p]
, noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n
)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
instance ApiResource GetXPubBalances (Store.SerialList Store.XPubBal) where
resourcePath _ = "/xpub/" <+> "/balances"
queryParams (GetXPubBalances p d n) = ([ParamBox p], noDefBox d <> noDefBox n)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
instance ApiResource GetXPubUnspent (Store.SerialList Store.XPubUnspent) where
resourcePath _ = "/xpub/" <+> "/unspent"
queryParams (GetXPubUnspent p d (LimitsParam l o sM) n) =
( [ParamBox p]
, noDefBox d <> noMaybeBox l <> noDefBox o <> noMaybeBox sM <> noDefBox n
)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
instance ApiResource DelCachedXPub (Store.GenericResult Bool) where
resourceMethod _ = DELETE
resourcePath _ = ("/xpub/" <:>)
queryParams (DelCachedXPub p d) = ([ParamBox p], noDefBox d)
captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)]
-------------
-- Network --
-------------
instance ApiResource GetPeers (Store.SerialList Store.PeerInformation) where
resourcePath _ _ = "/peers"
instance ApiResource GetHealth Store.HealthCheck where
resourcePath _ _ = "/health"
-------------
-- Helpers --
-------------
(<:>) :: Text -> [Text] -> Text
(<:>) = (<+> "")
(<+>) :: Text -> Text -> [Text] -> Text
a <+> b = fill 1 [a, b]
(<++>) :: Text -> Text -> [Text] -> Text
a <++> b = fill 2 [a, b]
fill :: Int -> [Text] -> [Text] -> Text
fill i a b
| length b /= i = error "Invalid query parameters"
| otherwise = mconcat $ uncurry (<>) <$> zip a (b <> repeat "")
noDefBox :: (Default p, Param p, Eq p) => p -> [ParamBox]
noDefBox p = [ParamBox p | p /= def]
noMaybeBox :: (Param p, Eq p) => Maybe p -> [ParamBox]
noMaybeBox (Just p) = [ParamBox p]
noMaybeBox _ = []
asProxy :: a -> Proxy a
asProxy = const Proxy
queryPath :: ApiResource a b => Network -> a -> Text
queryPath net a = f $ encParam <$> fst (queryParams a)
where
f = resourcePath $ asProxy a
encParam (ParamBox p) =
case encodeParam net p of
Just [res] -> res
_ -> error "Invalid query param"
capturePath :: ApiResource a b => Proxy a -> Scotty.RoutePattern
capturePath proxy =
fromString $ cs $ f $ toLabel <$> captureParams proxy
where
f = resourcePath proxy
toLabel (ProxyBox p) = ":" <> proxyLabel p
paramLabel :: Param p => p -> Text
paramLabel = proxyLabel . asProxy
-------------
-- Options --
-------------
class Param a where
proxyLabel :: Proxy a -> Text
encodeParam :: Network -> a -> Maybe [Text]
parseParam :: Network -> [Text] -> Maybe a
instance Param Address where
proxyLabel = const "address"
encodeParam net a = (: []) <$> addrToText net a
parseParam net [a] = textToAddr net a
parseParam _ _ = Nothing
instance Param [Address] where
proxyLabel = const "addresses"
encodeParam = mapM . addrToText
parseParam = mapM . textToAddr
data StartParam
= StartParamHash
{ startParamHash :: Hash256
}
| StartParamHeight
{ startParamHeight :: Natural
}
| StartParamTime
{ startParamTime :: Store.UnixTime
}
deriving (Eq, Show)
instance Param StartParam where
proxyLabel = const "height"
encodeParam _ p =
case p of
StartParamHash h -> return [txHashToHex (TxHash h)]
StartParamHeight h -> do
guard $ h <= 1230768000
return [cs $ show h]
StartParamTime t -> do
guard $ t > 1230768000
return [cs $ show t]
parseParam _ [s] = parseHash <|> parseHeight <|> parseUnix
where
parseHash = do
guard (T.length s == 32 * 2)
TxHash x <- hexToTxHash s
return $ StartParamHash x
parseHeight = do
x <- readMaybe $ cs s
guard $ x <= 1230768000
return $ StartParamHeight x
parseUnix = do
x <- readMaybe $ cs s
guard $ x > 1230768000
return $ StartParamTime x
parseParam _ _ = Nothing
newtype OffsetParam = OffsetParam
{ getOffsetParam :: Natural
}
deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral)
instance Default OffsetParam where
def = OffsetParam 0
instance Param OffsetParam where
proxyLabel = const "offset"
encodeParam _ (OffsetParam o) = Just [cs $ show o]
parseParam _ [s] = OffsetParam <$> readMaybe (cs s)
parseParam _ _ = Nothing
newtype LimitParam = LimitParam
{ getLimitParam :: Natural
}
deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral)
instance Param LimitParam where
proxyLabel = const "limit"
encodeParam _ (LimitParam l) = Just [cs $ show l]
parseParam _ [s] = LimitParam <$> readMaybe (cs s)
parseParam _ _ = Nothing
data LimitsParam = LimitsParam
{ paramLimit :: Maybe LimitParam -- 0 means maximum
, paramOffset :: OffsetParam
, paramStart :: Maybe StartParam
}
deriving (Eq, Show)
instance Default LimitsParam where
def = LimitsParam Nothing def Nothing
newtype HeightParam = HeightParam
{ getHeightParam :: Natural
}
deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral)
instance Param HeightParam where
proxyLabel = const "height"
encodeParam _ (HeightParam h) = Just [cs $ show h]
parseParam _ [s] = HeightParam <$> readMaybe (cs s)
parseParam _ _ = Nothing
newtype HeightsParam = HeightsParam
{ getHeightsParam :: [Natural]
}
deriving (Eq, Show, Read)
instance Param HeightsParam where
proxyLabel = const "heights"
encodeParam _ (HeightsParam hs) = Just $ cs . show <$> hs
parseParam _ xs = HeightsParam <$> mapM (readMaybe . cs) xs
newtype TimeParam = TimeParam
{ getTimeParam :: Store.UnixTime
}
deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral)
instance Param TimeParam where
proxyLabel = const "time"
encodeParam _ (TimeParam t) = Just [cs $ show t]
parseParam _ [s] = TimeParam <$> readMaybe (cs s)
parseParam _ _ = Nothing
instance Param XPubKey where
proxyLabel = const "xpub"
encodeParam net p = Just [xPubExport net p]
parseParam net [s] = xPubImport net s
parseParam _ _ = Nothing
instance Param Store.DeriveType where
proxyLabel = const "derive"
encodeParam net p = do
guard (getSegWit net || p == Store.DeriveNormal)
Just [Store.deriveTypeToText p]
parseParam net d = do
res <- case d of
[x] -> Store.textToDeriveType x
_ -> Nothing
guard (getSegWit net || res == Store.DeriveNormal)
return res
newtype NoCache = NoCache
{ getNoCache :: Bool
}
deriving (Eq, Show, Read)
instance Default NoCache where
def = NoCache False
instance Param NoCache where
proxyLabel = const "nocache"
encodeParam _ (NoCache True) = Just ["true"]
encodeParam _ (NoCache False) = Just ["false"]
parseParam _ = \case
["true"] -> Just $ NoCache True
["false"] -> Just $ NoCache False
_ -> Nothing
newtype NoTx = NoTx
{ getNoTx :: Bool
}
deriving (Eq, Show, Read)
instance Default NoTx where
def = NoTx False
instance Param NoTx where
proxyLabel = const "notx"
encodeParam _ (NoTx True) = Just ["true"]
encodeParam _ (NoTx False) = Just ["false"]
parseParam _ = \case
["true"] -> Just $ NoTx True
["false"] -> Just $ NoTx False
_ -> Nothing
instance Param BlockHash where
proxyLabel = const "block"
encodeParam _ b = Just [blockHashToHex b]
parseParam _ [s] = hexToBlockHash s
parseParam _ _ = Nothing
instance Param [BlockHash] where
proxyLabel = const "blocks"
encodeParam _ bs = Just $ blockHashToHex <$> bs
parseParam _ = mapM hexToBlockHash
instance Param TxHash where
proxyLabel = const "txid"
encodeParam _ t = Just [txHashToHex t]
parseParam _ [s] = hexToTxHash s
parseParam _ _ = Nothing
instance Param [TxHash] where
proxyLabel = const "txids"
encodeParam _ ts = Just $ txHashToHex <$> ts
parseParam _ = mapM hexToTxHash