6392dce...master · servant

.github/workflows/master.yml+34−34

@@ -76,40 +76,40 @@ jobs:

7676 (cd servant-conduit && eval $DOCTEST)

7777 (cd servant-pipes && eval $DOCTEST)

7878

79− stack:

80− name: stack / ghc ${{ matrix.ghc }}

81− runs-on: ubuntu-latest

82− strategy:

83− matrix:

84− stack: ["2.7.5"]

85− ghc: ["8.10.7"]

86−

87− steps:

88− - uses: actions/checkout@v2

89−

90− - uses: haskell/actions/setup@v1

91− name: Setup Haskell Stack

92− with:

93− ghc-version: ${{ matrix.ghc }}

94− stack-version: ${{ matrix.stack }}

95−

96− - uses: actions/cache@v2.1.3

97− name: Cache ~/.stack

98− with:

99− path: ~/.stack

100− key: ${{ runner.os }}-${{ matrix.ghc }}-stack

101−

102− - name: Install dependencies

103− run: |

104− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

105−

106− - name: Build

107− run: |

108− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

109−

110− - name: Test

111− run: |

112− stack test --system-ghc

79+ # stack:

80+ # name: stack / ghc ${{ matrix.ghc }}

81+ # runs-on: ubuntu-latest

82+ # strategy:

83+ # matrix:

84+ # stack: ["2.7.5"]

85+ # ghc: ["8.10.7"]

86+

87+ # steps:

88+ # - uses: actions/checkout@v2

89+

90+ # - uses: haskell/actions/setup@v1

91+ # name: Setup Haskell Stack

92+ # with:

93+ # ghc-version: ${{ matrix.ghc }}

94+ # stack-version: ${{ matrix.stack }}

95+

96+ # - uses: actions/cache@v2.1.3

97+ # name: Cache ~/.stack

98+ # with:

99+ # path: ~/.stack

100+ # key: ${{ runner.os }}-${{ matrix.ghc }}-stack

101+

102+ # - name: Install dependencies

103+ # run: |

104+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

105+

106+ # - name: Build

107+ # run: |

108+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

109+

110+ # - name: Test

111+ # run: |

112+ # stack test --system-ghc

113113

114114 ghcjs:

115115 name: ubuntu-latest / ghcjs 8.6

cabal.project+1

@@ -47,6 +47,7 @@ packages:

4747 doc/cookbook/using-custom-monad

4848 doc/cookbook/using-free-client

4949 -- doc/cookbook/open-id-connect

50+ doc/cookbook/managed-resource

5051

5152tests: True

5253optimization: False

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/1638new file+2

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

1+synopsis: Add Functor instance to AuthHandler.

2+prs: #1638

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/index.rst+1

@@ -37,3 +37,4 @@ you name it!

3737 sentry/Sentry.lhs

3838 testing/Testing.lhs

3939 open-id-connect/OpenIdConnect.lhs

40+ managed-resource/ManagedResource.lhs

doc/cookbook/managed-resource/ManagedResource.lhsnew file+114

@@ -0,0 +1,114 @@

1+# Request-lifetime Managed Resources

2+

3+Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.

4+

5+As usual, we start with a little bit of throat clearing.

6+

7+

8+``` haskell

9+{-# LANGUAGE DataKinds #-}

10+{-# LANGUAGE TypeOperators #-}

11+import Control.Concurrent

12+import Control.Exception (bracket, throwIO)

13+import Control.Monad.IO.Class

14+import Control.Monad.Trans.Resource

15+import Data.Acquire

16+import Network.HTTP.Client (newManager, defaultManagerSettings)

17+import Network.Wai.Handler.Warp

18+import Servant

19+import Servant.Client

20+import System.IO

21+```

22+

23+Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.

24+

25+``` haskell

26+type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent

27+

28+api :: Proxy API

29+api = Proxy

30+```

31+

32+But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.

33+

34+``` haskell

35+appContext :: Context '[Acquire Handle]

36+appContext = acquireHandle :. EmptyContext

37+

38+acquireHandle :: Acquire Handle

39+acquireHandle = mkAcquire newHandle closeHandle

40+

41+newHandle :: IO Handle

42+newHandle = do

43+ putStrLn "opening file"

44+ h <- openFile "test.txt" AppendMode

45+ putStrLn "opened file"

46+ return h

47+

48+closeHandle :: Handle -> IO ()

49+closeHandle h = do

50+ putStrLn "closing file"

51+ hClose h

52+ putStrLn "closed file"

53+```

54+

55+Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.

56+

57+``` haskell

58+server :: Server API

59+server = writeToFile

60+

61+ where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent

62+ writeToFile (_, h) msg = case msg of

63+ "illegal" -> error "wait, that's illegal!"

64+ legalMsg -> liftIO $ do

65+ putStrLn "writing file"

66+ hPutStrLn h legalMsg

67+ putStrLn "wrote file"

68+ return NoContent

69+```

70+

71+Finally we run the server in the background while we post messages to it.

72+

73+``` haskell

74+runApp :: IO ()

75+runApp = run 8080 (serveWithContext api appContext $ server)

76+

77+postMsg :: String -> ClientM NoContent

78+postMsg = client api

79+

80+main :: IO ()

81+main = do

82+ mgr <- newManager defaultManagerSettings

83+ bracket (forkIO $ runApp) killThread $ \_ -> do

84+ ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do

85+ liftIO $ putStrLn "sending hello message"

86+ _ <- postMsg "hello"

87+ liftIO $ putStrLn "sending illegal message"

88+ _ <- postMsg "illegal"

89+ liftIO $ putStrLn "done"

90+ print ms

91+```

92+

93+This program prints

94+

95+```

96+sending hello message

97+opening file

98+opened file

99+writing file

100+wrote file

101+closing file

102+closed file

103+sending illegal message

104+opening file

105+opened file

106+closing file

107+closed file

108+wait, that's illegal!

109+CallStack (from HasCallStack):

110+ error, called at ManagedResource.lhs:63:24 in main:Main

111+Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))

112+```

113+

114+and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.

doc/cookbook/managed-resource/managed-resource.cabalnew file+30

@@ -0,0 +1,30 @@

1+cabal-version: 2.2

2+name: cookbook-managed-resource

3+version: 0.1

4+synopsis: Simple managed resource cookbook example

5+homepage: http://docs.servant.dev/

6+license: BSD-3-Clause

7+license-file: ../../../servant/LICENSE

8+author: Servant Contributors

9+maintainer: haskell-servant-maintainers@googlegroups.com

10+build-type: Simple

11+tested-with: GHC==9.4.2

12+

13+executable cookbook-managed-resource

14+ main-is: ManagedResource.lhs

15+ build-depends: base == 4.*

16+ , text >= 1.2

17+ , aeson >= 1.2

18+ , servant

19+ , servant-client

20+ , servant-server

21+ , warp >= 3.2

22+ , wai >= 3.2

23+ , http-types >= 0.12

24+ , markdown-unlit >= 0.4

25+ , http-client >= 0.5

26+ , transformers

27+ , resourcet

28+ default-language: Haskell2010

29+ ghc-options: -Wall -pgmL markdown-unlit

30+ build-tool-depends: markdown-unlit:markdown-unlit

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

doc/requirements.txt+1

@@ -1,3 +1,4 @@

11recommonmark==0.5.0

22Sphinx==1.8.4

33sphinx_rtd_theme>=0.4.2

4+jinja2<3.1.0

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+23−5

@@ -74,10 +74,10 @@ 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,

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

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

8181 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

8282import Servant.API.Generic

8383 (GenericMode(..), ToServant, ToServantApi

@@ -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'.

@@ -776,6 +786,14 @@ instance HasClient m subapi =>

776786

777787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

778788

789+instance HasClient m subapi =>

790+ HasClient m (WithResource res :> subapi) where

791+

792+ type Client m (WithResource res :> subapi) = Client m subapi

793+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)

794+

795+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

796+

779797instance ( HasClient m api

780798 ) => HasClient m (AuthProtect tag :> api) where

781799 type Client m (AuthProtect tag :> api)

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

894912-- rootClient = client api

895913--

896914-- endpointClient :: ClientM Person

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

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

898916-- @

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

900918x // f = f x

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

927945-- rootClient = client api

928946--

929947-- hello :: String -> ClientM String

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

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

931949--

932950-- endpointClient :: ClientM Person

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

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

934952-- @

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

936954(/:) = 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/golden/comprehensive.md+18

@@ -530,6 +530,24 @@

530530

531531```

532532

533+## GET /resource

534+

535+### Response:

536+

537+- Status code 200

538+- Headers: []

539+

540+- Supported content types are:

541+

542+ - `application/json;charset=utf-8`

543+ - `application/json`

544+

545+- Example (`application/json;charset=utf-8`, `application/json`):

546+

547+```javascript

548+

549+```

550+

533551## GET /streaming

534552

535553### Request:

servant-docs/src/Servant/Docs/Internal.hs+4−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

@@ -1144,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where

11441144instance HasDocs api => HasDocs (WithNamedContext name context api) where

11451145 docsFor Proxy = docsFor (Proxy :: Proxy api)

11461146

1147+instance HasDocs api => HasDocs (WithResource res :> api) where

1148+ docsFor Proxy = docsFor (Proxy :: Proxy api)

1149+

11471150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where

11481151 docsFor Proxy (endpoint, action) =

11491152 docsFor (Proxy :: Proxy api) (endpoint, action')

servant-foreign/src/Servant/Foreign/Internal.hs+7

@@ -487,6 +487,13 @@ instance HasForeign lang ftype api =>

487487

488488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

489489

490+instance HasForeign lang ftype api =>

491+ HasForeign lang ftype (WithResource res :> api) where

492+

493+ type Foreign ftype (WithResource res :> api) = Foreign ftype api

494+

495+ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

496+

490497instance HasForeign lang ftype api

491498 => HasForeign lang ftype (HttpVersion :> api) where

492499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

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/Experimental/Auth.hs+2−1

@@ -1,5 +1,6 @@

11{-# OPTIONS_GHC -fno-warn-orphans #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

34{-# LANGUAGE DeriveGeneric #-}

45{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

@@ -44,7 +45,7 @@ type family AuthServerData a :: *

4445-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

4546newtype AuthHandler r usr = AuthHandler

4647 { unAuthHandler :: r -> Handler usr }

47− deriving (Generic, Typeable)

48+ deriving (Functor, Generic, Typeable)

4849

4950-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

5051mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

servant-server/src/Servant/Server/Internal.hs+76−5

@@ -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 #-}

@@ -35,9 +36,10 @@ module Servant.Server.Internal

3536import Control.Monad

3637 (join, when)

3738import Control.Monad.Trans

38− (liftIO)

39+ (liftIO, lift)

3940import Control.Monad.Trans.Resource

40− (runResourceT)

41+ (runResourceT, ReleaseKey)

42+import Data.Acquire

4143import qualified Data.ByteString as B

4244import qualified Data.ByteString.Builder as BB

4345import qualified Data.ByteString.Char8 as BC8

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

6466import Network.Socket

6567 (SockAddr)

6668import Network.Wai

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

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

6870 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

6971 requestMethod, responseLBS, responseStream, vault)

7072import Prelude ()

@@ -74,10 +76,10 @@ import Servant.API

7476 CaptureAll, Description, EmptyAPI, Fragment,

7577 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

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

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

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

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

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

80− WithNamedContext, NamedRoutes)

82+ WithNamedContext, WithResource, NamedRoutes)

8183import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

8284import Servant.API.ContentTypes

8385 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

115117 (AtLeastOneFragment, FragmentUnique)

116118

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

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

119125

120126 route ::

@@ -244,6 +250,42 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

244250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

245251 hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

246252

253+-- | If you use 'WithResource' in one of the endpoints for your API Servant

254+-- will provide the handler for this endpoint an argument of the specified type.

255+-- The lifespan of this resource will be automatically managed by Servant. This

256+-- resource will be created before the handler starts and it will be destoyed

257+-- after it ends. A new resource is created for each request to the endpoint.

258+

259+-- The creation and destruction are done using a 'Data.Acquire.Acquire'

260+-- provided via server 'Context'.

261+--

262+-- Example

263+--

264+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent

265+-- >

266+-- > server :: Server MyApi

267+-- > server = writeToFile

268+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent

269+-- > writeToFile (_, h) = hPutStrLn h "message"

270+--

271+-- In addition to the resource, the handler will also receive a 'ReleaseKey'

272+-- which can be used to deallocate the resource before the end of the request

273+-- if desired.

274+

275+instance (HasServer api ctx, HasContextEntry ctx (Acquire a))

276+ => HasServer (WithResource a :> api) ctx where

277+

278+ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m

279+

280+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s

281+

282+ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)

283+ where

284+ allocateResource :: DelayedIO (ReleaseKey, a)

285+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)

286+

287+

288+

247289allowedMethodHead :: Method -> Request -> Bool

248290allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

249291

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

611653 Fail a -> respond $ Fail a

612654 FailFatal e -> respond $ FailFatal e

613655

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+

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

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

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

servant-server/test/Servant/ServerSpec.hs+54−6

@@ -17,10 +17,14 @@ 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)

26+import Data.Acquire

27+ (Acquire, mkAcquire)

2428import qualified Data.ByteString as BS

2529import qualified Data.ByteString.Base64 as Base64

2630import Data.Char

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

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

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

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

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

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

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

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

5862import Servant.Server

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

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

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

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

6165 serveWithContext)

6266import Servant.Test.ComprehensiveAPI

6367import qualified Servant.Types.SourceT as S

6468import Test.Hspec

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

6670import Test.Hspec.Wai

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

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

6872 with, (<:>))

6973import qualified Test.Hspec.Wai as THW

7074

@@ -81,8 +85,11 @@ import Servant.Server.Internal.Context

8185-- This declaration simply checks that all instances are in place.

8286_ = serveWithContext comprehensiveAPI comprehensiveApiContext

8387

84−comprehensiveApiContext :: Context '[NamedContext "foo" '[]]

85−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

88+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]

89+comprehensiveApiContext =

90+ NamedContext EmptyContext :.

91+ mkAcquire (pure 10) (\_ -> pure ()) :.

92+ EmptyContext

8693

8794-- * Specs

8895

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

97104 reqBodySpec

98105 headerSpec

99106 rawSpec

107+ rawMSpec

100108 alternativeSpec

101109 responseHeadersSpec

102110 uverbResponseHeadersSpec

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

605613

606614-- }}}

607615------------------------------------------------------------------------------

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

608656-- * alternativeSpec {{{

609657------------------------------------------------------------------------------

610658type AlternativeApi =

servant-swagger/src/Servant/Swagger/Internal.hs+4

@@ -304,6 +304,10 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where

304304instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where

305305 toSwagger _ = toSwagger (Proxy :: Proxy sub)

306306

307+-- | @'WithResource'@ combinator does not change our specification at all.

308+instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where

309+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

310+

307311instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where

308312 toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))

309313 where

servant/servant.cabal+1

@@ -62,6 +62,7 @@ library

6262 Servant.API.Vault

6363 Servant.API.Verbs

6464 Servant.API.WithNamedContext

65+ Servant.API.WithResource

6566

6667 -- Types

6768 exposed-modules:

servant/src/Servant/API.hs+10−6

@@ -31,6 +31,8 @@ module Servant.API (

3131 -- | Access the location for arbitrary data to be shared by applications and middleware

3232 module Servant.API.WithNamedContext,

3333 -- | Access context entries in combinators in servant-server

34+ module Servant.API.WithResource,

35+ -- | Access a managed resource scoped to a single request

3436

3537 -- * Actual endpoints, distinguished by HTTP method

3638 module Servant.API.Verbs,

@@ -101,21 +103,23 @@ import Servant.API.Experimental.Auth

101103 (AuthProtect)

102104import Servant.API.Fragment

103105 (Fragment)

106+import Servant.API.Generic

107+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,

108+ ToServant, ToServantApi, fromServant, genericApi, toServant)

104109import Servant.API.Header

105110 (Header, Header')

106−import Servant.API.Generic

107− (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,

108− GenericServant, fromServant, toServant, genericApi)

109111import Servant.API.HttpVersion

110112 (HttpVersion (..))

111113import Servant.API.IsSecure

112114 (IsSecure (..))

113115import Servant.API.Modifiers

114116 (Lenient, Optional, Required, Strict)

117+import Servant.API.NamedRoutes

118+ (NamedRoutes)

115119import Servant.API.QueryParam

116120 (QueryFlag, QueryParam, QueryParam', QueryParams)

117121import Servant.API.Raw

118− (Raw)

122+ (Raw, RawM)

119123import Servant.API.RemoteHost

120124 (RemoteHost)

121125import Servant.API.ReqBody

@@ -137,8 +141,6 @@ import Servant.API.UVerb

137141 Unique, WithStatus (..), inject, statusOf)

138142import Servant.API.Vault

139143 (Vault)

140−import Servant.API.NamedRoutes

141− (NamedRoutes)

142144import Servant.API.Verbs

143145 (Delete, DeleteAccepted, DeleteNoContent,

144146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

@@ -150,6 +152,8 @@ import Servant.API.Verbs

150152 ReflectMethod (reflectMethod), StdMethod (..), Verb)

151153import Servant.API.WithNamedContext

152154 (WithNamedContext)

155+import Servant.API.WithResource

156+ (WithResource)

153157import Servant.Links

154158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

155159import Web.HttpApiData

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/API/UVerb/Union.hs+2−2

@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =

128128 ':$$: 'Text " " ':<>: 'ShowType rs

129129

130130type family Elem (x :: k) (xs :: [k]) :: Bool where

131+ Elem x (x ': _) = 'True

132+ Elem x (_ ': xs) = Elem x xs

131133 Elem _ '[] = 'False

132− Elem x (x' ': xs) =

133− If (x == x') 'True (Elem x xs)

134134

135135type family Unique xs :: Constraint where

136136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))

servant/src/Servant/API/WithResource.hsnew file+3

@@ -0,0 +1,3 @@

1+module Servant.API.WithResource (WithResource) where

2+

3+data WithResource res

servant/src/Servant/Links.hs+11−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

@@ -193,6 +193,8 @@ import Servant.API.Verbs

193193 (Verb, NoContentVerb)

194194import Servant.API.WithNamedContext

195195 (WithNamedContext)

196+import Servant.API.WithResource

197+ (WithResource)

196198import Web.HttpApiData

197199import Data.Kind

198200 (Type)

@@ -558,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where

558560 type MkLink (WithNamedContext name context sub) a = MkLink sub a

559561 toLink toA _ = toLink toA (Proxy :: Proxy sub)

560562

563+instance HasLink sub => HasLink (WithResource res :> sub) where

564+ type MkLink (WithResource res :> sub) a = MkLink sub a

565+ toLink toA _ = toLink toA (Proxy :: Proxy sub)

566+

561567instance HasLink sub => HasLink (RemoteHost :> sub) where

562568 type MkLink (RemoteHost :> sub) a = MkLink sub a

563569 toLink = simpleToLink (Proxy :: Proxy sub)

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

583589 type MkLink Raw a = a

584590 toLink toA _ = toA

585591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

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

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

588598 toLink toA _ = toA

servant/src/Servant/Test/ComprehensiveAPI.hs+1

@@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

7272 :<|> "description" :> Description "foo" :> GET

7373 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)

7474 :<|> "fragment" :> Fragment Int :> GET

75+ :<|> "resource" :> WithResource Int :> GET

7576 :<|> endpoint

7677

7778type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

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+