使用Haskell Servant的部分反向代理

Question

我正在尝试用Servant在Haskell中构建一个web服务器，其中的一部分api可以作为另一个api的反向代理。

如何实现这一点的I found an example。但它似乎不起作用：

type API
    = "cat" :> Get '[JSON] Cat

newtype Cat = Cat { cat :: String }

instance ToJSON Cat where
    toJSON (Cat mew) =
        object [ "cat" .= mew ]

server :: Server API
server = pure (Cat { cat = "mrowl" })

api :: Proxy (API :<|> Raw)
api = Proxy

app :: Manager -> Application
app manager =
    serve api $ server :<|> waiProxyTo forwardRequest defaultOnExc manager

forwardRequest :: Request -> IO WaiProxyResponse
forwardRequest _ =
    pure . WPRProxyDest . ProxyDest "127.0.0.1" $ 4567

startApp :: IO ()
startApp = do
    manager <- newManager defaultManagerSettings
    run 8080 (app manager)

它给出了以下类型错误(当我在我自己的代码库中尝试它时)：

    • Couldn't match type ‘Request
                           -> (Response -> IO ResponseReceived) -> IO ResponseReceived’
                     with ‘Tagged Handler Application’
      Expected type: Server (API :<|> Raw)
        Actual type: Handler Cat :<|> Application
    • In the second argument of ‘($)’, namely
        ‘server :<|> waiProxyTo forwardRequest defaultOnExc manager’
      In the expression:
        serve api
          $ server :<|> waiProxyTo forwardRequest defaultOnExc manager
      In an equation for ‘app’:
          app manager
            = serve api
                $ server :<|> waiProxyTo forwardRequest defaultOnExc manager
   |
32 |     serve api $ server :<|> waiProxyTo forwardRequest defaultOnExc manager
   |                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

(我的解释是，自编写示例以来，:<|>已更改为不接受组合服务器和应用程序。)

我可以用什么替换waiProxyTo forwardRequest defaultOnExc manager来使其正常工作？

Answer 1

我不完全理解为什么这样做，但我通过模仿serveDirectoryWith的工作方式让它工作起来：

import Servant.Server (ServerT, Tagged)
{- ... -}
forwardServer :: Manager -> ServerT Raw m
forwardServer manager = Tagged $ waiProxyTo forwardRequest defaultOnExc manager

forwardRequest :: Request -> IO WaiProxyResponse
forwardRequest _ =
    pure . WPRProxyDest . ProxyDest "127.0.0.1" $ 4567

app :: Manager -> Application
app manager =
    serve api $ server :<|> (forwardServer manager)