Add HasServer instance for Redirect

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

@@ -74,7 +74,7 @@ import           Servant.API
                  CaptureAll, Description, EmptyAPI, Fragment,
                  FramingRender (..), FramingUnrender (..), FromSourceIO (..),
                  Header', If, IsSecure (..), NoContentVerb, QueryFlag,
-                 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
+                 QueryParam', QueryParams, Raw, Redirect, ReflectMethod (reflectMethod),
                  RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                  Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
                  WithNamedContext, WithRoutingHeader, NamedRoutes)
@@ -89,7 +89,7 @@ import           Servant.API.Modifiers
 import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
 import           Servant.API.Status
-                 (statusFromNat)
+                 (Redirection, statusFromNat)
 import qualified Servant.Types.SourceT                      as S
 import           Servant.API.TypeErrors
 import           Web.HttpApiData
@@ -102,6 +102,7 @@ import           Servant.Server.Internal.Delayed
 import           Servant.Server.Internal.DelayedIO
 import           Servant.Server.Internal.ErrorFormatter
 import           Servant.Server.Internal.Handler
+import           Servant.Server.Internal.Redirect
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.RouterEnv
@@ -260,6 +261,23 @@ instance ( HasServer api context
   route _ context d =
       EnvRouter enableRoutingHeaders $ route (Proxy :: Proxy api) context d
 
+-- | TODO: Documentation
+instance ( HasServer api context
+         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
+         , KnownSymbol location
+         , AllStatusesInClass Redirection api
+         )
+      => HasServer (Redirect location :> api) context where
+
+  type ServerT (Redirect location :> api) m = ServerT api m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
+
+  route _ context d =
+      EnvRouter
+        (withLocationHeader $ symbolVal $ Proxy @location)
+        (route (Proxy :: Proxy api) context d)
+
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
 

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

@@ -22,7 +22,7 @@ import           Network.Wai
 import           Servant.Server.Internal.DelayedIO
 import           Servant.Server.Internal.Handler
 import           Servant.Server.Internal.RouterEnv
-                 (RouterEnv (..), hRoutedPathHeader, routedPathRepr)
+                 (RouterEnv (..), hLocationHeader, hRoutedPathHeader, routedPathRepr)
 import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.ServerError
 
@@ -266,11 +266,17 @@ runAction action env req respond k = runResourceT $
       e <- runHandler a
       case e of
         Left err -> return . Route . withRoutingHeaders $ responseServerError err
-        Right x  -> return $! withRoutingHeaders <$> k x
+        Right x  -> return $! withHeaders <$> k x
     withRoutingHeaders :: Response -> Response
     withRoutingHeaders = if shouldReturnRoutedPath env
       then mapResponseHeaders ((hRoutedPathHeader, cs $ routedPathRepr env) :)
       else id
+    withLocationHeader :: Response -> Response
+    withLocationHeader = case locationHeader env of
+      Nothing -> id
+      Just location -> mapResponseHeaders ((hLocationHeader, cs location) :)
+    withHeaders :: Response -> Response
+    withHeaders = withLocationHeader . withRoutingHeaders
 
 {- Note [Existential Record Update]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

@@ -23,14 +23,20 @@ import           Network.HTTP.Types.Header
                  (HeaderName)
 
 data RouterEnv env = RouterEnv
-  { routedPath :: [PathPiece]
+  { locationHeader :: Maybe String
+  , routedPath :: [PathPiece]
   , shouldReturnRoutedPath :: Bool
   , routerEnv :: env
   }
   deriving Functor
 
 emptyEnv :: a -> RouterEnv a
-emptyEnv v = RouterEnv [] False v
+emptyEnv v = RouterEnv
+  { locationHeader = Nothing
+  , routedPath = []
+  , shouldReturnRoutedPath = False
+  , routerEnv = v
+  }
 
 enableRoutingHeaders :: RouterEnv env -> RouterEnv env
 enableRoutingHeaders env = env { shouldReturnRoutedPath = True }
@@ -61,5 +67,11 @@ toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hin
 toCaptureTags :: [CaptureHint] -> Text
 toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
 
+withLocationHeader :: String -> RouterEnv a -> RouterEnv a
+withLocationHeader loc env = env { locationHeader = Just loc}
+
 hRoutedPathHeader :: HeaderName
 hRoutedPathHeader = "Servant-Routed-Path"
+
+hLocationHeader :: HeaderName
+hLocationHeader = "Location"