From 030d85288362b65c0a1c233cf3547b6f5e9c874e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Tue, 22 Mar 2022 11:21:54 +0100 Subject: [PATCH] Support UVerb in servant-auth-server --- .../servant-auth-server.cabal | 1 + .../Auth/Server/Internal/AddSetCookie.hs | 15 ++++++++++++++- .../test/Servant/Auth/ServerSpec.hs | 4 ++++ servant/src/Servant/API/ResponseHeaders.hs | 19 +++++++++++++++++++ servant/src/Servant/API/UVerb.hs | 3 +++ 5 files changed, 41 insertions(+), 1 deletion(-) diff --git a/servant-auth/servant-auth-server/servant-auth-server.cabal b/servant-auth/servant-auth-server/servant-auth-server.cabal index aad2687e..c1fe2316 100644 --- a/servant-auth/servant-auth-server/servant-auth-server.cabal +++ b/servant-auth/servant-auth-server/servant-auth-server.cabal @@ -129,6 +129,7 @@ test-suite spec , lens-aeson >= 1.0.2 && < 1.2 , warp >= 3.2.25 && < 3.4 , wreq >= 0.5.2.1 && < 0.6 + , text >= 1.2.3.0 && < 2.1 other-modules: Servant.Auth.ServerSpec default-language: Haskell2010 diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs index e3c60342..b481e518 100644 --- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..)) import qualified Network.HTTP.Types as HTTP import Network.Wai (mapResponseHeaders) import Servant +import Servant.API.UVerb.Union import Servant.API.Generic import Servant.Server.Generic import Web.Cookie @@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a +#if MIN_VERSION_servant_server(0,18,1) +type family MapAddSetCookieApiVerb (as :: [*]) where + MapAddSetCookieApiVerb '[] = '[] + MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as) +#endif + type family AddSetCookieApi a :: * type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b +#if MIN_VERSION_servant_server(0,19,0) type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api) +#endif type instance AddSetCookieApi (Verb method stat ctyps a) = Verb method stat ctyps (AddSetCookieApiVerb a) +#if MIN_VERSION_servant_server(0,18,1) +type instance AddSetCookieApi (UVerb method ctyps as) + = UVerb method ctyps (MapAddSetCookieApiVerb as) +#endif type instance AddSetCookieApi Raw = Raw #if MIN_VERSION_servant_server(0,15,0) type instance AddSetCookieApi (Stream method stat framing ctyps a) @@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb => AddSetCookies ('S n) (a -> oldb) (a -> newb) where addSetCookies cookies oldfn = addSetCookies cookies . oldfn -instance AddSetCookies 'Z orig orig where +instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where addSetCookies _ = id instance {-# OVERLAPPABLE #-} diff --git a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 1810e64d..b2e10c66 100644 --- a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} module Servant.Auth.ServerSpec (spec) where #if !MIN_VERSION_servant_server(0,16,0) @@ -25,6 +26,7 @@ import Data.Aeson (FromJSON, ToJSON, Value, import Data.Aeson.Lens (_JSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) import Data.CaseInsensitive (mk) import Data.Foldable (find) import Data.Monoid @@ -407,6 +409,7 @@ type API auths ( Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int :<|> NamedRoutes DummyRoutes + :<|> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 500 Text] :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) #if MIN_VERSION_servant_server(0,15,0) :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) @@ -483,6 +486,7 @@ server ccfg = Authenticated usr -> getInt usr :<|> postInt usr :<|> DummyRoutes { dummyInt = getInt usr } + :<|> respond (WithStatus @200 (42 :: Int)) :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0) :<|> return (S.source ["bytestring"]) diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index de60ef3b..556faa8c 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -8,6 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -51,6 +52,9 @@ import Prelude () import Prelude.Compat import Servant.API.Header (Header) +import Servant.API.UVerb.Union +import qualified Data.SOP.BasicFunctors as SOP +import qualified Data.SOP.NS as SOP -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'. @@ -170,6 +174,21 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers ' => AddHeader h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) +-- Instances to decorate all responses in a 'Union' with headers. The functional +-- dependencies force us to consider singleton lists as the base case in the +-- recursion (it is impossible to determine h and v otherwise from old / new +-- responses if the list is empty). +instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where + addOptionalHeader hdr resp = + SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp + +instance + (AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest), oldrest ~ (a ': as), newrest ~ (b ': bs)) + => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where + addOptionalHeader hdr resp = case resp of + SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead + SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers + -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- diff --git a/servant/src/Servant/API/UVerb.hs b/servant/src/Servant/API/UVerb.hs index ed59eded..5f504a73 100644 --- a/servant/src/Servant/API/UVerb.hs +++ b/servant/src/Servant/API/UVerb.hs @@ -38,6 +38,7 @@ import GHC.TypeLits (Nat) import Network.HTTP.Types (Status, StdMethod) import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender)) import Servant.API.Status (KnownStatus, statusVal) +import Servant.API.ResponseHeaders (Headers) import Servant.API.UVerb.Union class KnownStatus (StatusOf a) => HasStatus (a :: *) where @@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a instance KnownStatus n => HasStatus (WithStatus n a) where type StatusOf (WithStatus n a) = n +instance HasStatus a => HasStatus (Headers ls a) where + type StatusOf (Headers ls a) = StatusOf a -- | A variant of 'Verb' that can have any of a number of response values and status codes. --