Sử dụng công chức với ReaderT IO a

Question

Tôi đang sử dụng thư viện servant cho JSON API của mình. Tôi cần một số trợ giúp để có được ngăn xếp đơn nguyên ServerT MyAPI (ReaderT a IO) hoạt động.

Dưới đây là một ví dụ sử dụng ReaderT, nhưng không tích hợp nó với tớ:

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

Vì vậy, bây giờ tôi muốn có được nó làm việc với ServerT, làm theo tấm gương trong 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 

tôi nhận được lỗi sau:

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. 

Làm thế nào tôi có thể thoát khỏi những lỗi?

Câu hỏi tiếp theo: Tôi hiểu biến thế đơn nguyên nói chung, nhưng tôi bị mất. Tôi nên nghiên cứu chủ đề hoặc liên kết nào để biết đủ để trả lời câu hỏi của riêng mình?

Answer 1

Bạn đã gần như ở đó, kiểm tra nên là:

test :: ReaderT Int IO String 
test = giveMeAMessage 

Đối với các câu hỏi khác của bạn, tôi không có thời gian để trả lời chỉ là bây giờ nhưng chúng tôi phát triển tớ có lẽ nên làm cho nó dễ dàng hơn hoặc tốt hơn tài liệu.

Bạn có thể đọc qua nguồn cho bất kỳ phần nào gây nhầm lẫn cho bạn và sau đó đặt câu hỏi cụ thể?

Answer 2

Sau khi được giúp đỡ từ rất nhiều người và giờ đọc những điều ngẫu nhiên, đây là một ví dụ hoàn chỉnh về việc sử dụng Servant với ReaderT, được thực hiện như tôi có thể (sử dụng newtype, và GeneralizedNewtypeDeriving, tôi cũng đã thêm ngoại trừ trường hợp ngoại lệ).

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