diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 0b994cd3..8a88dcd5 100644 --- 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,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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a2b4f033..84632dc5 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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