Struggling with wiring-up a pair of type-class constrained monads within servant

Question

Please scroll-down to read an important edit to this question

Original (long-winded) question

My web-app's code is written in a type-class constrained monad, which looks something like this:

fetchOrderById :: (HasDatabase m) => Args -> m Result

sendConfirmationMail :: (HasSmtp m) => Args -> m EmailId

Each module has it's own server block, which looks like this:

data Routes route = Routes
  { rFetchOrder :: route :- CustomAuth :> "orders" :> Capture "OrderId" OrderId :> Get '[JSON] Order
  , rDeleteOrder :: route :- CustomAuth :> "deleteOrder" :> Capture "OrderId" OrderId :> Delete '[JSON] ()
  }

--
-- NOTE: This type-signature WILL NOT compile...
--
server :: Routes (AsServerT m)
server = Routes
  { rFetchOrder = \userId orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = \userId orderId -> runForUser deleteOrderPerms userId $ deleteOrderById orderId
  }

fetchOrderPerms :: Proxy '[ 'PermissionFetchOrder]
fetchOrderPerms = Proxy

deleteOrderPerms :: Proxy '[ 'PermissionDeleteOrder]
deleteOrderPerms = Proxy

Now, the runForUser function is where the "pair" of monads comes in. I want runForUser to have the following type-sig, where it transforms the "inner monad" n to the outer monad m WITHOUT making either of them concrete:

runForUser :: UserId -> n a -> m a

This "type-class magic" is required to not commit to a concrete monad as long as possible, which will, hopefully, allow me to write tests.

When finally wired-up for the production app, here's what runForUid will transform:

AppM '[PermissionFetchOrder] a -> ServantM a

AppM '[PermissionDeleteOrder] a -> ServantM a

-- and so on...

And when wired-up for tests:

TestM '[PermissionFetchOrder] a -> TestServantM a

TestM '[PermissionDeleteOrder] a -> TestServantM a

-- and so on...

I'm struggling with writing a type-class for the runForUid function. I've tried various techniques, and the closest that I've gotten is the following:

-- 
-- This compiles...
--
class (HasDatabase (InnerMonad m), HasSmtp (InnerMonad m)) => RunForUser m where
  type InnerMonad m :: * -> *

  runForUser :: Proxy (p :: [Permission]) ->  UserId -> (InnerMonad m) a -> m a


--
-- Even this compiles...
--
server :: (RunForUser m) => Routes (ServerT m)
server = Route
  { rFetchOrder = \uid orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = ...
  }

-- 
-- And this is where it gets stuck, because the compiler 
-- doesn't know how to deal with `perms` as it is not in 
-- scope
--
instance (HasDatabase (AppM perms), HasSmtp (AppM perms)) => RunForUser ServantM where
  type InnerMonad ServantM = AppM (perms :: [Permission])

  runForUser permProxy userId action = ...

If the solution that I have presented above, is on the right track, then my question is - how do I tell the compiler to not worry about perms? That is a job for the implementation of runForUser. Can I use RankNTypes in any way and stick a forall perms somewhere and get this to work?

On the other hand, if the approach given above is complete garbage, what is a better way to get this done?

Edit

I may have found an acceptable solution, but I'm still looking for a better way to avoid the type-related boilerplate.

{-# LANGUAGE DataKinds, RankNTypes, PartialSignature, ScopedTypeVariables -#}

type HasApp m = (HasDatabase m, HasSmtp m)

class HasServant ...

class (HasApp m, HasServant n) => RunForUser m n where
  runForUser :: Proxy (perms :: [Permission]) -> UserId -> m a -> n a

server :: forall m n . (RunForUser m n, HasApp m) => Routes (AsServerT n)
server = Routes
  { rFetchOrder = \userId orderId -> 
      runForUser fetchOrderPerms userId 
        --
        -- NOTE: Had to manually annotate the type `m a` and had
        -- to use PartialTypeSignatures to avoid having to specify
        -- the type `a` again.
        --
        (fetchOrderById orderId :: m _)
  , ...
  }

Saurabh Nanda Saurabh Nanda · Accepted Answer · 2019-07-09T05:01:35

Although my entire codebase has not yet compiled, I may have a possible answer that uses RankNTypes:

type HasApp m = (HasDatabase m, HasSmtp m)

type UserRunner m n = (forall perms a . Proxy (perms :: [Permission]) -> UserId -> (HasApp (m perms) => m perms a) -> n a)

server :: UserRunner m n -> Routes (AsServerT n)
server runForUid = Routes
  { rFetchOrder = \uid orderId -> runForUid fetchOrderPerms uid $ fetchOrderById orderId
  , rDeleteOrder = \uid orderId -> runForUid deleteOrderPerms uid $ deleteOrderById orderId
  }

Struggling with wiring-up a pair of type-class constrained monads within servant

Original (long-winded) question

Edit

1 Answers