From 1e0f28f4f5b3b734d45e50e307fbe92014b73cdf Mon Sep 17 00:00:00 2001 From: Anurag Ohri Date: Tue, 1 Aug 2023 14:18:44 +0530 Subject: [PATCH 1/6] Add AddSetCookies instance for when the left tree is the same before and after the transformation --- .../src/Servant/Auth/Server/Internal/AddSetCookie.hs | 5 +++++ 1 file changed, 5 insertions(+) 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..c25ee7a59 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 @@ -88,6 +88,11 @@ instance {-# OVERLAPS #-} => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b +instance {-# OVERLAPPING #-} + (AddSetCookies ('S n) a a, AddSetCookies ('S n) b b') + => AddSetCookies ('S n) (a :<|> b) (a :<|> b') where + addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b + instance {-# OVERLAPS #-} ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi , Generic (api (AsServerT m)) From d1ba1da6723af1b7923ab4e981109157c170f0d9 Mon Sep 17 00:00:00 2001 From: Anurag Ohri Date: Tue, 1 Aug 2023 14:24:46 +0530 Subject: [PATCH 2/6] Added changelog --- changelog.d/1698 | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 changelog.d/1698 diff --git a/changelog.d/1698 b/changelog.d/1698 new file mode 100644 index 000000000..040494312 --- /dev/null +++ b/changelog.d/1698 @@ -0,0 +1,3 @@ +synopsis: Add AddSetCookies instance for when the left tree is the same before and after the transformation. +prs: #1698 +issues: #1601 From 6689b92946cdcd13cf0ae238b076751949e2c1b3 Mon Sep 17 00:00:00 2001 From: Andrii Demydenko Date: Fri, 4 Aug 2023 18:17:26 +0100 Subject: [PATCH 3/6] 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 c25ee7a59..2b23797fa 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/ From 92ed2fea9ab5c5108d37af3e98ee68e71fd9248a Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Wed, 2 Aug 2023 12:55:43 +0100 Subject: [PATCH 4/6] Add NamedRoutes instance for IsElem --- changelog.d/1699 | 7 +++++++ servant/src/Servant/API/TypeLevel.hs | 5 +++++ 2 files changed, 12 insertions(+) create mode 100644 changelog.d/1699 diff --git a/changelog.d/1699 b/changelog.d/1699 new file mode 100644 index 000000000..5857bf8be --- /dev/null +++ b/changelog.d/1699 @@ -0,0 +1,7 @@ +synopsis: Add NamedRoutes instance to IsElem +prs: #1699 +issues: #1674 +description: { +Add missing IsElem instance for NamedRoutes, this allows links to be checked +with `safeLink`. +} diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 0eb972a1d..9872d3d14 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -64,6 +64,10 @@ import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody (ReqBody) +import Servant.API.NamedRoutes + (NamedRoutes) +import Servant.API.Generic + (ToServantApi) import Servant.API.Sub (type (:>)) import Servant.API.Verbs @@ -143,6 +147,7 @@ type family IsElem endpoint api :: Constraint where IsElem (Verb m s ct typ) (Verb m s ct' typ) = IsSubList ct ct' IsElem e e = () + IsElem e (NamedRoutes rs) = IsElem e (ToServantApi rs) IsElem e a = IsElem' e a -- | Check whether @sub@ is a sub-API of @api@. From 8c6fc5e583bb2d2025e1bad9fc076ca2cce723f0 Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Wed, 2 Aug 2023 14:02:33 +0100 Subject: [PATCH 5/6] Add tests for nested NamedRoutes links --- servant/test/Servant/LinksSpec.hs | 66 ++++++++++++++++++++++++++++++- 1 file changed, 65 insertions(+), 1 deletion(-) diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 55c682286..95258946c 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -1,10 +1,13 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Servant.LinksSpec where +import GHC.Generics + (Generic) import Data.Proxy (Proxy (..)) import Data.String @@ -44,17 +47,51 @@ type LinkableApi = "all" :> CaptureAll "names" String :> Get '[JSON] NoContent :<|> "get" :> Get '[JSON] NoContent - apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) + +newtype QuuxRoutes mode = QuuxRoutes + { corge :: mode :- "corge" :> Post '[PlainText] NoContent + } deriving Generic + +newtype WaldoRoutes mode = WaldoRoutes + { waldo :: mode :- "waldo" :> Get '[JSON] NoContent + } deriving Generic + +data FooRoutes mode = FooRoutes + { baz :: mode :- "baz" :> Get '[JSON] NoContent + , qux :: mode :- "qux" :> NamedRoutes QuuxRoutes + , quux :: mode :- "quux" :> QueryParam "grault" String :> Get '[JSON] NoContent + , garply :: mode :- "garply" :> Capture "garply" String + :> Capture "garplyNum" Int :> NamedRoutes WaldoRoutes + } deriving Generic + +data BaseRoutes mode = BaseRoutes + { foo :: mode :- "foo" :> NamedRoutes FooRoutes + , bar :: mode :- "bar" :> Get '[JSON] NoContent + } deriving Generic + +recordApiLink + :: (IsElem endpoint (NamedRoutes BaseRoutes), HasLink endpoint) + => Proxy endpoint -> MkLink endpoint Link +recordApiLink = safeLink (Proxy :: Proxy (NamedRoutes BaseRoutes)) + -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected +(//) :: a -> (a -> b) -> b +x // f = f x +infixl 1 // + +(/:) :: (a -> b -> c) -> b -> a -> c +(/:) = flip +infixl 2 /: + spec :: Spec spec = describe "Servant.Links" $ do it "generates correct links for capture query params" $ do @@ -106,6 +143,33 @@ spec = describe "Servant.Links" $ do let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` "" + it "Generate links from record fields accessors" $ do + fieldLink bar `shouldBeLink` "bar" + (fieldLink foo // baz) `shouldBeLink` "foo/baz" + (fieldLink foo // qux // corge) `shouldBeLink` "foo/qux/corge" + (fieldLink foo // quux /: Nothing) `shouldBeLink` "foo/quux" + (fieldLink foo // quux /: Just "floop") `shouldBeLink` "foo/quux?grault=floop" + (fieldLink foo // garply /: "captureme" /: 42 // waldo) + `shouldBeLink` "foo/garply/captureme/42/waldo" + + it "Check links from record fields" $ do + let sub1 = Proxy :: Proxy ("bar" :> Get '[JSON] NoContent) + recordApiLink sub1 `shouldBeLink` "bar" + + let sub2 = Proxy :: Proxy ("foo" :> "baz" :> Get '[JSON] NoContent) + recordApiLink sub2 `shouldBeLink` "foo/baz" + + let sub3 = Proxy :: Proxy ("foo" :> "quux" :> QueryParam "grault" String + :> Get '[JSON] NoContent) + recordApiLink sub3 (Just "floop") `shouldBeLink` "foo/quux?grault=floop" + + let sub4 :: Proxy ("foo" :> "garply" :> Capture "garplyText" String + :> Capture "garplyInt" Int :> "waldo" + :> Get '[JSON] NoContent) + sub4 = Proxy + recordApiLink sub4 "captureme" 42 + `shouldBeLink` "foo/garply/captureme/42/waldo" + -- The doctests below aren't run on CI, setting that up is tricky. -- They are run by makefile rule, however. From 020e73f68aadd6dbc561300656366c45e0560596 Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Thu, 3 Aug 2023 17:12:49 +0100 Subject: [PATCH 6/6] Don't use wreq-0.5.4.1 with ghc-8.6.5 --- cabal.project | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cabal.project b/cabal.project index 5663f806e..46194df1f 100644 --- a/cabal.project +++ b/cabal.project @@ -58,6 +58,10 @@ optimization: False constraints: crypton < 0, crypton-connection < 0, crypton-x509 < 0, crypton-x509-store < 0, crypton-x509-system < 0, crypton-x509-validation < 0 constraints: warp < 3.3.26 +-- wreq-0.5.4.1 doesn't seem to work with ghc-8.6.5 +if (impl(ghc < 8.8)) + constraints: wreq == 0.5.4.0 + allow-newer: servant-js:base -- Print ticks so that doctest type querying is consistent across GHC versions.