Using MonadUnliftIO in Servant

Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}

module Main (main) where

import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Control.Monad.IO.Unlift
import UnliftIO.Exception hiding (Handler)
import UnliftIO.Async
import UnliftIO.IORef
import UnliftIO.Concurrent
import Control.Monad.Except
import Control.Monad.Reader



--
-- This example drives a counter in an IORef which is available to a Servant API.
-- ReaderT is commonly used to enable this sort of this, but this example
-- achieves the same thing with MonadUnliftIO.  This is useful because other MonadUnliftIO
-- monads can be used such as effect monads from cleff and effectful.
--

--- Servant API
type CounterAPI
  =    "counter" :> Get '[JSON] Int
  :<|> "fail"    :> Get '[JSON] Int

counterAPI :: Proxy CounterAPI
counterAPI = Proxy

main :: IO ()
main = do
  counter_ref <- newIORef 0 -- IORef holding counter value
  race_
    -- run servant
    (runReaderT runserver counter_ref)
    -- run counter
    (forever $ modifyIORef' counter_ref (1+) >> threadDelay 1000000)

runserver :: ReaderT (IORef Int) IO ()
runserver = do

  let
    counterPage :: ReaderT (IORef Int) IO Int
    counterPage = do
      ask >>= readIORef

    failPage :: ReaderT (IORef Int) IO Int
    failPage = do
      throwIO err500 -- Exceptions to Servant get tunnelled through IO.

    server_rio :: ServerT CounterAPI (ReaderT (IORef Int) IO)
    server_rio = counterPage :<|> failPage

  server <- withRunInIO $ \toIo -> pure $ hoistServer counterAPI (Handler . ExceptT . try . toIo) server_rio
  -- `toIO` converts from (ReaderT (IORef Int) IO) to IO
  -- `Handler. ExceptT . try` "untunnels" Servant exceptions back to ExceptT

  let
    app :: Application
    app = serve counterAPI server

  liftIO $ putStrLn "Starting Server"
  liftIO $ run 8081 app