{-# 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