haskoin-store-data 0.30.1 → 0.31.0
raw patch · 6 files changed
+1388/−360 lines, 6 filesdep +data-defaultdep +http-clientdep +http-typesdep ~haskoin-core
Dependencies added: data-default, http-client, http-types, lens, mtl, wreq
Dependency ranges changed: haskoin-core
Files
- haskoin-store-data.cabal +21/−4
- src/Haskoin/Store/Data.hs +230/−122
- src/Haskoin/Store/WebClient.hs +258/−0
- src/Haskoin/Store/WebCommon.hs +548/−0
- test/Haskoin/Store/DataSpec.hs +258/−234
- test/Haskoin/Store/WebCommonSpec.hs +73/−0
haskoin-store-data.cabal view
@@ -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
src/Haskoin/Store/Data.hs view
@@ -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
+ src/Haskoin/Store/WebClient.hs view
@@ -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+
+ src/Haskoin/Store/WebCommon.hs view
@@ -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+
test/Haskoin/Store/DataSpec.hs view
@@ -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+ ]
+ test/Haskoin/Store/WebCommonSpec.hs view
@@ -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