How to use custom Monad with wai's `Application`?

[hasufell]

Say, you have an API built according to https://docs.servant.dev/en/stable/cookbook/using-custom-monad/UsingCustomMonad.html

Now you additionally have a Raw endpoint and want access to the ReaderT environment in the handler, which now is of type Application and not Handler.

Whatever I tried, I could not make it work (of course, I can pass the environment explicitly to the server function so I can just runReaderT, but that's not the "using custom monad" approach).

Example code:

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}

module Main where

import Control.Concurrent.Chan
import Control.Monad.IO.Class
import Data.Proxy
import Servant.API
import Servant.Server
import Network.Wai
import Control.Monad.Trans.Reader
import Network.Wai.Handler.Warp ( run )
import Network.Wai.Internal


type AppM = ReaderT AppState Handler

type WaiApplicationM = Request -> (Response -> IO ResponseReceived) -> AppM ResponseReceived

data AppState = AppState (Chan Int)

type API = LOL :<|> WAI

type WAI = "wai" :> Raw
type LOL = "lol" :> Get '[JSON] [Int]

api :: Proxy API
api = Proxy

server :: ServerT API AppM
server = lol :<|> (Tagged waiHandler :: Tagged AppM WaiApplicationM)
  where
    waiHandler :: WaiApplicationM
    waiHandler = \_ _ -> pure ResponseReceived

    lol :: AppM [Int]
    lol = do
      liftIO $ putStrLn "lol"
      return [1]

app :: Application
app = \req resp -> do
  c <- newChan
  serve api (hoistServer api (nt (AppState c)) $ server) req resp
 where
  nt :: AppState -> AppM a -> Handler a
  nt s x = flip runReaderT s x   

main :: IO ()
main = run 8081 app

Error:

app/Main.hs:36:10: error:
    • Couldn't match type ‘ReaderT AppState Handler ResponseReceived’
                     with ‘IO ResponseReceived’
      Expected type: ServerT API AppM
        Actual type: AppM [Int] :<|> Tagged AppM WaiApplicationM
    • In the expression:
        lol :<|> (Tagged waiHandler :: Tagged AppM WaiApplicationM)
      In an equation for ‘server’:
          server
            = lol :<|> (Tagged waiHandler :: Tagged AppM WaiApplicationM)
            where
                waiHandler :: WaiApplicationM
                waiHandler = \ _ _ -> pure ResponseReceived
                lol :: AppM [Int]
                lol
                  = do liftIO $ putStrLn "lol"
                       ....
   |
36 | server = lol :<|> (Tagged waiHandler :: Tagged AppM WaiApplicationM)

[arianvp]

Have you seen the https://hackage.haskell.org/package/wai-transformers-0.0.5/docs/Network-Wai-Trans.html package? I wonder if it could help

[hasufell]

Well, the problem isn't how to transform my transformer into Application, the problem is that the hoisting is deferred to the app start

app :: Application
app = \req resp -> do
  c <- newChan
  serve api (hoistServer api (nt (AppState c)) $ server) req resp
 where
  nt :: AppState -> AppM a -> Handler a
  nt s x = flip runReaderT s x   

So the natural transformation here is nt :: AppState -> AppM a -> Handler a, which does not align with Application/WaiApplicationM. So to me it seems this is a limitation of servants custom monad approach.

[gdeest]

I'd say the core issue here is not in the “custom approach” monad per se, but rather in the way the Raw combinator is implemented. We have type ServerT Raw m = Tagged m Application, but at first glance I don't see why we couldn't have a RawHandler combinator such that:

type ServerT RawHandler m = Request -> m Response

which would allow you to access your Reader environment.

There may be some difficulty I didn't think of, but Raw may just have been implemented the way it is because its primary purpose was to integrate with existing / non-servant WAI applications.

[hasufell]

There may be some difficulty I didn't think of, but Raw may just have been implemented the way it is because its primary purpose was to integrate with existing / non-servant WAI applications.

Yeah, I think that's true. The reason I use WAI application is because I utilize server-sent events via https://hackage.haskell.org/package/wai-extra-3.1.8/docs/Network-Wai-EventSource.html

type ServerT RawHandler m = Request -> m Response

Do you mean type ServerT RawHandler m = Tagged m (Request -> (Response -> m ResponseReceived) -> m ResponseReceived)?

This seems to be the current implementation:

servant/servant-server/src/Servant/Server/Internal.hs

Lines 591 to 593 in 7ef9730

	instance HasServer Raw context where
	type ServerT Raw m = Tagged m Application

Is there anything else special about the Raw type?

[hasufell]

I gave it a shot and I can't seem to find a way to implement this. The problem is:

  hoistServerWithContext :: Proxy RawHandler
                         -> Proxy context
                         -> (forall x. m x -> n x)
                         -> ServerT RawHandler m
                         -> ServerT RawHandler n

This has one natural transformation. However, given

type ApplicationT m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived

In order to transform ApplicationT m to ApplicationT n we seem need two natural transformations (from wai-transformers):

hoistApplicationT :: ( Monad m
                     , Monad n
                     ) => (forall a. m a -> n a)
                       -> (forall a. n a -> m a)
                       -> ApplicationT m
                       -> ApplicationT n
hoistApplicationT to from app req resp =
  to $ app req (from . resp)

[hasufell]

Ok, I made it compile this way...

instance HasServer RawHandler context where

  type ServerT RawHandler m = Tagged m (Request -> (Response -> IO ResponseReceived) -> m ResponseReceived)

  hoistServerWithContext _ _ n s =
    Tagged $ \req resp -> (\app -> n $ app req resp) . unTagged $ s

  route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
    r <- runDelayed (rawApplication) env request
    liftIO $ go r request respond

    where go r request respond = case r of
            Route app   -> do
              res <- runHandler $ (untag app) request (respond . Route)
              case res of
                Right r' -> pure r'
                Left e   -> liftIO $ respond $ FailFatal e
            Fail a      -> liftIO $ respond $ Fail a
            FailFatal e -> liftIO $ respond $ FailFatal e

Here we have to runHandler and throw the possible ServantError via liftIO $ respond $ FailFatal e... I'm not sure how correct this is.

[alpmestan]

There may be some difficulty I didn't think of, but Raw may just have been implemented the way it is because its primary purpose was to integrate with existing / non-servant WAI applications.

It has historically served two purposes: file serving and "low level endpoints" that can do anything they want with requests/responses (websockets, SSE, and all kinds of things that require direct access to arbitrary bits of the request, embedding an app indeed, etc).

[gdeest]

OK, a few comments / thoughts:

• I don't think we need Tagged anymore (the monad type appears in the RHS of the ServerT definition without it).
• I really think Request -> m Response should be enough. There is no need to require users to call respond themselves ; we can do it on their behalf in the route method.

I have the following working here (which is very similar to what you have):

instance HasServer RawM context where
  type ServerT RawM m = Request -> m Response

  route :: Proxy RawM -> Context context -> Delayed env (Request -> Handler Response) -> Router env
  route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
    routeResult <- runDelayed handleDelayed env request
    liftIO $ do
      ret <- case routeResult of
        Route handler   -> runHandler (handler request) >>=
          \case
             Left e -> pure $ FailFatal e
             Right a -> pure $ Route a
        Fail e -> pure $ Fail e
        FailFatal e -> pure $ FailFatal e
      respond ret

  hoistServerWithContext _ _ = fmap

I am still pondering whether that is the design we want, though.