时间戳

首页 > 解决方案 > Haskell Servant（客户端）：由于奇怪的 Accept 标头导致 UnsupportedContentType 错误

haskell - Haskell Servant（客户端）：由于奇怪的 Accept 标头导致 UnsupportedContentType 错误

问题描述

我正在尝试编写一个 HTTP 客户端来使用 Servant 查询 Hackage 并获取json数据。但是，当我尝试查询类似端点/user/alf（这只是一个伪随机现有用户名，我也尝试过不同的端点/packages/）时，我收到 UnsupportedContentType 错误。

我已经使用 wireshark 来调查和比较来自我的代码和这个 cURL 命令的请求：

$ curl -H "Accept: application/json" http://hackage.haskell.org/user/alf

两者都导致200 OK但 cURLjson按预期返回数据，而仆人得到html导致错误。

事实上，问题的根源似乎是Accept我的仆人代码产生的标题： "Accept: application/json;charset=utf-8,application/json"，但我不知道为什么会这样......

下面是我的代码和运行它的结果：

import Data.Aeson
         (FromJSON(..))
import Data.Proxy
         (Proxy(..))
import GHC.Generics
         (Generic)
import Network.HTTP.Client
         (newManager, defaultManagerSettings)
import Servant.API
         (Capture, Get, JSON, (:>))
import Servant.Client
         (BaseUrl(..), ClientM, Scheme( Http ),
          client, mkClientEnv, runClientM)

data UserDetailed = UserDetailed
  { username :: String
  , userid   :: Int
  , groups   :: [String]
  } deriving (Eq, Show, Generic)

instance FromJSON UserDetailed

type API =
  "user" :> Capture "username" String :> Get '[JSON] UserDetailed

api :: Proxy API
api = Proxy

getUser :: String -> ClientM UserDetailed
getUser = client api

main :: IO ()
main = do
  manager <- newManager defaultManagerSettings
  let userName = "alf"
  let url = BaseUrl Http "hackage.haskell.org" 80 ""
  res <- runClientM (getUser userName) (mkClientEnv manager url)
  case res of
    Left err -> putStrLn $ "Error: " ++ show err
    Right user -> putStrLn $
        userName ++ " maintains " ++ (show $ length $ groups user) ++ " packages"

以及错误信息（省略了大部分 html 内容）：

Error: UnsupportedContentType text/html;charset=utf-8 (Response {responseStatusCode = Status {statusCode = 200, statusMessage = "OK"}, responseHeader
s = fromList [("Server","nginx/1.14.0 (Ubuntu)"),("Content-Type","text/html; charset=utf-8"),("Content-Encoding","gzip"),("Transfer-Encoding","chunke
d"),("Accept-Ranges","bytes"),("Date","Sun, 21 Jul 2019 13:31:41 GMT"),("Via","1.1 varnish"),("Connection","keep-alive"),("X-Served-By","cache-hhn403
3-HHN"),("X-Cache","MISS"),("X-Cache-Hits","0"),("X-Timer","S1563715901.934337,VS0,VE626"),("Vary","Accept, Accept-Encoding")], responseHttpVersion =
 HTTP/1.1, responseBody = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
...
</html>"})

在Servant中执行此操作并返回的正确方法是什么json？知道是什么导致了这些奇怪的标题吗？

编辑：

找到了一种使用以下而不是解决此问题的方法defaultManagerSettings：

defaultManagerSettings {
  managerModifyRequest = \req -> return $
    req { requestHeaders = ("Accept", "application/json") :
          filter (("Accept" /=) . fst) (requestHeaders req) }
  }

这将直接替换Accept标题。它有效，但似乎仍然不是应该这样做的。

标签： haskellhttp-headersclientservant

解决方案

哇，真不幸。我敢说hackage在这方面被打破了。您（仆人对 JSON 的含义）没有将 HTML 列为有效类型，但由于字符集，hackage 还是将它给了您。这是 Hackage 的错，不是 Servants 的错——我希望你能举报。

至于你的问题，你如何让仆人只列出application/json而不是字符集作为 mime 类型，而不进行会破坏其他端点的连接范围设置。这可以通过像 JSON 一样定义您自己的类型并为 MimeUnrender、Accept 等提供实现来解决。

忽略导入和语言扩展的具体细节是：

data RealJSON
-- | @application/json@
instance Accept RealJSON where
    contentTypes _ =
      [ "application" // "json" ]
instance FromJSON a => MimeUnrender RealJSON a where
    mimeUnrender _ = eitherDecodeLenient

eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
eitherDecodeLenient input =
    parseOnly parser (cs input) >>= parseEither parseJSON
  where
    parser = skipSpace
          *> Data.Aeson.Parser.value
          <* skipSpace
          <* (endOfInput <?> "trailing junk after valid JSON")

完整的程序是：

#! /usr/bin/env cabal
{- cabal:
build-depends:
    base, aeson, attoparsec, bytestring,
    http-client, http-media,
    servant-client >= 0.16, servant >= 0.16.1,
    string-conversions
-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import qualified Data.Aeson.Parser
import           Data.Aeson (FromJSON(..))
import           Data.Aeson.Types (parseEither)
import           Data.Attoparsec.ByteString.Char8
                    (endOfInput, parseOnly, skipSpace, (<?>))
import           Data.ByteString.Lazy (ByteString)
import           Data.Proxy (Proxy(..))
import           Data.String.Conversions (cs)
import           GHC.Generics (Generic)
import           Network.HTTP.Client (newManager, defaultManagerSettings)
import           Network.HTTP.Media ((//))
import           Servant.API (Capture, Get, JSON, (:>), Accept(..))
import           Servant.API.ContentTypes (MimeUnrender(..))
import           Servant.Client (BaseUrl(..), ClientM, Scheme( Http ),
                                 client, mkClientEnv, runClientM)

data RealJSON
-- | @application/json@
instance Accept RealJSON where
    contentTypes _ =
      [ "application" // "json" ]
instance FromJSON a => MimeUnrender RealJSON a where
    mimeUnrender _ = eitherDecodeLenient

eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
eitherDecodeLenient input =
    parseOnly parser (cs input) >>= parseEither parseJSON
  where
    parser = skipSpace
          *> Data.Aeson.Parser.value
          <* skipSpace
          <* (endOfInput <?> "trailing junk after valid JSON")

data UserDetailed = UserDetailed
  { username :: String
  , userid   :: Int
  , groups   :: [String]
  } deriving (Eq, Show, Generic)

instance FromJSON UserDetailed

type API =
  "user" :> Capture "username" String :> Get '[RealJSON] UserDetailed

api :: Proxy API
api = Proxy

getUser :: String -> ClientM UserDetailed
getUser = client api

main :: IO ()
main = do
  manager <- newManager defaultManagerSettings
  let userName = "ThomasDuBuisson"
  let url = BaseUrl Http "hackage.haskell.org" 80 ""
  res <- runClientM (getUser userName) (mkClientEnv manager url)
  case res of
    Left err -> putStrLn $ "Error: " ++ show err
    Right user -> putStrLn $
        userName ++ " \"maintains\" " ++ (show $ length $ groups user) ++ " packages"

推荐阅读