通过servant在运行时更改web-root或路径前缀？

问题描述

我需要能够通过 CLI 参数更改我的 API 的网络根目录（或路径前缀）。

如果我的服务器公开了以下 API 路径...

/enqueue
/run
/cancel

...在启动时，应该可以通过传递 CLI 开关 --web-root=/admin 将它们更改为以下内容：

/admin/enqueue
/admin/run
/admin/cancel

该问题与解析命令行无关，这是通过 optparse-applicative 解决的问题。这是关于servant中的任何内置方式，AT RUNTIME，以（a）更改服务器的web-root，以及（b）在各种安全链接功能（通过生成allFieldLinks').

解决方法

Servant 没有为此提供简单的工具，并且 Servant.Link 的内部被过度保护（不幸的是 Haskell 包的常见问题），从而使其在链接端实现不必要地困难。>

您可以使用在运行时指定类型的常用方法在运行时指定的基本路径下安装服务 API。然而，获得安全链接以自动合并基本路径似乎几乎是不可能的。如果您对事后修复链接感到满意，那么以下方法可能会奏效。

鉴于您使用的是 allFieldLinks'，您可能使用的是通用接口，因此假设您有一个服务：

data HelloService route = HelloService
  { hello :: route :- "hello" :> Get '[PlainText] Text,world :: route :- "world" :> Get '[PlainText] Text
  } deriving (Generic)

helloServer :: HelloService AsServer
helloServer = HelloService
  { hello = return $ "Goto \"localhost:3000/" <> toUrlPiece (world asLink) <> "\"",world = return "Hello,world!"
  } where asLink = allFieldLinks

以通常无聊的方式在根部提供服务：

main = run 3000 $ genericServe helloServer

如果您想在不修改服务定义的情况下通过编译时基本路径（例如 /admin）提供此服务，您可以将 main 重写为：

main = run 3000 $ serve (Proxy @("admin" :> ToServant HelloService AsApi))
                        (genericServer helloServer)

要在运行时指定基本路径组件 "admin"，您可以在存在符号上定义和大小写匹配：

main = do
  let base = "admin"
  case someSymbolVal base of
    SomeSymbol (_ :: Proxy base) ->
      run 3000 $ serve (Proxy @(base :> ToServant HelloService AsApi))
                       (genericServer helloServer)

这仅允许基本路径中有一个组件，但您可以通过以下方式推广到多组件基础：

serveUnder :: forall service. HasServer service '[]
  => [String] -> Proxy service -> Server service -> Application
serveUnder [] p s = serve p s
serveUnder (x:xs) _ s = case someSymbolVal x of
  SomeSymbol (_ :: Proxy x) -> serveUnder xs (Proxy @(x :> service)) s

main :: IO ()
main = do
  let base = ["foo","bar"]  -- mount under /foo/bar
  run 3000 $ serveUnder (reverse base)
                        (genericApi (Proxy @HelloService))
                        (genericServer helloServer)

如果您尝试并访问 http://localhost:3000/foo/bar/hello，您会看到 allFieldLinks 没有反映新的挂载点。如果 Servant.Links 暴露更多的内部结构，这将很容易修复。不幸的是，解决此问题的唯一合理方法是将某种形式的运行时路径传递到 helloServer 并让它修复安全链接作为呈现的一部分。

生成的完整程序如下所示：

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}

module HelloService where

import Data.Text (Text)
import qualified Data.Text as T
import Servant
import Servant.API.Generic
import Servant.Server.Generic
import Network.URI
import Network.Wai.Handler.Warp
import GHC.TypeLits

data HelloService route = HelloService
  { hello :: route :- "hello" :> Get '[PlainText] Text,world :: route :- "world" :> Get '[PlainText] Text
  } deriving (Generic)

helloServer :: Text -> HelloService AsServer
helloServer webroot = HelloService
  { hello = return $ "Goto \"localhost:3000/" <> renderLink (world asLink) <> "\"",world!"
  } where asLink = allFieldLinks
          renderLink l = webroot <> toUrlPiece l

serveUnder :: forall service. HasServer service '[]
  => [String] -> Proxy service -> Server service -> Application
serveUnder [] p s = serve p s
serveUnder (x:xs) _ s = case someSymbolVal x of
  SomeSymbol (_ :: Proxy x) -> serveUnder xs (Proxy @(x :> service)) s

main :: IO ()
main = do
  let base = ["foo","bar"]  -- mount under /foo/bar
      webroot = "http://localhost:3000/" <> T.intercalate "/" (map escaped base) <> "/"
      escaped = T.pack . escapeURIString isUnreserved
  run 3000 $ serveUnder (reverse base)
                        (genericApi (Proxy @HelloService))
                        (genericServer (helloServer webroot))

haskell haskell servant