Deriving a Servant Schema from your Data

Posted on January 1, 2016

This post assumes some level of familiarity with the “modern Haskell extension zoo” in particular DataKinds, PolyKinds and TypeFamilies.

Basic Setup

The scenario we are in is a bunch of static data that determines which routes are valid and which aren’t. I got the idea for this post while working on documentation for haskell-ide-engine using servant-swagger. I simplify the code to make it independent of hie. So haskell-ide-engine has a list of plugins each having a list of commands. You can then make requests to /plugin/command passing all additional parameters via a JSON object. Here a Command consists of a name and a response that we send back when we get a request. Let’s take a look at the types

data Command =
  Command {cmdName :: T.Text, response :: T.Text}
data Plugin = Plugin { cmds :: [Command]}
type Plugins = M.Map T.Text Plugin

The static data (it’s important that it’s static) looks as follows

plugin1 :: Plugin
plugin1 =
  Plugin {cmds =
            [Command "cmd1.1" "cmd1.1 response"
            ,Command "cmd1.2" "cmd1.2 response"]}

plugin2 :: Plugin
plugin2 =
  Plugin {cmds =
            [Command "cmd2.1" "cmd2.1 response"
            ,Command "cmd2.2" "cmd2.2 response"]}

pluginList :: Plugins
pluginList = M.fromList [("plugin1",plugin1),("plugin2",plugin2)]

Now we take a look at the corresponding servant schema and the handlers

type CommandName = T.Text
type PluginName = T.Text
type Param = T.Text
type ParamMap = M.Map T.Text T.Text
type API = Capture "plugin" PluginName :>
           Capture "command" CommandName :>
           ReqBody '[JSON] ParamMap :>
           Post '[JSON] T.Text

lookupCommandResponse :: CommandName -> [Command] -> Maybe T.Text
lookupCommandResponse name =
  fmap response . find (\(Command name' _) -> name == name')

server :: Server API
server plugin command params =
  case lookupCommandResponse command . cmds =<<
             M.lookup plugin pluginList of
    Nothing -> left err404
    Just r -> pure r

Nothing fancy going on here, we have a single route, which captures the plugin and the command name and extracts a map of parameters from the request body. We won’t use that map here. It’s just there to show how this can be extended to something useful. Once we have the names we just do a lookup returning the response if it was successful or a 404 otherwise.

The Problem

Obviously, the above approach works just fine but there is (at least) one problem: Even though we know all plugins and commands at compile time, we don’t tell servant about them. At a first glance this might not be so bad, but if you want to generate documentation or client bindings for that API, using something like servant-swagger this is pretty bad. The documentation you can generate from a single route with two parameters is less useful than it needs to be. Wouldn’t it be great if we could teach servant about the existing plugins and commands and thereby profit a lot more from the cool documentation and binding generation servant provides?

Generating the Schema

Since the servant API is defined at the type level, we need to move the names to the type level too. Luckily GHC provides the GHC.TypeLits module for type level strings, and we can also reflect them back to the value level. So let’s make a type level representation of plugin

data PluginText = PluginText Symbol [Symbol]

Symbol is the equivalent of String at the type level. Using DataKinds we get a PluginType kind and a 'PluginType type constructor. Now we need to create a valid servant schema from a list of these. For that, we need to do induction on type level lists, so it’s nice to have a base case, which we’ll call Fail for :<|>, that always fails. This base case or identity gives us some sort of monoid structure with :<|> being a type level mappend and Fail being mempty. Note that :<|> is not strictly associative since (a :<|> b) :<|> c is a different type than a :<|> (b :<|> c), but that doesn’t make a difference in our case.

data Fail = Fail

instance HasServer Fail where
  type ServerT Fail m = Fail
  route _ _ _ f = f (failWith NotFound)

There is nothing that interesting going on, just note that we have to fill in Fail on the value level for Fail on the type level. Equipped with the identity for :<|>, we may move on. Given a command as a symbol, we just use a type synonym to create a route for it

type CommandRoute cmd = cmd :> ReqBody '[JSON] ParamMap :>
  Post '[JSON] T.Text

So what do we do if we have a list of command names? On the value level, we just create a function and recurse on the list. Luckily we have functions on the type level called TypeFamilies so let’s use that:

type family CommandRoutes list where
  CommandRoutes '[] = Fail
  CommandRoutes (cmd ': cmds) = CommandRoute cmd :<|>
                                CommandRoutes cmds

Now that we can route a list of commands, we’ll think about how the schema for a plugin should look. Let’s assume we already have the route for all the commands. Now it’s simply a case of prepending the plugin name:

type PluginRoute plugin cmdRoutes = plugin :> cmdRoutes

So finally, let’s convert a list of PluginTypes to a servant schema. We already have all the building blocks, so it’s fairly easy:

type family PluginRoutes list where
  PluginRoutes ('PluginType name cmds ': xs)
     = (PluginRoute name (CommandRoutes cmds)) :<|> PluginRoutes xs
  PluginRoutes '[] = Fail

Generating the Servant Handlers

So now we know how to get to the servant schema, but we also need the handlers that deal with the commands. How can we get from a type level list of PluginTypes to an implementation? Type classes! We just do induction on the lists using (the value level) Fail as the base case and combining the cases using (the value level) :<|>:


class HieServer (list :: [PluginType])  where
  hieServer
    :: Proxy list -> Server (PluginRoutes list)

instance HieServer '[] where
  hieServer _ = Fail

instance (KnownSymbol plugin,CommandServer cmds,HieServer xs)
          => HieServer ('PluginType plugin cmds ': xs) where
  hieServer _ =
    pluginHandler :<|> hieServer (Proxy :: Proxy xs)
    where pluginHandler
            :: Server (PluginRoute plugin (CommandRoutes cmds))
          pluginHandler =
            cmdServer (T.pack $ symbolVal (Proxy :: Proxy plugin))
                      (Proxy :: Proxy cmds)

class CommandServer (list :: [Symbol])  where
  cmdServer
    :: T.Text -> Proxy list -> Server (CommandRoutes list)

instance CommandServer '[] where
  cmdServer _ _ = Fail

instance (KnownSymbol x,CommandServer xs)
  => CommandServer (x ': xs) where
  cmdServer plugin _ =
    cmdHandler plugin
               (Proxy :: Proxy x) :<|>
    (cmdServer plugin (Proxy :: Proxy xs))

cmdHandler
  :: KnownSymbol x => T.Text -> Proxy x -> Server (CommandRoute x)
cmdHandler plugin cmd reqVal =
  case lookupCommandResponse cmd' . cmds =<<
             M.lookup plugin pluginList of
    Nothing -> left err404
    Just r -> pure r
    where cmd' = T.pack $ symbolVal cmd

Moving command and plugin names to the type level

We want to preserve the data representation we have right now since there might be a lot of code that uses it and shoving around stuff with complicated types is often not trivial, e.g. you need to hide arguments in an existential to put it in a map. It would be great if we could just tag our existing Command type with a Symbol. That’s exactly what Const is for. There is a small problem here: Const in GHC 7.10 is not polykinded, so we can’t use a Symbol here (in GHC 8.0 it will be polykinded). Luckily vinyl provides a polykinded Const in Data.Vinyl.Functor. Let’s build a function to create a tagged command:

buildCommand
  :: KnownSymbol s
  => Proxy s -> T.Text -> Vinyl.Const Command s
buildCommand name response =
  Vinyl.Const (Command (T.pack $ symbolVal name) response)

We use the KnownSymbol type class to reflect the string back to the value level. The Proxy here is not actually needed, but I found it more intuitive to specify the type in the arguments. Now we have a slight problem: we no longer have a list of Commands but a list of Vinyl.Const Command s with the s being different for every Command. Since the standard haskell list is uniform, we can’t use that anymore. Again Vinyl saves us by providing a Rec type, which takes data that varies in the last type parameter and keeps track of those parameters in a type level list. Since we want to preserve the original representation we pull out the type of the commands giving us

data Plugin cmds = Plugin { cmds :: cmds }

type UntaggedPlugin = Plugin [Command]
type TaggedPlugin cmds = Plugin (Vinyl.Rec (Vinyl.Const Command)
                                           cmds)

We need to slightly change our data

plugin1 :: TaggedPlugin '["cmd1.1","cmd1.2"]
plugin1 = Plugin (buildCommand (Proxy :: Proxy "cmd1.1")
                               "cmd1.1 response"
         Vinyl.:& buildCommand (Proxy :: Proxy "cmd1.2")
                               "cmd1.2 response"
         Vinyl.:& Vinyl.RNil)

We still don’t have the plugin name. Let’s see where we want to go and work our way backwards from there:

taggedPlugins :: Vinyl.Rec (Vinyl.Const (T.Text,UntaggedPlugin))
                 '[ 'PluginType "plugin1" _
                  , 'PluginType "plugin2" _]
taggedPlugins = tag plugin1 Vinyl.:& tag plugin2
                            Vinyl.:& Vinyl.RNil

The underscores represent the list of command names. You can either write them here manually or use PartialTypeSignatures to let GHC infer them for you if you are lazy like me. Once we have this type, we can use Vinyl.recordToList to get our original value level representation:

pluginList :: Plugins
pluginList = M.fromList $ Vinyl.recordToList taggedPlugins

So what should tag do? We’re going to define that in two steps: first we wrap it in another layer of Const, this time adding the plugin name. Then we smash them together, giving us a PluginType type parameter.

untagPlugin :: TaggedPlugin cmds -> UntaggedPlugin
untagPlugin (Plugin cmds) = Plugin $ Vinyl.recordToList cmds

retagPlugin
  :: forall name cmds.
     KnownSymbol name
  => Vinyl.Const (TaggedPlugin cmds) name
  -> Vinyl.Const (T.Text,UntaggedPlugin)
                 ('PluginType name cmds)
retagPlugin (Vinyl.Const desc) =
  Vinyl.Const $
  (T.pack $ symbolVal (Proxy :: Proxy name),untagPlugin desc)

type NamedPlugin name cmds = Vinyl.Const UntaggedPlugin
                                         ('PluginType name cmds)

tag
  :: KnownSymbol name
  => TaggedPlugin cmds
  -> Vinyl.Const (T.Text,UntaggedPlugin) ('PluginType name cmds)
tag = retagPlugin . Vinyl.Const

Hold tight we’re almost done! All that’s left is to throw away the data from the Rec type and make a Proxy out of it.

recProxy :: Vinyl.Rec f t -> Proxy t
recProxy _ = Proxy

So finally we can serve our API

serveAPI :: forall plugins.
            (HieServer plugins,HasServer (PluginRoutes plugins))
         => Proxy plugins -> IO ()
serveAPI plugins = run 8080 $ serve
  (Proxy :: Proxy (PluginRoutes plugins)) (hieServer plugins)

servePlugins :: IO ()
servePlugins = serveAPI (recProxy taggedPlugins)

Conclusion

To profit from servant’s full potential, you need to move as much information as possible into your API declaration. It might look like a fair amount of work, but considering you now get documentation & client bindings that might actually be useful, I think it’s worth a trouble (also it’s a lot of fun :)).

You can find the full code on github.

If you are interested, the PR adding this to haskell-ide-engine can be found here.