a226009...master · servant

changelog.d/1571new file+10

since splitsnapshots

unifiedsplit

@@ -0,0 +1,10 @@

1+synopsis: Support UVerb in servant-auth-server

2+prs: #1571

3+issues: #1570

4+description: {

5+UVerb endpoints are now supported by servant-auth-server and can be used under the

6+Auth combinator when writing servers. It is still unsupported by

7+servant-auth-client.

8+

9+This PR also brings Headers support in UVerb responses

10+}

changelog.d/1573new file+2

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

1+synopsis: Add API docs for ServerT

2+prs: #1573

changelog.d/1649new file+8

@@ -0,0 +1,8 @@

1+synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)

2+prs: #1649

3+

4+description: {

5+

6+Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)

7+

8+}

doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1

@@ -330,7 +330,7 @@ data Customer = Customer {

330```

331

332Here is the code that displays the homepage.

333−It should contain a link to the the `/login` URL.

333+It should contain a link to the `/login` URL.

334When the user clicks on this link it will be redirected to Google login page

335with some generated information.

336

doc/cookbook/uverb/UVerb.lhs+1−1

@@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so

199you can try until the right one returns a value.)

200

201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

202−another shot at at the problem. It is inspired by

202+another shot at the problem. It is inspired by

203servant-checked-exceptions, so it may be worth taking a closer look.

204The README claims that

205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

servant-auth/servant-auth-server/servant-auth-server.cabal+1

@@ -129,6 +129,7 @@ test-suite spec

129 , lens-aeson >= 1.0.2 && < 1.3

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132 other-modules:

133 other-modules:

133 Servant.Auth.ServerSpec

134 Servant.Auth.ServerSpec

134 default-language: Haskell2010

135 default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9

@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)

54

55 makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56 makeCookies authResult = do

57− xsrf <- makeXsrfCookie cookieSettings

58− fmap (Just xsrf `SetCookieCons`) $

59− case authResult of

57+ case authResult of

60− (Authenticated v) -> do

58+ (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

60+ xsrf <- makeXsrfCookie cookieSettings

63− Nothing -> return $ Nothing `SetCookieCons` SetCookieNil

64− Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil

61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)

65− _ -> return $ Nothing `SetCookieCons` SetCookieNil

62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)

66

63

67 go :: (AuthResult v -> ServerT api Handler)

64 go :: (AuthResult v -> ServerT api Handler)

68 -> (AuthResult v, SetCookieList n)

65 -> (AuthResult v, SetCookieList n)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1

@@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.UVerb.Union

14import Servant.API.Generic

15import Servant.API.Generic

15import Servant.Server.Generic

16import Servant.Server.Generic

16import Web.Cookie

17import Web.Cookie

@@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where

33 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35

36

37+#if MIN_VERSION_servant_server(0,18,1)

38+type family MapAddSetCookieApiVerb (as :: [*]) where

39+ MapAddSetCookieApiVerb '[] = '[]

40+ MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)

41+#endif

42+

36type family AddSetCookieApi a :: *

43type family AddSetCookieApi a :: *

37type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

44type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

38type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

45type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

46+#if MIN_VERSION_servant_server(0,19,0)

39type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

47type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

48+#endif

40type instance AddSetCookieApi (Verb method stat ctyps a)

49type instance AddSetCookieApi (Verb method stat ctyps a)

41 = Verb method stat ctyps (AddSetCookieApiVerb a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

51+#if MIN_VERSION_servant_server(0,18,1)

52+type instance AddSetCookieApi (UVerb method ctyps as)

53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)

54+#endif

42type instance AddSetCookieApi Raw = Raw

55type instance AddSetCookieApi Raw = Raw

43#if MIN_VERSION_servant_server(0,15,0)

56#if MIN_VERSION_servant_server(0,15,0)

44type instance AddSetCookieApi (Stream method stat framing ctyps a)

57type instance AddSetCookieApi (Stream method stat framing ctyps a)

@@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

57 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

70 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

58 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

59

72

60−instance AddSetCookies 'Z orig orig where

73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where

61 addSetCookies _ = id

74 addSetCookies _ = id

62

75

63instance {-# OVERLAPPABLE #-}

76instance {-# OVERLAPPABLE #-}

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+31−3

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

2module Servant.Auth.ServerSpec (spec) where

3module Servant.Auth.ServerSpec (spec) where

3

4

4#if !MIN_VERSION_servant_server(0,16,0)

5#if !MIN_VERSION_servant_server(0,16,0)

@@ -24,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,

24import Data.Aeson.Lens (_JSON)

25import Data.Aeson.Lens (_JSON)

25import qualified Data.ByteString as BS

26import qualified Data.ByteString as BS

26import qualified Data.ByteString.Lazy as BSL

27import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

27import Data.CaseInsensitive (mk)

29import Data.CaseInsensitive (mk)

28import Data.Foldable (find)

30import Data.Foldable (find)

29import Data.Monoid

31import Data.Monoid

@@ -39,6 +41,7 @@ import Network.HTTP.Types (Status, status200,

39import Network.Wai (responseLBS)

41import Network.Wai (responseLBS)

40import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wai.Handler.Warp (testWithApplication)

41import Network.Wreq (Options, auth, basicAuth,

43import Network.Wreq (Options, auth, basicAuth,

44+ checkResponse,

42 cookieExpiryTime, cookies,

45 cookieExpiryTime, cookies,

43 defaults, get, getWith, postWith,

46 defaults, get, getWith, postWith,

44 header, oauth2Bearer,

47 header, oauth2Bearer,

@@ -182,8 +185,21 @@ cookieAuthSpec

182 it "fails with no XSRF header or cookie" $ \port -> property

185 it "fails with no XSRF header or cookie" $ \port -> property

183 $ \(user :: User) -> do

186 $ \(user :: User) -> do

184 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

185− opts <- addJwtToCookie cookieCfg jwt

188+ opts' <- addJwtToCookie cookieCfg jwt

189+ let opts = opts' & checkResponse .~ Just mempty

186− getWith opts (url port) `shouldHTTPErrorWith` status401

190+ resp <- getWith opts (url port)

191+ resp ^. responseStatus `shouldBe` status401

192+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

193+

194+ -- Validating that the XSRF cookie isn't added for UVerb routes either.

195+ -- These routes can return a 401 response directly without using throwError / throwAll,

196+ -- which revealed a bug:

197+ --

198+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449

199+ resp <- getWith opts (url port ++ "/uverb")

200+ resp ^. responseStatus `shouldBe` status401

201+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

202+

187

203

188 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

204 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

189 $ \(user :: User) -> do

205 $ \(user :: User) -> do

@@ -405,13 +421,14 @@ type API auths

405 = Auth auths User :>

421 = Auth auths User :>

406 ( Get '[JSON] Int

422 ( Get '[JSON] Int

407 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

423 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

408− :<|> NamedRoutes DummyRoutes

424+ :<|> "named" :> NamedRoutes DummyRoutes

409 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

425 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

410#if MIN_VERSION_servant_server(0,15,0)

426#if MIN_VERSION_servant_server(0,15,0)

411 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

427 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

412#endif

428#endif

413 :<|> "raw" :> Raw

429 :<|> "raw" :> Raw

414 )

430 )

431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

415 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

432 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

416 , Header "Set-Cookie" SetCookie ] NoContent)

433 , Header "Set-Cookie" SetCookie ] NoContent)

417 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

434 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

@@ -489,6 +506,11 @@ server ccfg =

489 :<|> raw

506 :<|> raw

490 Indefinite -> throwAll err401

507 Indefinite -> throwAll err401

491 _ -> throwAll err403

508 _ -> throwAll err403

509+ ) :<|>

510+ (\authResult -> case authResult of

511+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))

512+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")

513+ _ -> respond (WithStatus @403 $ pack "Forbidden")

492 )

514 )

493 :<|> getLogin

515 :<|> getLogin

494 :<|> getLogout

516 :<|> getLogout

@@ -569,6 +591,12 @@ shouldMatchCookieNames cj patterns

569 = fmap cookie_name (destroyCookieJar cj)

591 = fmap cookie_name (destroyCookieJar cj)

570 `shouldMatchList` patterns

592 `shouldMatchList` patterns

571

593

594+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation

595+shouldNotHaveCookies cj patterns =

596+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns

597+ where cookieNames :: [BS.ByteString]

598+ cookieNames = cookie_name <$> destroyCookieJar cj

599+

572shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

600shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

573shouldMatchCookieNameValues cj patterns

601shouldMatchCookieNameValues cj patterns

574 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

602 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

servant-auth/servant-auth/src/Servant/Auth.hs+1−1

@@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

27

28-- ** Combinators

29

30−-- | A JSON Web Token (JWT) in the the Authorization header:

30+-- | A JSON Web Token (JWT) in the Authorization header:

31--

32-- @Authorization: Bearer \<token\>@

33--

servant-client-core/src/Servant/Client/Core/HasClient.hs+14−4

@@ -74,7 +74,7 @@ import Servant.API

74 FromSourceIO (..), Header', Headers (..), HttpVersion,

75 IsSecure, MimeRender (mimeRender),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

77− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,

78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

80 Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,

@@ -674,6 +674,16 @@ instance RunClient m => HasClient m Raw where

674

675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

676

677+instance RunClient m => HasClient m RawM where

678+ type Client m RawM

679+ = H.Method -> m Response

680+

681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM

682+ clientWithRoute _pm Proxy req httpMethod = do

683+ runRequest req { requestMethod = httpMethod }

684+

685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)

686+

677-- | If you use a 'ReqBody' in one of your endpoints in your API,

687-- | If you use a 'ReqBody' in one of your endpoints in your API,

678-- the corresponding querying function will automatically take

688-- the corresponding querying function will automatically take

679-- an additional argument of the type specified by your 'ReqBody'.

689-- an additional argument of the type specified by your 'ReqBody'.

@@ -902,7 +912,7 @@ infixl 2 /:

902-- rootClient = client api

912-- rootClient = client api

903--

913--

904-- endpointClient :: ClientM Person

914-- endpointClient :: ClientM Person

905−-- endpointClient = client // subApi // endpoint

915+-- endpointClient = client \/\/ subApi \/\/ endpoint

906-- @

916-- @

907(//) :: a -> (a -> b) -> b

917(//) :: a -> (a -> b) -> b

908x // f = f x

918x // f = f x

@@ -935,10 +945,10 @@ x // f = f x

935-- rootClient = client api

945-- rootClient = client api

936--

946--

937-- hello :: String -> ClientM String

947-- hello :: String -> ClientM String

938−-- hello name = rootClient // hello /: name

948+-- hello name = rootClient \/\/ hello \/: name

939--

949--

940-- endpointClient :: ClientM Person

950-- endpointClient :: ClientM Person

941−-- endpointClient = client // subApi /: "foobar123" // endpoint

951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint

942-- @

952-- @

943(/:) :: (a -> b -> c) -> b -> a -> c

953(/:) :: (a -> b -> c) -> b -> a -> c

944(/:) = flip

954(/:) = flip

servant-conduit/servant-conduit.cabal+1−1

@@ -32,7 +32,7 @@ library

32 , bytestring >=0.10.8.1 && <0.12

33 , conduit >=1.3.1 && <1.4

34 , mtl ^>=2.2.2 || ^>=2.3.1

35− , resourcet >=1.2.2 && <1.3

35+ , resourcet >=1.2.2 && <1.4

36 , servant >=0.15 && <0.20

37 , unliftio-core >=0.1.2.0 && <0.3

38 hs-source-dirs: src

servant-docs/src/Servant/Docs/Internal.hs+1−1

@@ -447,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =

447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

448

449

450−-- | Generate the docs for a given API that implements 'HasDocs' with with any

450+-- | Generate the docs for a given API that implements 'HasDocs' with any

451-- number of introduction(s)

452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

453docsWithIntros intros = docsWith defaultDocOptions intros mempty

servant-server/servant-server.cabal+3−3

@@ -23,7 +23,7 @@ author: Servant Contributors

23maintainer: haskell-servant-maintainers@googlegroups.com

24copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

25build-type: Simple

26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3

27

28extra-source-files:

29 CHANGELOG.md

@@ -88,10 +88,10 @@ library

88 , network >= 2.8 && < 3.2

89 , sop-core >= 0.4.0.0 && < 0.6

90 , string-conversions >= 0.4.0.1 && < 0.5

91− , resourcet >= 1.2.2 && < 1.3

91+ , resourcet >= 1.2.2 && < 1.4

92 , tagged >= 0.8.6 && < 0.9

93 , transformers-base >= 0.4.5.2 && < 0.5

94− , wai >= 3.2.1.2 && < 3.3

94+ , wai >= 3.2.2.1 && < 3.3

95 , wai-app-static >= 3.1.6.2 && < 3.2

96 , word8 >= 0.1.3 && < 0.2

97

servant-server/src/Servant/Server/Internal.hs+36−2

@@ -6,6 +6,7 @@

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE PolyKinds #-}

@@ -65,7 +66,7 @@ import Network.HTTP.Types hiding

65import Network.Socket

66import Network.Socket

66 (SockAddr)

67 (SockAddr)

67import Network.Wai

68import Network.Wai

68− (Application, Request, httpVersion, isSecure, lazyRequestBody,

69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,

69 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

70 requestMethod, responseLBS, responseStream, vault)

71 requestMethod, responseLBS, responseStream, vault)

71import Prelude ()

72import Prelude ()

@@ -75,7 +76,7 @@ import Servant.API

75 CaptureAll, Description, EmptyAPI, Fragment,

76 CaptureAll, Description, EmptyAPI, Fragment,

76 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

77 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

77 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

78 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

78− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),

79 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

80 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

80 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

81 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

81 WithNamedContext, WithResource, NamedRoutes)

82 WithNamedContext, WithResource, NamedRoutes)

@@ -116,6 +117,10 @@ import Servant.API.TypeLevel

116 (AtLeastOneFragment, FragmentUnique)

117 (AtLeastOneFragment, FragmentUnique)

117

118

118class HasServer api context where

119class HasServer api context where

120+ -- | The type of a server for this API, given a monad to run effects in.

121+ --

122+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike

123+ -- what the @T@ in the name might suggest.

119 type ServerT api (m :: * -> *) :: *

124 type ServerT api (m :: * -> *) :: *

120

125

121 route ::

126 route ::

@@ -648,6 +653,35 @@ instance HasServer Raw context where

648 Fail a -> respond $ Fail a

653 Fail a -> respond $ Fail a

649 FailFatal e -> respond $ FailFatal e

654 FailFatal e -> respond $ FailFatal e

650

655

656+-- | Just pass the request to the underlying application and serve its response.

657+--

658+-- Example:

659+--

660+-- > type MyApi = "images" :> Raw

661+-- >

662+-- > server :: Server MyApi

663+-- > server = serveDirectory "/var/www/images"

664+instance HasServer RawM context where

665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

666+

667+ route

668+ :: Proxy RawM

669+ -> Context context

670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env

671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do

672+ routeResult <- runDelayed handleDelayed env request

673+ let respond' = liftIO . respond

674+ liftIO $ case routeResult of

675+ Route handler -> runHandler (handler request (respond . Route)) >>=

676+ \case

677+ Left e -> respond' $ FailFatal e

678+ Right a -> pure a

679+ Fail e -> respond' $ Fail e

680+ FailFatal e -> respond' $ FailFatal e

681+

682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)

683+

684+

651-- | If you use 'ReqBody' in one of the endpoints for your API,

685-- | If you use 'ReqBody' in one of the endpoints for your API,

652-- this automatically requires your server-side handler to be a function

686-- this automatically requires your server-side handler to be a function

653-- that takes an argument of the type specified by 'ReqBody'.

687-- that takes an argument of the type specified by 'ReqBody'.

servant-server/test/Servant/ServerSpec.hs+47−4

@@ -17,8 +17,10 @@ import Prelude.Compat

17

18import Control.Monad

19 (forM_, unless, when)

20+import Control.Monad.Reader (runReaderT, ask)

20import Control.Monad.Error.Class

21import Control.Monad.Error.Class

21 (MonadError (..))

22 (MonadError (..))

23+import Control.Monad.IO.Class (MonadIO(..))

22import Data.Aeson

24import Data.Aeson

23 (FromJSON, ToJSON, decode', encode)

25 (FromJSON, ToJSON, decode', encode)

24import Data.Acquire

26import Data.Acquire

@@ -54,19 +56,19 @@ import Servant.API

54 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

56 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

55 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

57 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

56 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

58 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

57− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,

58 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

60 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

59 UVerb, Union, Verb, WithStatus (..), addHeader)

61 UVerb, Union, Verb, WithStatus (..), addHeader)

60import Servant.Server

62import Servant.Server

61− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),

62− emptyServer, err401, err403, err404, respond, serve,

64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,

63 serveWithContext)

65 serveWithContext)

64import Servant.Test.ComprehensiveAPI

66import Servant.Test.ComprehensiveAPI

65import qualified Servant.Types.SourceT as S

67import qualified Servant.Types.SourceT as S

66import Test.Hspec

68import Test.Hspec

67 (Spec, context, describe, it, shouldBe, shouldContain)

69 (Spec, context, describe, it, shouldBe, shouldContain)

68import Test.Hspec.Wai

70import Test.Hspec.Wai

69− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

70 with, (<:>))

72 with, (<:>))

71import qualified Test.Hspec.Wai as THW

73import qualified Test.Hspec.Wai as THW

72

74

@@ -102,6 +104,7 @@ spec = do

102 reqBodySpec

104 reqBodySpec

103 headerSpec

105 headerSpec

104 rawSpec

106 rawSpec

107+ rawMSpec

105 alternativeSpec

108 alternativeSpec

106 responseHeadersSpec

109 responseHeadersSpec

107 uverbResponseHeadersSpec

110 uverbResponseHeadersSpec

@@ -610,6 +613,46 @@ rawSpec = do

610

613

611-- }}}

614-- }}}

612------------------------------------------------------------------------------

615------------------------------------------------------------------------------

616+-- * rawMSpec {{{

617+------------------------------------------------------------------------------

618+

619+type RawMApi = "foo" :> RawM

620+

621+rawMApi :: Proxy RawMApi

622+rawMApi = Proxy

623+

624+rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m

625+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req

626+

627+rawMSpec :: Spec

628+rawMSpec = do

629+ describe "Servant.API.RawM" $ do

630+ it "gives access to monadic context" $ do

631+ flip runSession (serve rawMApi

632+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do

633+ response <- Network.Wai.Test.request defaultRequest{

634+ pathInfo = ["foo"]

635+ }

636+ liftIO $ do

637+ simpleBody response `shouldBe` "42"

638+

639+ it "lets users throw servant errors" $ do

640+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do

641+ response <- Network.Wai.Test.request defaultRequest{

642+ pathInfo = ["foo"]

643+ }

644+ liftIO $ do

645+ statusCode (simpleStatus response) `shouldBe` 404

646+

647+ it "gets the pathInfo modified" $ do

648+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do

649+ response <- Network.Wai.Test.request defaultRequest{

650+ pathInfo = ["foo", "bar"]

651+ }

652+ liftIO $ do

653+ simpleBody response `shouldBe` cs (show ["bar" :: String])

654+-- }}}

655+------------------------------------------------------------------------------

613-- * alternativeSpec {{{

656-- * alternativeSpec {{{

614------------------------------------------------------------------------------

657------------------------------------------------------------------------------

615type AlternativeApi =

658type AlternativeApi =

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

@@ -119,7 +119,7 @@ import Servant.API.NamedRoutes

119import Servant.API.QueryParam

120 (QueryFlag, QueryParam, QueryParam', QueryParams)

121import Servant.API.Raw

122− (Raw)

122+ (Raw, RawM)

123import Servant.API.RemoteHost

124 (RemoteHost)

125import Servant.API.ReqBody

servant/src/Servant/API/Raw.hs+3

@@ -15,3 +15,6 @@ import Data.Typeable

15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>

16-- to serve static files stored in a particular directory on your filesystem

17data Raw deriving Typeable

18+

19+-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.

20+data RawM deriving Typeable

servant/src/Servant/API/ResponseHeaders.hs+23

@@ -8,6 +8,7 @@

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13{-# OPTIONS_HADDOCK not-home #-}

14{-# OPTIONS_HADDOCK not-home #-}

@@ -51,6 +52,9 @@ import Prelude ()

51import Prelude.Compat

52import Prelude.Compat

52import Servant.API.Header

53import Servant.API.Header

53 (Header)

54 (Header)

55+import Servant.API.UVerb.Union

56+import qualified Data.SOP.BasicFunctors as SOP

57+import qualified Data.SOP.NS as SOP

54

58

55-- | Response Header objects. You should never need to construct one directly.

59-- | Response Header objects. You should never need to construct one directly.

56-- Instead, use 'addOptionalHeader'.

60-- Instead, use 'addOptionalHeader'.

@@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '

170 => AddHeader h v a new where

174 => AddHeader h v a new where

171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

172

176

177+-- Instances to decorate all responses in a 'Union' with headers. The functional

178+-- dependencies force us to consider singleton lists as the base case in the

179+-- recursion (it is impossible to determine h and v otherwise from old / new

180+-- responses if the list is empty).

181+instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where

182+ addOptionalHeader hdr resp =

183+ SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp

184+

185+instance

186+ ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)

187+ -- This ensures that the remainder of the response list is _not_ empty

188+ -- It is necessary to prevent the two instances for union types from

189+ -- overlapping.

190+ , oldrest ~ (a ': as), newrest ~ (b ': bs))

191+ => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where

192+ addOptionalHeader hdr resp = case resp of

193+ SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead

194+ SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers

195+

173-- | @addHeader@ adds a header to a response. Note that it changes the type of

196-- | @addHeader@ adds a header to a response. Note that it changes the type of

174-- the value in the following ways:

197-- the value in the following ways:

175--

198--

servant/src/Servant/API/UVerb.hs+3

@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)

38import Network.HTTP.Types (Status, StdMethod)

39import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))

40import Servant.API.Status (KnownStatus, statusVal)

41+import Servant.API.ResponseHeaders (Headers)

41import Servant.API.UVerb.Union

42import Servant.API.UVerb.Union

42

43

43class KnownStatus (StatusOf a) => HasStatus (a :: *) where

44class KnownStatus (StatusOf a) => HasStatus (a :: *) where

@@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a

86instance KnownStatus n => HasStatus (WithStatus n a) where

87instance KnownStatus n => HasStatus (WithStatus n a) where

87 type StatusOf (WithStatus n a) = n

88 type StatusOf (WithStatus n a) = n

88

89

90+instance HasStatus a => HasStatus (Headers ls a) where

91+ type StatusOf (Headers ls a) = StatusOf a

89

92

90-- | A variant of 'Verb' that can have any of a number of response values and status codes.

93-- | A variant of 'Verb' that can have any of a number of response values and status codes.

91--

94--

servant/src/Servant/Links.hs+5−1

@@ -175,7 +175,7 @@ import Servant.API.NamedRoutes

175import Servant.API.QueryParam

176 (QueryFlag, QueryParam', QueryParams)

177import Servant.API.Raw

178− (Raw)

178+ (Raw, RawM)

179import Servant.API.RemoteHost

180 (RemoteHost)

181import Servant.API.ReqBody

@@ -589,6 +589,10 @@ instance HasLink Raw where

589 type MkLink Raw a = a

590 toLink toA _ = toA

591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

592instance HasLink (Stream m status fr ct a) where

596instance HasLink (Stream m status fr ct a) where

593 type MkLink (Stream m status fr ct a) r = r

597 type MkLink (Stream m status fr ct a) r = r

594 toLink toA _ = toA

598 toLink toA _ = toA

servant/test/Servant/API/ResponseHeadersSpec.hs+11

@@ -2,10 +2,14 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Servant.API.ResponseHeadersSpec where

4

5+import Data.Proxy

6+import GHC.TypeLits

5import Test.Hspec

7import Test.Hspec

6

8

9+import Servant.API.ContentTypes

7import Servant.API.Header

10import Servant.API.Header

8import Servant.API.ResponseHeaders

11import Servant.API.ResponseHeaders

12+import Servant.API.UVerb

9

13

10spec :: Spec

14spec :: Spec

11spec = describe "Servant.API.ResponseHeaders" $ do

15spec = describe "Servant.API.ResponseHeaders" $ do

@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do

28 it "does not add a header" $ do

32 it "does not add a header" $ do

29 let val = noHeader 5 :: Headers '[Header "test" Int] Int

33 let val = noHeader 5 :: Headers '[Header "test" Int] Int

30 getHeaders val `shouldBe` []

34 getHeaders val `shouldBe` []

35+

36+ describe "HasStatus Headers" $ do

37+

38+ it "gets the status from the underlying value" $ do

39+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204

40+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503

41+