105 lines
2.8 KiB
Haskell
105 lines
2.8 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
import Control.Concurrent (forkIO, killThread)
|
|
import Control.Monad.Trans.Either
|
|
import Data.Aeson
|
|
import Data.Monoid
|
|
import Data.Proxy
|
|
import Data.Text
|
|
import GHC.Generics
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp
|
|
|
|
import Servant.API
|
|
import Servant.Client
|
|
import Servant.Docs
|
|
import Servant.Server
|
|
import Servant.Common.BaseUrl
|
|
|
|
-- * Example
|
|
|
|
data Greet = Greet { _msg :: Text }
|
|
deriving (Generic, Show)
|
|
|
|
instance FromJSON Greet
|
|
instance ToJSON Greet
|
|
|
|
instance ToCapture (Capture "name" Text) where
|
|
toCapture _ = DocCapture "name" "name of the person to greet"
|
|
|
|
instance ToCapture (Capture "greetid" Text) where
|
|
toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
|
|
|
|
instance ToParam (QueryParam "capital" Bool) where
|
|
toParam _ =
|
|
DocQueryParam "capital"
|
|
["true", "false"]
|
|
"Get the greeting message in uppercase (true) or not (false). Default is false."
|
|
Normal
|
|
|
|
instance ToSample Greet where
|
|
toSample = Just $ Greet "Hello, haskeller!"
|
|
|
|
-- API specification
|
|
type TestApi =
|
|
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
|
|
:<|> "greet" :> ReqBody Greet :> Post Greet
|
|
:<|> "delete" :> Capture "greetid" Text :> Delete
|
|
|
|
testApi :: Proxy TestApi
|
|
testApi = Proxy
|
|
|
|
-- Server-side handlers
|
|
server :: Server TestApi
|
|
server = hello :<|> greet :<|> delete
|
|
|
|
where hello name Nothing = hello name (Just False)
|
|
hello name (Just False) = return . Greet $ "Hello, " <> name
|
|
hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
|
|
|
|
greet = return
|
|
|
|
delete _ = return ()
|
|
|
|
-- Client-side query functions
|
|
clientApi :: Client TestApi
|
|
clientApi = client testApi
|
|
|
|
getGreet :: Text -> Maybe Bool -> BaseUrl -> EitherT String IO Greet
|
|
postGreet :: Greet -> BaseUrl -> EitherT String IO Greet
|
|
deleteGreet :: Text -> BaseUrl -> EitherT String IO ()
|
|
getGreet :<|> postGreet :<|> deleteGreet = clientApi
|
|
|
|
-- Turn the server into a WAI app
|
|
test :: Application
|
|
test = serve testApi server
|
|
|
|
-- Documentation
|
|
docsGreet :: API
|
|
docsGreet = docs testApi
|
|
|
|
-- Run the server
|
|
runTestServer :: Port -> IO ()
|
|
runTestServer port = run port test
|
|
|
|
-- Run some queries against the server
|
|
main :: IO ()
|
|
main = do
|
|
tid <- forkIO $ runTestServer 8001
|
|
let uri = BaseUrl Http "localhost" 8001
|
|
print =<< runEitherT (getGreet "alp" (Just True) uri)
|
|
print =<< runEitherT (getGreet "alp" (Just False) uri)
|
|
let g = Greet "yo"
|
|
print =<< runEitherT (postGreet g uri)
|
|
print =<< runEitherT (deleteGreet "blah" uri)
|
|
killThread tid
|
|
putStrLn "\n---------\n"
|
|
putStrLn $ markdown docsGreet
|