僕人組合子不通過下降到後續替代

Question

我做了一個自定義的組合子：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" 

Answer 1

聲明：我從來沒有使用僕人，但我理解它的方法。

您的MultiPartUpload :> sublayout處理程序太熱切了。如果你永遠是respondsucceedWith，那麼僕人無法知道它不匹配，因此它應該繼續嘗試下一個選擇。

如果您想要完成下一個選擇，您需要使用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 

這永遠不會看第二個選擇，除非第一個反應是不匹配的。

Answer 2

我創建了一個匹配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 
    )