Named-based selection of sub-API

Update example to redirect within NamedRoutes
Complete usage example (empty HasServer instance)
2022-04-13 13:39:45 +02:00 · 2022-04-13 11:51:12 +02:00 · 2022-04-13 11:28:11 +02:00 · 2022-04-04 10:51:40 +02:00
69 changed files with 222 additions and 550 deletions
--- a/.github/workflows/master.yml
+++ b/.github/workflows/master.yml
@ -20,7 +20,6 @@ jobs:
          - "8.10.7"
          - "9.0.2"
          - "9.2.2"
-          - "9.4.2"

    steps:
    - uses: actions/checkout@v2
@ -76,40 +75,40 @@ jobs:
        (cd servant-conduit && eval $DOCTEST)
        (cd servant-pipes && eval $DOCTEST)

-  # stack:
-  #   name: stack / ghc ${{ matrix.ghc }}
-  #   runs-on: ubuntu-latest
-  #   strategy:
-  #     matrix:
-  #       stack: ["2.7.5"]
-  #       ghc: ["8.10.7"]
+  stack:
+    name: stack / ghc ${{ matrix.ghc }}
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        stack: ["2.7.5"]
+        ghc: ["8.10.7"]

-  #   steps:
-  #   - uses: actions/checkout@v2
+    steps:
+    - uses: actions/checkout@v2

-  #   - uses: haskell/actions/setup@v1
-  #     name: Setup Haskell Stack
-  #     with:
-  #       ghc-version: ${{ matrix.ghc }}
-  #       stack-version: ${{ matrix.stack }}
+    - uses: haskell/actions/setup@v1
+      name: Setup Haskell Stack
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        stack-version: ${{ matrix.stack }}

-  #   - uses: actions/cache@v2.1.3
-  #     name: Cache ~/.stack
-  #     with:
-  #       path: ~/.stack
-  #       key: ${{ runner.os }}-${{ matrix.ghc }}-stack
+    - uses: actions/cache@v2.1.3
+      name: Cache ~/.stack
+      with:
+        path: ~/.stack
+        key: ${{ runner.os }}-${{ matrix.ghc }}-stack

-  #   - name: Install dependencies
-  #     run: |
-  #       stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
+    - name: Install dependencies
+      run: |
+        stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

-  #   - name: Build
-  #     run: |
-  #       stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
+    - name: Build
+      run: |
+        stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

-  #   - name: Test
-  #     run: |
-  #       stack test --system-ghc
+    - name: Test
+      run: |
+        stack test --system-ghc

  ghcjs:
    name: ubuntu-latest / ghcjs 8.6
--- a/cabal.project
+++ b/cabal.project
@ -47,7 +47,6 @@ packages:
  doc/cookbook/using-custom-monad
  doc/cookbook/using-free-client
  -- doc/cookbook/open-id-connect
-  doc/cookbook/managed-resource

 tests: True
 optimization: False
--- a/changelog.d/1573
+++ b/changelog.d/1573
@ -1,2 +0,0 @@
-synopsis: Add API docs for ServerT
-prs: #1573
--- a/changelog.d/1580
+++ b/changelog.d/1580
@ -1,12 +0,0 @@
-synopsis: Allow IO in validationKeys
-prs: #1580
-issues: #1579
-
-description: {
-
-Currently validationKeys are a fixed JWKSet. This does not work with OIDC
-providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to
-discover new and expired keys.
-
-This change alters the type of validationKeys from JWKSet to IO JWKSet.
-}
--- a/changelog.d/1589
+++ b/changelog.d/1589
@ -1,2 +0,0 @@
-synopsis: Only include question mark for nonempty query strings
-prs: 1589
--- a/changelog.d/1595
+++ b/changelog.d/1595
@ -1,2 +0,0 @@
-synopsis: Run ClientEnv's makeClientRequest in IO.
-prs: #1595
--- a/changelog.d/1606
+++ b/changelog.d/1606
@ -1,10 +0,0 @@
-synopsis: Handle Cookies correctly for RunStreamingClient
-prs: #1606
-issues: #1605
-
-description: {
-
-Makes performWithStreamingRequest take into consideration the
-CookieJar, which it previously didn't.
-
-}
--- a/changelog.d/1638
+++ b/changelog.d/1638
@ -1,2 +0,0 @@
-synopsis: Add Functor instance to AuthHandler.
-prs: #1638
--- a/changelog.d/1649
+++ b/changelog.d/1649
@ -1,8 +0,0 @@
-synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
-prs: #1649
-
-description: {
-
-Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
-
-}
--- a/doc/cookbook/index.rst
+++ b/doc/cookbook/index.rst
@ -37,4 +37,3 @@ you name it!
  sentry/Sentry.lhs
  testing/Testing.lhs
  open-id-connect/OpenIdConnect.lhs
-  managed-resource/ManagedResource.lhs
--- a/doc/cookbook/managed-resource/ManagedResource.lhs
+++ b/doc/cookbook/managed-resource/ManagedResource.lhs
@ -1,114 +0,0 @@
-# Request-lifetime Managed Resources
-
-Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
-
-As usual, we start with a little bit of throat clearing.
-
-
-``` haskell
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-import Control.Concurrent
-import Control.Exception (bracket, throwIO)
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Resource
-import Data.Acquire
-import Network.HTTP.Client (newManager, defaultManagerSettings)
-import Network.Wai.Handler.Warp
-import Servant
-import Servant.Client
-import System.IO
-```
-
-Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
-
-``` haskell
-type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
-
-api :: Proxy API
-api = Proxy
-```
-
-But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
-
-``` haskell
-appContext :: Context '[Acquire Handle]
-appContext = acquireHandle :. EmptyContext
-
-acquireHandle :: Acquire Handle
-acquireHandle = mkAcquire newHandle closeHandle
-
-newHandle :: IO Handle
-newHandle = do
-  putStrLn "opening file"
-  h <- openFile "test.txt" AppendMode
-  putStrLn "opened file"
-  return h
-
-closeHandle :: Handle -> IO ()
-closeHandle h = do
-  putStrLn "closing file"
-  hClose h
-  putStrLn "closed file"
-```
-
-Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
-
-``` haskell
-server :: Server API
-server = writeToFile
-
-  where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
-        writeToFile (_, h) msg = case msg of
-          "illegal" -> error "wait, that's illegal!"
-          legalMsg -> liftIO $ do
-            putStrLn "writing file"
-            hPutStrLn h legalMsg
-            putStrLn "wrote file"
-            return NoContent
-```
-
-Finally we run the server in the background while we post messages to it.
-
-``` haskell
-runApp :: IO ()
-runApp = run 8080 (serveWithContext api appContext $ server)
-
-postMsg :: String -> ClientM NoContent
-postMsg = client api
-
-main :: IO ()
-main = do
-  mgr <- newManager defaultManagerSettings
-  bracket (forkIO $ runApp) killThread $ \_ -> do
-    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
-      liftIO $ putStrLn "sending hello message"
-      _ <- postMsg "hello"
-      liftIO $ putStrLn "sending illegal message"
-      _ <- postMsg "illegal"
-      liftIO $ putStrLn "done"
-    print ms
-```
-
-This program prints
-
-```
-sending hello message
-opening file
-opened file
-writing file
-wrote file
-closing file
-closed file
-sending illegal message
-opening file
-opened file
-closing file
-closed file
-wait, that's illegal!
-CallStack (from HasCallStack):
-  error, called at ManagedResource.lhs:63:24 in main:Main
-Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
-```
-
-and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
--- a/doc/cookbook/managed-resource/managed-resource.cabal
+++ b/doc/cookbook/managed-resource/managed-resource.cabal
@ -1,30 +0,0 @@
-cabal-version:       2.2
-name:                cookbook-managed-resource
-version:             0.1
-synopsis:            Simple managed resource cookbook example
-homepage:            http://docs.servant.dev/
-license:             BSD-3-Clause
-license-file:        ../../../servant/LICENSE
-author:              Servant Contributors
-maintainer:          haskell-servant-maintainers@googlegroups.com
-build-type:          Simple
-tested-with:         GHC==9.4.2
-
-executable cookbook-managed-resource
-  main-is:             ManagedResource.lhs
-  build-depends:       base == 4.*
-                     , text >= 1.2
-                     , aeson >= 1.2
-                     , servant
-                     , servant-client
-                     , servant-server
-                     , warp >= 3.2
-                     , wai >= 3.2
-                     , http-types >= 0.12
-                     , markdown-unlit >= 0.4
-                     , http-client >= 0.5
-                     , transformers
-                     , resourcet
-  default-language:    Haskell2010
-  ghc-options:         -Wall -pgmL markdown-unlit
-  build-tool-depends: markdown-unlit:markdown-unlit
--- a/doc/cookbook/open-id-connect/OpenIdConnect.lhs
+++ b/doc/cookbook/open-id-connect/OpenIdConnect.lhs
@ -330,7 +330,7 @@ data Customer = Customer {
 ```

 Here is the code that displays the homepage.
-It should contain a link to the `/login` URL.
+It should contain a link to the the `/login` URL.
 When the user clicks on this link it will be redirected to Google login page
 with some generated information.

--- a/doc/cookbook/using-free-client/UsingFreeClient.lhs
+++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs
@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
 to http-client's `Request`, and we can inspect it:

 ```haskell
-        req' <- I.defaultMakeClientRequest burl req
+        let req' = I.defaultMakeClientRequest burl req
        putStrLn $ "Making request: " ++ show req'
 ```

--- a/doc/cookbook/uverb/UVerb.lhs
+++ b/doc/cookbook/uverb/UVerb.lhs
@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
 you can try until the right one returns a value.)

 [servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
-another shot at the problem.  It is inspired by
+another shot at at the problem.  It is inspired by
 servant-checked-exceptions, so it may be worth taking a closer look.
 The README claims that
 [cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
--- a/doc/requirements.txt
+++ b/doc/requirements.txt
@ -1,4 +1,3 @@
 recommonmark==0.5.0
 Sphinx==1.8.4
 sphinx_rtd_theme>=0.4.2
-jinja2<3.1.0
--- a/servant-auth/servant-auth-client/servant-auth-client.cabal
+++ b/servant-auth/servant-auth-client/servant-auth-client.cabal
@ -31,7 +31,7 @@ library
  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
  ghc-options: -Wall
  build-depends:
-      base                >= 4.10     && < 4.18
+      base                >= 4.10     && < 4.17
    , bytestring          >= 0.10.6.0 && < 0.12
    , containers          >= 0.5.6.2  && < 0.7
    , servant-auth        == 0.4.*
@ -74,7 +74,7 @@ test-suite spec
    , transformers         >= 0.4.2.0  && < 0.6
    , wai                  >= 3.2.1.2  && < 3.3
    , warp                 >= 3.2.25   && < 3.4
-    , jose                 >= 0.10     && < 0.11
+    , jose                 >= 0.7.0.0  && < 0.10
  other-modules:
      Servant.Auth.ClientSpec
  default-language: Haskell2010
--- a/servant-auth/servant-auth-docs/servant-auth-docs.cabal
+++ b/servant-auth/servant-auth-docs/servant-auth-docs.cabal
@ -35,11 +35,11 @@ library
  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
  ghc-options: -Wall
  build-depends:
-      base         >= 4.10    && < 4.18
+      base         >= 4.10    && < 4.17
    , servant-docs >= 0.11.2  && < 0.13
    , servant      >= 0.13    && < 0.20
    , servant-auth == 0.4.*
-    , lens         >= 4.16.1  && <5.3
+    , lens         >= 4.16.1  && <5.2
  exposed-modules:
      Servant.Auth.Docs
  default-language: Haskell2010
@ -50,7 +50,7 @@ test-suite doctests
  build-depends:
    base,
    servant-auth-docs,
-    doctest             >= 0.16   && < 0.21,
+    doctest             >= 0.16   && < 0.19,
    QuickCheck          >= 2.11.3 && < 2.15,
    template-haskell
  ghc-options:         -Wall -threaded
--- a/servant-auth/servant-auth-server/servant-auth-server.cabal
+++ b/servant-auth/servant-auth-server/servant-auth-server.cabal
@ -31,7 +31,7 @@ library
  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
  ghc-options: -Wall
  build-depends:
-      base                    >= 4.10     && < 4.18
+      base                    >= 4.10     && < 4.17
    , aeson                   >= 1.0.0.1  && < 3
    , base64-bytestring       >= 1.0.0.1  && < 2
    , blaze-builder           >= 0.4.1.0  && < 0.5
@ -41,17 +41,17 @@ library
    , data-default-class      >= 0.1.2.0  && < 0.2
    , entropy                 >= 0.4.1.3  && < 0.5
    , http-types              >= 0.12.2   && < 0.13
-    , jose                    >= 0.10     && < 0.11
-    , lens                    >= 4.16.1   && < 5.3
-    , memory                  >= 0.14.16  && < 0.19
+    , jose                    >= 0.7.0.0  && < 0.10
+    , lens                    >= 4.16.1   && < 5.2
+    , memory                  >= 0.14.16  && < 0.18
    , monad-time              >= 0.3.1.0  && < 0.4
-    , mtl                     ^>= 2.2.2   || ^>= 2.3.1
+    , mtl                     >= 2.2.2    && < 2.3
    , servant                 >= 0.13     && < 0.20
    , servant-auth            == 0.4.*
    , servant-server          >= 0.13     && < 0.20
    , tagged                  >= 0.8.4    && < 0.9
    , text                    >= 1.2.3.0  && < 2.1
-    , time                    >= 1.5.0.1  && < 1.13
+    , time                    >= 1.5.0.1  && < 1.12
    , unordered-containers    >= 0.2.9.0  && < 0.3
    , wai                     >= 3.2.1.2  && < 3.3

--- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs
+++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs
@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
  -- | Algorithm used to sign JWT.
  , jwtAlg          :: Maybe Jose.Alg
  -- | Keys used to validate JWT.
-  , validationKeys  :: IO Jose.JWKSet
+  , validationKeys  :: Jose.JWKSet
  -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
  -- intended recipient of the JWT.
  , audienceMatches :: Jose.StringOrURI -> IsMatch
@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
 defaultJWTSettings k = JWTSettings
   { signingKey = k
   , jwtAlg = Nothing
-   , validationKeys = pure $ Jose.JWKSet [k]
+   , validationKeys = Jose.JWKSet [k]
   , audienceMatches = const Matches }

 -- | The policies to use when generating cookies.
--- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs
+++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs
@ -2,7 +2,6 @@
 module Servant.Auth.Server.Internal.Cookie where

 import           Blaze.ByteString.Builder (toByteString)
-import           Control.Monad (MonadPlus(..), guard)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import qualified Crypto.JOSE              as Jose
--- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs
+++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs
@ -1,14 +1,18 @@
 module Servant.Auth.Server.Internal.JWT where

 import           Control.Lens
-import           Control.Monad (MonadPlus(..), guard)
+import           Control.Monad.Except
 import           Control.Monad.Reader
 import qualified Crypto.JOSE          as Jose
 import qualified Crypto.JWT           as Jose
+import           Data.Aeson           (FromJSON, Result (..), ToJSON, fromJSON,
+                                       toJSON)
 import           Data.ByteArray       (constEq)
 import qualified Data.ByteString      as BS
 import qualified Data.ByteString.Lazy as BSL
+import qualified Data.HashMap.Strict  as HM
 import           Data.Maybe           (fromMaybe)
+import qualified Data.Text            as T
 import           Data.Time            (UTCTime)
 import           Network.Wai          (requestHeaders)

@ -38,7 +42,7 @@ jwtAuthCheck jwtSettings = do
 -- token expires.
 makeJWT :: ToJWT a
  => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
-makeJWT v cfg expiry = Jose.runJOSE $ do
+makeJWT v cfg expiry = runExceptT $ do
  bestAlg <- Jose.bestJWSAlg $ signingKey cfg
  let alg = fromMaybe bestAlg $ jwtAlg cfg
  ejwt <- Jose.signClaims (signingKey cfg)
@ -54,15 +58,14 @@ makeJWT v cfg expiry = Jose.runJOSE $ do

 verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
 verifyJWT jwtCfg input = do
-  keys <- validationKeys jwtCfg
-  verifiedJWT <- Jose.runJOSE $ do
+  verifiedJWT <- liftIO $ runExceptT $ do
    unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
    Jose.verifyClaims
      (jwtSettingsToJwtValidationSettings jwtCfg)
-      keys
+      (validationKeys jwtCfg)
      unverifiedJWT
  return $ case verifiedJWT of
    Left (_ :: Jose.JWTError) -> Nothing
    Right v -> case decodeJWT v of
      Left _ -> Nothing
-      Right v' -> Just v'
+      Right v' -> Just v'
--- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs
+++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs
@ -2,7 +2,6 @@
 module Servant.Auth.Server.Internal.Types where

 import Control.Applicative
-import Control.Monad        (MonadPlus(..), ap)
 import Control.Monad.Reader
 import Control.Monad.Time
 import Data.Monoid          (Monoid (..))
--- a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs
+++ b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs
@ -6,12 +6,13 @@ module Servant.Auth.ServerSpec (spec) where
 #endif

 import           Control.Lens
+import           Control.Monad.Except                (runExceptT)
 import           Control.Monad.IO.Class              (liftIO)
 import           Crypto.JOSE                         (Alg (HS256, None), Error,
                                                      JWK, JWSHeader,
                                                      KeyMaterialGenParam (OctGenParam),
                                                      ToCompact, encodeCompact,
-                                                      genJWK, newJWSHeader, runJOSE)
+                                                      genJWK, newJWSHeader)
 import           Crypto.JWT                          (Audience (..), ClaimsSet,
                                                      NumericDate (NumericDate),
                                                      SignedJWT,
@ -539,7 +540,7 @@ addJwtToHeader jwt = case jwt of
    $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

 createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
-createJWT k a b = runJOSE $ signClaims k a b
+createJWT k a b = runExceptT $ signClaims k a b

 addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
 addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
--- a/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal
+++ b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal
@ -31,13 +31,15 @@ library
  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
  ghc-options: -Wall
  build-depends:
-      base            >= 4.10    && < 4.18
+      base            >= 4.10    && < 4.16
    , text            >= 1.2.3.0 && < 2.1
    , servant-swagger >= 1.1.5   && < 2
    , swagger2        >= 2.2.2   && < 3
    , servant         >= 0.13    && < 0.20
    , servant-auth    == 0.4.*
-    , lens            >= 4.16.1  && < 5.3
+    , lens            >= 4.16.1  && < 5.2
+  if impl(ghc >= 9)
+    buildable: False
  exposed-modules:
      Servant.Auth.Swagger
  default-language: Haskell2010
@ -59,6 +61,8 @@ test-suite spec
    , servant
    , servant-auth
    , lens
+  if impl(ghc >= 9)
+    buildable: False

  -- test dependencies
  build-depends:
--- a/servant-auth/servant-auth/servant-auth.cabal
+++ b/servant-auth/servant-auth/servant-auth.cabal
@ -33,11 +33,11 @@ library
  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
  ghc-options: -Wall
  build-depends:
-      base                    >= 4.10     && < 4.18
+      base                    >= 4.10     && < 4.17
    , containers              >= 0.6      && < 0.7
    , aeson                   >= 1.3.1.1  && < 3
-    , jose                    >= 0.10     && < 0.11
-    , lens                    >= 4.16.1   && < 5.3
+    , jose                    >= 0.7.0.0  && < 0.10
+    , lens                    >= 4.16.1   && < 5.2
    , servant                 >= 0.15     && < 0.20
    , text                    >= 1.2.3.0  && < 2.1
    , unordered-containers    >= 0.2.9.0  && < 0.3
--- a/servant-auth/servant-auth/src/Servant/Auth.hs
+++ b/servant-auth/servant-auth/src/Servant/Auth.hs
@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

 -- ** Combinators

-- | A JSON Web Token (JWT) in the Authorization header:
+-- | A JSON Web Token (JWT) in the the Authorization header:
 --
 --    @Authorization: Bearer \<token\>@
 --
--- a/servant-client-core/servant-client-core.cabal
+++ b/servant-client-core/servant-client-core.cabal
@ -50,14 +50,14 @@ library
  --
  -- note: mtl lower bound is so low because of GHC-7.8
  build-depends:
-      base                  >= 4.9      && < 4.18
+      base                  >= 4.9      && < 4.17
    , bytestring            >= 0.10.8.1 && < 0.12
    , constraints           >= 0.2      && < 0.14
    , containers            >= 0.5.7.1  && < 0.7
    , deepseq               >= 1.4.2.0  && < 1.5
    , text                  >= 1.2.3.0  && < 2.1
-    , transformers          >= 0.5.2.0  && < 0.7
-    , template-haskell      >= 2.11.1.0 && < 2.20
+    , transformers          >= 0.5.2.0  && < 0.6
+    , template-haskell      >= 2.11.1.0 && < 2.19

  if !impl(ghc >= 8.2)
    build-depends:
--- a/servant-client-core/src/Servant/Client/Core/HasClient.hs
+++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs
@ -77,7 +77,7 @@ import           Servant.API
                 NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
                 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
                 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
-                 Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
+                 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
                 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
 import           Servant.API.Generic
                 (GenericMode(..), ToServant, ToServantApi
@ -776,14 +776,6 @@ instance HasClient m subapi =>

  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

-instance HasClient m subapi =>
-  HasClient m (WithResource res :> subapi) where
-
-  type Client m (WithResource res :> subapi) = Client m subapi
-  clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
-
-  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
-
 instance ( HasClient m api
         ) => HasClient m (AuthProtect tag :> api) where
  type Client m (AuthProtect tag :> api)
@ -902,7 +894,7 @@ infixl 2 /:
 -- rootClient = client api
 --
 -- endpointClient :: ClientM Person
-- endpointClient = client \/\/ subApi \/\/ endpoint
+-- endpointClient = client // subApi // endpoint
 -- @
 (//) :: a -> (a -> b) -> b
 x // f = f x
@ -935,10 +927,10 @@ x // f = f x
 -- rootClient = client api
 --
 -- hello :: String -> ClientM String
-- hello name = rootClient \/\/ hello \/: name
+-- hello name = rootClient // hello /: name
 --
 -- endpointClient :: ClientM Person
-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
+-- endpointClient = client // subApi /: "foobar123" // endpoint
 -- @
 (/:) :: (a -> b -> c) -> b -> a -> c
 (/:) = flip
--- a/servant-client-ghcjs/servant-client-ghcjs.cabal
+++ b/servant-client-ghcjs/servant-client-ghcjs.cabal
@ -48,7 +48,7 @@ library
    , http-media          >=0.6.2   && <0.9
    , http-types          >=0.12    && <0.13
    , monad-control       >=1.0.0.4 && <1.1
-    , mtl                 ^>=2.2.2  || ^>=2.3.1
+    , mtl                 >=2.2.2   && <2.3
    , semigroupoids       >=5.3     && <5.4
    , string-conversions  >=0.3     && <0.5
    , transformers        >=0.3     && <0.6
--- a/servant-client/servant-client.cabal
+++ b/servant-client/servant-client.cabal
@ -41,15 +41,15 @@ library
  -- Bundled with GHC: Lower bound to not force re-installs
  -- text and mtl are bundled starting with GHC-8.4
  build-depends:
-      base                  >= 4.9      && < 4.18
+      base                  >= 4.9      && < 4.17
    , bytestring            >= 0.10.8.1 && < 0.12
    , containers            >= 0.5.7.1  && < 0.7
    , deepseq               >= 1.4.2.0  && < 1.5
-    , mtl                   ^>= 2.2.2   || ^>= 2.3.1
+    , mtl                   >= 2.2.2    && < 2.3
    , stm                   >= 2.4.5.1  && < 2.6
    , text                  >= 1.2.3.0  && < 2.1
-    , time                  >= 1.6.0.1  && < 1.13
-    , transformers          >= 0.5.2.0  && < 0.7
+    , time                  >= 1.6.0.1  && < 1.12
+    , transformers          >= 0.5.2.0  && < 0.6

  if !impl(ghc >= 8.2)
    build-depends:
--- a/servant-client/src/Servant/Client/Internal/HttpClient.hs
+++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs
@ -80,7 +80,7 @@ data ClientEnv
  { manager :: Client.Manager
  , baseUrl :: BaseUrl
  , cookieJar :: Maybe (TVar Client.CookieJar)
-  , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
+  , makeClientRequest :: BaseUrl -> Request -> Client.Request
  -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
  --   Note that:
  --      1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
 performRequest :: Maybe [Status] -> Request -> ClientM Response
 performRequest acceptStatus req = do
  ClientEnv m burl cookieJar' createClientRequest <- ask
-  clientRequest <- liftIO $ createClientRequest burl req
+  let clientRequest = createClientRequest burl req
  request <- case cookieJar' of
    Nothing -> pure clientRequest
    Just cj -> liftIO $ do
@ -229,8 +229,8 @@ clientResponseToResponse f r = Response
 -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
 --    The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
 --    otherwise the body, headers and query string are derived from the @servant@ 'Request'
-defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
-defaultMakeClientRequest burl r = return Client.defaultRequest
+defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
+defaultMakeClientRequest burl r = Client.defaultRequest
    { Client.method = requestMethod r
    , Client.host = fromString $ baseUrlHost burl
    , Client.port = baseUrlPort burl
@ -289,8 +289,7 @@ defaultMakeClientRequest burl r = return Client.defaultRequest
        Https -> True

    -- Query string builder which does not do any encoding
-    buildQueryString [] = mempty
-    buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
+    buildQueryString = ("?" <>) . foldl' addQueryParam mempty

    addQueryParam qs (k, v) =
          qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
--- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
+++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
@ -24,8 +24,7 @@ import           Control.DeepSeq
                 (NFData, force)
 import           Control.Exception
                 (evaluate, throwIO)
-import           Control.Monad
-                 (unless)
+import           Control.Monad ()
 import           Control.Monad.Base
                 (MonadBase (..))
 import           Control.Monad.Codensity
@ -141,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
 performRequest acceptStatus req = do
    -- TODO: should use Client.withResponse here too
  ClientEnv m burl cookieJar' createClientRequest <- ask
-  clientRequest <- liftIO $ createClientRequest burl req
+  let clientRequest = createClientRequest burl req
  request <- case cookieJar' of
    Nothing -> pure clientRequest
    Just cj -> liftIO $ do
@ -175,21 +174,10 @@ performRequest acceptStatus req = do
 -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
 performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
 performWithStreamingRequest req k = do
-  ClientEnv m burl cookieJar' createClientRequest <- ask
-  clientRequest <- liftIO $ createClientRequest burl req
-  request <- case cookieJar' of
-    Nothing -> pure clientRequest
-    Just cj -> liftIO $ do
-      now <- getCurrentTime
-      atomically $ do
-        oldCookieJar <- readTVar cj
-        let (newRequest, newCookieJar) =
-              Client.insertCookiesIntoRequest
-                clientRequest
-                oldCookieJar
-                now
-        writeTVar cj newCookieJar
-        pure newRequest
+  m <- asks manager
+  burl <- asks baseUrl
+  createClientRequest <- asks makeClientRequest
+  let request = createClientRequest burl req
  ClientM $ lift $ lift $ Codensity $ \k1 ->
      Client.withResponse request m $ \res -> do
          let status = Client.responseStatus res
--- a/servant-client/test/Servant/SuccessSpec.hs
+++ b/servant-client/test/Servant/SuccessSpec.hs
@ -162,8 +162,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
      mgr <- C.newManager C.defaultManagerSettings
      -- In proper situation, extra headers should probably be visible in API type.
      -- However, testing for response timeout is difficult, so we test with something which is easy to observe
-      let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
-                                           (defaultMakeClientRequest url r)
+      let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
          clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
      res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
      case res of
--- a/servant-conduit/servant-conduit.cabal
+++ b/servant-conduit/servant-conduit.cabal
@ -31,8 +31,8 @@ library
      base          >=4.9      && <5
    , bytestring    >=0.10.8.1 && <0.12
    , conduit       >=1.3.1    && <1.4
-    , mtl           ^>=2.2.2   || ^>=2.3.1
-    , resourcet     >=1.2.2    && <1.4
+    , mtl           >=2.2.2    && <2.3
+    , resourcet     >=1.2.2    && <1.3
    , servant       >=0.15     && <0.20
    , unliftio-core >=0.1.2.0  && <0.3
  hs-source-dirs:      src
--- a/servant-docs/golden/comprehensive.md
+++ b/servant-docs/golden/comprehensive.md
@ -530,24 +530,6 @@

 ```

-## GET /resource
-
-### Response:
-
- Status code 200
- Headers: []
-
- Supported content types are:
-
-    - `application/json;charset=utf-8`
-    - `application/json`
-
- Example (`application/json;charset=utf-8`, `application/json`):
-
-```javascript
-
-```
-
 ## GET /streaming

 ### Request:
--- a/servant-docs/servant-docs.cabal
+++ b/servant-docs/servant-docs.cabal
@ -41,7 +41,7 @@ library
  --
  -- note: mtl lower bound is so low because of GHC-7.8
  build-depends:
-      base       >= 4.9      && < 4.18
+      base       >= 4.9      && < 4.17
    , bytestring >= 0.10.8.1 && < 0.12
    , text       >= 1.2.3.0  && < 2.1

@ -59,7 +59,7 @@ library
    , hashable             >= 1.2.7.0  && < 1.5
    , http-media           >= 0.7.1.3  && < 0.9
    , http-types           >= 0.12.2   && < 0.13
-    , lens                 >= 4.17     && < 5.3
+    , lens                 >= 4.17     && < 5.2
    , string-conversions   >= 0.4.0.1  && < 0.5
    , universe-base        >= 1.1.1    && < 1.2
    , unordered-containers >= 0.2.9.0  && < 0.3
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@ -62,7 +62,6 @@ import           GHC.TypeLits
 import           Servant.API
 import           Servant.API.ContentTypes
 import           Servant.API.TypeLevel
-import           Servant.API.Generic

 import qualified Data.Universe.Helpers      as U

@ -447,7 +446,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
      & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints


-- | Generate the docs for a given API that implements 'HasDocs' with any
+-- | Generate the docs for a given API that implements 'HasDocs' with with any
 -- number of introduction(s)
 docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
 docsWithIntros intros = docsWith defaultDocOptions intros mempty
@ -1144,9 +1143,6 @@ instance HasDocs api => HasDocs (Vault :> api) where
 instance HasDocs api => HasDocs (WithNamedContext name context api) where
  docsFor Proxy = docsFor (Proxy :: Proxy api)

-instance HasDocs api => HasDocs (WithResource res :> api) where
-  docsFor Proxy = docsFor (Proxy :: Proxy api)
-
 instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
  docsFor Proxy (endpoint, action) =
    docsFor (Proxy :: Proxy api) (endpoint, action')
@ -1154,9 +1150,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
        authProxy = Proxy :: Proxy (BasicAuth realm usr)
        action' = over authInfo (|> toAuthInfo authProxy) action

-instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
-  docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
-
 -- ToSample instances for simple types
 instance ToSample NoContent
 instance ToSample Bool
--- a/servant-foreign/servant-foreign.cabal
+++ b/servant-foreign/servant-foreign.cabal
@ -41,7 +41,7 @@ library
  --
  -- note: mtl lower bound is so low because of GHC-7.8
  build-depends:
-      base        >= 4.9     && < 4.18
+      base        >= 4.9     && < 4.17
    , text        >= 1.2.3.0 && < 2.1

  -- Servant dependencies
@ -52,7 +52,7 @@ library
  -- Here can be exceptions if we really need features from the newer versions.
  build-depends:
      base-compat >= 0.10.5  && < 0.13
-    , lens        >= 4.17    && < 5.3
+    , lens        >= 4.17    && < 5.2
    , http-types  >= 0.12.2  && < 0.13

  hs-source-dirs:      src
--- a/servant-foreign/src/Servant/Foreign/Internal.hs
+++ b/servant-foreign/src/Servant/Foreign/Internal.hs
@ -487,13 +487,6 @@ instance HasForeign lang ftype api =>

  foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

-instance HasForeign lang ftype api =>
-  HasForeign lang ftype (WithResource res :> api) where
-
-  type Foreign ftype (WithResource res :> api) = Foreign ftype api
-
-  foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
-
 instance HasForeign lang ftype api
  => HasForeign lang ftype (HttpVersion :> api) where
  type Foreign ftype (HttpVersion :> api) = Foreign ftype api
--- a/servant-http-streams/servant-http-streams.cabal
+++ b/servant-http-streams/servant-http-streams.cabal
@ -38,14 +38,14 @@ library
  -- Bundled with GHC: Lower bound to not force re-installs
  -- text and mtl are bundled starting with GHC-8.4
  build-depends:
-      base                  >= 4.9      && < 4.18
+      base                  >= 4.9      && < 4.17
    , bytestring            >= 0.10.8.1 && < 0.12
    , containers            >= 0.5.7.1  && < 0.7
    , deepseq               >= 1.4.2.0  && < 1.5
-    , mtl                   ^>= 2.2.2   || ^>= 2.3.1
+    , mtl                   >= 2.2.2    && < 2.3
    , text                  >= 1.2.3.0  && < 2.1
-    , time                  >= 1.6.0.1  && < 1.13
-    , transformers          >= 0.5.2.0  && < 0.7
+    , time                  >= 1.6.0.1  && < 1.12
+    , transformers          >= 0.5.2.0  && < 0.6

  if !impl(ghc >= 8.2)
    build-depends:
--- a/servant-machines/servant-machines.cabal
+++ b/servant-machines/servant-machines.cabal
@ -31,7 +31,7 @@ library
      base          >=4.9      && <5
    , bytestring    >=0.10.8.1 && <0.12
    , machines      >=0.6.4    && <0.8
-    , mtl           ^>=2.2.2   || ^>=2.3.1
+    , mtl           >=2.2.2    && <2.3
    , servant       >=0.15     && <0.20
  hs-source-dirs:      src
  default-language:    Haskell2010
--- a/servant-pipes/servant-pipes.cabal
+++ b/servant-pipes/servant-pipes.cabal
@ -32,7 +32,7 @@ library
    , bytestring    >=0.10.8.1 && <0.12
    , pipes         >=4.3.9    && <4.4
    , pipes-safe    >=2.3.1    && <2.4
-    , mtl           ^>=2.2.2   || ^>=2.3.1
+    , mtl           >=2.2.2    && <2.3
    , monad-control >=1.0.2.3  && <1.1
    , servant       >=0.15     && <0.20
  hs-source-dirs:      src
--- a/servant-server/CHANGELOG.md
+++ b/servant-server/CHANGELOG.md
@ -3,17 +3,11 @@

 Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

-0.19.2
------
-
-Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
-
 0.19.1
 ------

 - Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
 - Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)

 0.19
 ----
--- a/servant-server/example/greet.hs
+++ b/servant-server/example/greet.hs
@ -1,10 +1,13 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds         #-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications   #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE TypeOperators      #-}

 import           Prelude ()
 import           Prelude.Compat
@ -29,7 +32,7 @@ instance FromJSON Greet
 instance ToJSON Greet

 -- API specification
-type TestApi =
+type TestApi' =
       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet

@ -42,6 +45,11 @@ type TestApi =

  :<|> NamedRoutes OtherRoutes

+type TestApi =
+       TestApi'
+  :<|> "redirect" :> Capture "redirectValue" Int :> RedirectOf TestApi'
+
+
 data OtherRoutes mode = OtherRoutes
  { version :: mode :- Get '[JSON] Int
  , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text
@ -58,7 +66,7 @@ testApi = Proxy
 --
 -- Each handler runs in the 'Handler' monad.
 server :: Server TestApi
-server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes
+server = (helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes) :<|> redirect
  where otherRoutes = OtherRoutes {..}

        bye name = pure $ "Bye, " <> name <> " !"
@ -72,6 +80,14 @@ server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes

        deleteGreetH _ = return NoContent

+        redirect 42 = pure $
+          RedirectOf (Proxy @("hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet))
+          (\buildPath -> buildPath "Nicolas" (Just True))
+
+        redirect _ = pure $
+          RedirectOf (namedRoute @"bye" @OtherRoutes)
+          (\buildPath -> buildPath "Gaël")
+
 -- Turn the server into a WAI app. 'serve' is provided by servant,
 -- more precisely by the Servant.Server module.
 test :: Application
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@ -1,6 +1,6 @@
 cabal-version:       2.2
 name:                servant-server
-version:             0.19.2
+version:             0.19.1

 synopsis:            A family of combinators for defining webservices APIs and serving them
 category:            Servant, Web
@ -23,7 +23,7 @@ author:              Servant Contributors
 maintainer:          haskell-servant-maintainers@googlegroups.com
 copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
 build-type:          Simple
-tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

 extra-source-files:
  CHANGELOG.md
@ -60,20 +60,20 @@ library
  -- Bundled with GHC: Lower bound to not force re-installs
  -- text and mtl are bundled starting with GHC-8.4
  build-depends:
-      base                >= 4.9      && < 4.18
+      base                >= 4.9      && < 4.17
    , bytestring          >= 0.10.8.1 && < 0.12
    , constraints         >= 0.2      && < 0.14
    , containers          >= 0.5.7.1  && < 0.7
-    , mtl                 ^>= 2.2.2   || ^>= 2.3.1
+    , mtl                 >= 2.2.2    && < 2.3
    , text                >= 1.2.3.0  && < 2.1
-    , transformers        >= 0.5.2.0  && < 0.7
+    , transformers        >= 0.5.2.0  && < 0.6
    , filepath            >= 1.4.1.1  && < 1.5

  -- Servant dependencies
  -- strict dependency as we re-export 'servant' things.
  build-depends:
      servant             >= 0.19     && < 0.20
-    , http-api-data       >= 0.4.1    && < 0.5.1
+    , http-api-data       >= 0.4.1    && < 0.4.4

  -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
  -- Here can be exceptions if we really need features from the newer versions.
@ -88,10 +88,10 @@ library
    , network             >= 2.8      && < 3.2
    , sop-core            >= 0.4.0.0  && < 0.6
    , string-conversions  >= 0.4.0.1  && < 0.5
-    , resourcet           >= 1.2.2    && < 1.4
+    , resourcet           >= 1.2.2    && < 1.3
    , tagged              >= 0.8.6    && < 0.9
    , transformers-base   >= 0.4.5.2  && < 0.5
-    , wai                 >= 3.2.2.1  && < 3.3
+    , wai                 >= 3.2.1.2  && < 3.3
    , wai-app-static      >= 3.1.6.2  && < 3.2
    , word8               >= 0.1.3    && < 0.2

--- a/servant-server/src/Servant/Server/Experimental/Auth.hs
+++ b/servant-server/src/Servant/Server/Experimental/Auth.hs
@ -1,6 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@ -45,7 +44,7 @@ type family AuthServerData a :: *
 -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
 newtype AuthHandler r usr = AuthHandler
  { unAuthHandler :: r -> Handler usr }
-  deriving (Functor, Generic, Typeable)
+  deriving (Generic, Typeable)

 -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
 mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE FlexibleContexts      #-}
@ -35,10 +34,9 @@ module Servant.Server.Internal
 import           Control.Monad
                 (join, when)
 import           Control.Monad.Trans
-                 (liftIO, lift)
+                 (liftIO)
 import           Control.Monad.Trans.Resource
-                 (runResourceT, ReleaseKey)
-import           Data.Acquire
+                 (runResourceT)
 import qualified Data.ByteString                            as B
 import qualified Data.ByteString.Builder                    as BB
 import qualified Data.ByteString.Char8                      as BC8
@ -78,7 +76,7 @@ import           Servant.API
                 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
                 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
-                 WithNamedContext, WithResource, NamedRoutes)
+                 WithNamedContext, NamedRoutes, RedirectOf(..))
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@ -96,8 +94,6 @@ import           Servant.API.TypeErrors
 import           Web.HttpApiData
                 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
                 parseUrlPieces)
-import           Data.Kind
-                 (Type)

 import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Context
@ -116,10 +112,6 @@ import           Servant.API.TypeLevel
                 (AtLeastOneFragment, FragmentUnique)

 class HasServer api context where
-  -- | The type of a server for this API, given a monad to run effects in.
-  --
-  -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
-  -- what the @T@ in the name might suggest.
  type ServerT api (m :: * -> *) :: *

  route ::
@ -249,42 +241,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
      formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
      hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

-- | If you use 'WithResource' in one of the endpoints for your API Servant
-- will provide the handler for this endpoint an argument of the specified type.
-- The lifespan of this resource will be automatically managed by Servant. This
-- resource will be created before the handler starts and it will be destoyed
-- after it ends. A new resource is created for each request to the endpoint.
-
-- The creation and destruction are done using a 'Data.Acquire.Acquire'
-- provided via server 'Context'.
--
-- Example
--
-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
-- >
-- > server :: Server MyApi
-- > server = writeToFile
-- >   where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
-- >         writeToFile (_, h) = hPutStrLn h "message"
--
-- In addition to the resource, the handler will also receive a 'ReleaseKey'
-- which can be used to deallocate the resource before the end of the request
-- if desired.
-
-instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
-      => HasServer (WithResource a :> api) ctx where
-
-  type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
-
-  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
-
-  route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
-    where
-      allocateResource :: DelayedIO (ReleaseKey, a)
-      allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
-
-
-
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

@ -865,11 +821,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
 -------------------------------------------------------------------------------

 -- Erroring instance for 'HasServer' when a combinator is not fully applied
-instance TypeError (PartialApplication 
-#if __GLASGOW_HASKELL__ >= 904
-                    @(Type -> [Type] -> Constraint) 
-#endif
-                    HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
+instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
  where
    type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
    route = error "unreachable"
@ -913,11 +865,7 @@ type HasServerArrowTypeError a b =
 -- XXX: This omits the @context@ parameter, e.g.:
 --
 -- "There is no instance for HasServer (Bool :> …)". Do we care ?
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub 
-#if __GLASGOW_HASKELL__ >= 904
-                                         @(Type -> [Type] -> Constraint) 
-#endif
-                                         HasServer ty) => HasServer (ty :> sub) context
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context

 instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

@ -940,6 +888,11 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer

  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)

+instance HasServer (RedirectOf api) context where
+  type ServerT (RedirectOf api) m = m (RedirectOf api)
+  route _ = undefined
+  hoistServerWithContext _ _ _ = undefined
+
 -- $setup
 -- >>> import Servant

--- a/servant-server/src/Servant/Server/Internal/Router.hs
+++ b/servant-server/src/Servant/Server/Internal/Router.hs
@ -28,12 +28,9 @@ import           Servant.Server.Internal.ServerError

 type Router env = Router' env RoutingApplication

-- | Holds information about pieces of url that are captured as variables.
 data CaptureHint = CaptureHint
  { captureName :: Text
-  -- ^ Holds the name of the captured variable
  , captureType :: TypeRep
-  -- ^ Holds the type of the captured variable
  }
  deriving (Show, Eq)

@ -57,21 +54,10 @@ data Router' env a =
      --   for the empty path, to be tried in order
  | CaptureRouter [CaptureHint] (Router' (Text, env) a)
      -- ^ first path component is passed to the child router in its
-      --   environment and removed afterwards.
-      --   The first argument is a list of hints for all variables that can be
-      --   captured by the router. The fact that it is a list is counter-intuitive,
-      --   because the 'Capture' combinator only allows to capture a single varible,
-      --   with a single name and a single type. However, the 'choice' smart
-      --   constructor may merge two 'Capture' combinators with different hints, thus
-      --   forcing the type to be '[CaptureHint]'.
-      --   Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
-      --   hints should always be non-empty.
+      --   environment and removed afterwards
  | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
      -- ^ all path components are passed to the child router in its
      --   environment and are removed afterwards
-      --   The first argument is a hint for the list of variables that can be
-      --   captured by the router. Note that the 'captureType' field of the hint
-      --   should always be '[a]' for some 'a'.
  | RawRouter     (env -> a)
      -- ^ to be used for routes we do not know anything about
  | Choice        (Router' env a) (Router' env a)
@ -115,10 +101,6 @@ choice router1 router2 = Choice router1 router2
 data RouterStructure =
    StaticRouterStructure  (Map Text RouterStructure) Int
  | CaptureRouterStructure [CaptureHint] RouterStructure
-  -- ^ The first argument holds information about variables
-  -- that are captured by the router. There may be several hints
-  -- if several routers have been aggregated by the 'choice'
-  -- smart constructor.
  | RawRouterStructure
  | ChoiceStructure        RouterStructure RouterStructure
  deriving (Eq, Show)
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@ -21,8 +21,6 @@ import           Control.Monad.Error.Class
                 (MonadError (..))
 import           Data.Aeson
                 (FromJSON, ToJSON, decode', encode)
-import           Data.Acquire
-                 (Acquire, mkAcquire)
 import qualified Data.ByteString                   as BS
 import qualified Data.ByteString.Base64            as Base64
 import           Data.Char
@ -83,11 +81,8 @@ import           Servant.Server.Internal.Context
 -- This declaration simply checks that all instances are in place.
 _ = serveWithContext comprehensiveAPI comprehensiveApiContext

-comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
-comprehensiveApiContext =
-  NamedContext EmptyContext :.
-  mkAcquire (pure 10) (\_ -> pure ()) :.
-  EmptyContext
+comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

 -- * Specs

--- a/servant-swagger/servant-swagger.cabal
+++ b/servant-swagger/servant-swagger.cabal
@ -106,11 +106,11 @@ test-suite spec
  type:             exitcode-stdio-1.0
  hs-source-dirs:   test
  main-is:          Spec.hs
-  build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11
+  build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10
  build-depends:    base
                  , base-compat
                  , aeson >=1.4.2.0 && <3
-                  , hspec >=2.6.0 && <2.11
+                  , hspec >=2.6.0 && <2.10
                  , QuickCheck
                  , lens
                  , lens-aeson >=1.0.2    && <1.3
--- a/servant-swagger/src/Servant/Swagger.hs
+++ b/servant-swagger/src/Servant/Swagger.hs
@ -55,7 +55,6 @@ import           Servant.Swagger.Internal.Orphans ()
 -- >>> import Data.Typeable
 -- >>> import GHC.Generics
 -- >>> import Servant.API
-- >>> import System.Environment
 -- >>> import Test.Hspec
 -- >>> import Test.QuickCheck
 -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
@ -65,7 +64,6 @@ import           Servant.Swagger.Internal.Orphans ()
 -- >>> :set -XGeneralizedNewtypeDeriving
 -- >>> :set -XOverloadedStrings
 -- >>> :set -XTypeOperators
-- >>> setEnv "HSPEC_COLOR" "no"
 -- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
 -- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
 -- >>> instance ToJSON User
--- a/servant-swagger/src/Servant/Swagger/Internal.hs
+++ b/servant-swagger/src/Servant/Swagger/Internal.hs
@ -3,13 +3,11 @@
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE OverloadedLists      #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE TypeFamilies         #-}
 #if __GLASGOW_HASKELL__ >= 806
 {-# LANGUAGE UndecidableInstances #-}
 #endif
@ -32,13 +30,11 @@ import qualified Data.Swagger                           as Swagger
 import           Data.Swagger.Declare
 import           Data.Text                              (Text)
 import qualified Data.Text                              as Text
-import           GHC.Generics                           (D1, Meta(..), Rep)
 import           GHC.TypeLits
 import           Network.HTTP.Media                     (MediaType)
 import           Servant.API
 import           Servant.API.Description                (FoldDescription,
                                                         reflectDescription)
-import           Servant.API.Generic                    (ToServantApi, AsApi)
 import           Servant.API.Modifiers                  (FoldRequired)

 import           Servant.Swagger.Internal.TypeLevel.API
@ -153,10 +149,6 @@ mkEndpointNoContentVerb path _ = mempty
 addParam :: Param -> Swagger -> Swagger
 addParam param = allOperations.parameters %~ (Inline param :)

-- | Add a tag to every operation in the spec.
-addTag :: Text -> Swagger -> Swagger
-addTag tag = allOperations.tags %~ ([tag] <>)
-
 -- | Add accepted content types to every operation in the spec.
 addConsumes :: [MediaType] -> Swagger -> Swagger
 addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
@ -304,10 +296,6 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
 instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'WithResource'@ combinator does not change our specification at all.
-instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where
-  toSwagger _ = toSwagger (Proxy :: Proxy sub)
-
 instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
  toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
    where
@ -451,9 +439,6 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo
        & required  ?~ True
        & schema    .~ ParamBody ref

-instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
-  toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
-
 -- =======================================================================
 -- Below are the definitions that should be in Servant.API.ContentTypes
 -- =======================================================================
--- a/servant-swagger/src/Servant/Swagger/Internal/Test.hs
+++ b/servant-swagger/src/Servant/Swagger/Internal/Test.hs
@ -29,12 +29,10 @@ import           Servant.Swagger.Internal.TypeLevel
 -- >>> import Control.Applicative
 -- >>> import GHC.Generics
 -- >>> import Test.QuickCheck
-- >>> import System.Environment (setEnv)
 -- >>> :set -XDeriveGeneric
 -- >>> :set -XGeneralizedNewtypeDeriving
 -- >>> :set -XDataKinds
 -- >>> :set -XTypeOperators
-- >>> setEnv "HSPEC_COLOR" "no"

 -- | Verify that every type used with @'JSON'@ content type in a servant API
 -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
--- a/servant/CHANGELOG.md
+++ b/servant/CHANGELOG.md
@ -2,11 +2,6 @@

 Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

-0.19.1
------
-
-Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
-
 0.19
 ----

--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@ -1,6 +1,6 @@
 cabal-version:       2.2
 name:                servant
-version:             0.19.1
+version:             0.19

 synopsis:            A family of combinators for defining webservices APIs
 category:            Servant, Web
@ -50,6 +50,7 @@ library
    Servant.API.QueryParam
    Servant.API.Raw
    Servant.API.RemoteHost
+    Servant.API.RedirectOf
    Servant.API.ReqBody
    Servant.API.ResponseHeaders
    Servant.API.Status
@ -62,7 +63,6 @@ library
    Servant.API.Vault
    Servant.API.Verbs
    Servant.API.WithNamedContext
-    Servant.API.WithResource

  -- Types
  exposed-modules:
@ -81,19 +81,19 @@ library
  --
  -- note: mtl lower bound is so low because of GHC-7.8
  build-depends:
-      base                   >= 4.9      && < 4.18
+      base                   >= 4.9      && < 4.17
    , bytestring             >= 0.10.8.1 && < 0.12
    , constraints            >= 0.2
-    , mtl                    ^>= 2.2.2   || ^>= 2.3.1
+    , mtl                    >= 2.2.2    && < 2.3
    , sop-core               >= 0.4.0.0  && < 0.6
-    , transformers           >= 0.5.2.0  && < 0.7
+    , transformers           >= 0.5.2.0  && < 0.6
    , text                   >= 1.2.3.0  && < 2.1


  -- We depend (heavily) on the API of these packages:
  -- i.e. re-export, or allow using without direct dependency
  build-depends:
-      http-api-data          >= 0.4.1    && < 0.5.1
+      http-api-data          >= 0.4.1    && < 0.4.4
    , singleton-bool         >= 0.1.4    && < 0.1.7

  -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
--- a/servant/src/Servant/API.hs
+++ b/servant/src/Servant/API.hs
@ -31,8 +31,6 @@ module Servant.API (
  -- | Access the location for arbitrary data to be shared by applications and middleware
  module Servant.API.WithNamedContext,
  -- | Access context entries in combinators in servant-server
-  module Servant.API.WithResource,
-  -- | Access a managed resource scoped to a single request

  -- * Actual endpoints, distinguished by HTTP method
  module Servant.API.Verbs,
@ -59,6 +57,9 @@ module Servant.API (
  -- * Response Headers
  module Servant.API.ResponseHeaders,

+  -- * Redirections
+  module Servant.API.RedirectOf,
+
  -- * Untyped endpoints
  module Servant.API.Raw,
  -- | Plugging in a wai 'Network.Wai.Application', serving directories
@ -103,25 +104,25 @@ import           Servant.API.Experimental.Auth
                 (AuthProtect)
 import           Servant.API.Fragment
                 (Fragment)
-import           Servant.API.Generic
-                 (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
-                 ToServant, ToServantApi, fromServant, genericApi, toServant)
 import           Servant.API.Header
                 (Header, Header')
+import           Servant.API.Generic
+                 (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,
+                 GenericServant, fromServant, toServant, genericApi)
 import           Servant.API.HttpVersion
                 (HttpVersion (..))
 import           Servant.API.IsSecure
                 (IsSecure (..))
 import           Servant.API.Modifiers
                 (Lenient, Optional, Required, Strict)
-import           Servant.API.NamedRoutes
-                 (NamedRoutes)
 import           Servant.API.QueryParam
                 (QueryFlag, QueryParam, QueryParam', QueryParams)
 import           Servant.API.Raw
                 (Raw)
 import           Servant.API.RemoteHost
                 (RemoteHost)
+import           Servant.API.RedirectOf
+                 (RedirectOf(..))
 import           Servant.API.ReqBody
                 (ReqBody, ReqBody')
 import           Servant.API.ResponseHeaders
@ -141,6 +142,8 @@ import           Servant.API.UVerb
                 Unique, WithStatus (..), inject, statusOf)
 import           Servant.API.Vault
                 (Vault)
+import           Servant.API.NamedRoutes
+                 (NamedRoutes, namedRoute)
 import           Servant.API.Verbs
                 (Delete, DeleteAccepted, DeleteNoContent,
                 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
@ -152,8 +155,6 @@ import           Servant.API.Verbs
                 ReflectMethod (reflectMethod), StdMethod (..), Verb)
 import           Servant.API.WithNamedContext
                 (WithNamedContext)
-import           Servant.API.WithResource
-                 (WithResource)
 import           Servant.Links
                 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
 import           Web.HttpApiData
--- a/servant/src/Servant/API/ContentTypes.hs
+++ b/servant/src/Servant/API/ContentTypes.hs
@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
 -- then this would be taken care of. However there is no more specific instance
 -- between that and 'MimeRender JSON a', so we do this instead
 instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
-    allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
+    allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
      where
        pctyp = Proxy :: Proxy ctyp

--- a/servant/src/Servant/API/NamedRoutes.hs
+++ b/servant/src/Servant/API/NamedRoutes.hs
@ -1,10 +1,28 @@
-{-# LANGUAGE KindSignatures #-}
-{-# OPTIONS_HADDOCK not-home    #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE ExplicitForAll      #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# OPTIONS_HADDOCK not-home     #-}

 module Servant.API.NamedRoutes (
    -- * NamedRoutes combinator
    NamedRoutes
+    -- * Term-level helpers
+  , namedRoute
  ) where

+import Data.Proxy (Proxy(..))
+import GHC.Records (HasField)
+import GHC.TypeLits (Symbol)
+
+import Servant.API.Generic (AsApi)
+
+namedRoute
+  :: forall (field :: Symbol) (api :: * -> *) a.
+     HasField field (api AsApi) a
+  => Proxy a
+namedRoute = Proxy
+
 -- | Combinator for embedding a record of named routes into a Servant API type.
 data NamedRoutes (api :: * -> *)
--- a/servant/src/Servant/API/RedirectOf.hs
+++ b/servant/src/Servant/API/RedirectOf.hs
@ -0,0 +1,12 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Servant.API.RedirectOf where
+
+import Data.Proxy (Proxy(..))
+import Servant.Links
+
+data RedirectOf api where
+   RedirectOf
+     :: (IsElem endpoint api, HasLink endpoint)
+     => Proxy endpoint -> (forall a. MkLink endpoint a -> a) -> RedirectOf api
--- a/servant/src/Servant/API/TypeLevel.hs
+++ b/servant/src/Servant/API/TypeLevel.hs
@ -60,6 +60,8 @@ import           Servant.API.Capture
 import           Servant.API.Fragment
 import           Servant.API.Header
                 (Header)
+import           Servant.API.NamedRoutes (NamedRoutes)
+import           Servant.API.Generic (ToServantApi)
 import           Servant.API.QueryParam
                 (QueryFlag, QueryParam, QueryParams)
 import           Servant.API.ReqBody
@ -73,8 +75,6 @@ import           Servant.API.UVerb
 import           GHC.TypeLits
                 (ErrorMessage (..), TypeError)

-
-
 -- * API predicates

 -- | Flatten API into a list of endpoints.
@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint
 --
 -- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
 -- ...
-- ... Could not ...
+-- ... Could not deduce...
 -- ...
 --
 -- An endpoint is considered within an api even if it is missing combinators
@ -127,6 +127,7 @@ type family IsElem' a s :: Constraint
 -- request represented by @a@ matches the endpoints serving @b@ (for the
 -- latter, use 'IsIn').
 type family IsElem endpoint api :: Constraint where
+  IsElem endpoint (NamedRoutes rec)       = IsElem endpoint (ToServantApi rec)
  IsElem e (sa :<|> sb)                   = Or (IsElem e sa) (IsElem e sb)
  IsElem (e :> sa) (e :> sb)              = IsElem sa sb
  IsElem sa (Header sym x :> sb)          = IsElem sa sb
@ -151,7 +152,7 @@ type family IsElem endpoint api :: Constraint where
 --
 -- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
 -- ...
-- ... Could not ...
+-- ... Could not deduce...
 -- ...
 --
 -- This uses @IsElem@ for checking; thus the note there applies here.
@ -174,7 +175,7 @@ type family AllIsElem xs api :: Constraint where
 --
 -- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
 -- ...
-- ... Could not ...
+-- ... Could not deduce...
 -- ...
 type family IsIn (endpoint :: *) (api :: *) :: Constraint where
  IsIn e (sa :<|> sb)                = Or (IsIn e sa) (IsIn e sb)
--- a/servant/src/Servant/API/UVerb.hs
+++ b/servant/src/Servant/API/UVerb.hs
@ -38,7 +38,6 @@ import GHC.TypeLits (Nat)
 import Network.HTTP.Types (Status, StdMethod)
 import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
 import Servant.API.Status (KnownStatus, statusVal)
-import Servant.API.ResponseHeaders (Headers)
 import Servant.API.UVerb.Union

 class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@ -53,9 +52,6 @@ statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
 instance HasStatus NoContent where
  type StatusOf NoContent = 204

-instance HasStatus a => HasStatus (Headers hs a) where
-  type StatusOf (Headers hs a) = StatusOf a
-
 class HasStatuses (as :: [*]) where
  type Statuses (as :: [*]) :: [Nat]
  statuses :: Proxy as -> [Status]
--- a/servant/src/Servant/API/UVerb/Union.hs
+++ b/servant/src/Servant/API/UVerb/Union.hs
@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =
    ':$$: 'Text "    " ':<>: 'ShowType rs

 type family Elem (x :: k) (xs :: [k]) :: Bool where
-  Elem x (x ': _) = 'True
-  Elem x (_ ': xs) = Elem x xs
  Elem _ '[] = 'False
+  Elem x (x' ': xs) =
+    If (x == x') 'True (Elem x xs)

 type family Unique xs :: Constraint where
  Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
--- a/servant/src/Servant/API/WithResource.hs
+++ b/servant/src/Servant/API/WithResource.hs
@ -1,3 +0,0 @@
-module Servant.API.WithResource (WithResource) where
-
-data WithResource res
--- a/servant/src/Servant/Links.hs
+++ b/servant/src/Servant/Links.hs
@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes    #-}
 {-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
@ -92,7 +91,7 @@
 -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
 -- >>> safeLink api bad_link
 -- ...
-- ...Could not ...
+-- ...Could not deduce...
 -- ...
 --
 --  This error is essentially saying that the type family couldn't find
@ -193,11 +192,7 @@ import           Servant.API.Verbs
                 (Verb, NoContentVerb)
 import           Servant.API.WithNamedContext
                 (WithNamedContext)
-import           Servant.API.WithResource
-                 (WithResource)
 import           Web.HttpApiData
-import           Data.Kind
-                 (Type)

 -- | A safe link datatype.
 -- The only way of constructing a 'Link' is using 'safeLink', which means any
@ -560,10 +555,6 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
    type MkLink (WithNamedContext name context sub) a = MkLink sub a
    toLink toA _ = toLink toA (Proxy :: Proxy sub)

-instance HasLink sub => HasLink (WithResource res :> sub) where
-    type MkLink (WithResource res :> sub) a = MkLink sub a
-    toLink toA _ = toLink toA (Proxy :: Proxy sub)
-
 instance HasLink sub => HasLink (RemoteHost :> sub) where
    type MkLink (RemoteHost :> sub) a = MkLink sub a
    toLink = simpleToLink (Proxy :: Proxy sub)
@ -656,20 +647,12 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
 -- >>> import Data.Text (Text)

 -- Erroring instance for 'HasLink' when a combinator is not fully applied
-instance TypeError (PartialApplication 
-#if __GLASGOW_HASKELL__ >= 904
-                    @(Type -> Constraint) 
-#endif
-                    HasLink arr) => HasLink ((arr :: a -> b) :> sub)
+instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
  where
    type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
    toLink = error "unreachable"

 -- Erroring instances for 'HasLink' for unknown API combinators
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub 
-#if __GLASGOW_HASKELL__ >= 904
-                                         @(Type -> Constraint) 
-#endif
-                                         HasLink ty) => HasLink (ty :> sub)
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)

 instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
--- a/servant/src/Servant/Test/ComprehensiveAPI.hs
+++ b/servant/src/Servant/Test/ComprehensiveAPI.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds     #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}

 -- | This is a module containing an API with all `Servant.API` combinators. It
@ -44,11 +45,13 @@ type ComprehensiveAPIWithoutStreaming =
 comprehensiveAPIWithoutStreaming :: Proxy ComprehensiveAPIWithoutStreaming
 comprehensiveAPIWithoutStreaming = Proxy

+type CaptureEndpoint = Capture' '[Description "example description"] "bar" Int :> GET
+
 -- | @:: API -> API@, so we have linear structure of the API.
 type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
    GET
    :<|> "get-int"          :> Get '[JSON] Int
-    :<|> "capture"          :> Capture' '[Description "example description"] "bar" Int :> GET
+    :<|> CaptureEndpoint
    :<|> "capture-lenient"  :> Capture' '[Lenient] "foo" Int :> GET
    :<|> "header"           :> Header "foo" Int :> GET
    :<|> "header-lenient"   :> Header' '[Required, Lenient] "bar" Int :> GET
@ -72,10 +75,15 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
    :<|> "description"      :> Description "foo" :> GET
    :<|> "alternative"      :> ("left" :> GET :<|> "right" :> GET)
    :<|> "fragment"         :> Fragment Int :> GET
-    :<|> "resource"         :> WithResource Int :> GET
    :<|> endpoint

 type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

 comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw
 comprehensiveAPIWithoutStreamingOrRaw = Proxy
+
+redirectEndpoints :: [RedirectOf ComprehensiveAPI]
+redirectEndpoints =
+  [ RedirectOf (Proxy @GET) id
+  , RedirectOf (Proxy @CaptureEndpoint) (\mkLink -> mkLink 42)
+  ]
--- a/servant/src/Servant/Types/SourceT.hs
+++ b/servant/src/Servant/Types/SourceT.hs
@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE RankNTypes          #-}
@ -155,10 +154,8 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
 -- | >>> lift [1,2,3] :: StepT [] Int
 -- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
 --
-#if !MIN_VERSION_transformers(0,6,0)
 instance MonadTrans StepT where
    lift = Effect . fmap (`Yield` Stop)
-#endif

 instance MFunctor StepT where
    hoist f = go where
--- a/servant/test/Servant/API/ContentTypesSpec.hs
+++ b/servant/test/Servant/API/ContentTypesSpec.hs
@ -33,8 +33,6 @@ import           Data.String.Conversions
 import qualified Data.Text                                        as TextS
 import qualified Data.Text.Encoding                               as TextSE
 import qualified Data.Text.Lazy                                   as TextL
-import           Control.Exception
-                 (evaluate)
 import           GHC.Generics
 import           Test.Hspec
 import           Test.QuickCheck
@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do
        it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
            property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

-    describe "The NoContent Content-Type type" $ do
-        let p = Proxy :: Proxy '[JSON]
-
-        it "does not render any content" $
-          allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))
-
-        it "evaluates the NoContent value" $
-          evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall
-
    describe "The PlainText Content-Type type" $ do
        let p = Proxy :: Proxy PlainText

--- a/servant/test/Servant/API/ResponseHeadersSpec.hs
+++ b/servant/test/Servant/API/ResponseHeadersSpec.hs
@ -2,14 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Servant.API.ResponseHeadersSpec where

-import           Data.Proxy
-import           GHC.TypeLits
 import           Test.Hspec

-import           Servant.API.ContentTypes
 import           Servant.API.Header
 import           Servant.API.ResponseHeaders
-import           Servant.API.UVerb

 spec :: Spec
 spec = describe "Servant.API.ResponseHeaders" $ do
@ -32,10 +28,3 @@ spec = describe "Servant.API.ResponseHeaders" $ do
    it "does not add a header" $ do
      let val = noHeader 5 :: Headers '[Header "test" Int] Int
      getHeaders val `shouldBe` []
-
-  describe "HasStatus Headers" $ do
-
-    it "gets the status from the underlying value" $ do
-      natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204
-      natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503
-
Author	SHA1	Message	Date
Gaël Deest	8ed061b931	Named-based selection of sub-API	2022-04-13 13:39:45 +02:00
Gaël Deest	0f82519899	Update example to redirect within NamedRoutes	2022-04-13 11:51:12 +02:00
Gaël Deest	a3efe4163d	Complete usage example (empty HasServer instance)	2022-04-13 11:28:11 +02:00
Gaël Deest	6d43580208	Prototype	2022-04-04 10:51:40 +02:00