1

我制作了一个自定义组合器：MultipartUpload，但是当我使用它时，它最终不仅应用了我使用它的路线，还应用了所有后续路线：

例如，在以下 API 中，MultipartUpload在第 2 条和第 3 条路线上运行。因此，如果我调用第三个，它将返回错误File upload required。我只希望它适用于第二个。如何？

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

这是如何MultipartUpload定义的。

{-# 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"
4

2 回答 2

5

免责声明：我从未使用过Servant，但我理解它的方法。

你的MultiPartUpload :> sublayout处理程序太急切了。如果你总是responding succeedWith，那么 Servant 无法知道它不匹配，因此它应该继续尝试下一个替代方案。

您需要failWith在您想要进入下一个替代方案的情况下使用。

您可以通过查看以下HasServer实例来了解情况:<|>：

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

除非第一个响应不匹配，否则这永远不会考虑第二种选择。

于 2016-03-16T03:02:26.563 回答
1

我之前创建了一个匹配 http 方法的组合器，因此它可以正确选择路由并允许 MultipartUpload 组合器需要上传，而不是简单地不匹配。

我还提出了一个要求澄清的问题：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

如果我这样使用它可以解决问题：

type ModelAPI =
  "models" :>
    (    ProjectKey :> Get '[JSON] [Model]
    :<|> ProjectKey :> Method POST :> MultipartUpload :> Post '[JSON] Model
    :<|> ProjectKey :> Capture "modelId" ID :> Get '[JSON] Model
    )
于 2016-03-16T16:57:20.707 回答