From c1e15ef4c335c733ad019dd1c5fd148b2133bda7 Mon Sep 17 00:00:00 2001
From: Kostiantyn Rybnikov <k-bx@k-bx.com>
Date: Sat, 20 Oct 2018 20:48:03 +0300
Subject: [PATCH] genericServeT and docs on using a custom monad with generics

---
 doc/cookbook/generic/Generic.lhs             | 43 +++++++++++++++++++-
 servant-server/src/Servant/Server/Generic.hs | 42 +++++++++++++++++++
 2 files changed, 84 insertions(+), 1 deletion(-)

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