Using servant with ReaderT IO a

问题:

I'm using the servant library for my JSON API. I need some help to get a ServerT MyAPI (ReaderT a IO) monad stack working.

Here's an example using ReaderT, but without integrating it with servant:

-- this code works

type TestAPI =
         "a" :> Get '[JSON] String
    :<|> "b" :> Get '[JSON] String

test2 :: EitherT ServantErr IO String
test2 = return "asdf"

testServer :: Int -> Server TestAPI
testServer code = test :<|> test2
  where
    test :: EitherT ServantErr IO String
    test = liftIO $ runReaderT (giveMeAMessage) code

-- this is contrived. In my real application I want to use a Reader for the database connection. 
giveMeAMessage :: ReaderT Int IO String
giveMeAMessage = do
    code <- ask
    name <- liftIO $ getProgName
    return $ show code <> name

So, now I would like to get it working with ServerT, following the example in this article.

-- this code doesn't compile 

testServerT :: ServerT TestAPI (ReaderT Int IO)
testServerT = test :<|> test
  where

    test :: EitherT ServantErr (ReaderT Int IO) String
    test = lift $ giveMeAMessage

testServer' :: Int -> Server TestAPI
testServer' code = enter (Nat $ liftIO . (`runReaderT` code)) testServerT

I get the following error:

server/Serials/Route/Test.hs:43:15:
    Couldn't match type ‘EitherT ServantErr (ReaderT Int IO) String’
                  with ‘ReaderT Int IO [Char]’
    Expected type: ServerT TestAPI (ReaderT Int IO)
      Actual type: EitherT ServantErr (ReaderT Int IO) String
                  :<|> EitherT ServantErr (ReaderT Int IO) String
    In the expression: test :<|> test
    In an equation for ‘testServerT’:
        testServerT
          = test :<|> test
          where
              test :: EitherT ServantErr (ReaderT Int IO) String
              test = lift $ giveMeAMessage
Failed, modules loaded: none.

How can I get rid of the error?

Followup question: I understand monad transformers generally, but I'm lost. What topics or links should I study to know enough to answer my own question?

回答1:

You were almost there, test should be:

test :: ReaderT Int IO String
test = giveMeAMessage

As for your other questions, I don't have time to answer just now but us servant developers should probably make it easier or better documented.

Could you please read through the source for whichever part confuses you, and then ask specific questions?

回答2:

After help from lots of folks and hours of reading random things here's a complete example of using Servant with ReaderT, done as fancy as I can (using newtype, and GeneralizedNewtypeDeriving, I also added ExceptT for exceptions).

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Serials.Route.Test where

import Control.Monad.Trans (lift)
import Control.Monad.Trans.Either
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Monoid
import Data.Text (Text, pack)
import Data.Text.Lazy (fromStrict)
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Servant.Server
import Servant
import Database.RethinkDB.NoClash
import System.Environment

data AppError = Invalid Text | NotFound | ServerError Text

newtype App a = App {
  runApp :: ReaderT Int (ExceptT AppError IO) a
} deriving (Monad, Functor, Applicative, MonadReader Int, MonadError AppError, MonadIO)

type TestAPI =
        "a" :> Get '[JSON] String
    :<|> "b" :> Get '[JSON] String
    :<|> "c" :> Get '[JSON] String

giveMeAMessage :: App String
giveMeAMessage = do
    code <- ask
    name <- getProgName'
    throwError $ Invalid "your input is invalid. not really, just to test"
    return $ show code <> name

testMaybe :: App (Maybe String)
testMaybe = return $ Nothing

testErr :: App (Either String String)
testErr = return $ Left "Oh no!"

getProgName' :: MonadIO m => m String
getProgName' = liftIO $ getProgName

hello :: IO String
hello = return "hello"

---------------------------------------------------------------

-- return a 404 if Nothing
isNotFound :: App (Maybe a) -> App a
isNotFound action = do
    res <- action
    case res of
      Nothing -> throwError $ NotFound
      Just v  -> return v

-- map to a generic error
isError :: Show e => App (Either e a) -> App a
isError action = do
    res <- action
    case res of
      Left e -> throwError $ ServerError $ pack $ show e
      Right v -> return v

-- wow, it's IN My monad here! that's swell
testServerT ::ServerT TestAPI App
testServerT = getA :<|> getB :<|> getC
  where

    getA :: App String
    getA = giveMeAMessage
    -- you can also lift IO functions
    --getA = liftIO $ hello

    -- I can map app functions that return Maybes and Eithers to 
    -- app exceptions using little functions like this
    getB :: App String
    getB = isNotFound $ testMaybe

    getC :: App String
    getC = isError $ testErr

-- this is awesome because I can easily map error codes here
runAppT :: Int -> App a -> EitherT ServantErr IO a
runAppT code action = do
    res <- liftIO $ runExceptT $ runReaderT (runApp action) code

    -- branch based on the error or value
    EitherT $ return $ case res of
      Left (Invalid text) -> Left err400 { errBody = textToBSL text }
      Left (NotFound)     -> Left err404
      Left (ServerError text) -> Left err500 { errBody = textToBSL text }
      Right a  -> Right a

textToBSL :: Text -> ByteString
textToBSL = encodeUtf8 . fromStrict

testServer' :: Int -> Server TestAPI
testServer' code = enter (Nat $ (runAppT code)) testServerT

回答3:

Recent versions of servant have simplified this a lot. See Using a custom monad in the servant cookbook.

nt :: State -> AppM a -> Handler a
nt s x = runReaderT x s

app :: State -> Application
app s = serve api $ hoistServer api (nt s) server