Example nested generic Servant API

Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Aeson
import qualified Data.IORef as IORef
import Data.IORef (IORef)
import qualified Data.Map as Map
import Data.Map (Map)
import Servant
import Servant.API.Generic
import Servant.Client
import Servant.Client.Generic
import Servant.Server
import Servant.Server.Generic
import Network.Wai
import Network.Wai.Handler.Warp

newtype ID a = ID Int
  deriving stock (Generic)
  deriving newtype (Eq, Ord, ToJSON, FromJSON, FromHttpApiData, ToHttpApiData)

data Book = Book
  { title :: String
  , author :: String
  } deriving (Generic, ToJSON, FromJSON)

data BookStore as = BookStore
  { createBook :: as :- ReqBody '[JSON] Book :> Post '[JSON] (ID Book)
  , readBook :: as :- Capture "id" (ID Book) :> Get '[JSON] Book
  }
  deriving (Generic, GClient)

instance
  ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )
  => GServer BookStore context

type Version = String

data API' as = API
  { bookStore :: as :- "books" :> GApi BookStore
  , apiVersion :: as :- "version" :> Get '[JSON] Version
  }
  deriving (Generic, GClient)

instance
  (HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) =>
  GServer API' context

type API = GApi API'

apiClient :: Client ClientM API
apiClient = client (Proxy @API)

data ServerEnv = ServerEnv
  { booksDb :: IORef (Map (ID Book) Book)
  , nextBookId :: IORef (ID Book)
  }

mkInitialServerEnv :: IO ServerEnv
mkInitialServerEnv = do
  booksDb <- IORef.newIORef Map.empty
  nextBookId <- IORef.newIORef (ID 1)
  return ServerEnv {..}

mkServerMonadToHandler :: ServerEnv -> (forall x. ServerMonad a -> Handler a)
mkServerMonadToHandler serverEnv =  (`runReaderT` serverEnv) . runServerMonad

newtype ServerMonad a = ServerMonad { runServerMonad :: ReaderT ServerEnv Handler a }
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ServerEnv)


mkHandlerServer :: IO (Server API)
mkHandlerServer = do
  initialEnv <- mkInitialServerEnv
  let nat = mkServerMonadToHandler initialEnv
  return $ hoistServer (Proxy @API) nat inMemoryServer

currentVersion :: Version
currentVersion = "1.0"

inMemoryServer :: ServerT API ServerMonad
inMemoryServer = API
  { bookStore = BookStore
      { createBook = \book -> do
          bookId <- do
            bookIdRef <- asks nextBookId
            liftIO $ IORef.atomicModifyIORef' bookIdRef $ \(ID i) -> (ID $ i+1, ID i)
          () <- do
            bookStoreRef <- asks booksDb
            liftIO $ IORef.atomicModifyIORef' bookStoreRef $ \currDb ->
              (Map.insert bookId book currDb, ())
          return bookId
     
      , readBook = \bookId -> do
          currDb <- liftIO . IORef.readIORef =<< asks booksDb
          case Map.lookup bookId currDb of
            Nothing -> ServerMonad $ lift $ throwError err404
            Just book -> return book
      }
  , apiVersion = pure currentVersion
  }


main :: IO ()
main = do
  server <- mkHandlerServer
  run 8080 $ serve (Proxy @API) server