How to use your own Monad in servant-websocket's conduit endpoint?

Question

I'm trying to figure out how to use a custom monad in the ConduitT definition of the WebSocketConduit endpoint provided by the servant-websocket library.

Say that I have this API:

type MyAPI = "ws" :> WebSocketConduit Value Value

if I try to define a handler for that endpoint that just copies input but I specify a Monad different from the parametric m:

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

I get this error:

    • 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

I faced this problem because the monad I want to use is one created with Polysemy with lots of effects, but I wanted to keep the example simple using the Reader monad.

So the general question is, how do you use a custom monad in a Conduit Websocket endpoint?

Solution

Thanks to the tips from fghibellini this is the full solution to a toy example:

#!/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