Merge pull request #670 from phadej/pull-649

Throw error on param parse failure.

servant-server/CHANGELOG.md

@@ -3,6 +3,10 @@
 
 * Add `err422` Unprocessable Entity
   ([#646](https://github.com/haskell-servant/servant/pull/646))
+* Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400
+  when parsing fails
+  ([#649](6e77453b67dc164e5381fb867e5e6475302619a3))
+* Added `paramD` block to `Delayed`
 
 * `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`.
   ([#641](https://github.com/haskell-servant/servant/issues/641))

servant-server/src/Servant/Server/Internal.hs

@@ -29,8 +29,10 @@ import qualified Data.ByteString            as B
 import qualified Data.ByteString.Char8      as BC8
 import qualified Data.ByteString.Lazy       as BL
 import           Data.Maybe                 (fromMaybe, mapMaybe)
+import           Data.Either                (partitionEithers)
 import           Data.String                (fromString)
 import           Data.String.Conversions    (cs, (<>))
+import qualified Data.Text                  as T
 import           Data.Typeable
 import           GHC.TypeLits               (KnownNat, KnownSymbol, natVal,
                                              symbolVal)
@@ -45,7 +47,7 @@ import           Network.Wai                (Application, Request, Response,
 import           Prelude                    ()
 import           Prelude.Compat
 import           Web.HttpApiData            (FromHttpApiData, parseHeaderMaybe,
-                                             parseQueryParamMaybe,
+                                             parseQueryParam,
                                              parseUrlPieceMaybe,
                                              parseUrlPieces)
 import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture,
@@ -311,14 +313,22 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
     Maybe a -> ServerT api m
 
   route Proxy context subserver =
-    let querytext r = parseQueryText $ rawQueryString r
+    let querytext req = parseQueryText $ rawQueryString req
-        param r =
+        parseParam req =
-          case lookup paramname (querytext r) of
+          case lookup paramname (querytext req) of
-            Nothing       -> Nothing -- param absent from the query string
+            Nothing       -> return Nothing -- param absent from the query string
-            Just Nothing  -> Nothing -- param present with no value -> Nothing
+            Just Nothing  -> return Nothing -- param present with no value -> Nothing
-            Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
+            Just (Just v) ->
-                                        -- the right type
+              case parseQueryParam v of
-    in route (Proxy :: Proxy api) context (passToServer subserver param)
+                  Left e -> delayedFailFatal err400
+                      { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e
+                      }
+
+                  Right param -> return $ Just param
+        delayed = addParameterCheck subserver . withRequest $ \req ->
+                    parseParam req
+
+    in route (Proxy :: Proxy api) context delayed
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -346,18 +356,25 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
   type ServerT (QueryParams sym a :> api) m =
     [a] -> ServerT api m
 
-  route Proxy context subserver =
+  route Proxy context subserver = route (Proxy :: Proxy api) context $
-    let querytext r = parseQueryText $ rawQueryString r
+      subserver `addParameterCheck` withRequest paramsCheck
-        -- if sym is "foo", we look for query string parameters
+    where
-        -- named "foo" or "foo[]" and call parseQueryParam on the
+      paramname = cs $ symbolVal (Proxy :: Proxy sym)
-        -- corresponding values
+      paramsCheck req =
-        parameters r = filter looksLikeParam (querytext r)
+          case partitionEithers $ fmap parseQueryParam params of
-        values r = mapMaybe (convert . snd) (parameters r)
+              ([], parsed) -> return parsed
-    in  route (Proxy :: Proxy api) context (passToServer subserver values)
+              (errs, _)    -> delayedFailFatal err400
-    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+                  { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs
-          looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
+                  }
-          convert Nothing = Nothing
+        where
-          convert (Just v) = parseQueryParamMaybe v
+          params :: [T.Text]
+          params = mapMaybe snd
+                 . filter (looksLikeParam . fst)
+                 . parseQueryText
+                 . rawQueryString
+                 $ req
+
+          looksLikeParam name = name == paramname || name == (paramname <> "[]")
 
 -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
@@ -439,22 +456,28 @@ instance ( AllCTUnrender list a, HasServer api context
   type ServerT (ReqBody list a :> api) m =
     a -> ServerT api m
 
-  route Proxy context subserver =
+  route Proxy context subserver
-    route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
+      = route (Proxy :: Proxy api) context $
+          addBodyCheck subserver ctCheck bodyCheck
     where
-      bodyCheck = withRequest $ \ request -> do
+      -- Content-Type check, we only lookup we can try to parse the request body
+      ctCheck = withRequest $ \ request -> do
         -- See HTTP RFC 2616, section 7.2.1
         -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
         -- See also "W3C Internet Media Type registration, consistency of use"
         -- http://www.w3.org/2001/tag/2002/0129-mime
         let contentTypeH = fromMaybe "application/octet-stream"
                          $ lookup hContentType $ requestHeaders request
-        mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
+        case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
-               <$> liftIO (lazyRequestBody request)
+          Nothing -> delayedFailFatal err415
+          Just f  -> return f
+
+      -- Body check, we get a body parsing functions as the first argument.
+      bodyCheck f = withRequest $ \ request -> do
+        mrqbody <- f <$> liftIO (lazyRequestBody request)
         case mrqbody of
-          Nothing        -> delayedFailFatal err415
+          Left e  -> delayedFailFatal err400 { errBody = cs e }
-          Just (Left e)  -> delayedFailFatal err400 { errBody = cs e }
+          Right v -> return v
-          Just (Right v) -> return v
 
 -- | Make sure the incoming request starts with @"/path"@, strip it and
 -- pass the rest of the request path to @api@.

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -132,14 +132,14 @@ toApplication ra request respond = ra request routingRespond
 -- 405 (bad method)
 -- 401 (unauthorized)
 -- 415 (unsupported media type)
--- 400 (bad request)
 -- 406 (not acceptable)
+-- 400 (bad request)
 -- @
 --
 -- Therefore, while routing, we delay most checks so that they
 -- will ultimately occur in the right order.
 --
--- A 'Delayed' contains three delayed blocks of tests, and
+-- A 'Delayed' contains many delayed blocks of tests, and
 -- the actual handler:
 --
 -- 1. Delayed captures. These can actually cause 404, and
@@ -152,23 +152,36 @@ toApplication ra request respond = ra request routingRespond
 -- it does not provide an input for the handler. Method checks
 -- are comparatively cheap.
 --
--- 3. Body and accept header checks. The request body check can
+-- 3. Authentication checks. This can cause 401.
--- cause both 400 and 415. This provides an input to the handler.
+--
--- The accept header check can be performed as the final
+-- 4. Accept and content type header checks. These checks
--- computation in this block. It can cause a 406.
+-- can cause 415 and 406 errors.
+--
+-- 5. Query parameter checks. They require parsing and can cause 400 if the
+-- parsing fails. Query parameter checks provide inputs to the handler
+--
+-- 6. Body check. The request body check can cause 400.
 --
 data Delayed env c where
   Delayed :: { capturesD :: env -> DelayedIO captures
              , methodD   :: DelayedIO ()
              , authD     :: DelayedIO auth
-             , bodyD     :: DelayedIO body
+             , acceptD   :: DelayedIO ()
-             , serverD   :: captures -> auth -> body -> Request -> RouteResult c
+             , contentD  :: DelayedIO contentType
+             , paramsD   :: DelayedIO params
+             , bodyD     :: contentType -> DelayedIO body
+             , serverD   :: captures
+                         -> params
+                         -> auth
+                         -> body
+                         -> Request
+                         -> RouteResult c
              } -> Delayed env c
 
 instance Functor (Delayed env) where
   fmap f Delayed{..} =
     Delayed
-      { serverD = \ c a b req -> f <$> serverD c a b req
+      { serverD = \ c p a b req -> f <$> serverD c p a b req
       , ..
       } -- Note [Existential Record Update]
 
@@ -200,7 +213,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
 -- | A 'Delayed' without any stored checks.
 emptyDelayed :: RouteResult a -> Delayed env a
 emptyDelayed result =
-  Delayed (const r) r r r (\ _ _ _ _ -> result)
+  Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)
   where
     r = return ()
 
@@ -225,10 +238,21 @@ addCapture :: Delayed env (a -> b)
 addCapture Delayed{..} new =
   Delayed
     { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
-    , serverD   = \ (x, v) a b req -> ($ v) <$> serverD x a b req
+    , serverD   = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req
     , ..
     } -- Note [Existential Record Update]
 
+-- | Add a parameter check to the end of the params block
+addParameterCheck :: Delayed env (a -> b)
+                  -> DelayedIO a
+                  -> Delayed env b
+addParameterCheck Delayed {..} new =
+  Delayed
+    { paramsD = (,) <$> paramsD <*> new
+    , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req
+    , ..
+    }
+
 -- | Add a method check to the end of the method block.
 addMethodCheck :: Delayed env a
                -> DelayedIO ()
@@ -246,24 +270,29 @@ addAuthCheck :: Delayed env (a -> b)
 addAuthCheck Delayed{..} new =
   Delayed
     { authD   = (,) <$> authD <*> new
-    , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
+    , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req
     , ..
     } -- Note [Existential Record Update]
 
--- | Add a body check to the end of the body block.
+-- | Add a content type and body checks around parameter checks.
+--
+-- We'll report failed content type check (415), before trying to parse
+-- query parameters (400). Which, in turn, happens before request body parsing.
 addBodyCheck :: Delayed env (a -> b)
-             -> DelayedIO a
+             -> DelayedIO c         -- ^ content type check
+             -> (c -> DelayedIO a)  -- ^ body check
              -> Delayed env b
-addBodyCheck Delayed{..} new =
+addBodyCheck Delayed{..} newContentD newBodyD =
   Delayed
-    { bodyD    = (,) <$> bodyD <*> new
+    { contentD = (,) <$> contentD <*> newContentD
-    , serverD  = \ c a (z, v) req -> ($ v) <$> serverD c a z req
+    , bodyD    = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
+    , serverD  = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
     , ..
     } -- Note [Existential Record Update]
 
 
--- | Add an accept header check to the beginning of the body
+-- | Add an accept header check before handling parameters.
--- block. There is a tradeoff here. In principle, we'd like
+-- In principle, we'd like
 -- to take a bad body (400) response take precedence over a
 -- failed accept check (406). BUT to allow streaming the body,
 -- we cannot run the body check and then still backtrack.
@@ -277,7 +306,7 @@ addAcceptCheck :: Delayed env a
                -> Delayed env a
 addAcceptCheck Delayed{..} new =
   Delayed
-    { bodyD = new *> bodyD
+    { acceptD = acceptD *> new
     , ..
     } -- Note [Existential Record Update]
 
@@ -287,7 +316,7 @@ addAcceptCheck Delayed{..} new =
 passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
 passToServer Delayed{..} x =
   Delayed
-    { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
+    { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req
     , ..
     } -- Note [Existential Record Update]
 
@@ -301,16 +330,16 @@ runDelayed :: Delayed env a
            -> env
            -> Request
            -> ResourceT IO (RouteResult a)
-runDelayed Delayed{..} env req  =
+runDelayed Delayed{..} env = runDelayedIO $ do
-  runDelayedIO
+    r <- ask
-    (do c <- capturesD env
+    c <- capturesD env
-        methodD
+    methodD
-        a <- authD
+    a <- authD
-        b <- bodyD
+    acceptD
-        r <- ask
+    content <- contentD
-        liftRouteResult (serverD c a b r)
+    p <- paramsD       -- Has to be before body parsing, but after content-type checks
-    )
+    b <- bodyD content
-    req
+    liftRouteResult (serverD c p a b r)
 
 -- | Runs a delayed server and the resulting action.
 -- Takes a continuation that lets us send a response.

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -6,9 +6,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
 
+import           Control.Monad              (when)
 import           Data.Aeson                 (encode)
 import qualified Data.ByteString.Char8      as BC
 import qualified Data.ByteString.Lazy.Char8 as BCL
+import           Data.Monoid                ((<>))
 import           Data.Proxy
 import           Network.HTTP.Types         (hAccept, hAuthorization,
                                              hContentType, methodGet,
@@ -44,13 +46,14 @@ type ErrorOrderApi = "home"
                   :> BasicAuth "error-realm" ()
                   :> ReqBody '[JSON] Int
                   :> Capture "t" Int
+                  :> QueryParam "param" Int
                   :> Post '[JSON] Int
 
 errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ _ -> throwError err402
+errorOrderServer = \_ _ _ _ -> throwError err402
 
 -- On error priorities:
 --
@@ -85,7 +88,8 @@ errorOrderSpec =
       goodContentType = (hContentType, "application/json")
       goodAccept      = (hAccept, "application/json")
       goodMethod      = methodPost
-      goodUrl         = "home/2"
+      goodUrl         = "home/2?param=55"
+      badParams       = goodUrl <> "?param=foo"
       goodBody        = encode (5 :: Int)
       -- username:password = servant:server
       goodAuth        = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
@@ -95,24 +99,35 @@ errorOrderSpec =
       `shouldRespondWith` 404
 
   it "has 405 as its second highest priority error" $ do
-    request badMethod goodUrl [badAuth, badContentType, badAccept] badBody
+    request badMethod badParams [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 405
 
   it "has 401 as its third highest priority error (auth)" $ do
-    request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
+    request goodMethod badParams [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 401
 
   it "has 406 as its fourth highest priority error" $ do
-    request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
+    request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 406
 
   it "has 415 as its fifth highest priority error" $ do
-    request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody
+    request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
       `shouldRespondWith` 415
 
   it "has 400 as its sixth highest priority error" $ do
-    request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
+    badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
-      `shouldRespondWith` 400
+    badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
+
+    -- Both bad body and bad params result in 400
+    return badParamsRes `shouldRespondWith` 400
+    return badBodyRes `shouldRespondWith` 400
+
+    -- Param check should occur before body checks
+    both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
+    when (both /= badParamsRes) $ liftIO $
+        expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
+    when (both == badBodyRes) $ liftIO $
+        expectationFailure $ "badParams + badBody == badBody: " ++ show both
 
   it "has handler-level errors as last priority" $ do
     request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
@@ -221,7 +236,6 @@ errorRetrySpec =
         then Nothing
         else Just "body not correct\n"
 
-
 -- }}}
 ------------------------------------------------------------------------------
 -- * Error Choice {{{

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

@@ -19,6 +19,7 @@ import Data.Proxy
 import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
 import Servant
 import Servant.Server.Internal.RoutingApplication
+import Network.Wai (defaultRequest)
 import Test.Hspec
 import Test.Hspec.Wai (request, shouldRespondWith, with)
 
@@ -56,20 +57,23 @@ freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
 
 delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
 delayed body srv = Delayed
-  { capturesD = \_ -> return ()
+  { capturesD = \() -> return ()
   , methodD   = return ()
   , authD     = return ()
-  , bodyD     = do
+  , acceptD   = return ()
-      liftIO (writeTestResource"hia" >> putStrLn "garbage created")
+  , contentD  = return ()
+  , paramsD   = return ()
+  , bodyD     = \() -> do
+      liftIO (writeTestResource "hia" >> putStrLn "garbage created")
       _ <- register (freeTestResource >> putStrLn "garbage collected")
       body
-  , serverD   = \() () _body _req -> srv
+  , serverD   = \() () () _body _req -> srv
   }
 
 simpleRun :: Delayed () (Handler ())
           -> IO ()
 simpleRun d = fmap (either ignoreE id) . try $
-  runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500)
+  runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
 
   where ignoreE :: SomeException -> ()
         ignoreE = const ()
@@ -84,10 +88,10 @@ data Res (sym :: Symbol)
 instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
     type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
     route Proxy ctx server = route (Proxy :: Proxy api) ctx $
-        server `addBodyCheck` check
+        addBodyCheck server (return ()) check
       where
         sym  = symbolVal (Proxy :: Proxy sym)
-        check = do
+        check () = do
             liftIO $ writeTestResource sym
             _ <- register freeTestResource
             return delayedTestRef

servant-server/test/Servant/ServerSpec.hs

@@ -275,12 +275,14 @@ captureAllSpec = do
 type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
                 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
                 :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
+                :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person
+                :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person
 
 queryParamApi :: Proxy QueryParamApi
 queryParamApi = Proxy
 
 qpServer :: Server QueryParamApi
-qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges
 
   where qpNames (_:name2:_) = return alice { name = name2 }
         qpNames _           = return alice
@@ -288,6 +290,11 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
         qpCapitalize False = return alice
         qpCapitalize True  = return alice { name = map toUpper (name alice) }
 
+        qpAge Nothing = return alice
+        qpAge (Just age') = return alice{ age = age'}
+
+        qpAges ages = return alice{ age = sum ages}
+
         queryParamServer (Just name_) = return alice{name = name_}
         queryParamServer Nothing = return alice
 
@@ -319,6 +326,54 @@ queryParamSpec = do
               name = "john"
              }
 
+      it "parses a query parameter" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+        let params = "?age=55"
+        response <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params,
+            queryString = parseQuery params,
+            pathInfo = ["param"]
+           }
+        liftIO $
+            decode' (simpleBody response) `shouldBe` Just alice{
+              age = 55
+            }
+
+      it "generates an error on query parameter parse failure" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+        let params = "?age=foo"
+        response <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params,
+            queryString = parseQuery params,
+            pathInfo = ["param"]
+           }
+        liftIO $ statusCode (simpleStatus response) `shouldBe` 400
+        return ()
+
+      it "parses multiple query parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+        let params = "?ages=10&ages=22"
+        response <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params,
+            queryString = parseQuery params,
+            pathInfo = ["multiparam"]
+           }
+        liftIO $
+            decode' (simpleBody response) `shouldBe` Just alice{
+              age = 32
+            }
+
+      it "generates an error on parse failures of multiple parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+        let params = "?ages=2&ages=foo"
+        response <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params,
+            queryString = parseQuery params,
+            pathInfo = ["multiparam"]
+           }
+        liftIO $ statusCode (simpleStatus response) `shouldBe` 400
+        return ()
+
 
       it "allows retrieving value-less GET parameters" $
         (flip runSession) (serve queryParamApi qpServer) $ do

servant/src/Servant/API/ContentTypes.hs

@@ -220,14 +220,20 @@ class Accept ctype => MimeUnrender ctype a where
     {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
 
 class AllCTUnrender (list :: [*]) a where
+    canHandleCTypeH
+        :: Proxy list
+        -> ByteString  -- Content-Type header
+        -> Maybe (ByteString -> Either String a)
+
     handleCTypeH :: Proxy list
                  -> ByteString     -- Content-Type header
                  -> ByteString     -- Request body
                  -> Maybe (Either String a)
+    handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
 
 instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
-    handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
+    canHandleCTypeH p ctypeH =
-      where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
+        M.mapContentMedia (allMimeUnrender p) (cs ctypeH)
 
 --------------------------------------------------------------------------
 -- * Utils (Internal)
@@ -292,20 +298,19 @@ instance OVERLAPPING_
 --------------------------------------------------------------------------
 class (AllMime list) => AllMimeUnrender (list :: [*]) a where
     allMimeUnrender :: Proxy list
-                    -> ByteString
+                    -> [(M.MediaType, ByteString -> Either String a)]
-                    -> [(M.MediaType, Either String a)]
 
 instance AllMimeUnrender '[] a where
-    allMimeUnrender _ _ = []
+    allMimeUnrender _ = []
 
 instance ( MimeUnrender ctyp a
          , AllMimeUnrender ctyps a
          ) => AllMimeUnrender (ctyp ': ctyps) a where
-    allMimeUnrender _ bs =
+    allMimeUnrender _ =
         (map mk $ NE.toList $ contentTypes pctyp)
-        ++ allMimeUnrender pctyps bs
+        ++ allMimeUnrender pctyps
       where
-        mk ct   = (ct, mimeUnrenderWithType pctyp ct bs)
+        mk ct   = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)
         pctyp  = Proxy :: Proxy ctyp
         pctyps = Proxy :: Proxy ctyps