1

カスタム コンビネータ: を作成しましたMultipartUploadが、それを使用すると、それを使用するルートだけでなく、後続のすべてのルートが適用されます。

たとえば、次の API ではMultipartUpload、2 番目と 3 番目のルートの両方で実行されます。したがって、3番目を呼び出すと、エラーが返されますFile upload required。私はそれが2番目にのみ適用されることを望みます。どのように？

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ハンドラーは熱心すぎます。常にrespondと ing している場合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

これは、最初の応答が一致しない場合を除き、2 番目の選択肢を調べません。

于 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 に答える