Complete usage example (empty HasServer instance)

servant-server/example/greet.hs

@@ -1,10 +1,13 @@
-{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE PolyKinds         #-}
+{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE PolyKinds          #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# 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,13 @@ 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))
+
+        -- Fail in any other case
+        redirect _ = throwError err500
+
 -- 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