Servant combinator doesn't fall through to subsequent alternatives

Question

I made a custom combinator: MultipartUpload, but when I use it, it ends up applying not only the route I use it on, but all subsequent routes:

For example, in the following API, MultipartUpload runs on both the 2nd AND 3rd route. So if I call the 3rd it will return the error File upload required. I only want it to apply to the 2nd. How?

type ModelAPI =
  "models" :>
    (    ProjectKey :> Get '[JSON] [Model]
    :<|> ProjectKey :> MultipartUpload :> Post '[JSON] Model
    :<|> ProjectKey :> Capture "modelId" ID :> Get '[JSON] Model
    )

Here is how MultipartUpload is defined.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Servant.Multipart
  ( MultipartUpload
  , FileInfo(..)
  ) where

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Types (status400)
import Network.Wai.Parse
import Network.Wai (responseLBS)
import Servant
import Servant.Server.Internal


data MultipartUpload

instance (HasServer sublayout) => HasServer (MultipartUpload :> sublayout) where
  type ServerT (MultipartUpload :> sublayout) m =
    FileInfo ByteString -> ServerT sublayout m

  route Proxy subserver req respond = do
    dat <- parseRequestBody lbsBackEnd req
    let files = snd dat
    case files of
      [(_, f)] ->
        if Lazy.null $ fileContent f
          then respond . succeedWith $ responseLBS status400 [] "Empty file"
          else route (Proxy :: Proxy sublayout) (subserver f) req respond
      [] ->
        respond . succeedWith $ responseLBS status400 [] "File upload required"

      _ ->
        respond . succeedWith $ responseLBS status400 [] "At most one file allowed"

Answer 1

I created a combinator that matches the http method earlier, so it can choose a route correctly and allow the MultipartUpload combinator to require an upload, instead of simply not matching.

I also filed an issue asking for clarification: https://github.com/haskell-servant/servant/issues/410

-- combinator that returns a mismatch if the method doesn't match
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Servant.Method where

import qualified Network.HTTP.Types as HTTP
import Network.Wai (requestMethod)
import Servant
import Servant.Server.Internal

data GET
data POST
data DELETE
data PUT

data Method a

class ToMethod method where
    toMethod :: Proxy method -> HTTP.Method

instance ToMethod GET where
    toMethod _ = HTTP.methodGet

instance ToMethod POST where
    toMethod _ = HTTP.methodPost

instance ToMethod DELETE where
    toMethod _ = HTTP.methodDelete

instance ToMethod PUT where
    toMethod _ = HTTP.methodPut

instance (ToMethod method, HasServer api) => HasServer (Method method :> api) where
  type ServerT (Method method :> api) m =
    ServerT api m

  route Proxy api req respond = do
    if requestMethod req == toMethod (Proxy :: Proxy method)
      then route (Proxy :: Proxy api) api req respond
      else respond . failWith $ WrongMethod

If I use it like this it solves the problem:

type ModelAPI =
  "models" :>
    (    ProjectKey :> Get '[JSON] [Model]
    :<|> ProjectKey :> Method POST :> MultipartUpload :> Post '[JSON] Model
    :<|> ProjectKey :> Capture "modelId" ID :> Get '[JSON] Model
    )

Answer 2

Disclaimer: I've never used Servant, but I understand its approach.

Your MultiPartUpload :> sublayout handler is too eager. If you are always responding with succeedWith, then Servant has no way of knowing that it doesn't match and thus it should go on to trying the next alternative.

You'll need to use failWith in cases where you want to fall through to the next alternative.

You can see this is the case by checking out the HasServer instance for :<|>:

instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
  -- ...     
  route Proxy (a :<|> b) request respond =
    route pa a request $ \mResponse ->
      if isMismatch mResponse
        then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
        else respond mResponse

this never looks at the second alternative unless the first response is a mismatch.