将 servant 与 ReaderT IO a 一起使用

Question

我正在为我的 JSON API 使用 servant 库。我需要一些帮助才能使 ServerT MyAPI (ReaderT a IO) monad 堆栈正常工作。

这是一个使用 ReaderT 的示例，但没有将其与 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

所以，现在我想让它与 ServerT 一起使用，按照 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

我收到以下错误：

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.

如何消除错误？

后续问题：我大体上了解 monad 转换器，但我迷路了。我应该学习哪些主题或链接才能知道足以回答我自己的问题？

Answer 1

你快到了，测试应该是：

test :: ReaderT Int IO String
test = giveMeAMessage

至于你的其他问题，我现在没有时间回答，但我们的仆人开发人员可能应该让它更容易或更好地记录下来。

能否请您通读一下源码，找出您感到困惑的部分，然后提出具体问题？

Answer 2

在很多人的帮助和数小时随机阅读之后，这里有一个将 Servant 与 ReaderT 结合使用的完整示例，尽我所能（使用 newtype 和 GeneralizedNewtypeDeriving，我还添加了 ExceptT 作为例外）。

{-# 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

Answer 3

servant 的最新版本对此进行了很多简化。参见仆人食谱中的Using a custom monad。

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

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

将 servant 与 ReaderT IO a 一起使用

Using servant with ReaderT IO a

monads

haskell

monad-transformers