master..c19ed0f · typeable/servant

changelog.d/1580deleted−12

since splitsnapshots

unifiedsplit

@@ -1,12 +0,0 @@

1−synopsis: Allow IO in validationKeys

2−prs: #1580

3−issues: #1579

4−

5−description: {

6−

7−Currently validationKeys are a fixed JWKSet. This does not work with OIDC

8−providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to

9−discover new and expired keys.

10−

11−This change alters the type of validationKeys from JWKSet to IO JWKSet.

12−}

changelog.d/1589deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Only include question mark for nonempty query strings

2−prs: 1589

changelog.d/1595deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Run ClientEnv's makeClientRequest in IO.

2−prs: #1595

doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1

@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`

119to http-client's `Request`, and we can inspect it:

120

121```haskell

122− req' <- I.defaultMakeClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

123 putStrLn $ "Making request: " ++ show req'

124```

125

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2

@@ -33,7 +33,7 @@ data JWTSettings = JWTSettings

33 -- | Algorithm used to sign JWT.

34 , jwtAlg :: Maybe Jose.Alg

35 -- | Keys used to validate JWT.

36− , validationKeys :: IO Jose.JWKSet

36+ , validationKeys :: Jose.JWKSet

37 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

38 -- intended recipient of the JWT.

39 , audienceMatches :: Jose.StringOrURI -> IsMatch

@@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings

44defaultJWTSettings k = JWTSettings

45 { signingKey = k

46 , jwtAlg = Nothing

47− , validationKeys = pure $ Jose.JWKSet [k]

47+ , validationKeys = Jose.JWKSet [k]

48 , audienceMatches = const Matches }

49

50-- | The policies to use when generating cookies.

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+3−4

@@ -58,15 +58,14 @@ makeJWT v cfg expiry = runExceptT $ do

58

59verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

60verifyJWT jwtCfg input = do

61− keys <- validationKeys jwtCfg

62− verifiedJWT <- runExceptT $ do

61+ verifiedJWT <- liftIO $ runExceptT $ do

63 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

62 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

64 Jose.verifyClaims

63 Jose.verifyClaims

65 (jwtSettingsToJwtValidationSettings jwtCfg)

64 (jwtSettingsToJwtValidationSettings jwtCfg)

66− keys

65+ (validationKeys jwtCfg)

67 unverifiedJWT

66 unverifiedJWT

68 return $ case verifiedJWT of

67 return $ case verifiedJWT of

69 Left (_ :: Jose.JWTError) -> Nothing

68 Left (_ :: Jose.JWTError) -> Nothing

70 Right v -> case decodeJWT v of

69 Right v -> case decodeJWT v of

71 Left _ -> Nothing

70 Left _ -> Nothing

72− Right v' -> Just v'

71+ Right v' -> Just v'

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+5−1

@@ -31,13 +31,15 @@ library

31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32 ghc-options: -Wall

33 build-depends:

34− base >= 4.10 && < 4.17

34+ base >= 4.10 && < 4.16

35 , text >= 1.2.3.0 && < 2.1

36 , servant-swagger >= 1.1.5 && < 2

37 , swagger2 >= 2.2.2 && < 3

38 , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40 , lens >= 4.16.1 && < 5.2

41+ if impl(ghc >= 9)

42+ buildable: False

41 exposed-modules:

43 exposed-modules:

42 Servant.Auth.Swagger

44 Servant.Auth.Swagger

43 default-language: Haskell2010

45 default-language: Haskell2010

@@ -59,6 +61,8 @@ test-suite spec

59 , servant

61 , servant

60 , servant-auth

62 , servant-auth

61 , lens

63 , lens

64+ if impl(ghc >= 9)

65+ buildable: False

62

66

63 -- test dependencies

67 -- test dependencies

64 build-depends:

68 build-depends:

servant-client-core/src/Servant/Client/Core/Request.hs+3−4

@@ -51,9 +51,9 @@ import Network.HTTP.Media

51 (MediaType)

52import Network.HTTP.Types

53 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

54− http11, methodGet, urlEncodeBuilder)

54+ http11, methodGet)

55import Servant.API

56− (ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)

56+ (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

57

58import Servant.Client.Core.Internal (mediaTypeRnf)

59

@@ -165,8 +165,7 @@ appendToQueryString pname pvalue req

165-- | Encode a query parameter value.

166--

167encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168−encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString

168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

169− . urlEncodeBuilder True . encodeUtf8 . toQueryParam

170

169

171-- | Add header to the request being constructed.

170-- | Add header to the request being constructed.

172--

171--

servant-client/src/Servant/Client/Internal/HttpClient.hs+5−6

@@ -80,7 +80,7 @@ data ClientEnv

80 { manager :: Client.Manager

81 , baseUrl :: BaseUrl

82 , cookieJar :: Maybe (TVar Client.CookieJar)

83− , makeClientRequest :: BaseUrl -> Request -> IO Client.Request

83+ , makeClientRequest :: BaseUrl -> Request -> Client.Request

84 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'

85 -- Note that:

86 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,

@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

162performRequest :: Maybe [Status] -> Request -> ClientM Response

163performRequest acceptStatus req = do

164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− clientRequest <- liftIO $ createClientRequest burl req

165+ let clientRequest = createClientRequest burl req

166 request <- case cookieJar' of

167 Nothing -> pure clientRequest

168 Just cj -> liftIO $ do

@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response

229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'

230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'

231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'

232−defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request

232+defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

233−defaultMakeClientRequest burl r = return Client.defaultRequest

233+defaultMakeClientRequest burl r = Client.defaultRequest

234 { Client.method = requestMethod r

235 , Client.host = fromString $ baseUrlHost burl

236 , Client.port = baseUrlPort burl

@@ -289,8 +289,7 @@ defaultMakeClientRequest burl r = return Client.defaultRequest

289 Https -> True

290

291 -- Query string builder which does not do any encoding

292− buildQueryString [] = mempty

293− buildQueryString qps = "?" <> foldl' addQueryParam mempty qps

292+ buildQueryString = ("?" <>) . foldl' addQueryParam mempty

294

293

295 addQueryParam qs (k, v) =

294 addQueryParam qs (k, v) =

296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

295 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2

@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response

140performRequest acceptStatus req = do

141 -- TODO: should use Client.withResponse here too

142 ClientEnv m burl cookieJar' createClientRequest <- ask

143− clientRequest <- liftIO $ createClientRequest burl req

143+ let clientRequest = createClientRequest burl req

144 request <- case cookieJar' of

145 Nothing -> pure clientRequest

146 Just cj -> liftIO $ do

@@ -177,7 +177,7 @@ performWithStreamingRequest req k = do

177 m <- asks manager

178 burl <- asks baseUrl

179 createClientRequest <- asks makeClientRequest

180− request <- liftIO $ createClientRequest burl req

180+ let request = createClientRequest burl req

181 ClientM $ lift $ lift $ Codensity $ \k1 ->

182 Client.withResponse request m $ \res -> do

183 let status = Client.responseStatus res

servant-client/test/Servant/SuccessSpec.hs+1−2

@@ -162,8 +162,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

162 mgr <- C.newManager C.defaultManagerSettings

163 -- In proper situation, extra headers should probably be visible in API type.

164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

165− let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })

165+ let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

166− (defaultMakeClientRequest url r)

167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

166 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

167 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

169 case res of

168 case res of

servant-docs/src/Servant/Docs/Internal.hs−4

@@ -62,7 +62,6 @@ import GHC.TypeLits

62import Servant.API

63import Servant.API.ContentTypes

64import Servant.API.TypeLevel

65−import Servant.API.Generic

66

65

67import qualified Data.Universe.Helpers as U

66import qualified Data.Universe.Helpers as U

68

67

@@ -1151,9 +1150,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r

1151 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1150 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1152 action' = over authInfo (|> toAuthInfo authProxy) action

1151 action' = over authInfo (|> toAuthInfo authProxy) action

1153

1152

1154−instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1155− docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1156−

1157-- ToSample instances for simple types

1153-- ToSample instances for simple types

1158instance ToSample NoContent

1154instance ToSample NoContent

1159instance ToSample Bool

1155instance ToSample Bool

servant-swagger/src/Servant/Swagger.hs−2

@@ -55,7 +55,6 @@ import Servant.Swagger.Internal.Orphans ()

55-- >>> import Data.Typeable

56-- >>> import GHC.Generics

57-- >>> import Servant.API

58−-- >>> import System.Environment

59-- >>> import Test.Hspec

58-- >>> import Test.Hspec

60-- >>> import Test.QuickCheck

59-- >>> import Test.QuickCheck

61-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

60-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

@@ -65,7 +64,6 @@ import Servant.Swagger.Internal.Orphans ()

65-- >>> :set -XGeneralizedNewtypeDeriving

64-- >>> :set -XGeneralizedNewtypeDeriving

66-- >>> :set -XOverloadedStrings

65-- >>> :set -XOverloadedStrings

67-- >>> :set -XTypeOperators

66-- >>> :set -XTypeOperators

68−-- >>> setEnv "HSPEC_COLOR" "no"

69-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

67-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

70-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

68-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

71-- >>> instance ToJSON User

69-- >>> instance ToJSON User

servant-swagger/src/Servant/Swagger/Internal.hs−11

@@ -3,13 +3,11 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedLists #-}

7{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE TypeFamilies #-}

13#if __GLASGOW_HASKELL__ >= 806

11#if __GLASGOW_HASKELL__ >= 806

14{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

15#endif

13#endif

@@ -32,13 +30,11 @@ import qualified Data.Swagger as Swagger

32import Data.Swagger.Declare

30import Data.Swagger.Declare

33import Data.Text (Text)

31import Data.Text (Text)

34import qualified Data.Text as Text

32import qualified Data.Text as Text

35−import GHC.Generics (D1, Meta(..), Rep)

36import GHC.TypeLits

33import GHC.TypeLits

37import Network.HTTP.Media (MediaType)

34import Network.HTTP.Media (MediaType)

38import Servant.API

35import Servant.API

39import Servant.API.Description (FoldDescription,

36import Servant.API.Description (FoldDescription,

40 reflectDescription)

37 reflectDescription)

41−import Servant.API.Generic (ToServantApi, AsApi)

42import Servant.API.Modifiers (FoldRequired)

38import Servant.API.Modifiers (FoldRequired)

43

39

44import Servant.Swagger.Internal.TypeLevel.API

40import Servant.Swagger.Internal.TypeLevel.API

@@ -153,10 +149,6 @@ mkEndpointNoContentVerb path _ = mempty

153addParam :: Param -> Swagger -> Swagger

149addParam :: Param -> Swagger -> Swagger

154addParam param = allOperations.parameters %~ (Inline param :)

150addParam param = allOperations.parameters %~ (Inline param :)

155

151

156−-- | Add a tag to every operation in the spec.

157−addTag :: Text -> Swagger -> Swagger

158−addTag tag = allOperations.tags %~ ([tag] <>)

159−

160-- | Add accepted content types to every operation in the spec.

152-- | Add accepted content types to every operation in the spec.

161addConsumes :: [MediaType] -> Swagger -> Swagger

153addConsumes :: [MediaType] -> Swagger -> Swagger

162addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

154addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

@@ -447,9 +439,6 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo

447 & required ?~ True

439 & required ?~ True

448 & schema .~ ParamBody ref

440 & schema .~ ParamBody ref

449

441

450−instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where

451− toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

452−

453-- =======================================================================

442-- =======================================================================

454-- Below are the definitions that should be in Servant.API.ContentTypes

443-- Below are the definitions that should be in Servant.API.ContentTypes

455-- =======================================================================

444-- =======================================================================

servant-swagger/src/Servant/Swagger/Internal/Test.hs−2

@@ -29,12 +29,10 @@ import Servant.Swagger.Internal.TypeLevel

29-- >>> import Control.Applicative

30-- >>> import GHC.Generics

31-- >>> import Test.QuickCheck

32−-- >>> import System.Environment (setEnv)

33-- >>> :set -XDeriveGeneric

32-- >>> :set -XDeriveGeneric

34-- >>> :set -XGeneralizedNewtypeDeriving

33-- >>> :set -XGeneralizedNewtypeDeriving

35-- >>> :set -XDataKinds

34-- >>> :set -XDataKinds

36-- >>> :set -XTypeOperators

35-- >>> :set -XTypeOperators

37−-- >>> setEnv "HSPEC_COLOR" "no"

38

36

39-- | Verify that every type used with @'JSON'@ content type in a servant API

37-- | Verify that every type used with @'JSON'@ content type in a servant API

40-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

38-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295-- then this would be taken care of. However there is no more specific instance

296-- between that and 'MimeRender JSON a', so we do this instead

297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

299 where

300 pctyp = Proxy :: Proxy ctyp

301

servant/test/Servant/API/ContentTypesSpec.hs−11

@@ -33,8 +33,6 @@ import Data.String.Conversions

33import qualified Data.Text as TextS

34import qualified Data.Text.Encoding as TextSE

35import qualified Data.Text.Lazy as TextL

36−import Control.Exception

37− (evaluate)

38import GHC.Generics

36import GHC.Generics

39import Test.Hspec

37import Test.Hspec

40import Test.QuickCheck

38import Test.QuickCheck

@@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do

80 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

78 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

81 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

79 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

82

80

83− describe "The NoContent Content-Type type" $ do

84− let p = Proxy :: Proxy '[JSON]

85−

86− it "does not render any content" $

87− allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))

88−

89− it "evaluates the NoContent value" $

90− evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall

91−

92 describe "The PlainText Content-Type type" $ do

81 describe "The PlainText Content-Type type" $ do

93 let p = Proxy :: Proxy PlainText

82 let p = Proxy :: Proxy PlainText

94

83