我 试图 弄 清楚 如何 在 servant-websocket 库 提供 的 WebSocketConduit 端点 的 ConduitT 定义 中 使用 自 定义 单子 。
假设 我 有 这个 API ：

type MyAPI = "ws" :> WebSocketConduit Value Value

中 的 每 一 个
如果 我 试图 为 端点 定义 一 个 只 复制 输入 处理 程序 ， 但 指定 的 Monad 与 参数 m 不同 ：

ws :: ConduitT Value Value (Reader String) ()
ws _ = CL.map id

格式
我 得到 这个 错误 ：

• Couldn't match type: transformers-0.5.6.2:Control.Monad.Trans.Reader.ReaderT
                             String Data.Functor.Identity.Identity
                     with: resourcet-1.2.5:Control.Monad.Trans.Resource.Internal.ResourceT
                             IO

格式
我 之所以 遇到 这个 问题 ， 是 因为 我 想 使用 的 单子 是 一 词 多义 产生 的 ， 有 很多 效果 ， 但 我 想 使用 Reader 单子 来 保持 例子 的 简单 。
因此 ， 一般 的 问题 是 ， 如何 在 Conduit Websocket 端点 中 使用 自 定义 monad ？

• • 解决 方案 * *

感谢 fghibellini 的 提示 ， 这 是 一 个 玩具 示例 的 完整 解决 方案 ：

#!/usr/bin/env stack
{-
 stack --resolver lts-19.07 script --package servant --package servant-server
       --package servant-websockets --package polysemy --package aeson --package mtl
       --package wai --package warp --package conduit
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Conduit
import qualified Data.Conduit.List as CL
import Control.Monad.Except (ExceptT(ExceptT))
import Data.Aeson (ToJSON, FromJSON)
import Data.Char (toUpper)
import Data.Function ((&))
import GHC.Generics ( Generic )
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Polysemy ( runM, Sem, Members, Embed )
import Polysemy.Error ( runError, Error )
import Polysemy.Trace ( trace, traceToStdout, Trace )
import Servant
import Servant.API.WebSocketConduit (WebSocketConduit)
import Servant.Server

-- Dummy message
newtype Message = Message { content :: String } deriving (Show, Generic)

instance ToJSON Message
instance FromJSON Message

type MyApi = "toupper" :> ReqBody '[JSON] Message :> Post '[JSON] Message
            :<|> "ws-toupper" :> WebSocketConduit Message Message
            :<|> "ws-toupper-sem" :> WebSocketConduit Message Message

server :: Members '[Trace, Embed IO] r => ServerT MyApi (Sem r)
server = toupper :<|> wstoupper :<|> wstoupperWithSem

toupper :: Members '[Trace, Embed IO] r => Message -> Sem r Message
toupper (Message msg) = do
  trace $ "Received msg in the REST endpoint: " ++ msg
  return (Message . map toUpper $ msg)

wstoupper :: Monad m => ConduitT Message Message m ()
wstoupper = CL.map (\(Message msg) -> Message . map toUpper $ msg)

wstoupperWithSem :: ConduitT Message Message (ResourceT IO) ()
wstoupperWithSem = transPipe (liftIO . interpreter) semConduit
  where
    interpreter :: Sem '[Trace , Embed IO] a -> IO a
    interpreter sem = sem
      & traceToStdout
      & runM

    semConduit :: Members '[Trace, Embed IO] r => ConduitT Message Message (Sem r) ()
    semConduit = mapMC effect

    effect :: Members '[Trace] r => Message -> Sem r Message
    effect (Message msg) = do
      trace $ "Received msg through the WS: " ++ msg
      return (Message . map toUpper $ msg)

liftServer :: ServerT MyApi Handler
liftServer = hoistServer api interpreter server
  where
    interpreter :: Sem '[Trace, Error ServerError , Embed IO] a -> Handler a
    interpreter sem = sem
      & traceToStdout
      & runError
      & runM
      & liftHandler

    liftHandler = Handler . ExceptT

api :: Proxy MyApi
api = Proxy

app :: Application
app = serve api liftServer

main :: IO ()
main = do
  putStrLn "Starting server on http://localhost:8080"
  run 8080 app

格式