在ReaderT IO a中使用服务程序

Question

我正在为我的JSON使用servant库。我需要一些帮助，使一个ServerT MyAPI (ReaderT a IO)单栈工作。

下面是一个使用ReaderT的示例，但是没有将它与服务集成：

-- 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.

我怎样才能消除这个错误？

后续问题:我大致了解单台变压器，但我迷路了。我应该学习哪些主题或链接来了解足够多的知识来回答自己的问题？

Answer 1

你快到了，测试应该是：

test :: ReaderT Int IO String
test = giveMeAMessage

至于您的其他问题，我现在没有时间回答，但是美国的仆人开发人员可能会使它更容易或更好地记录下来。

请你翻阅资料中任何令你困惑的部分，然后问一些具体的问题。

Answer 2

在许多人的帮助和几个小时的随机阅读之后，这里有一个使用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

最近版本的仆人已经大大简化了这一点。请参阅仆人食谱中的使用自定义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