From 72f5d5c86ef3db22888b34450abe8339e1f5e6b1 Mon Sep 17 00:00:00 2001 From: Andrii Demydenko Date: Fri, 4 Aug 2023 18:17:26 +0100 Subject: [PATCH] Use full header type in response header instances (#1697) * Use `Header'` in response headers Use `Header'` instead of `Header` in response, so it's possible to provide `Description`, for example: ``` type PaginationTotalCountHeader = Header' '[ Description "Indicates to the client total count of items in collection" , Optional , Strict ] "Total-Count" Int ``` Note: if you want to add header with description you should use `addHeader'` or `noHeader'` which accepts `Header'` with all modifiers. --- changelog.d/full-header-type | 23 +++++++++ .../Auth/Server/Internal/AddSetCookie.hs | 8 ++- .../Servant/Auth/Server/Internal/Cookie.hs | 18 +++---- servant-server/test/Servant/ServerSpec.hs | 14 ++++-- .../src/Servant/Swagger/Internal.hs | 10 ++-- servant/src/Servant/API.hs | 5 +- servant/src/Servant/API/ResponseHeaders.hs | 50 ++++++++++++------- servant/src/Servant/API/TypeLevel.hs | 3 +- .../test/Servant/API/ResponseHeadersSpec.hs | 8 +++ stack.yaml | 17 +++++-- 10 files changed, 107 insertions(+), 49 deletions(-) create mode 100644 changelog.d/full-header-type diff --git a/changelog.d/full-header-type b/changelog.d/full-header-type new file mode 100644 index 000000000..99e7e1e51 --- /dev/null +++ b/changelog.d/full-header-type @@ -0,0 +1,23 @@ +synopsis: Use `Header'` in response headers. +prs: #1697 + +description: { + +Use `Header'` instead of `Header` in response, so it's possible to provide +`Description`, for example: + +``` +type PaginationTotalCountHeader = + Header' + '[ Description "Indicates to the client total count of items in collection" + , Optional + , Strict + ] + "Total-Count" + Int +``` + +Note: if you want to add header with description you should use `addHeader'` +or `noHeader'` which accepts `Header'` with all modifiers. + +} 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 b481e5181..985ec08b1 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 @@ -7,11 +7,9 @@ module Servant.Auth.Server.Internal.AddSetCookie where import Blaze.ByteString.Builder (toByteString) import qualified Data.ByteString as BS -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 @@ -76,12 +74,12 @@ instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where instance {-# OVERLAPPABLE #-} ( Functor m , AddSetCookies n (m old) (m cookied) - , AddHeader "Set-Cookie" SetCookie cookied new + , AddHeader mods "Set-Cookie" SetCookie cookied new ) => AddSetCookies ('S n) (m old) (m new) where addSetCookies (mCookie `SetCookieCons` rest) oldVal = case mCookie of - Nothing -> noHeader <$> addSetCookies rest oldVal - Just cookie -> addHeader cookie <$> addSetCookies rest oldVal + Nothing -> noHeader' <$> addSetCookies rest oldVal + Just cookie -> addHeader' cookie <$> addSetCookies rest oldVal instance {-# OVERLAPS #-} (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs index 8f72d8955..df1e4459f 100644 --- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs @@ -5,8 +5,6 @@ import Blaze.ByteString.Builder (toByteString) import Control.Monad (MonadPlus(..), guard) import Control.Monad.Except import Control.Monad.Reader -import qualified Crypto.JOSE as Jose -import qualified Crypto.JWT as Jose import Data.ByteArray (constEq) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS64 @@ -18,11 +16,11 @@ import Data.Time.Clock (UTCTime(..), secondsToDiffTime) import Network.HTTP.Types (methodGet) import Network.HTTP.Types.Header(hCookie) import Network.Wai (Request, requestHeaders, requestMethod) -import Servant (AddHeader, addHeader) +import Servant (AddHeader, addHeader') import System.Entropy (getEntropy) import Web.Cookie -import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT) +import Servant.Auth.JWT (FromJWT, ToJWT) import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) import Servant.Auth.Server.Internal.Types @@ -132,8 +130,8 @@ applySessionCookieSettings cookieSettings setCookie = setCookie -- provided response object with XSRF and session cookies. This should be used -- when a user successfully authenticates with credentials. acceptLogin :: ( ToJWT session - , AddHeader "Set-Cookie" SetCookie response withOneCookie - , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) + , AddHeader mods "Set-Cookie" SetCookie response withOneCookie + , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies ) => CookieSettings -> JWTSettings -> session @@ -144,7 +142,7 @@ acceptLogin cookieSettings jwtSettings session = do Nothing -> pure Nothing Just sessionCookie -> do xsrfCookie <- makeXsrfCookie cookieSettings - return $ Just $ addHeader sessionCookie . addHeader xsrfCookie + return $ Just $ addHeader' sessionCookie . addHeader' xsrfCookie -- | Arbitrary cookie expiry time set back in history after unix time 0 expireTime :: UTCTime @@ -152,12 +150,12 @@ expireTime = UTCTime (ModifiedJulianDay 50000) 0 -- | Adds headers to a response that clears all session cookies -- | using max-age and expires cookie attributes. -clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie - , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) +clearSession :: ( AddHeader mods "Set-Cookie" SetCookie response withOneCookie + , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies ) => CookieSettings -> response -> withTwoCookies -clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie +clearSession cookieSettings = addHeader' clearedSessionCookie . addHeader' clearedXsrfCookie where -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both cookieSettingsExpires = cookieSettings diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 89375736f..16c8a6d9f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -53,12 +53,12 @@ import Network.Wai.Test import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, - Headers, HttpVersion, IsSecure (..), JSON, Lenient, - NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, + Delete, Description, EmptyAPI, Fragment, Get, HasStatus (StatusOf), + Header, Header', Headers, HttpVersion, IsSecure (..), JSON, Lenient, + NoContent (..), NoContentVerb, NoFraming, OctetStream, Optional, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, - UVerb, Union, Verb, WithStatus (..), addHeader) + UVerb, Union, Verb, WithStatus (..), addHeader, addHeader') import Servant.Server (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..), emptyServer, err401, err403, err404, hoistServer, respond, serve, @@ -121,6 +121,7 @@ type VerbApi method status :<|> "noContent" :> NoContentVerb method :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "headerD" :> Verb method status '[JSON] (Headers '[Header' '[Description "desc", Optional, Strict] "H" Int] Person) :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) @@ -133,6 +134,7 @@ verbSpec = describe "Servant.API.Verb" $ do :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B") :<|> return (S.source ["bytestring"]) @@ -177,6 +179,10 @@ verbSpec = describe "Servant.API.Verb" $ do liftIO $ statusCode (simpleStatus response2) `shouldBe` status liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + response3 <- THW.request method "/headerD" [] "" + liftIO $ statusCode (simpleStatus response3) `shouldBe` status + liftIO $ simpleHeaders response3 `shouldContain` [("H", "5")] + it "handles trailing '/' gracefully" $ do response <- THW.request method "/headerNC/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index 5f7a1ff30..cb37eb751 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -38,7 +38,6 @@ import Network.HTTP.Media (MediaType) import Servant.API import Servant.API.Description (FoldDescription, reflectDescription) -import Servant.API.Generic (ToServantApi, AsApi) import Servant.API.Modifiers (FoldRequired) import Servant.Swagger.Internal.TypeLevel.API @@ -470,10 +469,15 @@ instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where class ToResponseHeader h where toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header) -instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where - toResponseHeader _ = (hname, Swagger.Header Nothing hschema) +instance (KnownSymbol sym, ToParamSchema a, KnownSymbol (FoldDescription mods)) => ToResponseHeader (Header' mods sym a) where + toResponseHeader _ = + ( hname + , Swagger.Header (transDesc $ reflectDescription (Proxy :: Proxy mods)) hschema + ) where hname = Text.pack (symbolVal (Proxy :: Proxy sym)) + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) hschema = toParamSchema (Proxy :: Proxy a) class AllToResponseHeader hs where diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 80d36bc09..347f6d846 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -127,8 +127,9 @@ import Servant.API.ReqBody import Servant.API.ResponseHeaders (AddHeader, BuildHeadersTo (buildHeadersTo), GetHeaders (getHeaders), HList (..), HasResponseHeader, - Headers (..), ResponseHeader (..), addHeader, getHeadersHList, - getResponse, lookupResponseHeader, noHeader) + Headers (..), ResponseHeader (..), addHeader, addHeader', + getHeadersHList, getResponse, lookupResponseHeader, noHeader, + noHeader') import Servant.API.Stream (FramingRender (..), FramingUnrender (..), FromSourceIO (..), NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream, diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 490553c51..b9ab50eeb 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -24,7 +24,9 @@ module Servant.API.ResponseHeaders , ResponseHeader (..) , AddHeader , addHeader + , addHeader' , noHeader + , noHeader' , HasResponseHeader , lookupResponseHeader , BuildHeadersTo(buildHeadersTo) @@ -37,7 +39,7 @@ module Servant.API.ResponseHeaders import Control.DeepSeq (NFData (..)) import Data.ByteString.Char8 as BS - (ByteString, init, pack, unlines) + (ByteString, pack) import qualified Data.CaseInsensitive as CI import qualified Data.List as L import Data.Proxy @@ -52,7 +54,9 @@ import Web.HttpApiData import Prelude () import Prelude.Compat import Servant.API.Header - (Header) + (Header') +import Servant.API.Modifiers + (Optional, Strict) import Servant.API.UVerb.Union import qualified Data.SOP.BasicFunctors as SOP import qualified Data.SOP.NS as SOP @@ -81,11 +85,11 @@ instance NFData a => NFData (ResponseHeader sym a) where data HList a where HNil :: HList '[] - HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs) + HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs) class NFDataHList xs where rnfHList :: HList xs -> () instance NFDataHList '[] where rnfHList HNil = () -instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where +instance (y ~ Header' mods h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where rnfHList (HCons h xs) = rnf h `seq` rnfHList xs instance NFDataHList xs => NFData (HList xs) where @@ -93,7 +97,7 @@ instance NFDataHList xs => NFData (HList xs) where type family HeaderValMap (f :: * -> *) (xs :: [*]) where HeaderValMap f '[] = '[] - HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs + HeaderValMap f (Header' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs class BuildHeadersTo hs where @@ -105,7 +109,7 @@ instance {-# OVERLAPPING #-} BuildHeadersTo '[] where -- The current implementation does not manipulate HTTP header field lines in any way, -- like merging field lines with the same field name in a single line. instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) - => BuildHeadersTo (Header h v ': xs) where + => BuildHeadersTo (Header' mods h v ': xs) where buildHeadersTo headers = case L.find wantedHeader headers of Nothing -> MissingHeader `HCons` buildHeadersTo headers Just header@(_, val) -> case parseHeader val of @@ -130,7 +134,7 @@ instance GetHeadersFromHList '[] where getHeadersFromHList _ = [] instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs) - => GetHeadersFromHList (Header h x ': xs) + => GetHeadersFromHList (Header' mods h x ': xs) where getHeadersFromHList hdrs = case hdrs of Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest @@ -151,42 +155,42 @@ instance GetHeaders' '[] where getHeaders' _ = [] instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v) - => GetHeaders' (Header h v ': rest) + => GetHeaders' (Header' mods h v ': rest) where getHeaders' hs = getHeadersFromHList $ getHeadersHList hs -- * Adding headers -- We need all these fundeps to save type inference -class AddHeader h v orig new - | h v orig -> new, new -> h, new -> v, new -> orig where +class AddHeader (mods :: [*]) h v orig new + | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -- In this instance, we add a Header on top of something that is already decorated with some headers instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v ) - => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where + => AddHeader mods h v (Headers (fst ': rest) a) (Headers (Header' mods h v ': fst ': rest) a) where addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -- In this instance, 'a' parameter is decorated with a Header. -instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a) - => AddHeader h v a new where +instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a) + => AddHeader mods 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 +instance (AddHeader mods h v old new) => AddHeader mods 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) + ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest) -- This ensures that the remainder of the response list is _not_ empty -- It is necessary to prevent the two instances for union types from -- overlapping. , oldrest ~ (a ': as), newrest ~ (b ': bs)) - => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where + => AddHeader mods 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 @@ -211,21 +215,29 @@ instance -- Note that while in your handlers type annotations are not required, since -- the type can be inferred from the API type, in other cases you may find -- yourself needing to add annotations. -addHeader :: AddHeader h v orig new => v -> orig -> new +addHeader :: AddHeader '[Optional, Strict] h v orig new => v -> orig -> new addHeader = addOptionalHeader . Header +-- | Same as 'addHeader' but works with `Header'`, so it's possible to use any @mods@. +addHeader' :: AddHeader mods h v orig new => v -> orig -> new +addHeader' = addOptionalHeader . Header + -- | Deliberately do not add a header to a value. -- -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String -- >>> getHeaders example1 -- [] -noHeader :: AddHeader h v orig new => orig -> new +noHeader :: AddHeader '[Optional, Strict] h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader +-- | Same as 'noHeader' but works with `Header'`, so it's possible to use any @mods@. +noHeader' :: AddHeader mods h v orig new => orig -> new +noHeader' = addOptionalHeader MissingHeader + class HasResponseHeader h a headers where hlistLookupHeader :: HList headers -> ResponseHeader h a -instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where +instance {-# OVERLAPPING #-} HasResponseHeader h a (Header' mods h a ': rest) where hlistLookupHeader (HCons ha _) = ha instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 3a3689070..0eb972a1d 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -59,7 +59,7 @@ import Servant.API.Capture (Capture, CaptureAll) import Servant.API.Fragment import Servant.API.Header - (Header) + (Header, Header') import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody @@ -130,6 +130,7 @@ type family IsElem endpoint api :: Constraint where IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) IsElem (e :> sa) (e :> sb) = IsElem sa sb IsElem sa (Header sym x :> sb) = IsElem sa sb + IsElem sa (Header' mods sym x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) = IsElem sa sb diff --git a/servant/test/Servant/API/ResponseHeadersSpec.hs b/servant/test/Servant/API/ResponseHeadersSpec.hs index 94d66078d..a1c2f080e 100644 --- a/servant/test/Servant/API/ResponseHeadersSpec.hs +++ b/servant/test/Servant/API/ResponseHeadersSpec.hs @@ -7,7 +7,11 @@ import GHC.TypeLits import Test.Hspec import Servant.API.ContentTypes +import Servant.API.Description + (Description) import Servant.API.Header +import Servant.API.Modifiers + (Optional, Strict) import Servant.API.ResponseHeaders import Servant.API.UVerb @@ -27,6 +31,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] + it "adds a header with description to a value" $ do + let val = addHeader' "hi" 5 :: Headers '[Header' '[Description "desc", Optional, Strict] "test" String] Int + getHeaders val `shouldBe` [("test", "hi")] + describe "noHeader" $ do it "does not add a header" $ do diff --git a/stack.yaml b/stack.yaml index 76402522e..d1372419d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,18 +1,25 @@ resolver: nightly-2023-04-14 packages: -- servant-client-core/ +- servant/ +- servant-auth/servant-auth +- servant-auth/servant-auth-client +- servant-auth/servant-auth-docs +- servant-auth/servant-auth-server +- servant-auth/servant-auth-swagger + - servant-client/ +- servant-client-core/ +- servant-http-streams/ - servant-docs/ - servant-foreign/ -- servant-http-streams/ - servant-server/ -- servant/ +- servant-swagger/ -- servant-conduit +# streaming - servant-machines/ +- servant-conduit - servant-pipes/ -- servant-swagger/ # allow-newer: true # ignores all bounds, that's a sledgehammer # - doc/tutorial/