diff --git a/haskoin-store-data.cabal b/haskoin-store-data.cabal --- a/haskoin-store-data.cabal +++ b/haskoin-store-data.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ff0584ff56dabdcdddbb2101073b857dbfdeb7d79d68e3c3bec4055c0affcad3 +-- hash: 7b2e90bc7d3c3a7fd4b2974a4e606253b6e27262dccce0c21b63537bdf6c9c52 name: haskoin-store-data -version: 0.30.1 +version: 0.31.0 synopsis: Data for Haskoin Store description: Data and its (de)serialisation functions for Haskoin Store category: Bitcoin, Finance, Network @@ -26,6 +26,8 @@ library exposed-modules: Haskoin.Store.Data + Haskoin.Store.WebClient + Haskoin.Store.WebCommon other-modules: Paths_haskoin_store_data hs-source-dirs: @@ -36,13 +38,19 @@ , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , containers >=0.6.2.1 + , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.13.3 + , haskoin-core >=0.13.6 + , http-client >=0.6.4.1 + , http-types >=0.12.3 + , lens >=4.18.1 + , mtl >=2.2.2 , network >=3.1.1.1 , scotty >=0.11.5 , string-conversions >=0.4.0.1 , text >=1.2.4.0 + , wreq >=0.5.3.2 default-language: Haskell2010 test-suite haskoin-store-test @@ -50,7 +58,10 @@ main-is: Spec.hs other-modules: Haskoin.Store.DataSpec + Haskoin.Store.WebCommonSpec Haskoin.Store.Data + Haskoin.Store.WebClient + Haskoin.Store.WebCommon Paths_haskoin_store_data hs-source-dirs: test @@ -63,13 +74,19 @@ , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , containers >=0.6.2.1 + , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0 - , haskoin-core >=0.13.3 + , haskoin-core >=0.13.6 , hspec >=2.7.1 + , http-client >=0.6.4.1 + , http-types >=0.12.3 + , lens >=4.18.1 + , mtl >=2.2.2 , network >=3.1.1.1 , scotty >=0.11.5 , string-conversions >=0.4.0.1 , text >=1.2.4.0 + , wreq >=0.5.3.2 default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Haskoin/Store/Data.hs b/src/Haskoin/Store/Data.hs --- a/src/Haskoin/Store/Data.hs +++ b/src/Haskoin/Store/Data.hs @@ -68,30 +68,39 @@ -- * Other Data , TxId(..) , GenericResult(..) + , RawResult(..) + , RawResultList(..) , PeerInformation(..) , HealthCheck(..) , Event(..) , Except(..) - ) where + ) +where + import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) import Control.Exception (Exception) -import Control.Monad (guard, join) +import Control.Monad (guard, join, mzero, (<=<)) import Data.Aeson (Encoding, FromJSON (..), ToJSON (..), Value (..), object, pairs, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as A -import Data.Aeson.Encoding (list, null_, pair, text) +import Data.Aeson.Encoding (list, null_, pair, text, + unsafeToEncoding) import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.ByteString.Builder (char7, lazyByteStringHex) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS +import Data.Default (Default (..)) +import Data.Foldable (toList) import Data.Hashable (Hashable (..)) import qualified Data.IntMap as I import Data.IntMap.Strict (IntMap) -import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, + mapMaybe) import Data.Serialize (Get, Put, Serialize (..), getWord32be, getWord64be, getWord8, putWord32be, putWord64be, putWord8) @@ -114,17 +123,20 @@ txHashToHex, wrapPubKey) import Web.Scotty.Trans (ScottyError (..)) -data DeriveType - = DeriveNormal +data DeriveType = DeriveNormal | DeriveP2SH | DeriveP2WPKH deriving (Show, Eq, Generic, NFData, Serialize) +instance Default DeriveType where + def = DeriveNormal + data XPubSpec = XPubSpec { xPubSpecKey :: !XPubKey , xPubDeriveType :: !DeriveType - } deriving (Show, Eq, Generic, NFData) + } + deriving (Show, Eq, Generic, NFData) instance Hashable XPubSpec where hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} = @@ -169,9 +181,9 @@ data BlockRef = BlockRef { blockRefHeight :: !BlockHeight - -- ^ block height in the chain + -- ^ block height in the chain , blockRefPos :: !Word32 - -- ^ position of transaction within the block + -- ^ position of transaction within the block } | MemRef { memRefTime :: !UnixTime @@ -222,12 +234,14 @@ return MemRef {memRefTime = mempool} -- | Transaction in relation to an address. -data TxRef = TxRef - { txRefBlock :: !BlockRef - -- ^ block information - , txRefHash :: !TxHash - -- ^ transaction hash - } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) +data TxRef = + TxRef + { txRefBlock :: !BlockRef + -- ^ block information + , txRefHash :: !TxHash + -- ^ transaction hash + } + deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) instance ToJSON TxRef where toJSON btx = object ["txid" .= txRefHash btx, "block" .= txRefBlock btx] @@ -248,17 +262,17 @@ data Balance = Balance { balanceAddress :: !Address - -- ^ address balance + -- ^ address balance , balanceAmount :: !Word64 - -- ^ confirmed balance + -- ^ confirmed balance , balanceZero :: !Word64 - -- ^ unconfirmed balance + -- ^ unconfirmed balance , balanceUnspentCount :: !Word64 - -- ^ number of unspent outputs + -- ^ number of unspent outputs , balanceTxCount :: !Word64 - -- ^ number of transactions + -- ^ number of transactions , balanceTotalReceived :: !Word64 - -- ^ total amount from all outputs in this address + -- ^ total amount from all outputs in this address } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) @@ -284,7 +298,7 @@ balanceToJSON :: Network -> Balance -> Value balanceToJSON net b = - object $ + object [ "address" .= addrToJSON net (balanceAddress b) , "confirmed" .= balanceAmount b , "unconfirmed" .= balanceZero b @@ -324,13 +338,15 @@ } -- | Unspent output. -data Unspent = Unspent - { unspentBlock :: !BlockRef - , unspentPoint :: !OutPoint - , unspentAmount :: !Word64 - , unspentScript :: !ShortByteString - , unspentAddress :: !(Maybe Address) - } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) +data Unspent = + Unspent + { unspentBlock :: !BlockRef + , unspentPoint :: !OutPoint + , unspentAmount :: !Word64 + , unspentScript :: !ShortByteString + , unspentAddress :: !(Maybe Address) + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) instance Coin Unspent where coinValue = unspentAmount @@ -384,28 +400,30 @@ } -- | Database value for a block entry. -data BlockData = BlockData - { blockDataHeight :: !BlockHeight - -- ^ height of the block in the chain - , blockDataMainChain :: !Bool - -- ^ is this block in the main chain? - , blockDataWork :: !BlockWork - -- ^ accumulated work in that block - , blockDataHeader :: !BlockHeader - -- ^ block header - , blockDataSize :: !Word32 - -- ^ size of the block including witnesses - , blockDataWeight :: !Word32 - -- ^ weight of this block (for segwit networks) - , blockDataTxs :: ![TxHash] - -- ^ block transactions - , blockDataOutputs :: !Word64 - -- ^ sum of all transaction outputs - , blockDataFees :: !Word64 - -- ^ sum of all transaction fees - , blockDataSubsidy :: !Word64 - -- ^ block subsidy - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) +data BlockData = + BlockData + { blockDataHeight :: !BlockHeight + -- ^ height of the block in the chain + , blockDataMainChain :: !Bool + -- ^ is this block in the main chain? + , blockDataWork :: !BlockWork + -- ^ accumulated work in that block + , blockDataHeader :: !BlockHeader + -- ^ block header + , blockDataSize :: !Word32 + -- ^ size of the block including witnesses + , blockDataWeight :: !Word32 + -- ^ weight of this block (for segwit networks) + , blockDataTxs :: ![TxHash] + -- ^ block transactions + , blockDataOutputs :: !Word64 + -- ^ sum of all transaction outputs + , blockDataFees :: !Word64 + -- ^ sum of all transaction fees + , blockDataSubsidy :: !Word64 + -- ^ block subsidy + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) blockDataToJSON :: Network -> BlockData -> Value blockDataToJSON net bv = @@ -565,12 +583,11 @@ <> "sequence" .= sq <> "pkscript" `pair` text (encodeHex ps) <> "value" .= val - <> "address" `pair` (maybe null_ (addrToEncoding net) a) + <> "address" `pair` maybe null_ (addrToEncoding net) a <> (if getSegWit net then "witness" .= fmap (map encodeHex) wit else mempty) ) - storeInputToEncoding net StoreCoinbase { inputPoint = OutPoint oph opi , inputSequence = sq , inputSigScript = ss @@ -634,12 +651,14 @@ Just b -> return b -- | Information about input spending output. -data Spender = Spender - { spenderHash :: !TxHash +data Spender = + Spender + { spenderHash :: !TxHash -- ^ input transaction hash - , spenderIndex :: !Word32 + , spenderIndex :: !Word32 -- ^ input position in transaction - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) instance ToJSON Spender where toJSON n = object ["txid" .= txHashToHex (spenderHash n), "input" .= spenderIndex n] @@ -650,12 +669,14 @@ A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input" -- | Output information. -data StoreOutput = StoreOutput - { outputAmount :: !Word64 - , outputScript :: !ByteString - , outputSpender :: !(Maybe Spender) - , outputAddress :: !(Maybe Address) - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) +data StoreOutput = + StoreOutput + { outputAmount :: !Word64 + , outputScript :: !ByteString + , outputSpender :: !(Maybe Spender) + , outputAddress :: !(Maybe Address) + } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) storeOutputToJSON :: Network -> StoreOutput -> Value storeOutputToJSON net d = @@ -694,10 +715,12 @@ , outputAddress = addr } -data Prev = Prev - { prevScript :: !ByteString - , prevAmount :: !Word64 - } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) +data Prev = + Prev + { prevScript :: !ByteString + , prevAmount :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput toInput i Nothing w = @@ -727,14 +750,16 @@ , outputAddress = eitherToMaybe (scriptToAddressBS (scriptOutput o)) } -data TxData = TxData - { txDataBlock :: !BlockRef - , txData :: !Tx - , txDataPrevs :: !(IntMap Prev) - , txDataDeleted :: !Bool - , txDataRBF :: !Bool - , txDataTime :: !Word64 - } deriving (Show, Eq, Ord, Generic, Serialize, NFData) +data TxData = + TxData + { txDataBlock :: !BlockRef + , txData :: !Tx + , txDataPrevs :: !(IntMap Prev) + , txDataDeleted :: !Bool + , txDataRBF :: !Bool + , txDataTime :: !Word64 + } + deriving (Show, Eq, Ord, Generic, Serialize, NFData) toTransaction :: TxData -> IntMap Spender -> Transaction toTransaction t sm = @@ -794,32 +819,34 @@ sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) -- | Detailed transaction information. -data Transaction = Transaction - { transactionBlock :: !BlockRef +data Transaction = + Transaction + { transactionBlock :: !BlockRef -- ^ block information for this transaction - , transactionVersion :: !Word32 + , transactionVersion :: !Word32 -- ^ transaction version - , transactionLockTime :: !Word32 + , transactionLockTime :: !Word32 -- ^ lock time - , transactionInputs :: ![StoreInput] + , transactionInputs :: ![StoreInput] -- ^ transaction inputs - , transactionOutputs :: ![StoreOutput] + , transactionOutputs :: ![StoreOutput] -- ^ transaction outputs - , transactionDeleted :: !Bool + , transactionDeleted :: !Bool -- ^ this transaction has been deleted and is no longer valid - , transactionRBF :: !Bool + , transactionRBF :: !Bool -- ^ this transaction can be replaced in the mempool - , transactionTime :: !Word64 + , transactionTime :: !Word64 -- ^ time the transaction was first seen or time of block - , transactionId :: !TxHash + , transactionId :: !TxHash -- ^ transaction id - , transactionSize :: !Word32 + , transactionSize :: !Word32 -- ^ serialized transaction size (includes witness data) - , transactionWeight :: !Word32 + , transactionWeight :: !Word32 -- ^ transaction weight - , transactionFees :: !Word64 + , transactionFees :: !Word64 -- ^ fees that this transaction pays (0 for coinbase) - } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + } + deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) transactionData :: Transaction -> Tx transactionData t = @@ -908,18 +935,19 @@ } -- | Information about a connected peer. -data PeerInformation - = PeerInformation { peerUserAgent :: !ByteString +data PeerInformation = + PeerInformation + { peerUserAgent :: !ByteString -- ^ user agent string - , peerAddress :: !String + , peerAddress :: !String -- ^ network address - , peerVersion :: !Word32 + , peerVersion :: !Word32 -- ^ version number - , peerServices :: !Word64 + , peerServices :: !Word64 -- ^ services field - , peerRelay :: !Bool + , peerRelay :: !Bool -- ^ will relay transactions - } + } deriving (Show, Eq, Ord, Generic, NFData, Serialize) instance ToJSON PeerInformation where @@ -960,10 +988,12 @@ } -- | Address balances for an extended public key. -data XPubBal = XPubBal - { xPubBalPath :: ![KeyIndex] - , xPubBal :: !Balance - } deriving (Show, Ord, Eq, Generic, Serialize, NFData) +data XPubBal = + XPubBal + { xPubBalPath :: ![KeyIndex] + , xPubBal :: !Balance + } + deriving (Show, Ord, Eq, Generic, Serialize, NFData) xPubBalToJSON :: Network -> XPubBal -> Value xPubBalToJSON net XPubBal {xPubBalPath = p, xPubBal = b} = @@ -981,10 +1011,12 @@ return XPubBal {xPubBalPath = path, xPubBal = balance} -- | Unspent transaction for extended public key. -data XPubUnspent = XPubUnspent - { xPubUnspentPath :: ![KeyIndex] - , xPubUnspent :: !Unspent - } deriving (Show, Eq, Generic, Serialize, NFData) +data XPubUnspent = + XPubUnspent + { xPubUnspentPath :: ![KeyIndex] + , xPubUnspent :: !Unspent + } + deriving (Show, Eq, Generic, Serialize, NFData) xPubUnspentToJSON :: Network -> XPubUnspent -> Value xPubUnspentToJSON net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = @@ -1159,8 +1191,8 @@ } data Event - = EventBlock BlockHash - | EventTx TxHash + = EventBlock !BlockHash + | EventTx !TxHash deriving (Show, Eq, Generic, Serialize, NFData) instance ToJSON Event where @@ -1185,9 +1217,11 @@ return $ EventBlock i _ -> fail $ "Could not recognize event type: " <> t -newtype GenericResult a = GenericResult - { getResult :: a - } deriving (Show, Eq, Generic, Serialize, NFData) +newtype GenericResult a = + GenericResult + { getResult :: a + } + deriving (Show, Eq, Generic, Serialize, NFData) instance ToJSON a => ToJSON (GenericResult a) where toJSON (GenericResult b) = object ["result" .= b] @@ -1195,8 +1229,58 @@ instance FromJSON a => FromJSON (GenericResult a) where parseJSON = - A.withObject "result" $ \o -> GenericResult <$> o .: "result" + A.withObject "GenericResult" $ \o -> GenericResult <$> o .: "result" +newtype RawResult a = + RawResult + { getRawResult :: a + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance S.Serialize a => ToJSON (RawResult a) where + toJSON (RawResult b) = + object [ "result" .= A.String (encodeHex $ S.encode b)] + toEncoding (RawResult b) = + pairs $ "result" `pair` unsafeToEncoding str + where + str = char7 '"' <> lazyByteStringHex (S.runPutLazy $ put b) <> char7 '"' + +instance S.Serialize a => FromJSON (RawResult a) where + parseJSON = + A.withObject "RawResult" $ \o -> do + res <- o .: "result" + let valM = eitherToMaybe . S.decode =<< decodeHex res + maybe mzero (return . RawResult) valM + +newtype RawResultList a = + RawResultList + { getRawResultList :: [a] + } + deriving (Show, Eq, Generic, Serialize, NFData) + +instance Semigroup (RawResultList a) where + (RawResultList a) <> (RawResultList b) = RawResultList $ a <> b + +instance Monoid (RawResultList a) where + mempty = RawResultList mempty + +instance S.Serialize a => ToJSON (RawResultList a) where + toJSON (RawResultList xs) = + toJSON $ encodeHex . S.encode <$> xs + toEncoding (RawResultList xs) = + list (unsafeToEncoding . str) xs + where + str x = + char7 '"' <> lazyByteStringHex (S.runPutLazy (put x)) <> char7 '"' + +instance S.Serialize a => FromJSON (RawResultList a) where + parseJSON = + A.withArray "RawResultList" $ \vec -> + RawResultList <$> mapM parseElem (toList vec) + where + parseElem = A.withText "RawResultListElem" $ maybe mzero return . f + f = eitherToMaybe . S.decode <=< decodeHex + newtype TxId = TxId TxHash deriving (Show, Eq, Generic, Serialize, NFData) @@ -1212,18 +1296,10 @@ = ThingNotFound | ServerError | BadRequest - | UserError String - | StringError String + | UserError !String + | StringError !String | BlockTooLarge - deriving (Eq, Ord, Serialize, Generic, NFData) - -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" + deriving (Show, Eq, Ord, Serialize, Generic, NFData) instance Exception Except @@ -1232,4 +1308,36 @@ showError = TL.pack . show instance ToJSON Except where - toJSON e = object ["error" .= TL.pack (show e)] + toJSON e = + object $ + case e of + ThingNotFound -> + ["error" .= String "not-found"] + ServerError -> + ["error" .= String "server-error"] + BadRequest -> + ["error" .= String "bad-request"] + UserError msg -> + [ "error" .= String "user-error" + , "message" .= String (cs msg) + ] + StringError msg -> + [ "error" .= String "string-error" + , "message" .= String (cs msg) + ] + BlockTooLarge -> + ["error" .= String "block-too-large"] + +instance FromJSON Except where + parseJSON = + A.withObject "Except" $ \o -> do + ctr <- o .: "error" + msg <- fromMaybe "" <$> o .:? "message" + case ctr of + String "not-found" -> return ThingNotFound + String "server-error" -> return ServerError + String "bad-request" -> return BadRequest + String "user-error" -> return $ UserError msg + String "string-error" -> return $ StringError msg + String "block-too-large" -> return BlockTooLarge + _ -> mzero diff --git a/src/Haskoin/Store/WebClient.hs b/src/Haskoin/Store/WebClient.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/WebClient.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Store.WebClient +( ApiConfig(..) +, apiCall +, apiBatch +-- Blocks +, GetBlock(..) +, GetBlocks(..) +, GetBlockRaw(..) +, GetBlockBest(..) +, GetBlockBestRaw(..) +, GetBlockLatest(..) +, GetBlockHeight(..) +, GetBlockHeights(..) +, GetBlockHeightRaw(..) +, GetBlockTime(..) +, GetBlockTimeRaw(..) +-- Transactions +, GetTx(..) +, GetTxs(..) +, GetTxRaw(..) +, GetTxsRaw(..) +, GetTxsBlock(..) +, GetTxsBlockRaw(..) +, GetTxAfter(..) +, PostTx(..) +, GetMempool(..) +, GetEvents(..) +-- Address +, GetAddrTxs(..) +, GetAddrsTxs(..) +, GetAddrTxsFull(..) +, GetAddrsTxsFull(..) +, GetAddrBalance(..) +, GetAddrsBalance(..) +, GetAddrUnspent(..) +, GetAddrsUnspent(..) +-- XPubs +, GetXPub(..) +, GetXPubTxs(..) +, GetXPubTxsFull(..) +, GetXPubBalances(..) +, GetXPubUnspent(..) +, GetXPubEvict(..) +-- Network +, GetPeers(..) +, GetHealth(..) +-- Params +, StartParam(..) +, OffsetParam(..) +, LimitParam(..) +, LimitsParam(..) +, HeightParam(..) +, HeightsParam(..) +, Store.DeriveType(..) +, NoCache(..) +, NoTx(..) +) + +where + +import Control.Arrow (second) +import Control.Exception +import Control.Lens ((.~), (?~), (^.)) +import Control.Monad.Except +import Data.Default (Default, def) +import Data.Monoid (Endo (..), appEndo) +import qualified Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Haskoin.Constants +import qualified Haskoin.Store.Data as Store +import Haskoin.Store.WebCommon +import Haskoin.Transaction +import Haskoin.Util +import Network.HTTP.Client (Request (..)) +import Network.HTTP.Types (StdMethod (..)) +import Network.HTTP.Types.Status +import qualified Network.Wreq as HTTP +import Network.Wreq.Types (ResponseChecker) +import Numeric.Natural (Natural) + +-- | Configuration specifying the Network and the Host for API calls. +-- Default instance: +-- +-- @ +-- ApiConfig +-- { configNetwork = bch +-- , configHost = "https://api.haskoin.com/" +-- } +-- @ +-- +data ApiConfig = ApiConfig + { configNetwork :: !Network + , configHost :: !String + } + deriving (Eq, Show) + +instance Default ApiConfig where + def = ApiConfig + { configNetwork = bch + , configHost = "https://api.haskoin.com/" + } + +-- | Make a call to the haskoin-store API. +-- +-- Usage (default options): +-- +-- > apiCall def $ GetAddrsTxs addrs def +-- +-- With options: +-- +-- > apiCall def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 } +-- +apiCall :: + (ApiResource a b, MonadIO m, MonadError Store.Except m) + => ApiConfig + -> a + -> m b +apiCall (ApiConfig net apiHost) res = do + args <- liftEither $ toOptions net res + let url = apiHost <> getNetworkName net <> cs (queryPath net res) + case resourceMethod $ asProxy res of + GET -> liftEither =<< liftIO (getBinary args url) + POST -> + case resourceBody res of + Just (PostBox val) -> + liftEither =<< liftIO (postBinary args url val) + _ -> throwError $ Store.StringError "Could not post resource" + _ -> throwError $ Store.StringError "Unsupported HTTP method" + +-- | Batch commands that have a large list of arguments: +-- +-- > apiBatch 20 def (GetAddrsTxs addrs def) +-- +apiBatch :: + (Batchable a b, MonadIO m, MonadError Store.Except m) + => Natural + -> ApiConfig + -> a + -> m b +apiBatch i conf res = mconcat <$> mapM (apiCall conf) (resourceBatch i res) + +class (ApiResource a b, Monoid b) => Batchable a b where + resourceBatch :: Natural -> a -> [a] + +instance Batchable GetBlocks [Store.BlockData] where + resourceBatch i (GetBlocks hs t) = (`GetBlocks` t) <$> chunksOf i hs + +instance Batchable GetBlockHeights [Store.BlockData] where + resourceBatch i (GetBlockHeights (HeightsParam hs) n) = + (`GetBlockHeights` n) <$> (HeightsParam <$> chunksOf i hs) + +instance Batchable GetTxs [Store.Transaction] where + resourceBatch i (GetTxs ts) = GetTxs <$> chunksOf i ts + +instance Batchable GetTxsRaw (Store.RawResultList Tx) where + resourceBatch i (GetTxsRaw ts) = GetTxsRaw <$> chunksOf i ts + +instance Batchable GetAddrsTxs [Store.TxRef] where + resourceBatch i (GetAddrsTxs as l) = (`GetAddrsTxs` l) <$> chunksOf i as + +instance Batchable GetAddrsTxsFull [Store.Transaction] where + resourceBatch i (GetAddrsTxsFull as l) = + (`GetAddrsTxsFull` l) <$> chunksOf i as + +instance Batchable GetAddrsBalance [Store.Balance] where + resourceBatch i (GetAddrsBalance as) = GetAddrsBalance <$> chunksOf i as + +instance Batchable GetAddrsUnspent [Store.Unspent] where + resourceBatch i (GetAddrsUnspent as l) = + (`GetAddrsUnspent` l) <$> chunksOf i as + +------------------ +-- API Internal -- +------------------ + +toOptions :: + ApiResource a b => Network -> a -> Either Store.Except (Endo HTTP.Options) +toOptions net res = + mconcat <$> mapM f (snd $ queryParams res) + where + f (ParamBox p) = toOption net p + +toOption :: Param a => Network -> a -> Either Store.Except (Endo HTTP.Options) +toOption net a = do + res <- maybeToEither (Store.UserError "Invalid Param") $ encodeParam net a + return $ applyOpt (paramLabel a) res + +applyOpt :: Text -> [Text] -> Endo HTTP.Options +applyOpt p t = Endo $ HTTP.param p .~ [Text.intercalate "," t] + +getBinary :: + S.Serialize a + => Endo HTTP.Options + -> String + -> IO (Either Store.Except a) +getBinary opts url = do + resE <- try $ HTTP.getWith (binaryOpts opts) url + return $ do + res <- resE + toExcept $ S.decodeLazy $ res ^. HTTP.responseBody + +postBinary :: + (S.Serialize a, S.Serialize r) + => Endo HTTP.Options + -> String + -> a + -> IO (Either Store.Except r) +postBinary opts url body = do + resE <- try $ HTTP.postWith (binaryOpts opts) url (S.encode body) + return $ do + res <- resE + toExcept $ S.decodeLazy $ res ^. HTTP.responseBody + +binaryOpts :: Endo HTTP.Options -> HTTP.Options +binaryOpts opts = + appEndo (opts <> accept <> stat) HTTP.defaults + where + accept = Endo $ HTTP.header "Accept" .~ ["application/octet-stream"] + stat = Endo $ HTTP.checkResponse ?~ checkStatus + +checkStatus :: ResponseChecker +checkStatus req res + | statusIsSuccessful status = return () + | isHealthPath && code == 503 = return () -- Ignore health checks + | otherwise = do + e <- S.decode <$> res ^. HTTP.responseBody + throwIO $ + case e of + Right except -> except :: Store.Except + _ -> Store.StringError err + where + code = res ^. HTTP.responseStatus . HTTP.statusCode + message = res ^. HTTP.responseStatus . HTTP.statusMessage + status = mkStatus code message + err = unwords ["Code:", show code, "Message:", cs message] + isHealthPath = "/health" `Text.isInfixOf` cs (path req) + +--------------- +-- Utilities -- +--------------- + +toExcept :: Either String a -> Either Store.Except a +toExcept (Right a) = Right a +toExcept (Left err) = Left $ Store.UserError err + +chunksOf :: Natural -> [a] -> [[a]] +chunksOf n xs + | null xs = [] + | otherwise = + uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs + diff --git a/src/Haskoin/Store/WebCommon.hs b/src/Haskoin/Store/WebCommon.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/WebCommon.hs @@ -0,0 +1,548 @@ +{-# 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.Default (Default, def) +import Data.Proxy (Proxy(..)) +import qualified Data.Serialize as S +import Data.String (IsString (..)) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as Text +import Haskoin.Address +import Haskoin.Block (Block, BlockHash, blockHashToHex, + hexToBlockHash) +import Haskoin.Constants +import Haskoin.Crypto (Hash256) +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 S.Serialize 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 . S.Serialize 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 +-- 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 GetXPubEvict = GetXPubEvict !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.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.BlockData] where + resourcePath _ _ = "/block/latest" + queryParams (GetBlockLatest t) = ([], noDefBox t) + +instance ApiResource GetBlockHeight [Store.BlockData] where + resourcePath _ = ("/block/height/" <:>) + queryParams (GetBlockHeight h t) = ([ParamBox h], noDefBox t) + captureParams _ = [ProxyBox (Proxy :: Proxy HeightParam)] + +instance ApiResource GetBlockHeights [Store.BlockData] where + resourcePath _ _ = "/block/height" + 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)] + +------------------ +-- Transactions -- +------------------ + +instance ApiResource GetTx Store.Transaction where + resourcePath _ = ("/transaction/" <:>) + queryParams (GetTx h) = ([ParamBox h], []) + captureParams _ = [ProxyBox (Proxy :: Proxy TxHash)] + +instance ApiResource GetTxs [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.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 [TxHash] where + resourcePath _ _ = "/mempool" + queryParams (GetMempool l o) = ([], noMaybeBox l <> noDefBox o) + +instance ApiResource GetEvents [Store.Event] where + resourcePath _ _ = "/events" + +------------- +-- Address -- +------------- + +instance ApiResource GetAddrTxs [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.TxRef] where + resourcePath _ _ = "/address/transactions" + queryParams (GetAddrsTxs as (LimitsParam l o sM)) = + ([] , [ParamBox as] <> noMaybeBox l <> noDefBox o <> noMaybeBox sM) + +instance ApiResource GetAddrTxsFull [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.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.Balance] where + resourcePath _ _ = "/address/balances" + queryParams (GetAddrsBalance as) = ([] , [ParamBox as]) + +instance ApiResource GetAddrUnspent [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.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.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.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.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.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 GetXPubEvict (Store.GenericResult Bool) where + resourcePath _ = "/xpub/" <+> "/evict" + queryParams (GetXPubEvict p d) = ([ParamBox p], noDefBox d) + captureParams _ = [ProxyBox (Proxy :: Proxy XPubKey)] + +------------- +-- Network -- +------------- + +instance ApiResource GetPeers [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 = (:[]) <$> addrToString net a + parseParam net [a] = stringToAddr net a + parseParam _ _ = Nothing + +instance Param [Address] where + proxyLabel = const "addresses" + encodeParam = mapM . addrToString + parseParam = mapM . stringToAddr + +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 (Text.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) + case p of + Store.DeriveNormal -> Just ["standard"] + Store.DeriveP2SH -> Just ["compat"] + Store.DeriveP2WPKH -> Just ["segwit"] + parseParam net d = do + res <- case d of + ["standard"] -> Just Store.DeriveNormal + ["compat"] -> Just Store.DeriveP2SH + ["segwit"] -> Just Store.DeriveP2WPKH + _ -> 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 + diff --git a/test/Haskoin/Store/DataSpec.hs b/test/Haskoin/Store/DataSpec.hs --- a/test/Haskoin/Store/DataSpec.hs +++ b/test/Haskoin/Store/DataSpec.hs @@ -1,159 +1,185 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Haskoin.Store.DataSpec ( spec ) where -import Data.Aeson (Encoding, FromJSON (..), ToJSON (..), - Value) +import Control.Monad (forM_, (<=<)) +import Data.Aeson (Encoding, FromJSON (..), Value) import qualified Data.Aeson as A import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Parser (decodeWith, json) -import Data.Aeson.Types (Parser, parse) -import Data.ByteString (pack) +import Data.Aeson.Types (Parser, parseMaybe) import qualified Data.ByteString.Short as BSS -import Data.Serialize (Serialize (..), decode, encode) +import Data.Map.Strict (singleton) +import Data.Proxy +import qualified Data.Serialize as S import Data.String.Conversions (cs) -import Haskoin (Address (..), BlockHash (..), - BlockHeader (..), Hash160 (..), - Hash256 (..), Network (..), - OutPoint (..), RejectCode (..), - Tx (..), TxHash (..), TxIn (..), - TxOut (..), XPubKey (..), bch, - bchRegTest, bchTest, btc, btcRegTest, - btcTest, ripemd160, sha256) -import Haskoin.Store.Data (Balance (..), BlockData (..), - BlockRef (..), TxRef (..), - DeriveType (..), Event (..), - HealthCheck (..), - PeerInformation (..), Prev (..), - Spender (..), StoreInput (..), - StoreOutput (..), Transaction (..), - TxData (..), TxId (..), Unspent (..), - XPubBal (..), XPubSpec (..), - XPubSummary (..), XPubUnspent (..), - balanceParseJSON, balanceToEncoding, - balanceToJSON, blockDataToEncoding, - blockDataToJSON, transactionParseJSON, - transactionToEncoding, - transactionToJSON, unspentParseJSON, - unspentToEncoding, unspentToJSON, - xPubUnspentParseJSON, - xPubUnspentToEncoding, - xPubUnspentToJSON) -import Test.Hspec (Expectation, Spec, describe, shouldBe) +import qualified Data.Typeable as T +import Haskoin +import Haskoin.Store.Data +import Haskoin.Util.Arbitrary +import Test.Hspec (Spec, describe, shouldBe, + shouldSatisfy) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary (..), Gen, - arbitraryPrintableChar, - arbitraryUnicodeChar, elements, - forAll, listOf, listOf1, oneof) +import Test.QuickCheck +data SerialBox = + forall a. (Show a, Eq a, T.Typeable a, S.Serialize a) => + SerialBox (Gen a) + +data JsonBox = + forall a. (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) => + JsonBox (Gen a) + +data NetBox = + forall a. (Show a, Eq a, T.Typeable a, Arbitrary a) => + NetBox ( Network -> a -> Value + , Network -> a -> Encoding + , Network -> Value -> Parser a + , Gen (Network, a) + ) + +serialVals :: [SerialBox] +serialVals = + [ SerialBox (arbitrary :: Gen DeriveType) + , SerialBox (arbitrary :: Gen XPubSpec) + , SerialBox (arbitrary :: Gen BlockRef) + , SerialBox (arbitrary :: Gen TxRef) + , SerialBox (arbitrary :: Gen Balance) + , SerialBox (arbitrary :: Gen Unspent) + , SerialBox (arbitrary :: Gen BlockData) + , SerialBox (arbitrary :: Gen StoreInput) + , SerialBox (arbitrary :: Gen Spender) + , SerialBox (arbitrary :: Gen StoreOutput) + , SerialBox (arbitrary :: Gen Prev) + , SerialBox (arbitrary :: Gen TxData) + , SerialBox (arbitrary :: Gen Transaction) + , SerialBox (arbitrary :: Gen XPubBal) + , SerialBox (arbitrary :: Gen XPubUnspent) + , SerialBox (arbitrary :: Gen XPubSummary) + , SerialBox (arbitrary :: Gen HealthCheck) + , SerialBox (arbitrary :: Gen Event) + , SerialBox (arbitrary :: Gen TxId) + , SerialBox (arbitrary :: Gen PeerInformation) + , SerialBox (arbitrary :: Gen (GenericResult BlockData)) + , SerialBox (arbitrary :: Gen (RawResult BlockData)) + , SerialBox (arbitrary :: Gen (RawResultList BlockData)) + , SerialBox (arbitrary :: Gen Except) + ] + +jsonVals :: [JsonBox] +jsonVals = + [ JsonBox (arbitrary :: Gen TxRef) + , JsonBox (arbitrary :: Gen BlockRef) + , JsonBox (arbitrary :: Gen Spender) + , JsonBox (arbitrary :: Gen XPubSummary) + , JsonBox (arbitrary :: Gen HealthCheck) + , JsonBox (arbitrary :: Gen Event) + , JsonBox (arbitrary :: Gen TxId) + , JsonBox (arbitrary :: Gen PeerInformation) + , JsonBox (arbitrary :: Gen (GenericResult XPubSummary)) + , JsonBox (arbitrary :: Gen (RawResult BlockData)) + , JsonBox (arbitrary :: Gen (RawResultList BlockData)) + , JsonBox (arbitrary :: Gen Except) + ] + +netVals :: [NetBox] +netVals = + [ NetBox ( balanceToJSON + , balanceToEncoding + , balanceParseJSON + , arbitraryNetData) + , NetBox ( storeOutputToJSON + , storeOutputToEncoding + , storeOutputParseJSON + , arbitraryNetData) + , NetBox ( unspentToJSON + , unspentToEncoding + , unspentParseJSON + , arbitraryNetData) + , NetBox ( xPubBalToJSON + , xPubBalToEncoding + , xPubBalParseJSON + , arbitraryNetData) + , NetBox ( xPubUnspentToJSON + , xPubUnspentToEncoding + , xPubUnspentParseJSON + , arbitraryNetData) + , NetBox ( storeInputToJSON + , storeInputToEncoding + , storeInputParseJSON + , arbitraryStoreInputNet) + , NetBox ( blockDataToJSON + , blockDataToEncoding + , const parseJSON + , arbitraryBlockDataNet) + , NetBox ( transactionToJSON + , transactionToEncoding + , transactionParseJSON + , arbitraryTransactionNet) + ] + spec :: Spec spec = do - describe "Binary serialization" $ do - prop "identity for derivation type" $ \x -> testSerial (x :: DeriveType) - prop "identity for xpub spec" $ \x -> testSerial (x :: XPubSpec) - prop "identity for block ref" $ \x -> testSerial (x :: BlockRef) - prop "identity for block tx" $ \x -> testSerial (x :: TxRef) - prop "identity for balance" $ \x -> testSerial (x :: Balance) - prop "identity for unspent" $ \x -> testSerial (x :: Unspent) - prop "identity for block data" $ \x -> testSerial (x :: BlockData) - prop "identity for input" $ \x -> testSerial (x :: StoreInput) - prop "identity for spender" $ \x -> testSerial (x :: Spender) - prop "identity for output" $ \x -> testSerial (x :: StoreOutput) - prop "identity for previous output" $ \x -> testSerial (x :: Prev) - prop "identity for tx data" $ \x -> testSerial (x :: TxData) - prop "identity for transaction" $ \x -> testSerial (x :: Transaction) - prop "identity for xpub balance" $ \x -> testSerial (x :: XPubBal) - prop "identity for xpub unspent" $ \x -> testSerial (x :: XPubUnspent) - prop "identity for xpub summary" $ \x -> testSerial (x :: XPubSummary) - prop "identity for health check" $ \x -> testSerial (x :: HealthCheck) - prop "identity for event" $ \x -> testSerial (x :: Event) - prop "identity for txid" $ \x -> testSerial (x :: TxId) - prop "identity for peer info" $ \x -> testSerial (x :: PeerInformation) - describe "JSON serialization" $ do - prop "identity for balance" . forAll arbitraryNetData $ \(net, x) -> - testNetJSON - (balanceParseJSON net) - (balanceToJSON net) - (balanceToEncoding net) - x - prop "identity for block tx" $ \x -> testJSON (x :: TxRef) - prop "identity for block ref" $ \x -> testJSON (x :: BlockRef) - prop "identity for unspent" . forAll arbitraryNetData $ \(net, x) -> - testNetJSON - (unspentParseJSON net) - (unspentToJSON net) - (unspentToEncoding net) - x - prop "identity for block data" . forAll arbitraryNetData $ \(net, x) -> - let x' = - if getSegWit net - then x - else x {blockDataWeight = 0} - in testNetJSON - parseJSON - (blockDataToJSON net) - (blockDataToEncoding net) - x' - prop "identity for spender" $ \x -> testJSON (x :: Spender) - prop "identity for transaction" . forAll arbitraryNetData $ \(net, x) -> - let f i = i {inputWitness = Nothing} - x' = - if getSegWit net - then x - else x - { transactionInputs = - map f (transactionInputs x) - , transactionWeight = 0 - } - x'' = - if getReplaceByFee net - then x' - else x' {transactionRBF = False} - in testNetJSON - (transactionParseJSON net) - (transactionToJSON net) - (transactionToEncoding net) - x'' - prop "identity for xpub summary" $ \x -> testJSON (x :: XPubSummary) - prop "identity for xpub unspent" . forAll arbitraryNetData $ \(net, x) -> - testNetJSON - (xPubUnspentParseJSON net) - (xPubUnspentToJSON net) - (xPubUnspentToEncoding net) - x - prop "identity for health check" $ \x -> testJSON (x :: HealthCheck) - prop "identity for event" $ \x -> testJSON (x :: Event) - prop "identity for txid" $ \x -> testJSON (x :: TxId) - prop "identity for peer information" $ \x -> - testJSON (x :: PeerInformation) - -testJSON :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation -testJSON input = (A.decode . A.encode) input `shouldBe` Just input + describe "Data.Serialize Encoding" $ + forM_ serialVals $ \(SerialBox g) -> testSerial g + describe "Data.Aeson Encoding" $ + forM_ jsonVals $ \(JsonBox g) -> testJson g + describe "Data.Aeson Encoding with Network" $ + forM_ netVals $ \(NetBox (j,e,p,g)) -> testNetJson j e p g -testNetJSON :: - (Eq a, Show a) - => (Value -> Parser a) - -> (a -> Value) - -> (a -> Encoding) - -> a - -> Expectation -testNetJSON parsejson tojson toenc x = - let encval = A.encode (tojson x) - encenc = encodingToLazyByteString (toenc x) - decval = decodeWith json (parse parsejson) encval - decenc = decodeWith json (parse parsejson) encenc - in do - decval `shouldBe` Just x - decenc `shouldBe` Just x +testSerial :: (Eq a, Show a, T.Typeable a, S.Serialize a) => Gen a -> Spec +testSerial gen = + prop ("Data.Serialize encoding/decoding identity for " <> name) $ + forAll gen $ \x -> (S.decode . S.encode) x `shouldBe` Right x + where + name = show $ T.typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy -testSerial :: (Eq a, Show a, Serialize a) => a -> Expectation -testSerial input = (decode . encode) input `shouldBe` Right input +testJson :: + (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec +testJson gen = do + prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` jsonID) + prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` encodingID) + where + name = show $ T.typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + jsonID x = + (A.fromJSON . A.toJSON) (singleton ("object" :: String) x) == + A.Success (singleton ("object" :: String) x) + encodingID x = + (A.decode . encodingToLazyByteString . A.toEncoding) + (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) -arbitraryNetwork :: Gen Network -arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest] +testNetJson :: + (Eq a, Show a, T.Typeable a, Arbitrary a) + => (Network -> a -> Value) + -> (Network -> a -> Encoding) + -> (Network -> Value -> Parser a) + -> Gen (Network, a) + -> Spec +testNetJson j e p g = do + prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ + forAll g $ \(net, x) -> + dec net (encVal net x) `shouldBe` Just x + prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ + forAll g $ \(net, x) -> + dec net (encEnc net x) `shouldBe` Just x + where + encVal net = A.encode . j net + encEnc net = encodingToLazyByteString . e net + dec net = parseMaybe (p net) <=< A.decode + name = show $ T.typeRep $ proxy j + proxy :: (Network -> a -> Value) -> Proxy a + proxy = const Proxy arbitraryNetData :: Arbitrary a => Gen (Network, a) arbitraryNetData = do @@ -165,46 +191,14 @@ arbitrary = oneof [BlockRef <$> arbitrary <*> arbitrary, MemRef <$> arbitrary] -instance Arbitrary Hash256 where - arbitrary = sha256 . pack <$> listOf1 arbitrary - -instance Arbitrary TxHash where - arbitrary = TxHash <$> arbitrary - -instance Arbitrary OutPoint where - arbitrary = OutPoint <$> arbitrary <*> arbitrary - -instance Arbitrary TxIn where - arbitrary = - TxIn <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> - arbitrary - -instance Arbitrary TxOut where - arbitrary = TxOut <$> arbitrary <*> (pack <$> listOf1 arbitrary) - -instance Arbitrary Tx where - arbitrary = do - ver <- arbitrary - txin <- listOf1 arbitrary - txout <- listOf1 arbitrary - txlock <- arbitrary - return - Tx - { txVersion = ver - , txIn = txin - , txOut = txout - , txWitness = [] - , txLockTime = txlock - } - instance Arbitrary Prev where - arbitrary = Prev <$> (pack <$> listOf1 arbitrary) <*> arbitrary + arbitrary = Prev <$> arbitraryBS1 <*> arbitrary instance Arbitrary TxData where arbitrary = TxData <$> arbitrary - <*> arbitrary + <*> arbitraryTx btc <*> arbitrary <*> arbitrary <*> arbitrary @@ -213,30 +207,39 @@ instance Arbitrary StoreInput where arbitrary = oneof - [ StoreCoinbase <$> arbitrary <*> arbitrary <*> - (pack <$> listOf1 arbitrary) <*> - (oneof - [ Just <$> (listOf $ pack <$> listOf1 arbitrary) - , return Nothing - ]) - , StoreInput <$> arbitrary <*> arbitrary <*> - (pack <$> listOf1 arbitrary) <*> - (pack <$> listOf1 arbitrary) <*> - arbitrary <*> - (oneof - [ Just <$> (listOf $ pack <$> listOf1 arbitrary) - , return Nothing - ]) <*> - arbitrary + [ StoreCoinbase + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryMaybe (listOf arbitraryBS1) + , StoreInput + <$> arbitraryOutPoint + <*> arbitrary + <*> arbitraryBS1 + <*> arbitraryBS1 + <*> arbitrary + <*> arbitraryMaybe (listOf arbitraryBS1) + <*> arbitraryMaybe arbitraryAddress ] +arbitraryStoreInputNet :: Gen (Network, StoreInput) +arbitraryStoreInputNet = do + net <- arbitraryNetwork + store <- arbitrary + let res | getSegWit net = store + | otherwise = store{ inputWitness = Nothing } + return (net, res) + instance Arbitrary Spender where - arbitrary = Spender <$> arbitrary <*> arbitrary + arbitrary = Spender <$> arbitraryTxHash <*> arbitrary instance Arbitrary StoreOutput where arbitrary = - StoreOutput <$> arbitrary <*> (pack <$> listOf1 arbitrary) <*> arbitrary <*> - arbitrary + StoreOutput + <$> arbitrary + <*> arbitraryBS1 + <*> arbitrary + <*> arbitraryMaybe arbitraryAddress instance Arbitrary Transaction where arbitrary = @@ -249,13 +252,27 @@ <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary + <*> arbitraryTxHash <*> arbitrary <*> arbitrary <*> arbitrary +arbitraryTransactionNet :: Gen (Network, Transaction) +arbitraryTransactionNet = do + net <- arbitraryNetwork + val <- arbitrary + let val1 | getSegWit net = val + | otherwise = val{ transactionInputs = f <$> transactionInputs val + , transactionWeight = 0 + } + res | getReplaceByFee net = val1 + | otherwise = val1{ transactionRBF = False } + return (net, res) + where + f i = i {inputWitness = Nothing} + instance Arbitrary PeerInformation where - arbitrary = do + arbitrary = PeerInformation <$> (cs <$> listOf arbitraryUnicodeChar) <*> listOf arbitraryPrintableChar @@ -263,19 +280,12 @@ <*> arbitrary <*> arbitrary -instance Arbitrary BlockHash where - arbitrary = BlockHash <$> arbitrary - instance Arbitrary HealthCheck where - arbitrary = do - bh <- arbitrary - hh <- arbitrary - let mb = elements [Nothing, Just bh] - mh = elements [Nothing, Just hh] + arbitrary = HealthCheck - <$> mb + <$> arbitraryMaybe arbitraryBlockHash <*> arbitrary - <*> mh + <*> arbitraryMaybe arbitraryBlockHash <*> arbitrary <*> arbitrary <*> arbitrary @@ -298,37 +308,22 @@ , RejectCheckpoint ] -instance Arbitrary XPubKey where - arbitrary = - XPubKey <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> - arbitrary - instance Arbitrary XPubSpec where - arbitrary = XPubSpec <$> arbitrary <*> arbitrary + arbitrary = XPubSpec <$> (snd <$> arbitraryXPubKey) <*> arbitrary instance Arbitrary DeriveType where arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH] instance Arbitrary TxId where - arbitrary = TxId <$> arbitrary + arbitrary = TxId <$> arbitraryTxHash instance Arbitrary TxRef where - arbitrary = TxRef <$> arbitrary <*> arbitrary - -instance Arbitrary Hash160 where - arbitrary = ripemd160 . pack <$> listOf1 arbitrary - -instance Arbitrary Address where - arbitrary = - oneof - [ PubKeyAddress <$> arbitrary - , ScriptAddress <$> arbitrary - ] + arbitrary = TxRef <$> arbitrary <*> arbitraryTxHash instance Arbitrary Balance where arbitrary = Balance - <$> arbitrary + <$> arbitraryAddress <*> arbitrary <*> arbitrary <*> arbitrary @@ -337,14 +332,12 @@ instance Arbitrary Unspent where arbitrary = - Unspent <$> arbitrary <*> arbitrary <*> arbitrary <*> - (BSS.toShort . pack <$> listOf1 arbitrary) <*> arbitrary - -instance Arbitrary BlockHeader where - arbitrary = - BlockHeader <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> - arbitrary <*> - arbitrary + Unspent + <$> arbitrary + <*> arbitraryOutPoint + <*> arbitrary + <*> (BSS.toShort <$> arbitraryBS1) + <*> arbitraryMaybe arbitraryAddress instance Arbitrary BlockData where arbitrary = @@ -352,14 +345,31 @@ <$> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary + <*> arbitraryBlockHeader <*> arbitrary <*> arbitrary - <*> listOf1 arbitrary + <*> listOf1 arbitraryTxHash <*> arbitrary <*> arbitrary <*> arbitrary +arbitraryBlockDataNet :: Gen (Network, BlockData) +arbitraryBlockDataNet = do + net <- arbitraryNetwork + dat <- arbitrary + let res | getSegWit net = dat + | otherwise = dat{ blockDataWeight = 0} + return (net, res) + +instance Arbitrary a => Arbitrary (GenericResult a) where + arbitrary = GenericResult <$> arbitrary + +instance Arbitrary a => Arbitrary (RawResult a) where + arbitrary = RawResult <$> arbitrary + +instance Arbitrary a => Arbitrary (RawResultList a) where + arbitrary = RawResultList <$> arbitrary + instance Arbitrary XPubBal where arbitrary = XPubBal <$> arbitrary <*> arbitrary @@ -378,4 +388,18 @@ instance Arbitrary Event where arbitrary = - oneof [EventBlock <$> arbitrary, EventTx <$> arbitrary] + oneof + [ EventBlock <$> arbitraryBlockHash + , EventTx <$> arbitraryTxHash + ] + +instance Arbitrary Except where + arbitrary = + oneof + [ return ThingNotFound + , return ServerError + , return BadRequest + , UserError <$> arbitrary + , StringError <$> arbitrary + , return BlockTooLarge + ] diff --git a/test/Haskoin/Store/WebCommonSpec.hs b/test/Haskoin/Store/WebCommonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/WebCommonSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haskoin.Store.WebCommonSpec + ( spec + ) where + +import Control.Monad (forM_) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Haskoin +import Haskoin.Store.Data +import Haskoin.Store.DataSpec () +import Haskoin.Store.WebCommon +import Haskoin.Util.Arbitrary +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +data GenBox = forall p. (Show p, Eq p, Param p) => GenBox (Gen p) + +params :: [GenBox] +params = + [ GenBox arbitraryAddress + , GenBox (listOf arbitraryAddress) + , GenBox (arbitrary :: Gen StartParam) + , GenBox (arbitrarySizedNatural :: Gen OffsetParam) + , GenBox (arbitrarySizedNatural :: Gen LimitParam) + , GenBox (arbitrarySizedNatural :: Gen HeightParam) + , GenBox (arbitrary :: Gen HeightsParam) + , GenBox (arbitrarySizedNatural :: Gen TimeParam) + , GenBox (snd <$> arbitraryXPubKey :: Gen XPubKey) + , GenBox (arbitrary :: Gen DeriveType) + , GenBox (NoCache <$> arbitrary :: Gen NoCache) + , GenBox (NoTx <$> arbitrary :: Gen NoTx) + , GenBox arbitraryBlockHash + , GenBox (listOf arbitraryBlockHash) + , GenBox arbitraryTxHash + , GenBox (listOf arbitraryTxHash) + ] + +spec :: Spec +spec = + describe "Parameter encoding" $ + forM_ params $ \(GenBox g) -> testParam g + +testParam :: (Eq a, Show a, Param a) => Gen a -> Spec +testParam pGen = + prop ("encodeParam/parseParam identity for parameter " <> name) $ + forAll pGen $ \p -> + case encodeParam btc p of + Just txts -> parseParam btc txts `shouldBe` Just p + _ -> expectationFailure "Param encoding failed" + where + name = cs $ proxyLabel $ proxy pGen + proxy :: Gen a -> Proxy a + proxy = const Proxy + +instance Arbitrary StartParam where + arbitrary = + oneof + [ StartParamHash <$> arbitraryHash256 + , StartParamHeight . fromIntegral <$> + (choose (0, 1230768000) :: Gen Word64) + , StartParamTime . fromIntegral <$> + (choose (1230768000, maxBound) :: Gen Word64) + ] + +instance Arbitrary HeightsParam where + arbitrary = HeightsParam <$> listOf arbitrarySizedNatural