From bfa854f20eec6213d93cb25e5da71771812f576d Mon Sep 17 00:00:00 2001
From: Nicolas BACQUEY <nicolas.bacquey@tweag.io>
Date: Tue, 29 Mar 2022 17:17:23 +0200
Subject: [PATCH] Move combinator + helpers for status checking

---
 servant-server/servant-server.cabal           |  1 +
 .../src/Servant/Server/Internal/Redirect.hs   | 53 +++++++++++++++++++
 servant/src/Servant/API.hs                    |  2 +-
 servant/src/Servant/API/Environment.hs        | 33 +++++++++++-
 4 files changed, 87 insertions(+), 2 deletions(-)
 create mode 100644 servant-server/src/Servant/Server/Internal/Redirect.hs

diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 7ab77e69..d27cb749 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -46,6 +46,7 @@ library
     Servant.Server.Internal.DelayedIO
     Servant.Server.Internal.ErrorFormatter
     Servant.Server.Internal.Handler
+    Servant.Server.Internal.Redirect
     Servant.Server.Internal.RouterEnv
     Servant.Server.Internal.RouteResult
     Servant.Server.Internal.Router
diff --git a/servant-server/src/Servant/Server/Internal/Redirect.hs b/servant-server/src/Servant/Server/Internal/Redirect.hs
new file mode 100644
index 00000000..ab196ed8
--- /dev/null
+++ b/servant-server/src/Servant/Server/Internal/Redirect.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleInstances      #-}          
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+module Servant.Server.Internal.Redirect where
+
+import           Data.SOP.Constraint
+                 (All)
+import           GHC.TypeLits
+                 (Nat, ErrorMessage(..), TypeError)
+import           Servant.API
+                 ((:>), (:<|>), Raw, Statuses, Stream, UVerb, Verb)
+import           Servant.API.Status
+                 (HasStatusClass, KnownStatusClass)
+
+type family (as :: [k]) ++ (bs :: [k]) :: [k] where
+  '[] ++ bs = bs
+  (a ': as) ++ bs = a ': (as ++ bs)
+
+-- | A type class to gather all statically declared HTTP status codes of an api
+class HasApiStatuses a where
+  type ApiStatuses a :: [Nat]
+
+instance HasApiStatuses (Verb method status ctypes a) where
+  type ApiStatuses (Verb _ status _ _) = '[status]
+
+instance HasApiStatuses (Stream method status framing ctypes a) where
+  type ApiStatuses (Stream _ status _ _ _) = '[status]
+
+instance HasApiStatuses (UVerb method ctypes as) where
+  type ApiStatuses (UVerb _ _ as) = Statuses as
+
+instance HasApiStatuses Raw where
+  type ApiStatuses Raw = TypeError ('Text "cannot observe the HTTP statuses of a Raw API")
+
+instance (HasApiStatuses api) => HasApiStatuses (api' :> api) where
+  type ApiStatuses (_ :> api) = ApiStatuses api
+
+instance (HasApiStatuses api1, HasApiStatuses api2) => HasApiStatuses (api1 :<|> api2) where
+  type ApiStatuses (api1 :<|> api2) = (ApiStatuses api1) ++ (ApiStatuses api2)
+
+-- | A type class to check that all statically declared HTTP status codes of an api
+-- belong to the same status class, as defined by @KnownStatusClass@.
+class AllStatusesInClass c api
+
+instance ( HasApiStatuses api
+         , KnownStatusClass c
+         , All (HasStatusClass c) (ApiStatuses api)
+         ) => AllStatusesInClass c api
diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs
index 2673dac4..bd1f0470 100644
--- a/servant/src/Servant/API.hs
+++ b/servant/src/Servant/API.hs
@@ -100,7 +100,7 @@ import           Servant.API.Description
 import           Servant.API.Empty
                  (EmptyAPI (..))
 import           Servant.API.Environment
-                 (WithRoutingHeader)
+                 (Redirect, WithRoutingHeader)
 import           Servant.API.Experimental.Auth
                  (AuthProtect)
 import           Servant.API.Fragment
diff --git a/servant/src/Servant/API/Environment.hs b/servant/src/Servant/API/Environment.hs
index 08e477d7..fcad0031 100644
--- a/servant/src/Servant/API/Environment.hs
+++ b/servant/src/Servant/API/Environment.hs
@@ -1,6 +1,12 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE KindSignatures     #-}
+
 {-# OPTIONS_HADDOCK not-home    #-}
 -- | Define API combinator that modify the behaviour of the routing environment.
-module Servant.API.Environment (WithRoutingHeader) where
+module Servant.API.Environment (Redirect, WithRoutingHeader) where
+
+import           GHC.TypeLits
+                 (Symbol)
 
 -- | Modify the behaviour of the following sub-API, such that all endpoint of said API
 -- return an additional routing header in their response.
@@ -21,6 +27,31 @@ module Servant.API.Environment (WithRoutingHeader) where
 --
 data WithRoutingHeader
 
+-- | Modify the behaviour of the following sub-API, such that all endpoints of said API
+-- return a "Location" header, set to the value of @location@ type variable. An API using
+-- the @Redirect@ combinator **does not typecheck** if any of the endpoints below the
+-- combinator returns a status code outside the 3xx range, or if it is used to redirect
+-- a @Raw@ API (because we cannot guarantee anything about them).
+--
+-- For instance, the following API doesn't have a @HasServer@ instance:
+--
+-- >>> type BadApi
+-- >>>   =    "old-api" :> Redirect "/new-api" :> Get '[JSON] Foo
+-- >>>   :<|> "new-api" :> Get '[JSON] Foo
+-- >>>     -- @Get@ is an alias for @Verb 'GET 200@
+--
+-- Whereas this one does:
+--
+-- >>> type GoodApi
+-- >>>   =    "old-api" :> Redirect "/new-api" :> Verb 'GET 301 '[JSON] Foo
+-- >>>   :<|> "new-api" :> Get '[JSON] Foo
+-- >>>     -- GET /old-api will return a response with status 301 and the following header:
+-- >>>     --   ("Location", "/new-api")
+--
+-- @since TODO
+--
+data Redirect (location :: Symbol)
+
 -- $setup
 -- >>> import Servant.API
 -- >>> import Data.Aeson