Add serveWithContextT, ServerContext (#1441)

servant-server: add serveWithContexT and ServerContext

.github/workflows/master.yml

@@ -95,8 +95,8 @@ jobs:
     runs-on: ubuntu-latest
     strategy:
       matrix:
-        stack: ["2.3.1"]
-        ghc: ["8.8.4"]
+        stack: ["2.7.3"]
+        ghc: ["8.10.4"]
 
     steps:
     - uses: actions/checkout@v2

servant-docs/servant-docs.cabal

@@ -102,7 +102,7 @@ test-suite spec
 
   -- Additional dependencies
   build-depends:
-      tasty         >= 1.1.0.4  && < 1.3,
+      tasty         >= 1.1.0.4  && < 1.5,
       tasty-golden  >= 2.3.2    && < 2.4,
       tasty-hunit   >= 0.10.0.1 && < 0.11,
       transformers  >= 0.5.2.0  && < 0.6

servant-server/src/Servant/Server.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
@@ -11,6 +12,8 @@ module Servant.Server
   ( -- * Run a wai application from an API
     serve
   , serveWithContext
+  , serveWithContextT
+  , ServerContext
 
   , -- * Construct a wai Application from an API
     toApplication
@@ -128,6 +131,15 @@ import           Servant.Server.UVerb
 
 -- * Implementing Servers
 
+-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'.
+--
+-- Typically, this will add default context entries to the context. You shouldn't typically
+-- need to worry about these constraints, but if you write a helper function that wraps
+-- 'serveWithContext', you might need to include this constraint.
+type ServerContext context =
+  ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
+  )
+
 -- | 'serve' allows you to implement an API and produce a wai 'Application'.
 --
 -- Example:
@@ -157,11 +169,21 @@ serve p = serveWithContext p EmptyContext
 -- 'defaultErrorFormatters' will always be appended to the end of the passed context,
 -- but if you pass your own formatter, it will override the default one.
 serveWithContext :: ( HasServer api context
-                    , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )
+                    , ServerContext context
+                    )
     => Proxy api -> Context context -> Server api -> Application
-serveWithContext p context server =
-  toApplication (runRouter format404 (route p context (emptyDelayed (Route server))))
+serveWithContext p context = serveWithContextT p context id
+
+-- | A general 'serve' function that allows you to pass a custom context and hoisting function to
+-- apply on all routes.
+serveWithContextT ::
+  forall api context m.
+  (HasServer api context, ServerContext context) =>
+  Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application
+serveWithContextT p context toHandler server =
+  toApplication (runRouter format404 (route p context (emptyDelayed router)))
   where
+    router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server
     format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
 
 -- | Hoist server implementation.

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.24
+resolver: lts-18.5
 packages:
 - servant-client-core/
 - servant-client/

stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290
+    pantry-tree:
+      size: 809
+      sha256: 17af1c2e709cd84bfda066b9ebb04cdde7f92660c51a1f7401a1e9f766524e93
+  original:
+    hackage: hspec-wai-0.10.1
+snapshots:
+- completed:
+    size: 585817
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+    sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887
+  original: lts-18.5