通过服务在运行时更改web根(或路径前缀)？

Question

我需要赋予通过CLI参数更改API的web根(或路径前缀)的能力。

如果我的服务器公开下列API路径..。

/enqueue
/run
/cancel

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

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

这个问题与解析命令行无关，这是一个通过optparse-applicative解决的问题。它是服务程序AT运行时中的任何内置方式，用于(a)更改服务器的web根，(b)对各种安全链接函数(通过allFieldLinks'生成)进行相应的更改。

Answer 1

仆人没有提供直接的工具来完成这个操作，而且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))