From c1e15ef4c335c733ad019dd1c5fd148b2133bda7 Mon Sep 17 00:00:00 2001 From: Kostiantyn Rybnikov Date: Sat, 20 Oct 2018 20:48:03 +0300 Subject: [PATCH 1/3] 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 From 5620d2d781b80d47b5de0e1150b2ca04d28f8c3e Mon Sep 17 00:00:00 2001 From: Kostiantyn Rybnikov Date: Mon, 22 Oct 2018 14:09:45 +0300 Subject: [PATCH 2/3] Rename one function, run custom monad code from main --- doc/cookbook/generic/Generic.lhs | 17 +++++------------ servant-server/src/Servant/Server/Generic.hs | 6 +++--- 2 files changed, 8 insertions(+), 15 deletions(-) diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs index bbb5d871..d41da7af 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, mainMyMonad) where +module Main (main, api, getLink, routesLinks, cliGet) where import Control.Exception (throwIO) import Data.Proxy (Proxy (..)) @@ -102,6 +102,10 @@ 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" ``` @@ -134,14 +138,3 @@ 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 baa9e246..c3a2e3b4 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -13,7 +13,7 @@ module Servant.Server.Generic ( AsServer, genericServe, genericServeT, - genericServeT', + genericServeTWithContext, genericServer, genericServerT, ) where @@ -62,7 +62,7 @@ genericServeT f server = serve p $ hoistServer p f (genericServerT server) -- 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' +genericServeTWithContext :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]). ( GenericServant routes (AsServerT m) , GenericServant routes AsApi @@ -73,7 +73,7 @@ genericServeT' -> routes (AsServerT m) -- ^ your record full of request handlers -> Context ctx -- ^ the 'Context' to serve the application with -> Application -genericServeT' f server ctx = +genericServeTWithContext f server ctx = serveWithContext p ctx $ hoistServerWithContext p pctx f (genericServerT server) where From 9d06e42525c77d6cd9f5f159f13fa89ed59c4bad Mon Sep 17 00:00:00 2001 From: Kostiantyn Rybnikov Date: Tue, 23 Oct 2018 09:41:58 +0300 Subject: [PATCH 3/3] Add ReaderT import --- doc/cookbook/generic/Generic.lhs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs index d41da7af..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