使用带有ReaderT IO的servant a

Question

我正在使用该servant库作为我的JSON API.我需要一些帮助才能使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 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

在很多人的帮助和几个小时的随机阅读之后,这里有一个完整的例子,使用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 2

你几乎在那里,测试应该是:

test :: ReaderT Int IO String
test = giveMeAMessage

至于你的其他问题,我现在没有时间回答,但我们的仆人开发者应该更容易或更好地记录.

您能否阅读一下您遇到困扰的部分,然后提出具体问题？