Named-based selection of sub-API

servant-server/example/greet.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications   #-}
 {-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE TypeOperators      #-}
 
@@ -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

servant-server/src/Servant/Server/Internal.hs

@@ -76,7 +76,7 @@ import           Servant.API
                  QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
                  RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                  Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
-                 WithNamedContext, NamedRoutes)
+                 WithNamedContext, NamedRoutes, RedirectOf(..))
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -888,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
 

servant/servant.cabal

@@ -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

servant/src/Servant/API.hs

@@ -57,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
@@ -118,6 +121,8 @@ 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
@@ -138,7 +143,7 @@ import           Servant.API.UVerb
 import           Servant.API.Vault
                  (Vault)
 import           Servant.API.NamedRoutes
-                 (NamedRoutes)
+                 (NamedRoutes, namedRoute)
 import           Servant.API.Verbs
                  (Delete, DeleteAccepted, DeleteNoContent,
                  DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

servant/src/Servant/API/NamedRoutes.hs

@@ -1,10 +1,28 @@
+{-# 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 :: * -> *)

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

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.
@@ -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

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
@@ -78,3 +81,9 @@ type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrR
 
 comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw
 comprehensiveAPIWithoutStreamingOrRaw = Proxy
+
+redirectEndpoints :: [RedirectOf ComprehensiveAPI]
+redirectEndpoints =
+  [ RedirectOf (Proxy @GET) id
+  , RedirectOf (Proxy @CaptureEndpoint) (\mkLink -> mkLink 42)
+  ]