a226009..master · servant

changelog.d/1571new file+10

@@ -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 {

330330```

331331

332332Here 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.

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

335335with some generated information.

336336

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

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

200200

201201[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

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

204204The README claims that

205205[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

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

130130 , warp >= 3.2.25 && < 3.4

131131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132133 other-modules:

133134 Servant.Auth.ServerSpec

134135 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)

5454

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

5656 makeCookies authResult = do

57− xsrf <- makeXsrfCookie cookieSettings

58− fmap (Just xsrf `SetCookieCons`) $

59− case authResult of

60− (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

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

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

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

57+ case authResult of

58+ (Authenticated v) -> do

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

60+ xsrf <- makeXsrfCookie cookieSettings

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

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

6663

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

6865 -> (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 (..))

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14+import Servant.API.UVerb.Union

1415import Servant.API.Generic

1516import Servant.Server.Generic

1617import Web.Cookie

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

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

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

3536

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+

3643type family AddSetCookieApi a :: *

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

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

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

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

48+#endif

4049type instance AddSetCookieApi (Verb method stat ctyps a)

4150 = 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

4255type instance AddSetCookieApi Raw = Raw

4356#if MIN_VERSION_servant_server(0,15,0)

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

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

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

5871 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

5972

60−instance AddSetCookies 'Z orig orig where

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

6174 addSetCookies _ = id

6275

6376instance {-# OVERLAPPABLE #-}

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

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

23module Servant.Auth.ServerSpec (spec) where

34

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

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

2425import Data.Aeson.Lens (_JSON)

2526import qualified Data.ByteString as BS

2627import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

2729import Data.CaseInsensitive (mk)

2830import Data.Foldable (find)

2931import Data.Monoid

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

3941import Network.Wai (responseLBS)

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

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

44+ checkResponse,

4245 cookieExpiryTime, cookies,

4346 defaults, get, getWith, postWith,

4447 header, oauth2Bearer,

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

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

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

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

185− opts <- addJwtToCookie cookieCfg jwt

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

188+ opts' <- addJwtToCookie cookieCfg jwt

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

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+

187203

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

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

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

405421 = Auth auths User :>

406422 ( Get '[JSON] Int

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

408− :<|> NamedRoutes DummyRoutes

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

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

410426#if MIN_VERSION_servant_server(0,15,0)

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

412428#endif

413429 :<|> "raw" :> Raw

414430 )

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

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

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

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

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

489506 :<|> raw

490507 Indefinite -> throwAll err401

491508 _ -> 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")

492514 )

493515 :<|> getLogin

494516 :<|> getLogout

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

569591 = fmap cookie_name (destroyCookieJar cj)

570592 `shouldMatchList` patterns

571593

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+

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

573601shouldMatchCookieNameValues cj patterns

574602 = 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

2727

2828-- ** Combinators

2929

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

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

3131--

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

3333--

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

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

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

7575 IsSecure, MimeRender (mimeRender),

7676 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

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

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

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

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

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

674674

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

676676

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+

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

678688-- the corresponding querying function will automatically take

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

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

902912-- rootClient = client api

903913--

904914-- endpointClient :: ClientM Person

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

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

906916-- @

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

908918x // f = f x

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

935945-- rootClient = client api

936946--

937947-- hello :: String -> ClientM String

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

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

939949--

940950-- endpointClient :: ClientM Person

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

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

942952-- @

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

944954(/:) = flip

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

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

3232 , bytestring >=0.10.8.1 && <0.12

3333 , conduit >=1.3.1 && <1.4

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

35− , resourcet >=1.2.2 && <1.3

35+ , resourcet >=1.2.2 && <1.4

3636 , servant >=0.15 && <0.20

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

3838 hs-source-dirs: src

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

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

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

448448

449449

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

451451-- number of introduction(s)

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

453453docsWithIntros intros = docsWith defaultDocOptions intros mempty

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

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

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

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

2525build-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

2727

2828extra-source-files:

2929 CHANGELOG.md

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

8888 , network >= 2.8 && < 3.2

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

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

91− , resourcet >= 1.2.2 && < 1.3

91+ , resourcet >= 1.2.2 && < 1.4

9292 , tagged >= 0.8.6 && < 0.9

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

94− , wai >= 3.2.1.2 && < 3.3

94+ , wai >= 3.2.2.1 && < 3.3

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

9696 , word8 >= 0.1.3 && < 0.2

9797

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

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

66{-# LANGUAGE FlexibleContexts #-}

77{-# LANGUAGE FlexibleInstances #-}

88{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE LambdaCase #-}

910{-# LANGUAGE MultiParamTypeClasses #-}

1011{-# LANGUAGE OverloadedStrings #-}

1112{-# LANGUAGE PolyKinds #-}

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

6566import Network.Socket

6667 (SockAddr)

6768import Network.Wai

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

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

6970 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

7071 requestMethod, responseLBS, responseStream, vault)

7172import Prelude ()

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

7576 CaptureAll, Description, EmptyAPI, Fragment,

7677 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

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

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

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

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

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

8182 WithNamedContext, WithResource, NamedRoutes)

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

116117 (AtLeastOneFragment, FragmentUnique)

117118

118119class 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.

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

120125

121126 route ::

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

648653 Fail a -> respond $ Fail a

649654 FailFatal e -> respond $ FailFatal e

650655

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+

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

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

653687-- 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

1717

1818import Control.Monad

1919 (forM_, unless, when)

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

2021import Control.Monad.Error.Class

2122 (MonadError (..))

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

2224import Data.Aeson

2325 (FromJSON, ToJSON, decode', encode)

2426import Data.Acquire

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

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

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

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

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

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

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

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

6062import Servant.Server

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

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

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

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

6365 serveWithContext)

6466import Servant.Test.ComprehensiveAPI

6567import qualified Servant.Types.SourceT as S

6668import Test.Hspec

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

6870import Test.Hspec.Wai

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

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

7072 with, (<:>))

7173import qualified Test.Hspec.Wai as THW

7274

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

102104 reqBodySpec

103105 headerSpec

104106 rawSpec

107+ rawMSpec

105108 alternativeSpec

106109 responseHeadersSpec

107110 uverbResponseHeadersSpec

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

610613

611614-- }}}

612615------------------------------------------------------------------------------

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+------------------------------------------------------------------------------

613656-- * alternativeSpec {{{

614657------------------------------------------------------------------------------

615658type AlternativeApi =

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

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

119119import Servant.API.QueryParam

120120 (QueryFlag, QueryParam, QueryParam', QueryParams)

121121import Servant.API.Raw

122− (Raw)

122+ (Raw, RawM)

123123import Servant.API.RemoteHost

124124 (RemoteHost)

125125import Servant.API.ReqBody

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

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

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

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

1717data 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 @@

88{-# LANGUAGE PolyKinds #-}

99{-# LANGUAGE ScopedTypeVariables #-}

1010{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

1112{-# LANGUAGE TypeOperators #-}

1213{-# LANGUAGE UndecidableInstances #-}

1314{-# OPTIONS_HADDOCK not-home #-}

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

5152import Prelude.Compat

5253import Servant.API.Header

5354 (Header)

55+import Servant.API.UVerb.Union

56+import qualified Data.SOP.BasicFunctors as SOP

57+import qualified Data.SOP.NS as SOP

5458

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

5660-- Instead, use 'addOptionalHeader'.

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

170174 => AddHeader h v a new where

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

172176

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+

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

174197-- the value in the following ways:

175198--

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

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

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

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

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

41+import Servant.API.ResponseHeaders (Headers)

4142import Servant.API.UVerb.Union

4243

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

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

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

8788 type StatusOf (WithStatus n a) = n

8889

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

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

8992

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

9194--

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

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

175175import Servant.API.QueryParam

176176 (QueryFlag, QueryParam', QueryParams)

177177import Servant.API.Raw

178− (Raw)

178+ (Raw, RawM)

179179import Servant.API.RemoteHost

180180 (RemoteHost)

181181import Servant.API.ReqBody

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

589589 type MkLink Raw a = a

590590 toLink toA _ = toA

591591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

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

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

594598 toLink toA _ = toA

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

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

22{-# LANGUAGE OverloadedStrings #-}

33module Servant.API.ResponseHeadersSpec where

44

5+import Data.Proxy

6+import GHC.TypeLits

57import Test.Hspec

68

9+import Servant.API.ContentTypes

710import Servant.API.Header

811import Servant.API.ResponseHeaders

12+import Servant.API.UVerb

913

1014spec :: Spec

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

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

2832 it "does not add a header" $ do

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

3034 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+