servant and MonadUnliftIO

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


  -- Use unliftio's `toIO` to get these ReaderTs closer to what Servant likes.
  -- Note:   toIO :: MonadUnliftIO m => m a -> m (IO a)
  counterPage_io :: IO Int <- toIO counterPage
  failPage_io    :: IO Int <- toIO failPage

  let
    server_io = counterPage_io :<|> failPage_io

  -- If we had a monadic hoistServer we could do this...
  --
  -- let
  --   server_rio :: ServerT CounterAPI (ReaderT (IORef Int) IO)
  --   server_rio = counterPage :<|> failPage
  -- server_io <- hoistServerM counterAPI toIO server_rio


  let
    -- hoist IO into Handler
    server = hoistServer counterAPI ioToHandler server_io

    app :: Application
    app = serve counterAPI server

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

-- Convert an IO action (possibly carrying Servant exceptions)
-- into a Servant `Handler`.
ioToHandler :: IO a -> Handler a
ioToHandler = Handler . ExceptT . try