Haskell Servant (client): UnsupportedContentType error due to weird Accept header

Question

I am trying to write an HTTP client to query Hackage using Servant and get json data. However when I try to query an endpoint like /user/alf (that is just a pseudo-random existing user name, I have tried different endpoints like /packages/ too) I get an UnsupportedContentType error.

I have used wireshark to investigate and compared requests from my code and from this cURL command:

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

Both result in 200 OK but cURL returns json data as expected, while servant gets html which causes the error.

In fact the root of the problem seem to be the Accept headers that my servant code produces: "Accept: application/json;charset=utf-8,application/json", but I have no idea why it does that...

Below is my code and the result of running it:

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"

And the error message (omitted most of the html content):

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>"})

What is the proper way to do this in Servant and get json back? Any idea what causes those weird headers?

Edit:

Found a way to work around this using following instead of defaultManagerSettings:

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

which will straight up replace the Accept header. It works, but still seems like that is not how it is supposed to be done.

Thomas M. DuBuisson Thomas M. DuBuisson · Accepted Answer · 2019-07-21T19:46:05

Wow, that's unfortunate. I dare say hackage is broken in this regard. You (servant's meaning of JSON) did not list HTML as a valid type yet hackage gave it to you anyway because of a charset. This is Hackage's fault and not Servants - I hope you will report it.

As to your question, how do you get servant to list only application/json and not the charset as the mime type without making a connection wide setting that will break other endpoints. This is solvable by defining your own type much like JSON and giving implementations for MimeUnrender, Accept, etc.

The nuts and bolts, ignoring imports and language extensions, are:

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")

The full program is:

#! /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 Servant (client): UnsupportedContentType error due to weird Accept header

1 Answers