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