different handler monads in haskell-servant

gistfile1.hs

{-# LANGUAGE DataKinds, DefaultSignatures, FlexibleInstances, FunctionalDependencies, TypeFamilies, TypeOperators #-}
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader

import Data.Proxy

import Network.Wai

import Servant.API
import Servant.Server


-- user-facing API

-- `run` turns one handler into another
run :: (Handler h, ExecHandler e a, e ~ Base h) => h -> a (UnwrapHandler h)
run handler = unwrap <$> exec <*> pure handler

-- typeclasses
class Handler h where
        -- user defined handler monads define this
        type UnwrapHandler h :: *

        -- these are only used internally, and not exported
        type Base h :: *
        type Base h = h
        unwrap :: (Base h -> UnwrapHandler (Base h)) -> h -> UnwrapHandler h
        default unwrap :: (h ~ Base h) => (Base h -> UnwrapHandler (Base h)) -> h -> UnwrapHandler h
        unwrap = id

class (Handler h, h ~ Base h, Applicative a) => ExecHandler h a | h -> a where
        -- user defined handler monads implement this
        exec :: a (h -> UnwrapHandler h)

-- USAGE:
--
-- To use another type as handler (e.g. a monad `M`), the user defines the following instances:
--   instance Handler (M a) where
--       type UnwrapHandler (M a) :: ...
--   instance ExecHandler (M a) app where
--       exec = ...
--
-- The type `UnwrapHandler (M a)` defined what other handler (M a) can be turned into.
-- The most common thing here will be `EitherT (Int,String) IO a`, but this can also be used to nest handlers.
--
-- The `ExecHandler` instance gives a way to execute the inner handler. The `exec` function does the actual
-- transformation. The `app` type argument is an Applicative that gives the type of the `exec` function.
--
-- The `run` function can then be used to convert handlers into other handlers.
--
-- For example, consider the instance:
--   instance Handler (M a) where
--       type UnwrapMandler (M a) = EitherT (Int,String) IO a
--   instance ExecHandler (M a) ((->) x) where
--       ...
--
-- Then `run` can be used as follows:
--   run :: m a -> x -> EitherT (Int,String) IO a
--   run :: (arg -> m a) -> x -> arg -> EitherT (Int,String) IO a
--   run :: (arg1 -> arg2 -> m a) -> x -> arg1 -> arg2 -> EitherT (Int,String) IO a
--   run :: ((arg -> m a) :<|> m b) -> x -> ((arg -> EitherT (Int,String) IO a) :<|> EitherT (Int,String) IO b)
--     ...


-- predefined instances
instance Handler h => Handler (a -> h) where
        type Base (a -> h) = Base h
        type UnwrapHandler (a -> h) = a -> UnwrapHandler h
        unwrap baseUnwrap fn a = unwrap baseUnwrap (fn a)

instance (Handler a, Handler b, Base a ~ Base b) => Handler (a :<|> b) where
        type Base (a :<|> b) = Base a
        type UnwrapHandler (a :<|> b) = UnwrapHandler a :<|> UnwrapHandler b
        unwrap baseUnwrap (a :<|> b) = unwrap baseUnwrap a :<|> unwrap baseUnwrap b


--
-- EXAMPLES (not part of servant, the user writes this code)
--

-- let's assume all our server side code runs in (ReaderT ServerContext IO)
data ServerContext = ServerContext
type ServerMonad a = ReaderT ServerContext IO a

-- declare that (ReaderT s m) can be transformed into (EitherT (Int,String) m a)...
instance Monad m => Handler (ReaderT s m a) where
        type UnwrapHandler (ReaderT s m a) = EitherT (Int,String) m a

-- ... and how to execute it
instance Monad m => ExecHandler (ReaderT s m a) ((->) s) where
        exec s reader = lift $ runReaderT reader s

type MyAPI = "hello" :> Capture "name" String :> Get String
myAPI :: Proxy MyAPI
myAPI = Proxy

myHandler :: String -> ServerMonad String
myHandler name = return $ "Hello, " ++ name

-- (run myHandler) :: ServerContext -> String -> EitherT (Int,String) IO String
myApplication :: ServerContext -> Application
myApplication ctx = serve myAPI (run myHandler ctx)


-- let's introduce another monad for authenticated requests...
newtype SessionMonad a = SessionMonad a

instance Functor SessionMonad where fmap = undefined
instance Applicative SessionMonad where pure = undefined ; (<*>) = undefined
instance Monad SessionMonad where (>>=) = undefined ; return = undefined

runAuthenticated :: Maybe String -> SessionMonad a -> ServerMonad a
runAuthenticated = undefined

getUserId :: SessionMonad String
getUserId = undefined

-- ... and declare it as a sub-monad of ServerMonad
instance Handler (SessionMonad a) where
        type UnwrapHandler (SessionMonad a) = ServerMonad a

instance ExecHandler (SessionMonad a) ((->) (Maybe String)) where
        exec = runAuthenticated

-- and let's introduce a shortcut for API definition
-- (note that this is not a new type level combinator, just a synonym)
type Auth api = Header "Authentication" String :> api


type MyAuthAPI = "authHello" :> Get String

myAuthHandler :: SessionMonad String
myAuthHandler = do name <- getUserId
                   return $ "Hello, authenticated " ++ name

-- we can now compose the handlers
type CompAPI = MyAPI :<|> Auth MyAuthAPI
compAPI :: Proxy CompAPI
compAPI = Proxy

-- (run myAuthHandler) :: Maybe String -> ServerMonad String
compHandler = myHandler :<|> run myAuthHandler

compApplication :: ServerContext -> Application
compApplication ctx = serve compAPI (run compHandler ctx)

-- CAVEATS (or: why I'm not 100% satisfied with this yet):
-- 
-- - The `UnwrapHandler h` type is a type function, so this defines a kind of one-way street how handler types
--   are transformed into each other, with eath handler `h` having exactly one parent `UnwrapHandler h`.
--   I tried making it a second argument to the typeclass, but then the types become ambiguous.
-- 
-- - The second argument of the `ExecHandler` typeclass can not be a type synonym. That means it's not possible
--   to for example have an `exec` function with two arguments, or no argument. You can of course uncurry or pass,
--   but that doesn't compose so well. For example, the trick with the `Auth` type alias wouldn't work so nice if it
--   would contain two capturing path components (e.g. a second header).