Filter the parts of a Request Path which match against a Static Segment in Servant

Supposing I'm running a Servant webserver, with two endpoints, with a type looking like this:

type BookAPI =
  "books" :> Get '[JSON] (Map Text Text)
    :<|> "book" :> Capture "Name" Text :> ReqBody '[JSON] (Text) :> Post '[JSON] (Text)

λ:T.putStrLn $ layout (Proxy :: Proxy BookAPI)
/
├─ book/
│  └─ <capture>/
│     └─•
└─ books/
   └─•

I might want to use something like Network.Wai.Middleware.Prometheus's instrumentHandlerValue to generate a Prometheus metric that fire's every time this API is called, with a handler value set to the path of the request.

However, if I do something like the following:

prometheusMiddlware = instrumentHandlerValue (T.intercalate "\\" . pathInfo)

This is bad, because different requests to the book/<Name> endpoint, such as book/great-expectations and book/vanity-fair result in different labels, this is fine if the number of books is small, but if it's very large then the amount of data used by these metrics is very big, and either my service falls over, or my monitoring bill becomes very large.

I'd quite like a function, that took a Servant API, and a Wai Request, and if it matched, returned a list of segments in a form that was the same for each endpoint.

That is requests to /books would return Just ["books"], requests to /book/little-dorrit would return Just ["book", "Name"], and requests to /films would return Nothing.

I can kind of see how you might go about writing this by pattern matching on Router' from Servant.Server.Internal.Router, but it's not clear to me that relying on an internal package in order to do this is a good idea.

Is there a better way?

Solution

The pathInfo function returns all the path segments for a Request. Perhaps we could define a typeclass that, given a Servant API, produced a "parser" for the list of segments, whose result would be a formatted version of the list.

The parser type could be something like:

import Data.Text 
import Control.Monad.State.Strict
import Control.Applicative

type PathParser = StateT ([Text],[Text]) Maybe ()

Where the first [Text] in the state are the path segments yet to be parsed, and the second are the formatted path segments we have accumulated so far.

This type has an Alternative instance where failure discards state (basically backtracking) and a MonadFail instance that returns mzero on pattern-match failure inside do-blocks.

The typeclass:

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
import Data.Data ( Proxy )
import GHC.TypeLits

class HasPathParser (x :: k) where
    pathParser :: Proxy x -> PathParser

The instance for Symbol moves the path piece from the pending list to the processed list:

instance KnownSymbol piece => HasPathParser (piece :: Symbol) where
  pathParser _ = do
      (piece : rest, found) <- get -- we are using MonadFail here
      guard (piece == Data.Text.pack (symbolVal (Proxy @piece)))
      put (rest, piece : found)

The instance for Capture puts the name of the path variable—not the value—on the processed list:

instance KnownSymbol name => HasPathParser (Capture name x) where
  pathParser _ = do
      (_ : rest, found) <- get  -- we are using MonadFail here
      put (rest, Data.Text.pack (symbolVal (Proxy @name)) : found)

When we reach a Verb (GET, POST...) we require that no pending path pieces should remain:

instance HasPathParser (Verb method statusCode contextTypes a) where
  pathParser _ = do
      ([], found) <- get -- we are using MonadFail here
      put ([], found)

Some other instances:

instance HasPathParser (ReqBody x y) where
  pathParser _ = pure ()

instance (HasPathParser a, HasPathParser b) => HasPathParser (a :> b) where
  pathParser _ = pathParser (Proxy @a) *> pathParser (Proxy @b)

instance (HasPathParser a, HasPathParser b) => HasPathParser (a :<|> b) where
  pathParser _ = pathParser (Proxy @a) <|> pathParser (Proxy @b)

Putting it to work:

main :: IO ()
main = do
    do let Just ([], result) = execStateT (pathParser (Proxy @BookAPI)) (["books"],[])
       print result
       -- ["books"]
    do let Just ([], result) = execStateT (pathParser (Proxy @BookAPI)) (["book", "somebookid"],[])
       print result
       -- ["Name","book"]