如何在自定义servant处理程序中响应HTTP状态？

Question

我创建了一个自定义的仆人处理

type ServiceSet = TVar (M.Map String [MicroService]) 
type LocalHandler = ReaderT ServiceSet IO 

但我没能找到一种方法来响应一个404未找到的状态代码，客户端在以下功能：

getService :: String -> LocalHandler MicroService 
getService sn = do 
    tvar <- ask 
    ms <- liftIO $ do 
    sl <- atomically $ do 
     sm <- readTVar tvar 
     return $ case M.lookup sn sm of 
     Nothing -> [] 
     Just sl -> sl 
    let n = length sl 
    i <- randomRIO (0, n - 1) 
    return $ if n == 0 
     then Nothing 
     else Just . head . drop i $ sl 
    case ms of 
    Nothing -> ??? -- throwError err404 
    Just ms' -> return ms' 

如何发送404个状态代码在???？

Answer 1

您需要将ExceptT添加到您的monad变换堆栈中。目前，只有ReaderT，没有办法对抛出错误的概念进行编码。

{-# LANGUAGE DataKinds  #-} 
{-# LANGUAGE TypeOperators #-} 

module Lib where 

import Control.Monad.Except 
import Control.Monad.Reader 
import Data.Maybe 
import Data.Map 
import GHC.Conc 
import Prelude hiding (lookup) 
import Servant.API 
import Servant.Server 
import System.Random 

type API = 
    Capture "name" String :> Get '[JSON] Int 

type World = 
    TVar (Map String [Int]) 

type Effects = 
    ExceptT ServantErr (ReaderT World IO) 

server :: World -> Server API 
server world = 
    enter (Nat transform) get 
    where 
    transform :: Effects a -> ExceptT ServantErr IO a 
    transform (ExceptT foo) = 
     ExceptT $ runReaderT foo world 

get :: String -> Effects Int 
get sn = do 
    tvar <- ask 
    ms <- liftIO $ do 
    sl <- atomically $ do 
     sm <- readTVar tvar 
     return (fromMaybe [] (lookup sn sm)) 
    let n = length sl 
    i <- randomRIO (0, n - 1) 
    return $ if n == 0 
     then Nothing 
     else Just . head . drop i $ sl 
    case ms of 
    Nothing -> 
     throwError err404 
    Just ms' -> 
     return ms' 

随着ExceptT ServantErr . ReaderT (TVar ...)你再throwError err404可以，这仆人将赶上并使用返回一个HTTP 404的自然转化ExceptT ServantErr . ReaderT (TVar ...) :~> ExceptT ServantErr然后就可以展开，从而以排出读者重新包装效果。总而言之，不是更多的代码。