Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment