diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/haskoin-store-data.cabal b/haskoin-store-data.cabal --- a/haskoin-store-data.cabal +++ b/haskoin-store-data.cabal @@ -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.* diff --git a/src/Haskoin/Store/Data.hs b/src/Haskoin/Store/Data.hs --- a/src/Haskoin/Store/Data.hs +++ b/src/Haskoin/Store/Data.hs @@ -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 diff --git a/src/Haskoin/Store/WebClient.hs b/src/Haskoin/Store/WebClient.hs --- a/src/Haskoin/Store/WebClient.hs +++ b/src/Haskoin/Store/WebClient.hs @@ -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 diff --git a/src/Haskoin/Store/WebCommon.hs b/src/Haskoin/Store/WebCommon.hs --- a/src/Haskoin/Store/WebCommon.hs +++ b/src/Haskoin/Store/WebCommon.hs @@ -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 diff --git a/test/Haskoin/Store/DataSpec.hs b/test/Haskoin/Store/DataSpec.hs --- a/test/Haskoin/Store/DataSpec.hs +++ b/test/Haskoin/Store/DataSpec.hs @@ -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 diff --git a/test/Haskoin/Store/RobustSpec.hs b/test/Haskoin/Store/RobustSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/RobustSpec.hs @@ -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 = "Bad Gateway" + 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: Bad Gateway") + 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]