b0b02f1948
We define `ServerT (NamedRoutes api) m` as `api (AsServerT m)`, so that the server of an record-defined API is a record of handlers. The implementation piggy backs on the instance for “vanilla” servant types with `(:<|>)`, using the `GServantProduct` for converting backd and forth between the record / vanilla servers. The main difficulty is that GHC needs to know that this operation is legit, which can be expressed as the fact that: ``` GToServant (Rep (ServerT (NamedRoutes api))) m ~ ServerT (GToServant (Rep (api AsApi))) m ``` plus a few additional constraints. This is easy enough for `route`, as we know that `m ~ Handler`. But in the case of `hoistServerWithContext`, the two involved monads are unknown ; in other words, this constraint needs to hold `forall m.` Switching `-XQuantifiedConstraints` on is not sufficient, as our constraints involve type families (`Rep` and `ServerT`). Our trick is to use an intermediary typeclass, `GServer`, as a provider of evidence (in the form of a `Dict`) that our constraints are indeed satisfied for a particular monad. The only instance of `GServer` is defined along with it, so it is practically invisible to users.
89 lines
2.5 KiB
Haskell
89 lines
2.5 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
import Prelude ()
|
|
import Prelude.Compat
|
|
|
|
import Data.Aeson
|
|
import Data.Proxy
|
|
import Data.Text
|
|
import GHC.Generics
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp
|
|
|
|
import Servant
|
|
import Servant.Server.Generic ()
|
|
import Servant.API.Generic
|
|
|
|
-- * Example
|
|
|
|
-- | A greet message data type
|
|
newtype Greet = Greet { _msg :: Text }
|
|
deriving (Generic, Show)
|
|
|
|
instance FromJSON Greet
|
|
instance ToJSON Greet
|
|
|
|
-- API specification
|
|
type TestApi =
|
|
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
|
|
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
|
|
|
|
-- POST /greet with a Greet as JSON in the request body,
|
|
-- returns a Greet as JSON
|
|
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
|
|
|
|
-- DELETE /greet/:greetid
|
|
:<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
|
|
|
|
:<|> NamedRoutes OtherRoutes
|
|
|
|
data OtherRoutes mode = OtherRoutes
|
|
{ version :: mode :- Get '[JSON] Int
|
|
, bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text
|
|
}
|
|
deriving Generic
|
|
|
|
testApi :: Proxy TestApi
|
|
testApi = Proxy
|
|
|
|
-- Server-side handlers.
|
|
--
|
|
-- There's one handler per endpoint, which, just like in the type
|
|
-- that represents the API, are glued together using :<|>.
|
|
--
|
|
-- Each handler runs in the 'Handler' monad.
|
|
server :: Server TestApi
|
|
server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes
|
|
where otherRoutes = OtherRoutes {..}
|
|
|
|
bye name = pure $ "Bye, " <> name <> " !"
|
|
version = pure 42
|
|
|
|
helloH name Nothing = helloH name (Just False)
|
|
helloH name (Just False) = return . Greet $ "Hello, " <> name
|
|
helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
|
|
|
|
postGreetH greet = return greet
|
|
|
|
deleteGreetH _ = return NoContent
|
|
|
|
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
|
-- more precisely by the Servant.Server module.
|
|
test :: Application
|
|
test = serve testApi server
|
|
|
|
-- Run the server.
|
|
--
|
|
-- 'run' comes from Network.Wai.Handler.Warp
|
|
runTestServer :: Port -> IO ()
|
|
runTestServer port = run port test
|
|
|
|
-- Put this all to work!
|
|
main :: IO ()
|
|
main = runTestServer 8001
|