haskoin-store-data 2.0.0 → 2.0.1
raw patch · 7 files changed
+460/−62 lines, 7 filesdep ~networkPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network
API changes (from Hackage documentation)
+ Haskoin.Store.WebCommon: pathEncodes :: ApiResource a b => Network -> Ctx -> a -> Bool
Files
- CHANGELOG.md +72/−0
- haskoin-store-data.cabal +3/−2
- src/Haskoin/Store/Data.hs +90/−37
- src/Haskoin/Store/WebClient.hs +51/−14
- src/Haskoin/Store/WebCommon.hs +36/−9
- test/Haskoin/Store/DataSpec.hs +7/−0
- test/Haskoin/Store/RobustSpec.hs +201/−0
CHANGELOG.md view
@@ -6,6 +6,78 @@ ## [Unreleased] +## [2.0.1] - 2026-11-12++The fixes of a review of the parsers, the types and the client. No parser+refused an object for having more fields than it reads; what was wrong was+elsewhere. `test/Haskoin/Store/RobustSpec.hs` holds each by the input that+showed it.++### Fixed+- **A peer could make `/peers` fail.** The JSON of `PeerInfo` decoded the+ user agent as strict UTF-8 and threw on one that is not. The server+ fills it with the bytes of the peer's version message. Bytes that are+ not UTF-8 are now written as the replacement character; `relayed_by`+ of `BinfoTx` the same.+- **Values that failed with `error` after their parser had answered.**+ - A health check whose `time` is not a time: the reader used `read`.+ - An xpub of the Blockchain.info format whose `path` is not a path: the+ fallback was a text that `error`ed when read as a path.+- **`apiCall` threw `error`** for an address in the path that the network+ cannot write, such as a SegWit address on Bitcoin Cash. It answers+ `UserError`, as it did for one in the query string. `pathEncodes` is new+ and says whether `queryPath` can be called.+- **`apiBatch` with a size of zero never returned.** Zero is taken for one.+- **The client lost what the server said in an error.**+ - Only the first piece of the body was read, so an error that came in+ two pieces was "could not decode error". The whole body is read, up+ to 64 KiB.+ - An error that the client does not know, from a newer server, is read+ as `StringError` with its name and message, instead of not at all.+ - A message that is not text no longer makes the error unreadable.+ - An answer that is not from the server, such as the page of a proxy,+ is `StringError` with the status and the start of the body.+- **`apiEvents` stopped, as if asked to, at a line it could not read**,+ and the events after it were lost. A newer server that tells of more+ than blocks and transactions would have stopped every client. Such a+ line is left out. A line longer than 64 KiB ends the stream with an+ error, instead of being kept without limit.+- **Numbers of request parameters wrapped around.** `-1`, a number too+ large for its type, hexadecimal and spaces were read, the first two as+ another number: `-1` as the largest. Only decimal digits that fit are+ read now, in `parseBinfoBlockId`, `parseBinfoTxId`, `parseBinfoFilter`+ and the `time`, `height`, `heights`, `limit`, `offset` and start+ parameters.+- A date before 1970 in `parseBinfoDate`, and a time before 1970 in a+ health check, were read as a number near 2^64. They are refused.+- `RawResult`, `RawResultList` and the services of `PeerInfo` took bytes+ after the value and ignored them. They are refused.+- An `address` that is neither null nor an address, in an unspent output,+ an input or an output, was read as no address. It is refused.+- The binary reader of `DeriveType` took any unknown byte for `normal`. It+ fails.+- Differences of unsigned amounts that could wrap now stop at zero:+ `txDataFee`, the fee of `toTransaction`, and `sent` of an address in+ `toBinfoAddrs`.+- `isOK` of `BlockHealth` took the difference of two heights in 32 signed+ bits.+- `Ord BinfoXPubPath` compared only the fingerprint of the parent and the+ path, so two different keys could compare equal while `==` said no.+- A `BlockRef` with neither form says what it expected, not that+ `mempool` is missing.++### Changed+- `apiCall`, `apiBatch` and `apiEvents` answer `Left (StringError …)` when+ the server cannot be reached or the URL cannot be read. They used to+ throw the exception of the HTTP client, which a caller that looked only+ at the `Either` did not expect.++### Not changed+- `BlockData` writes `weight` only on networks with SegWit and reads a+ missing one as zero. A weight on Bitcoin Cash is therefore lost on the+ way; it has no meaning there, and writing it would add a field to the+ API.+ ## [2.0.0] - 2026-11-12 The API speaks JSON only. The binary encoding of the API is gone, from the
haskoin-store-data.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store-data-version: 2.0.0+version: 2.0.1 synopsis: Data types and API client of Haskoin Store description: The types of the data that Haskoin Store serves (blocks, transactions, balances, unspent outputs, extended public keys, health checks, events and@@ -77,6 +77,7 @@ Haskoin.Store.DataSpec Haskoin.Store.Gen Haskoin.Store.Laws+ Haskoin.Store.RobustSpec Haskoin.Store.WebCommonSpec Paths_haskoin_store_data hs-source-dirs:@@ -105,7 +106,7 @@ , http-client >=0.7.19 && <0.8 , http-types >=0.12.6 && <0.13 , lens >=5.3.6 && <5.4- , network >=3.2.12.0 && <3.3+ , network , string-conversions >=0.4.0.1 && <0.5 , text >=2.1.4 && <2.2 , time ==1.14.*
src/Haskoin/Store/Data.hs view
@@ -134,10 +134,10 @@ ) where -import Control.Applicative (optional, (<|>))+import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) import Control.Exception (Exception)-import Control.Monad (guard, join, mzero, when)+import Control.Monad (guard, join, mzero, when, unless) import Data.Aeson ( FromJSON (..), ToJSON (..),@@ -156,7 +156,6 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.Bytes.Get-import Data.Bytes.Get qualified as Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Default (Default (..))@@ -184,6 +183,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T+import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds,@@ -244,7 +244,7 @@ 0x00 -> return DeriveNormal 0x01 -> return DeriveP2SH 0x02 -> return DeriveP2WPKH- _ -> return DeriveNormal+ x -> fail ("Unknown derivation type: " <> show x) instance Binary DeriveType where put = serialize@@ -380,7 +380,8 @@ instance FromJSON BlockRef where parseJSON =- A.withObject "BlockRef" $ \o -> b o <|> m o+ A.withObject "BlockRef" $ \o ->+ b o <|> m o <|> fail "Expected height and position, or mempool" where b o = do height <- o .: "height"@@ -656,7 +657,7 @@ script <- o .: "pkscript" >>= jsonHex address <- o .: "address"- >>= maybe (return Nothing) (optional . unmarshalValue net)+ >>= maybe (return Nothing) (fmap Just . unmarshalValue net) return Unspent {outpoint = OutPoint {..}, ..} -- | Database value for a block entry.@@ -890,7 +891,7 @@ value <- o .: "value" address <- o .: "address"- >>= maybe (return Nothing) (optional . unmarshalValue net)+ >>= maybe (return Nothing) (fmap Just . unmarshalValue net) return StoreInput {..} -- | Parse a hex string in JSON.@@ -981,7 +982,7 @@ spender <- o .: "spender" address <- o .: "address"- >>= maybe (return Nothing) (optional . unmarshalValue net)+ >>= maybe (return Nothing) (fmap Just . unmarshalValue net) return StoreOutput {..} -- | Output spent by an input, as stored with the transaction.@@ -1086,12 +1087,48 @@ put = serialize get = deserialize --- | Fee of a transaction: inputs minus outputs, or zero for a coinbase.+-- | A whole number written in decimal digits and nothing else, if it fits+-- its type. 'Text.Read.readMaybe' also takes a sign, hexadecimal and+-- spaces around, and wraps a number that does not fit: @-1@ read as the+-- largest number of the type.+decimal :: forall a. (Integral a, Bounded a) => Text -> Maybe a+decimal t+ | T.null t || T.length t > 20 || T.any (\c -> c < '0' || c > '9') t = Nothing+ | n > toInteger (maxBound :: a) = Nothing+ | otherwise = Just (fromInteger n)+ where+ n = T.foldl' (\acc c -> acc * 10 + toInteger (fromEnum c - fromEnum '0')) 0 t++-- | The seconds of a time since 1970, if it is not before then and they+-- fit in 64 bits.+unixSeconds :: UTCTime -> Maybe Word64+unixSeconds t+ | s < 0 || s > toInteger (maxBound :: Word64) = Nothing+ | otherwise = Just (fromInteger s)+ where+ s = floor (utcTimeToPOSIXSeconds t) :: Integer++-- | Read one value from all of the bytes: bytes after it are an error.+whole :: (Serial a) => ByteString -> Either String a+whole = runGetS $ do+ x <- deserialize+ end <- isEmpty+ unless end (fail "Bytes after the value")+ return x++-- | A difference that stops at zero. Amounts are unsigned, and one taken+-- from a smaller one would wrap around to a number near 2^64.+minus :: Word64 -> Word64 -> Word64+minus a b = if a >= b then a - b else 0++-- | Fee of a transaction: inputs minus outputs, or zero for a coinbase, and+-- for a transaction whose outputs are worth more than the inputs that the+-- store has for it. txDataFee :: TxData -> Word64 txDataFee t = if isCoinbaseTx t.tx then 0- else inputs - outputs+ else inputs `minus` outputs where inputs = sum $ map (.value) $ IntMap.elems t.prevs outputs = sum $ map (.value) t.tx.outputs@@ -1116,7 +1153,7 @@ fee = if any isCoinbase ins then 0- else inv - outv+ else inv `minus` outv } where -- Serialize once with the witness and once without it, and only once@@ -1279,7 +1316,7 @@ instance ToJSON PeerInfo where toJSON p = A.object- [ "useragent" .= String (T.decodeUtf8 p.userAgent),+ [ "useragent" .= String (T.decodeUtf8Lenient p.userAgent), "address" .= p.address, "version" .= p.version, "services"@@ -1289,7 +1326,7 @@ toEncoding p = A.pairs $ mconcat- [ "useragent" `A.pair` A.text (T.decodeUtf8 p.userAgent),+ [ "useragent" `A.pair` A.text (T.decodeUtf8Lenient p.userAgent), "address" `A.pair` toEncoding p.address, "version" `A.pair` A.int32 p.version, "services" `A.pair` hexEncoding (runPutL $ serialize p.services),@@ -1305,7 +1342,7 @@ version <- o .: "version" services <- o .: "services" >>= jsonHex >>= \b ->- case runGetS deserialize b of+ case whole b of Left e -> fail $ "Could not decode services: " <> e Right s -> return s relay <- o .: "relay"@@ -1470,10 +1507,8 @@ instance Healthy BlockHealth where isOK x =- h - b <= x.max- where- h = fromIntegral x.headers- b = fromIntegral x.blocks+ -- as integers: the difference of two heights does not fit their type+ toInteger x.headers - toInteger x.blocks <= toInteger x.max instance ToJSON BlockHealth where toJSON h =@@ -1648,8 +1683,10 @@ peers <- o .: "peers" network <- o .: "net" version <- o .: "version"- utcTime <- read <$> o .: "time"- let time = round $ utcTimeToPOSIXSeconds utcTime+ -- 'read' would say yes to any text here, and fail with 'error' when+ -- the time is used, after the parser has answered+ utcTime <- o .: "time" >>= \t -> maybe (fail ("Not a time: " <> t)) return (readMaybe t)+ time <- maybe (fail "A time before 1970, or too far ahead") return (unixSeconds utcTime) redis <- o .:? "redis" >>= mapM (.: "ok") return HealthCheck {..} @@ -1842,10 +1879,8 @@ parseJSON = A.withObject "RawResult" $ \o -> do res <- o .: "result"- let m =- eitherToMaybe . Bytes.Get.runGetS deserialize- =<< decodeHex res- maybe mzero (return . RawResult) m+ let m = eitherToMaybe . whole =<< decodeHex res+ maybe (fail "Not the hexadecimal of one value") (return . RawResult) m -- | List response, a JSON array. newtype SerialList a = SerialList {get :: [a]}@@ -1888,10 +1923,10 @@ A.withArray "RawResultList" $ \vec -> RawResultList <$> mapM parseElem (toList vec) where- deser = eitherToMaybe . runGetS deserialize+ deser = eitherToMaybe . whole parseElem = A.withText "RawResultListItem" $ \t ->- maybe mzero return (decodeHex t >>= deser)+ maybe (fail "Not the hexadecimal of one value") return (decodeHex t >>= deser) -- | Hash of a transaction, as returned when posting one, encoded in JSON as -- @{\"txid\": hash}@.@@ -1978,7 +2013,13 @@ parseJSON = A.withObject "Except" $ \o -> do ctr <- o .: "error"- msg' <- o .:? "message" .!= ""+ -- a message that is not text is shown as it is: an error with an+ -- odd message is still that error+ msg' <-+ o .:? "message" >>= \case+ Nothing -> return ""+ Just (String t) -> return (T.unpack t)+ Just other -> return (cs (A.encode other)) case ctr of String "not-found-or-invalid-arg" -> return ThingNotFound@@ -1999,7 +2040,12 @@ return RequestTooLarge String "behind-fleet" -> return BehindFleet- _ -> mzero+ -- an error from a newer server: its name and message are kept,+ -- instead of failing to read the answer at all+ String other ->+ return . StringError $+ T.unpack other <> (if null msg' then "" else ": " <> msg')+ _ -> fail "The error is not named by a text" --------------------------------------- -- Blockchain.info API Compatibility --@@ -2026,7 +2072,7 @@ parseBinfoBlockId :: Text -> Maybe BinfoBlockId parseBinfoBlockId t = (BinfoBlockHash <$> hexToBlockHash t)- <|> (BinfoBlockIndex <$> readMaybe (cs t))+ <|> (BinfoBlockIndex <$> decimal t) -- | Transaction identified by hash or by short number; see 'toIntTxId'. data BinfoTxId@@ -2046,7 +2092,7 @@ parseBinfoTxId :: Text -> Maybe BinfoTxId parseBinfoTxId t = (BinfoTxIdHash <$> hexToTxHash t)- <|> (BinfoTxIdIndex <$> readMaybe (cs t))+ <|> (BinfoTxIdIndex <$> decimal t) instance ToJSON BinfoTxId where toJSON (BinfoTxIdHash h) = toJSON h@@ -2079,7 +2125,7 @@ -- Blockchain.info uses for it. parseBinfoFilter :: Text -> Maybe BinfoFilter parseBinfoFilter t =- readMaybe (cs t) >>= \case+ decimal t >>= \case (0 :: Int) -> Just BinfoFilterAll 1 -> Just BinfoFilterSent 2 -> Just BinfoFilterReceived@@ -2682,7 +2728,7 @@ "size" .= t.size, "weight" .= t.weight, "fee" .= t.fee,- "relayed_by" .= T.decodeUtf8 t.relayed,+ "relayed_by" .= T.decodeUtf8Lenient t.relayed, "lock_time" .= t.locktime, "tx_index" .= t.index, "double_spend" .= t.doubleSpend,@@ -2711,7 +2757,7 @@ "size" `A.pair` A.word32 t.size, "weight" `A.pair` A.word32 t.weight, "fee" `A.pair` A.word64 t.fee,- "relayed_by" `A.pair` A.text (T.decodeUtf8 t.relayed),+ "relayed_by" `A.pair` A.text (T.decodeUtf8Lenient t.relayed), "lock_time" `A.pair` A.word32 t.locktime, "tx_index" `A.pair` toEncoding t.index, "double_spend" `A.pair` A.bool t.doubleSpend,@@ -2923,12 +2969,19 @@ } deriving (Eq, Show, Generic, NFData) +-- | By the fingerprint of the parent and the path first, as it always+-- was, and then by the rest of the key, so that only equal values compare+-- equal. instance Ord BinfoXPubPath where compare = compare `on` f where f b = ( b.key.parent,- b.deriv+ b.deriv,+ b.key.depth,+ b.key.index,+ b.key.chain,+ b.key.key.get ) instance MarshalJSON (Network, Ctx) BinfoXPubPath where@@ -2948,7 +3001,7 @@ unmarshalValue (net, ctx) = A.withObject "BinfoXPubPath" $ \o -> do key <- o .: "m" >>= unmarshalValue (net, ctx)- deriv <- fromMaybe "bad xpub path" . parseSoft <$> o .: "path"+ deriv <- o .: "path" >>= \t -> maybe (fail ("Not a derivation path: " <> t)) return (parseSoft t) return BinfoXPubPath {..} -- | Information about the chain and prices in @\/blockchain\/multiaddr@.@@ -3183,7 +3236,7 @@ -- @dd\/mm\/yyyy@. parseBinfoDate :: Text -> Maybe BinfoDate parseBinfoDate t =- BinfoDate . round . utcTimeToPOSIXSeconds <$> (p "%d-%m-%Y" <|> p "%d/%m/%Y")+ (p "%d-%m-%Y" <|> p "%d/%m/%Y") >>= fmap BinfoDate . unixSeconds where p fmt = parseTimeM False defaultTimeLocale fmt (cs t) @@ -3363,7 +3416,7 @@ xpubBals = map (uncurry xpubBal) $ HashMap.toList onlyXpubs addrBals = let f Balance {..} =- let sent = received - balance+ let sent = received `minus` balance balance = confirmed + unconfirmed in BinfoAddrBalance {..} in map f $ HashMap.elems onlyAddrs
src/Haskoin/Store/WebClient.hs view
@@ -110,7 +110,7 @@ import Haskoin.Store.WebCommon import Haskoin.Transaction import Haskoin.Util-import Network.HTTP.Client (Request (..), RequestBody (..))+import Network.HTTP.Client (HttpException (..), Request (..), RequestBody (..)) import Network.HTTP.Types (StdMethod (..)) import Network.HTTP.Types.Status import Network.Wreq qualified as HTTP@@ -152,7 +152,9 @@ -- > apiCall ctx def $ GetAddrsUnspent addrs def {limit = Just 10} -- -- Only @GET@ and @POST@ endpoints are supported. The result is the error--- that the server answered with, or the response.+-- that the server answered with, or the response. A request that could+-- not be made, or got no answer, is an error too ('Store.StringError' with+-- the reason): no exception of the HTTP client leaves this function. apiCall :: (ApiResource a b) => Ctx ->@@ -162,6 +164,8 @@ apiCall ctx (ApiConfig net apiHost) res = case toOptions net ctx res of Left e -> return (Left e)+ -- as for a parameter of the query string that cannot be written+ Right _ | not (pathEncodes net ctx res) -> return (Left (Store.UserError "Invalid Param")) Right args -> let url = apiHost <> net.name <> cs (queryPath net ctx res) in case resourceMethod $ asProxy res of@@ -177,7 +181,8 @@ -- > apiBatch ctx 20 def (GetAddrsTxs addrs def) -- -- The list is split into chunks of the given size, one call is made per chunk,--- and the results are concatenated. The calls stop at the first error.+-- and the results are concatenated. The calls stop at the first error. A+-- size of zero is taken for one. apiBatch :: (Batchable a b) => Ctx ->@@ -223,7 +228,7 @@ -- | The events of a server, from now or from after one of them. listenEvents :: ApiConfig -> Maybe Store.Event -> (Store.Event -> IO Bool) -> IO (Either Store.Except ()) listenEvents (ApiConfig net apiHost) after handle = do- r <- try (try (HTTP.foldGetWith (jsonOpts mempty) step BS.empty url))+ r <- try (reaching (HTTP.foldGetWith (jsonOpts mempty) step BS.empty url)) return $ case r of Left Stopped -> Right () Right (Left e) -> Left e@@ -235,15 +240,24 @@ -- one event a line; a chunk may end in the middle of one step pending chunk = go (pending <> chunk) go bytes = case BS.elemIndex 10 bytes of- Nothing -> return bytes+ Nothing+ -- an event is a hundred bytes: this is not a stream of events+ | BS.length bytes > maxEventLine -> throwIO (Store.StringError "A line of the events is too long")+ | otherwise -> return bytes Just i -> do let (line, rest) = (BS.take i bytes, BS.drop (i + 1) bytes)- continue <-- if BS.all (`BS.elem` " \r\t") line- then return True- else maybe (return False) handle (A.decodeStrict line)+ -- A line that is not an event this client knows is left out: a+ -- newer server may tell of more than blocks and transactions, and+ -- to stop there would lose the events that follow, without a+ -- word.+ continue <- maybe (return True) handle (A.decodeStrict line) if continue then go rest else throwIO Stopped +-- | The most bytes of a line of @\/events@ that the client keeps while it+-- waits for the end of the line.+maxEventLine :: Int+maxEventLine = 65536+ -- | Thrown inside 'apiEvents' to leave the stream when the caller has -- heard enough. data Stopped = Stopped@@ -332,7 +346,7 @@ String -> IO (Either Store.Except a) getJSON net ctx opts url = do- r <- try (HTTP.getWith (jsonOpts opts) url)+ r <- reaching (HTTP.getWith (jsonOpts opts) url) return (r >>= readResponse net ctx) -- | Make a @POST@ request with a body of text and read the JSON response.@@ -345,9 +359,21 @@ Text -> IO (Either Store.Except a) postJSON net ctx opts url body = do- r <- try (HTTP.postWith (jsonOpts opts) url (Raw "text/plain" (RequestBodyBS (Text.encodeUtf8 body))))+ r <- reaching (HTTP.postWith (jsonOpts opts) url (Raw "text/plain" (RequestBodyBS (Text.encodeUtf8 body)))) return (r >>= readResponse net ctx) +-- | Make a request, and give the error that the server answered with+-- ('checkStatus'), or the reason why there was no answer, as a value. A+-- server that is down, a name that does not resolve and a URL that cannot+-- be read are faults a caller has to expect, as much as an error of the+-- server.+reaching :: IO a -> IO (Either Store.Except a)+reaching act =+ (Right <$> act) `catches` [Handler (return . Left), Handler (return . Left . unreached)]+ where+ unreached (HttpExceptionRequest _ why) = Store.StringError ("Could not reach the server: " <> show why)+ unreached (InvalidUrlException url why) = Store.StringError ("Not a URL: " <> url <> ": " <> why)+ -- | Read a response from the JSON of its body. readResponse :: (ApiResponse a) => Network -> Ctx -> HTTP.Response BSL.ByteString -> Either Store.Except a readResponse net ctx res =@@ -371,16 +397,26 @@ | statusIsSuccessful status = return () | isHealthPath && code == 503 = return () -- Ignore health checks | otherwise = do- body <- res ^. HTTP.responseBody+ -- the whole body, which may come in pieces, up to a size no error+ -- of the server has+ body <- BS.concat <$> pieces (65536 :: Int) throwIO $ case A.decodeStrict body of Just except -> except :: Store.Except- Nothing -> Store.StringError "could not decode error"+ -- not an error of the server: a proxy's page, most likely+ Nothing ->+ Store.StringError $+ "HTTP " <> show code <> ": " <> cs (Text.take 200 (Text.decodeUtf8Lenient body)) where code = res ^. HTTP.responseStatus . HTTP.statusCode message = res ^. HTTP.responseStatus . HTTP.statusMessage status = mkStatus code message isHealthPath = "/health" `Text.isInfixOf` cs (path req)+ pieces left+ | left <= 0 = return []+ | otherwise = do+ piece <- res ^. HTTP.responseBody+ if BS.null piece then return [] else (piece :) <$> pieces (left - BS.length piece) --------------- -- Utilities --@@ -391,4 +427,5 @@ chunksOf n xs | null xs = [] | otherwise =- uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral n) xs+ -- chunks of nothing would never use the list up+ uncurry (:) $ second (chunksOf n) $ splitAt (fromIntegral (max 1 n)) xs
src/Haskoin/Store/WebCommon.hs view
@@ -74,6 +74,7 @@ noMaybeBox, asProxy, queryPath,+ pathEncodes, capturePath, paramLabel, Param (..),@@ -116,7 +117,6 @@ import Haskoin.Util (MarshalJSON (..), encodeHex) import Network.HTTP.Types (StdMethod (..)) import Numeric.Natural (Natural)-import Text.Read (readMaybe) ------------------- -- API Resources --@@ -604,7 +604,18 @@ asProxy :: a -> Proxy a asProxy = const Proxy --- | Path of a request, with its path parameters filled in.+-- | Whether the path parameters of a request can be written for the+-- network: an address of another network cannot. 'queryPath' fails with+-- 'error' when they cannot, so ask this first.+pathEncodes :: (ApiResource a b) => Network -> Ctx -> a -> Bool+pathEncodes net ctx a = all ok (fst (queryParams a))+ where+ ok (ParamBox p) = case encodeParam net ctx p of+ Just [_] -> True+ _ -> False++-- | Path of a request, with its path parameters filled in. Fails with+-- 'error' for a parameter that the network cannot write ('pathEncodes'). queryPath :: (ApiResource a b) => Network -> Ctx -> a -> Text queryPath net ctx a = f $ encParam <$> fst (queryParams a) where@@ -686,15 +697,31 @@ TxHash x <- hexToTxHash s return $ StartParamHash x parseHeight = do- x <- readMaybe $ cs s+ x <- natural s guard $ x <= 1230768000 return $ StartParamHeight x parseUnix = do- x <- readMaybe $ cs s+ x <- bounded s guard $ x > 1230768000 return $ StartParamTime x parseParam _net _ctx _ = Nothing +-- | A whole number written in decimal digits and nothing else.+-- 'Text.Read.readMaybe' also takes hexadecimal and spaces around, and at+-- a type of fixed width a sign and a number that does not fit, which it+-- wraps: @-1@ read as the largest number of the type.+natural :: Text -> Maybe Natural+natural t+ | T.null t || T.length t > 40 || T.any (\c -> c < '0' || c > '9') t = Nothing+ | otherwise = Just (T.foldl' (\acc c -> acc * 10 + fromIntegral (fromEnum c - fromEnum '0')) 0 t)++-- | The same for a type of fixed width: nothing if the number does not fit.+bounded :: forall a. (Integral a, Bounded a) => Text -> Maybe a+bounded t = do+ n <- natural t+ guard (toInteger n <= toInteger (maxBound :: a))+ return (fromIntegral n)+ -- | Number of results to skip (@offset@). newtype OffsetParam = OffsetParam {get :: Natural} deriving (Eq, Show, Read, Enum, Ord, Num, Real, Integral)@@ -705,7 +732,7 @@ instance Param OffsetParam where proxyLabel = const "offset" encodeParam _net _ctx (OffsetParam o) = Just [cs $ show o]- parseParam _net _ctx [s] = OffsetParam <$> readMaybe (cs s)+ parseParam _net _ctx [s] = OffsetParam <$> natural s parseParam _net _ctx _ = Nothing -- | Maximum number of results (@limit@).@@ -715,7 +742,7 @@ instance Param LimitParam where proxyLabel = const "limit" encodeParam _net _ctx (LimitParam l) = Just [cs $ show l]- parseParam _net _ctx [s] = LimitParam <$> readMaybe (cs s)+ parseParam _net _ctx [s] = LimitParam <$> natural s parseParam _net _ctx _ = Nothing -- | Pagination of a list of results.@@ -740,7 +767,7 @@ instance Param HeightParam where proxyLabel = const "height" encodeParam _net _ctx (HeightParam h) = Just [cs $ show h]- parseParam _net _ctx [s] = HeightParam <$> readMaybe (cs s)+ parseParam _net _ctx [s] = HeightParam <$> natural s parseParam _net _ctx _ = Nothing -- | List of block heights (@heights@).@@ -750,7 +777,7 @@ instance Param HeightsParam where proxyLabel = const "heights" encodeParam _net _ctx (HeightsParam hs) = Just $ cs . show <$> hs- parseParam _net _ctx xs = HeightsParam <$> mapM (readMaybe . cs) xs+ parseParam _net _ctx xs = HeightsParam <$> mapM natural xs -- | Unix timestamp in seconds (@time@). newtype TimeParam = TimeParam {get :: Store.UnixTime}@@ -759,7 +786,7 @@ instance Param TimeParam where proxyLabel = const "time" encodeParam _net _ctx (TimeParam t) = Just [cs $ show t]- parseParam _net _ctx [s] = TimeParam <$> readMaybe (cs s)+ parseParam _net _ctx [s] = TimeParam <$> bounded s parseParam _net _ctx _ = Nothing instance Param XPubKey where
test/Haskoin/Store/DataSpec.hs view
@@ -104,6 +104,13 @@ v -> v it "reads what a store wrote before there was a check of Redis" $ do A.fromJSON (without "redis" (A.toJSON bare {redis = Just False})) `shouldBe` A.Success bare+ it "refuses a time that it cannot read, instead of failing when the time is used" $ do+ let badly = \case+ A.Object o -> A.Object (KeyMap.insert "time" (A.String "yesterday") o)+ v -> v+ (A.fromJSON (badly (A.toJSON bare)) :: A.Result HealthCheck) `shouldSatisfy` \case+ A.Error _ -> True+ A.Success _ -> False it "is fit to serve without its Redis, and says that it is without" $ do isOK bare {redis = Just False} `shouldBe` True A.toJSON bare {redis = Just False} `shouldSatisfy` \case
+ test/Haskoin/Store/RobustSpec.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- | What a review of the package found in November 2026, each held here+-- by the input that showed it: values that failed with 'error' after+-- their parser had answered, numbers that wrapped around, a loop, and a+-- client that lost what the server said.+module Haskoin.Store.RobustSpec (spec) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (bracket, evaluate)+import Control.Monad (forM_, void)+import Data.Aeson qualified as A+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types qualified as A+import Data.ByteString qualified as B+import Data.ByteString.Char8 qualified as C+import Data.ByteString.Lazy qualified as BL+import Data.Bytes.Get (runGetS)+import Data.Bytes.Serial (deserialize)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.IntMap qualified as IntMap+import Data.List (isInfixOf, isPrefixOf)+import Data.Maybe (fromJust, isJust)+import Data.Text (Text)+import Haskoin+import Haskoin.Store.Data+import Haskoin.Store.Gen+import Haskoin.Store.WebClient+import Haskoin.Store.WebCommon+import Haskoin.Util.Arbitrary+import Network.Socket qualified as S+import Network.Socket.ByteString qualified as S+import Test.Hspec+import Test.QuickCheck (generate)++-- | Change a field of an object.+with :: A.Key -> A.Value -> A.Value -> A.Value+with k v (A.Object o) = A.Object (KeyMap.insert k v o)+with _ _ other = other++failed :: Either String a -> Bool+failed = either (const True) (const False)++-- | A server that answers one request with these pieces, a moment apart,+-- and closes. The action is given its address.+serving :: [B.ByteString] -> (String -> IO a) -> IO a+serving pieces go =+ bracket open S.close $ \sock -> do+ port <- S.socketPort sock+ void . forkIO $ do+ (conn, _) <- S.accept sock+ void (S.recv conn 65536)+ forM_ pieces $ \piece -> S.sendAll conn piece >> threadDelay 50000+ S.close conn+ go ("http://127.0.0.1:" <> show port <> "/")+ where+ open = do+ sock <- S.socket S.AF_INET S.Stream S.defaultProtocol+ S.setSocketOption sock S.ReuseAddr 1+ S.bind sock (S.SockAddrInet 0 (S.tupleToHostAddress (127, 0, 0, 1)))+ S.listen sock 1+ return sock++-- | The head of a response whose body comes in chunks.+chunked :: B.ByteString -> B.ByteString+chunked status =+ "HTTP/1.1 " <> status <> "\r\nContent-Type: application/json\r\nTransfer-Encoding: chunked\r\n\r\n"++chunk :: B.ByteString -> B.ByteString+chunk bytes = C.pack (hex (B.length bytes)) <> "\r\n" <> bytes <> "\r\n"+ where+ hex n = let (q, r) = n `divMod` 16 in (if q > 0 then hex q else "") <> [("0123456789abcdef" !! r)]++spec :: Spec+spec = prepareContext $ \ctx -> do+ describe "Encoders" $ do+ it "write a peer whose user agent is not UTF-8" $ do+ let peer =+ PeerInfo+ { userAgent = B.pack [0x2f, 0xff, 0xfe, 0x2f],+ address = "10.0.0.1:8333",+ version = 70015,+ services = 1,+ relay = True+ }+ BL.length (A.encode peer) `shouldSatisfy` (> 0)+ BL.length (A.encode (A.toJSON peer)) `shouldSatisfy` (> 0)++ describe "Parsers" $ do+ it "refuse a path of an xpub that is not one, instead of failing later" $ do+ key <- generate (arbitraryXPubKey ctx)+ let good = marshalValue (btc, ctx) BinfoXPubPath {key = key, deriv = Deriv :/ 0 :/ 1}+ parse v = A.parseEither (unmarshalValue (btc, ctx)) v :: Either String BinfoXPubPath+ parse good `shouldSatisfy` (not . failed)+ forM_ ["M/0'/1", "0/1", "nonsense"] $ \path ->+ evaluate (failed (parse (with "path" (A.String path) good))) `shouldReturn` True+ it "read an error that they do not know, and one with an odd message" $ do+ let parse = A.parseEither A.parseJSON :: A.Value -> Either String Except+ parse (A.object ["error" A..= ("rate-limited" :: Text), "message" A..= ("slow down" :: Text)])+ `shouldBe` Right (StringError "rate-limited: slow down")+ parse (A.object ["error" A..= ("user-error" :: Text), "message" A..= (5 :: Int)])+ `shouldBe` Right (UserError "5")+ it "refuse bytes after a raw value" $ do+ tx <- generate (arbitraryTx btc ctx)+ let good = A.toJSON (RawResult tx)+ hex = case good of+ A.Object o | Just (A.String t) <- KeyMap.lookup "result" o -> t+ _ -> error "No result"+ parse v = A.parseEither A.parseJSON v :: Either String (RawResult Tx)+ parse good `shouldBe` Right (RawResult tx)+ parse (with "result" (A.String (hex <> "deadbeef")) good) `shouldSatisfy` failed+ (A.parseEither A.parseJSON (A.toJSON [hex <> "00"]) :: Either String (RawResultList Tx))+ `shouldSatisfy` failed+ it "refuse an address that is not text, instead of reading none" $ do+ unspent <- generate (arbitraryUnspent btc)+ let parse v = A.parseEither (unmarshalValue btc) v :: Either String Unspent+ parse (marshalValue btc unspent) `shouldBe` Right unspent+ parse (with "address" (A.Number 12345) (marshalValue btc unspent)) `shouldSatisfy` failed+ parse (with "address" A.Null (marshalValue btc unspent)) `shouldSatisfy` (not . failed)+ it "refuse a derivation type that they do not know" $+ (runGetS deserialize (B.singleton 9) :: Either String DeriveType) `shouldSatisfy` failed+ it "say what is missing of a place in the chain" $+ (A.parseEither A.parseJSON (A.object ["height" A..= (1 :: Int)]) :: Either String BlockRef)+ `shouldSatisfy` either ("height and position" `isInfixOf`) (const False)++ describe "Numbers" $ do+ it "of parameters are decimal digits that fit, and nothing else" $ do+ parseBinfoBlockId "7" `shouldBe` Just (BinfoBlockIndex 7)+ forM_ ["4294967296", "-1", "0x10", " 7", "7 ", "", "1e3"] $ \t ->+ (t, parseBinfoBlockId t) `shouldBe` (t, Nothing)+ parseBinfoTxId "18446744073709551616" `shouldBe` Nothing+ parseBinfoFilter " 0x6 " `shouldSatisfy` (not . isJust)+ parseBinfoFilter "6" `shouldSatisfy` isJust+ (parseParam btc ctx ["-1"] :: Maybe TimeParam) `shouldBe` Nothing+ (parseParam btc ctx ["18446744073709551616"] :: Maybe TimeParam) `shouldBe` Nothing+ (parseParam btc ctx ["1700000000"] :: Maybe TimeParam) `shouldBe` Just (TimeParam 1700000000)+ (parseParam btc ctx ["-5"] :: Maybe StartParam) `shouldBe` Nothing+ (parseParam btc ctx [" 5"] :: Maybe LimitParam) `shouldBe` Nothing+ (parseParam btc ctx ["0x10"] :: Maybe OffsetParam) `shouldBe` Nothing+ (parseParam btc ctx ["5"] :: Maybe LimitParam) `shouldBe` Just (LimitParam 5)+ it "of a date before 1970 are refused" $ do+ parseBinfoDate "01-01-1960" `shouldBe` Nothing+ parseBinfoDate "01-01-2020" `shouldBe` Just (BinfoDate 1577836800)+ it "do not wrap around when one is taken from a smaller one" $ do+ td <- generate (arbitraryTxData ctx)+ txDataFee td {prevs = IntMap.empty} `shouldBe` 0+ isOK BlockHealth {headers = 3000000000, blocks = 10, max = 2} `shouldBe` False++ describe "Order" $+ it "of xpub paths has no two different ones equal" $ do+ key <- generate (arbitraryXPubKey ctx)+ let a = BinfoXPubPath {key = key, deriv = Deriv :/ 0}+ b = BinfoXPubPath {key = key {index = key.index + 1}, deriv = Deriv :/ 0}+ (a == b, compare a b == EQ) `shouldBe` (False, False)++ describe "Client" $ do+ let nowhere = "http://127.0.0.1:1/"+ segwit = fromJust (textToAddr btc "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t4")+ reason (Left (StringError why)) = why+ reason _ = ""+ it "answers an error for an address that the network cannot write" $+ apiCall ctx (ApiConfig bch nowhere) (GetAddrBalance segwit) `shouldReturn` Left (UserError "Invalid Param")+ it "answers an error, and throws nothing, when there is no server" $ do+ r <- apiCall ctx (ApiConfig btc nowhere) (GetAddrBalance segwit)+ reason r `shouldSatisfy` ("Could not reach the server" `isPrefixOf`)+ e <- apiEvents (ApiConfig btc nowhere) (\_ -> return True)+ reason e `shouldSatisfy` ("Could not reach the server" `isPrefixOf`)+ it "ends a batch of size zero" $ do+ r <- apiBatch ctx 0 (ApiConfig btc nowhere) (GetTxs [TxHash (sha256 ("a" :: B.ByteString))])+ reason r `shouldSatisfy` ("Could not reach the server" `isPrefixOf`)+ it "reads an error that comes in pieces" $ do+ let body = BL.toStrict (A.encode ThingNotFound)+ (one, two) = B.splitAt 10 body+ r <- serving [chunked "404 Not Found", chunk one, chunk two, "0\r\n\r\n"] $ \host ->+ apiCall ctx (ApiConfig btc host) (GetAddrBalance segwit)+ r `shouldBe` Left ThingNotFound+ it "says the status and the start of an answer that is not from the server" $ do+ let page = "<html>Bad Gateway</html>"+ answer =+ "HTTP/1.1 502 Bad Gateway\r\nContent-Length: "+ <> C.pack (show (B.length page))+ <> "\r\n\r\n"+ <> page+ r <- serving [answer] $ \host -> apiCall ctx (ApiConfig btc host) (GetAddrBalance segwit)+ r `shouldBe` Left (StringError "HTTP 502: <html>Bad Gateway</html>")+ it "goes on after a line of events that it does not know" $ do+ let one = TxHash (sha256 ("one" :: B.ByteString))+ two = TxHash (sha256 ("two" :: B.ByteString))+ line e = BL.toStrict (A.encode e) <> "\n"+ (start, end) = B.splitAt 20 (line (EventTx two))+ heard <- newIORef []+ r <- serving+ [ chunked "200 OK",+ chunk (line (EventTx one) <> "{\"type\":\"reorg\",\"id\":\"00\"}\n" <> start),+ chunk end,+ "0\r\n\r\n"+ ]+ $ \host -> apiEvents (ApiConfig btc host) (\e -> modifyIORef' heard (<> [e]) >> return True)+ r `shouldBe` Right ()+ readIORef heard `shouldReturn` [EventTx one, EventTx two]