Changing the web-root (or path-prefix) at runtime via servant? - haskell

Question

I need to give the ability to change the web-root (or path-prefix) of my API via CLI arguments.
If my server exposes the following API paths...
/enqueue
/run
/cancel
...at startup it should be possible to change them to the following by passing a CLI switch --web-root=/admin:
/admin/enqueue
/admin/run
/admin/cancel
The question is not related to parsing the command-line, which is a solved problem via optparse-applicative. It's about any in-built way in servant, AT RUNTIME, to (a) change the web-root of the server, and (b) make the corresponding change in various safe-links functions (generated via allFieldLinks').

Answer 1

Servant provides no straightforward facility for doing this, and the internals of Servant.Link have been zealously overprotected (an unfortunately common problem with Haskell packages) so as to make it unnecessarily difficult to implement on the link side.
You can mount a servant API under a runtime-specified base path using the usual methods of specifying types at runtime. However, getting safe links to automatically incorporate the base path seems close to impossible. If you're satisfied with fixing up the links after the fact, then the following might work.
Given that you're using allFieldLinks', you're probably using the generic interface, so suppose you have a service:
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
with the usual boring way of serving it at the root:
main = run 3000 $ genericServe helloServer
If you wanted to serve this off a compile-time base path (e.g., /admin) without modifying the service definition, you could rewrite main as:
main = run 3000 $ serve (Proxy #("admin" :> ToServant HelloService AsApi))
(genericServer helloServer)
To specify the base path component "admin" at runtime, you can define and case-match on an existential symbol:
main = do
let base = "admin"
case someSymbolVal base of
SomeSymbol (_ :: Proxy base) ->
run 3000 $ serve (Proxy #(base :> ToServant HelloService AsApi))
(genericServer helloServer)
This only allows one component in the base path, but you can generalize to a multiple-component base with:
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)
If you try this out and visit http://localhost:3000/foo/bar/hello, you'll see that the allFieldLinks doesn't reflect the new mount point. If Servant.Links exposed more internals, this would be trivial to fix. Unfortunately, as it is, the only reasonable way to address this is to pass some form of the runtime path into helloServer and have it fix the safe links as part of the rendering.
The resulting full program would look something like this:
{-# 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))