Replace sub api to change implementation for an endpoint handler to a more efficient one.

replace-sub-api.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [servant-swagger servant-swagger-ui])"
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}
module Main where

import           Control.Monad.Trans        (liftIO)
import           Data.Aeson                 (FromJSON, ToJSON)
import qualified Data.Aeson                 as Aeson
import qualified Data.ByteString.Lazy.Char8 as BSL8
import           Data.Swagger               (Swagger)
import qualified Data.Swagger               as Swagger
import           Data.Text                  (Text)
import           GHC.Generics               (Generic)
import qualified Network.HTTP.Types         as HTTP
import qualified Network.Wai                as Wai
import qualified Network.Wai.Handler.Warp   as Warp
import           Servant
import           Servant.Swagger
import           Servant.Swagger.UI

-- * API

type SampleAPI
    = "send" :> SendItem
      -- ^ we want to be able to provide a more efficient
      -- Raw implementation for this endpoint
      -- specifically to avoid unnecessary ToJSON/FromJSON
      -- conversions and validations
 :<|> "list" :> ListItems

type EfficientSampleAPI
  = Replace SendItem Raw SampleAPI

type family Replace old new api where
  Replace old new old = new
  Replace old new (param :> api) = param :> Replace old new api
  Replace old new (left :<|> right)
    = Replace old new left :<|> Replace old new right
  Replace old new api = api

type SendItem
  = ReqBody '[JSON] Item              -- ^ An item to save.
 :> PostNoContent '[JSON] NoContent

type ListItems = Get '[JSON] Items

sampleAPI :: Proxy SampleAPI
sampleAPI = Proxy

-- * Model

-- | A sample Item data type that can be encoded/decoded as JSON.
data Item = Item
  { title       :: Text
  , description :: Text
  } deriving (Generic, ToJSON, FromJSON, Swagger.ToSchema)

-- | A bunch of 'Item's.
newtype Items = Items
  { items :: [Item]
  } deriving (Generic, ToJSON, FromJSON, Swagger.ToSchema)

-- * Server handlers

-- | A sample server with standard 'serveSendItem' implementation.
sampleServer :: Server SampleAPI
sampleServer
    = serveSendItem -- a standard Servant handler
 :<|> serveListItems

-- | Handle sent 'Item' by dumping its JSON encoding to stdout.
serveSendItem :: Item -> Handler NoContent
serveSendItem item = do
  liftIO $ BSL8.putStrLn (Aeson.encode item)
  return NoContent

-- | Serve some list of items.
serveListItems :: Handler Items
serveListItems = return $ Items
  [ Item { title = "Char", description = "Something to sit on" } ]

-- | Like 'sampleServer', but with 'efficientSendItem'.
efficientServer :: Server EfficientSampleAPI
efficientServer
    = efficientSendItem
 :<|> serveListItems

-- | An efficient implementation of SendItem API.
-- Here we bypass Servant's encoding/decoding of JSON
-- and merely dump request body to stdout.
efficientSendItem :: Server Raw
efficientSendItem = Tagged $ \req respond -> do
  body <- Wai.strictRequestBody req
  BSL8.putStrLn body
  respond $ Wai.responseLBS HTTP.status200 [] "Hello World"

sampleSwagger :: Swagger
sampleSwagger = toSwagger sampleAPI

-- | Complete API with 'SampleAPI' and Swagger documentation.
type API
    = SwaggerSchemaUI "swagger-ui" "swagger.json"
 :<|> SampleAPI

main :: IO ()
main = do
  putStrLn "Starting a server at http://localhost:8080"
  putStrLn "Swagger UI available at http://localhost:8080/swagger-ui"
  Warp.run 8080 $ serve (Proxy @(Replace SampleAPI EfficientSampleAPI API)) $
    swaggerSchemaUIServer sampleSwagger :<|> efficientServer