diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs index 5c1ada3f..29f33052 100644 --- a/doc/cookbook/generic/Generic.lhs +++ b/doc/cookbook/generic/Generic.lhs @@ -7,10 +7,11 @@ {-# LANGUAGE TypeOperators #-} module Main (main, api, getLink, routesLinks, cliGet) where -import Control.Exception (throwIO) -import Data.Proxy (Proxy (..)) -import Network.Wai.Handler.Warp (run) -import System.Environment (getArgs) +import Control.Exception (throwIO) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.Proxy (Proxy (..)) +import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) import Servant import Servant.Client @@ -102,5 +103,39 @@ main = do ("run":_) -> do putStrLn "Starting cookbook-generic at http://localhost:8000" run 8000 app + -- see this cookbook below for custom-monad explanation + ("run-custom-monad":_) -> do + putStrLn "Starting cookbook-generic with a custom monad at http://localhost:8000" + run 8000 (appMyMonad AppCustomState) _ -> 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 diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index f9ea9abd..c3a2e3b4 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, + genericServeTWithContext, 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. +genericServeTWithContext + :: 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 +genericServeTWithContext 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