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

Question

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

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

/enqueue
/run
/cancel

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

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

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

标签： haskellservant

Answer 1

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 = return "Hello, 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))