我正在尝试编写一个 HTTP 客户端来使用 Servant 查询 Hackage 并获取 json 数据。但是，当我尝试查询像 /user/alf 这样的端点(这只是一个伪随机的现有用户名，我也尝试了不同的端点，例如 /packages/)我收到 UnsupportedContentType 错误。
我使用wireshark 来调查和比较来 self 的代码和此cURL 命令的请求:
$ curl -H "Accept: application/json" http://hackage.haskell.org/user/alf
两者都会导致 200 OK，但 cURL 按预期返回 json 数据，而servant 获取 html 导致错误。
事实上，问题的根源似乎是我的仆人代码生成的 Accept header :
“接受: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 header 。它有效，但似乎仍然不是它应该如何完成的。
最佳答案
哇，真不幸。我敢说 hackage 在这方面已经被打破了。您(JSON 的仆人含义)没有将 HTML 列为有效类型，但 hackage 还是因为字符集而将其提供给了您。这是 Hackage 的错，而不是 Servants 的错 - 我希望你能举报。
至于你的问题，如何让servant仅列出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"
关于Haskell 仆人(客户端): UnsupportedContentType error due to weird Accept header，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/57134030/