diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs index 5c1ada3f..bbb5d871 100644 --- a/doc/cookbook/generic/Generic.lhs +++ b/doc/cookbook/generic/Generic.lhs @@ -5,7 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} -module Main (main, api, getLink, routesLinks, cliGet) where +module Main (main, api, getLink, routesLinks, cliGet, mainMyMonad) where import Control.Exception (throwIO) import Data.Proxy (Proxy (..)) @@ -104,3 +104,44 @@ main = do run 8000 app _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run" ``` + +## Using generics together with a custom monad + +If your app uses a custom monad, here's how you can combine it with +generics. + +```haskell +data AppCustomState = + AppCustomState + +type AppM = ReaderT AppCustomState Handler + +apiMyMonad :: Proxy (ToServantApi Routes) +apiMyMonad = genericApi (Proxy :: Proxy Routes) + +getRouteMyMonad :: Int -> AppM String +getRouteMyMonad = return . show + +putRouteMyMonad :: Int -> AppM Bool +putRouteMyMonad = return . odd + +recordMyMonad :: Routes (AsServerT AppM) +recordMyMonad = Routes {_get = getRouteMyMonad, _put = putRouteMyMonad} + +-- natural transformation +nt :: AppCustomState -> AppM a -> Handler a +nt s x = runReaderT x s + +appMyMonad :: AppCustomState -> Application +appMyMonad state = genericServeT (nt state) recordMyMonad + +mainMyMonad :: IO () +mainMyMonad = do + args <- getArgs + case args of + ("run":_) -> do + putStrLn "Starting cookbook-generic at http://localhost:8000" + run 8000 (appMyMonad AppCustomState) + _ -> + putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run" +``` diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index f9ea9abd..baa9e246 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -11,6 +12,8 @@ module Servant.Server.Generic ( AsServerT, AsServer, genericServe, + genericServeT, + genericServeT', genericServer, genericServerT, ) where @@ -38,6 +41,45 @@ genericServe => routes AsServer -> Application genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- by providing a transformation to bring each handler back in the 'Handler' +-- monad. +genericServeT + :: forall (routes :: * -> *) (m :: * -> *). + ( GenericServant routes (AsServerT m) + , GenericServant routes AsApi + , HasServer (ToServantApi routes) '[] + , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) + ) + => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Application +genericServeT f server = serve p $ hoistServer p f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- while using the given 'Context' to serve the application (contexts are typically +-- used by auth-related combinators in servant, e.g to hold auth checks) and the given +-- transformation to map all the handlers back to the 'Handler' monad. +genericServeT' + :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]). + ( GenericServant routes (AsServerT m) + , GenericServant routes AsApi + , HasServer (ToServantApi routes) ctx + , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) + ) + => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Context ctx -- ^ the 'Context' to serve the application with + -> Application +genericServeT' f server ctx = + serveWithContext p ctx $ + hoistServerWithContext p pctx f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + pctx = Proxy :: Proxy ctx + -- | Transform record of endpoints into a 'Server'. genericServer :: GenericServant routes AsServer