Haskell Servant: How to deal with invalid Accept header (or ignore it completely)

I'm writing a webhook endpoint (receiving end) and don't really have control over the incoming Accept header in the request. Here's what it is:

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

I've tried Post '[JSON, HTML, PlainText] Text but it results in a 406 status code.

IIUC, Servant is unable to parse this as a valid Accept header due to the * (which should probably be */*) and the q=.2 (which should probably be q=0.2

How do I deal with this? The realistic situation is that I don't care about the Accept header, and the webhook sender doesn't really care about the response body (only the response code matters)

I found Network.HTTP.Media.Accept.Accept which has parseAccept :: ByteString -> Maybe a, which I tried using like this...

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)

...but all this jugglery doesn't really work!

PS: This might be related to Haskell Servant (client): UnsupportedContentType error due to weird Accept header

Solution

You could consider writing a Middleware to fix up the broken Accept header before it's passed to servant. This would affect all routes, but that's probably what you want anyway.

It would look something like:

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

and when you run your Servant server, just wrap it in the middleware:

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

If you want to check in your Middleware whether or not a header fix is necessary, note that Servant uses matchAccept from Network.HTTP.Media in the http-media package which in turn uses parseQuality to do the matching. You can check in the middleware if parseQuality succeeds or fails:

λ> :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]

As above, it appears to be the invalid quality numbers specifically that are causing problems.

This seems to be a known issue that, unfortunately, the developers are refusing to fix. Fortunately, http-media is open source with a permissive license, so you are free to patch it yourself for your own use or for redistribution.