Haskell Servant：如何处理无效的 Accept 标头（或完全忽略它）

Question

我正在编写一个 webhook 端点（接收端）并且实际上无法控制请求中传入的 Accept 标头。它是这样的：

Accept: text/html, image/gif, image/jpeg, *; q=.2, */*; q=.2

我试过 Post '[JSON, HTML, PlainText] Text 但它导致了 406 状态代码。

IIUC，由于*（可能应该是*/*）和q=.2（可能应该是q=0.2），Servant 无法将其解析为有效的Accept 标头

我该如何处理？现实情况是我不关心 Accept 标头，webhook 发送者也不真正关心响应主体（只有响应代码很重要）

我发现 Network.HTTP.Media.Accept.Accept 有 parseAccept :: ByteString -> Maybe a，我试过这样使用...

data IrrelevantAcceptHeader = IrrelevantAcceptHeader deriving (Show)

instance Network.HTTP.Media.Accept.Accept IrrelevantAcceptHeader where
  parseAccept _ = Just IrrelevantAcceptHeader
  matches _ _ = True
  moreSpecificThan _ _ = False
  hasExtensionParameters _ = True

instance Servant.Accept IrrelevantAcceptHeader where
  contentType _ = fromString "text/html, image/gif, image/jpeg, *; q=.2, */*; q=.2"

instance MimeRender IrrelevantAcceptHeader Text where
  mimeRender _ txt = toS txt

-- and here's how it's used:

data Routes route = Routes
  { rWebhook 
    :: route 
    :- "webhook" 
    :> Header' '[Required, Strict] "X-Api-Secret" Text 
    :> ReqBody '[JSON] Aeson.Value 
    :> Post '[IrrelevantAcceptHeader] Text
  } deriving (Generic)

......但是所有这些杂耍并不真正奏效！

PS：这可能与Haskell Servant (client): UnsupportedContentType error due to weird Accept header有关

Answer 1

您可以考虑编写一个 Middleware 来修复损坏的 Accept 标头，然后再将其传递给 servant。这会影响所有路线，但这可能就是您想要的。

它看起来像：

import Network.Wai
import Network.HTTP.Types.Header

fixAccept :: Middleware
fixAccept app req
  = app (req { requestHeaders = map fixAcceptHeader (requestHeaders req) })
  where fixAcceptHeader (key, value) 
          | key == hAccept = (hAccept, value)  -- do something to "value" here
        fixAcceptHeader other = other

当你运行你的 Servant 服务器时，只需将它包装在中间件中：

main :: IO ()
main = run 8080 (fixAccept app1)

如果您想检查您的中间件是否需要修复标头，请注意 Servant 使用 http-media 包中的 Network.HTTP.Media 中的 matchAccept，后者又使用 parseQuality 进行匹配。如果 parseQuality 成功或失败，您可以检查中间件：

λ> :set -XOverloadedStrings
λ> import Data.ByteString
λ> import Network.HTTP.Media
λ> parseQuality "Accept: text/html, image/gif, image/jpeg, *; q=.2, */*; q=.2" :: Maybe [Quality ByteString]
Nothing
λ> parseQuality "Accept: text/html, image/gif, image/jpeg, *; q=0.2, */*; q=0.2" :: Maybe [Quality ByteString]
Just [Accept: text/html;q=1,image/gif;q=1,image/jpeg;q=1,*;q=0.2,*/*;q=0.2]

如上所述，似乎是无效的质量数字导致了问题。

这似乎是一个known issue，不幸的是，开发人员拒绝修复。幸运的是，http-media 是具有宽松许可证的开源软件，因此您可以自由地自行修补它以供自己使用或重新分发。