ServantFancy.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ServantFromData where

import qualified Data.Vinyl.Functor as Vinyl
import qualified Data.Vinyl as Vinyl
import           Control.Monad.Trans.Either
import           Data.List
import qualified Data.Map as M
import           Data.Proxy
import qualified Data.Text as T
import           GHC.TypeLits
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Servant.API
import           Servant.Server
import           Servant.Server.Internal

data Command =
  Command {cmdName :: T.Text, response :: T.Text}

data Plugin cmds = Plugin { cmds :: cmds}

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

type Plugins = M.Map T.Text UntaggedPlugin

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)

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

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

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

type CommandName = T.Text
type PluginName = T.Text

type Param = T.Text
type ParamMap = M.Map T.Text T.Text

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

data PluginType = PluginType Symbol [Symbol]

data Fail = Fail

instance HasServer Fail where

  type ServerT Fail m = Fail

  route _ _ _ f = f (failWith NotFound)

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

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

type PluginRoute plugin cmdRoutes = plugin :> cmdRoutes

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

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

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

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

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

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)