Combining servers from APIs defined as generic records of routes

[plredmond]

Similar to https://github.com/haskell-servant/servant/issues/1085, I needed to write a server which was composed of multiple APIs. I found Docs » Cookbook » Structuring APIs but my APIs were defined as Docs » Cookbook » Using generics and so I wasn't sure how to approach it. My first attempt to combine compositionally failed. I looked at the documentation a bit more and found an escape hatch, but it doesn't feel like the "right" approach because a server defined as a record via routes AsServer isn't reusable.

Combining two routes-records via composition does not work.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Main where

import Servant
import Servant.API.Generic
import Servant.Server.Generic

data ChildRoutes mode = ChildRoutes
    { child :: mode :- "child" :> Get '[PlainText] String
    }
    deriving (Generic)

data ParentRoutes mode = ParentRoutes
    { parent :: mode :- "parent" :> Get '[PlainText] String
    , childRoutes :: ChildRoutes mode
    }
    deriving (Generic)

app :: Application
app = undefined -- genericServe parentHandlers -- Can't genericServe parentHandlers for some reason
  where
    parentHandlers :: ParentRoutes AsServer
    parentHandlers = ParentRoutes
        { parent = return "parent handler ok"
        , childRoutes = childHandlers
        }
    childHandlers :: ChildRoutes AsServer
    childHandlers = ChildRoutes
        { child = return "child handler ok"
        }

main = print "todo"

Eg0.hs:22:7-33: error:
    • Couldn't match type ‘ServerT (ChildRoutes AsApi) Handler’
                     with ‘ChildRoutes (AsServerT Handler)’
        arising from a use of ‘genericServe’
    • In the expression: genericServe parentHandlers
      In an equation for ‘app’:
          app
            = genericServe parentHandlers
            where
                parentHandlers :: ParentRoutes AsServer
                parentHandlers
                  = ParentRoutes
                      {parent = return "parent handler ok", childRoutes = childHandlers}
                childHandlers :: ChildRoutes AsServer
                childHandlers = ChildRoutes {child = return "child handler ok"}
   |
22 | app = genericServe parentHandlers -- Can't genericServe parentHandlers for some reason
   |       ^^^^^^^^^^^^^^^^^^^^^^^^^^^

Converting two routes-records to normal servant APIs and combining their servers as siblings does work.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Main where

import Servant
import Servant.API.Generic
import Servant.Server.Generic

data LeftRoutes mode = LeftRoutes
    { left :: mode :- "left" :> Get '[PlainText] String
    }
    deriving (Generic)

data RightRoutes mode = RightRoutes
    { right :: mode :- "right" :> Get '[PlainText] String
    }
    deriving (Generic)

app :: Application
app = serve
    (Proxy :: Proxy (ToServantApi LeftRoutes :<|> ToServantApi RightRoutes))
    (leftServer :<|> rightServer)
  where
    -- It seems silly to have two servers defined this way, but it's important
    -- when they have more than one endpoint so that structure of the :<|> tree
    -- matches that of the api types.
    leftServer :: Server (ToServantApi LeftRoutes)
    leftServer
        =   return "left handler ok"
    rightServer :: Server (ToServantApi RightRoutes)
    rightServer
        =   return "right handler ok"

main = print "todo"

Again, although I found a solution, it's not very satisfactory because it leaves servers defined as routes AsServer not reusable. The purpose of this issue is to ask:

• What is the correct way to do this?
• Can we get some documentation about it? I can write some documentation if there is consensus about the correct approach.

[plredmond]

https://github.com/haskell-servant/servant/issues/1339 is related.

[tschuchortdev]

Have you tried this?

data ParentRoutes mode = ParentRoutes
    { parent :: mode :- "parent" :> Get '[PlainText] String
    , childRoutes :: mode :- ToServantApi ChildRoutes
    }
    deriving (Generic)

I have a feeling like it might work.