2ec4771 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Add server support for response headers

2ec4771Julian K. Arni12 years ago

CHANGELOG.md+1

compare with master

unifiedsplit

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

6* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)

7* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)

8* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)

9+* Add server support for response headers

100.2.4

110.2.4

11-----

12-----

servant-server.cabal+1

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

80 base == 4.*

81 , aeson

82 , bytestring

83+ , bytestring-conversion

83 , directory

84 , directory

84 , either

85 , either

85 , exceptions

86 , exceptions

src/Servant/Server/Internal.hs+124−35

@@ -1,45 +1,53 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverlappingInstances #-}

4{-# LANGUAGE OverlappingInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

9module Servant.Server.Internal where

10module Servant.Server.Internal where

11−import Control.Applicative ((<$>))

12+import Control.Applicative ((<$>))

12−import Control.Monad.Trans.Either (EitherT, runEitherT)

13+import Control.Monad.Trans.Either (EitherT, runEitherT)

13−import qualified Data.ByteString as B

14+import qualified Data.ByteString as B

14−import qualified Data.ByteString.Lazy as BL

15+import qualified Data.ByteString.Lazy as BL

15−import Data.IORef (newIORef, readIORef, writeIORef)

16+import Data.IORef (newIORef, readIORef, writeIORef)

16−import Data.List (unfoldr)

17+import Data.List (unfoldr)

17−import Data.Maybe (catMaybes, fromMaybe)

18+import Data.Maybe (catMaybes, fromMaybe)

18−import Data.Monoid (Monoid, mempty, mappend)

19+import Data.Monoid (Monoid, mappend, mempty)

19−import Data.String (fromString)

20+import Data.String (fromString)

20−import Data.String.Conversions (cs, (<>))

21+import Data.String.Conversions (cs, (<>))

22+import Data.Text (Text)

23+import qualified Data.Text as T

21−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

24+import Data.Text.Encoding (decodeUtf8, encodeUtf8)

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−import Data.Typeable

25+import Data.Typeable

25−import GHC.TypeLits (KnownSymbol, symbolVal)

26+import GHC.TypeLits (KnownSymbol, symbolVal)

26−import Network.HTTP.Types hiding (Header)

27+import Network.HTTP.Types hiding (Header, ResponseHeaders)

27−import Network.Wai ( Response, Request, ResponseReceived, Application

28+import Network.Wai (Application, Request, Response,

28− , pathInfo, requestBody, strictRequestBody

29+ ResponseReceived, lazyRequestBody,

30+ pathInfo, rawQueryString,

29− , lazyRequestBody, requestHeaders, requestMethod,

31+ requestBody, requestHeaders,

30− rawQueryString, responseLBS)

32+ requestMethod, responseLBS,

31−import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header

33+ strictRequestBody)

32− , MatrixParams, MatrixParam, MatrixFlag

34+import Servant.API ((:<|>) (..), (:>), Capture,

33− , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))

35+ Delete, Get, Header, MatrixFlag,

36+ MatrixParam, MatrixParams, Patch,

37+ Post, Put, QueryFlag, QueryParam,

38+ QueryParams, Raw, ReqBody)

34−import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)

39+import Servant.API.ContentTypes (AcceptHeader (..),

40+ AllCTRender (..),

35− , AllCTUnrender(..),)

41+ AllCTUnrender (..))

42+import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)

36−import Servant.Common.Text (FromText, fromText)

43+import Servant.Common.Text (FromText, fromText)

39data ReqBodyState = Uncalled

46data ReqBodyState = Uncalled

40 | Called !B.ByteString

47 | Called !B.ByteString

41 | Done !B.ByteString

48 | Done !B.ByteString

50+

43toApplication :: RoutingApplication -> Application

51toApplication :: RoutingApplication -> Application

44toApplication ra request respond = do

52toApplication ra request respond = do

45 reqBodyRef <- newIORef Uncalled

53 reqBodyRef <- newIORef Uncalled

@@ -286,6 +294,7 @@ instance ( AllCTRender ctypes a

286 respond $ failWith WrongMethod

294 respond $ failWith WrongMethod

287 | otherwise = respond $ failWith NotFound

295 | otherwise = respond $ failWith NotFound

288

296

297+-- '()' ==> 204 No Content

289instance HasServer (Get ctypes ()) where

298instance HasServer (Get ctypes ()) where

290 type ServerT (Get ctypes ()) m = m ()

299 type ServerT (Get ctypes ()) m = m ()

291 route Proxy action request respond

300 route Proxy action request respond

@@ -299,6 +308,26 @@ instance HasServer (Get ctypes ()) where

299 respond $ failWith WrongMethod

308 respond $ failWith WrongMethod

300 | otherwise = respond $ failWith NotFound

309 | otherwise = respond $ failWith NotFound

301

310

311+-- Add response headers

312+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

313+ type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

314+ route Proxy action request respond

315+ | pathIsEmpty request && requestMethod request == methodGet = do

316+ e <- runEitherT action

317+ respond $ case e of

318+ Right output -> do

319+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

320+ headers = getHeaders output

321+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

322+ Nothing -> failWith UnsupportedMediaType

323+ Just (contentT, body) -> succeedWith $

324+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

325+ Left (status, message) -> succeedWith $

326+ responseLBS (mkStatus status (cs message)) [] (cs message)

327+ | pathIsEmpty request && requestMethod request /= methodGet =

328+ respond $ failWith WrongMethod

329+ | otherwise = respond $ failWith NotFound

330+

302-- | If you use 'Header' in one of the endpoints for your API,

331-- | If you use 'Header' in one of the endpoints for your API,

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

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

304-- that takes an argument of the type specified by 'Header'.

333-- that takes an argument of the type specified by 'Header'.

@@ -377,6 +406,26 @@ instance HasServer (Post ctypes ()) where

377 respond $ failWith WrongMethod

406 respond $ failWith WrongMethod

378 | otherwise = respond $ failWith NotFound

407 | otherwise = respond $ failWith NotFound

379

408

409+-- Add response headers

410+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

411+ type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

412+ route Proxy action request respond

413+ | pathIsEmpty request && requestMethod request == methodPost = do

414+ e <- runEitherT action

415+ respond $ case e of

416+ Right output -> do

417+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

418+ headers = getHeaders output

419+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

420+ Nothing -> failWith UnsupportedMediaType

421+ Just (contentT, body) -> succeedWith $

422+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

423+ Left (status, message) -> succeedWith $

424+ responseLBS (mkStatus status (cs message)) [] (cs message)

425+ | pathIsEmpty request && requestMethod request /= methodPost =

426+ respond $ failWith WrongMethod

427+ | otherwise = respond $ failWith NotFound

428+

380-- | When implementing the handler for a 'Put' endpoint,

429-- | When implementing the handler for a 'Put' endpoint,

381-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

430-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

382-- and 'Servant.API.Post.Post', the handler code runs in the

431-- and 'Servant.API.Post.Post', the handler code runs in the

@@ -387,7 +436,7 @@ instance HasServer (Post ctypes ()) where

387--

436--

388-- If successfully returning a value, we use the type-level list, combined

437-- If successfully returning a value, we use the type-level list, combined

389-- with the request's @Accept@ header, to encode the value for you

438-- with the request's @Accept@ header, to encode the value for you

390−-- (returning a status code of 201). If there was no @Accept@ header or it

439+-- (returning a status code of 200). If there was no @Accept@ header or it

391-- was @*/*@, we return encode using the first @Content-Type@ type on the

440-- was @*/*@, we return encode using the first @Content-Type@ type on the

392-- list.

441-- list.

393instance ( AllCTRender ctypes a

442instance ( AllCTRender ctypes a

@@ -423,6 +472,26 @@ instance HasServer (Put ctypes ()) where

423 respond $ failWith WrongMethod

472 respond $ failWith WrongMethod

424 | otherwise = respond $ failWith NotFound

473 | otherwise = respond $ failWith NotFound

425

474

475+-- Add response headers

476+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

477+ type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

478+ route Proxy action request respond

479+ | pathIsEmpty request && requestMethod request == methodPut = do

480+ e <- runEitherT action

481+ respond $ case e of

482+ Right output -> do

483+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

484+ headers = getHeaders output

485+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

486+ Nothing -> failWith UnsupportedMediaType

487+ Just (contentT, body) -> succeedWith $

488+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

489+ Left (status, message) -> succeedWith $

490+ responseLBS (mkStatus status (cs message)) [] (cs message)

491+ | pathIsEmpty request && requestMethod request /= methodPut =

492+ respond $ failWith WrongMethod

493+ | otherwise = respond $ failWith NotFound

494+

426-- | When implementing the handler for a 'Patch' endpoint,

495-- | When implementing the handler for a 'Patch' endpoint,

427-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

496-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

428-- and 'Servant.API.Put.Put', the handler code runs in the

497-- and 'Servant.API.Put.Put', the handler code runs in the

@@ -433,7 +502,7 @@ instance HasServer (Put ctypes ()) where

433--

502--

434-- If successfully returning a value, we just require that its type has

503-- If successfully returning a value, we just require that its type has

435-- a 'ToJSON' instance and servant takes care of encoding it for you,

504-- a 'ToJSON' instance and servant takes care of encoding it for you,

436−-- yielding status code 201 along the way.

505+-- yielding status code 200 along the way.

437instance ( AllCTRender ctypes a

506instance ( AllCTRender ctypes a

438 ) => HasServer (Patch ctypes a) where

507 ) => HasServer (Patch ctypes a) where

439 type ServerT (Patch ctypes a) m = m a

508 type ServerT (Patch ctypes a) m = m a

@@ -467,6 +536,26 @@ instance HasServer (Patch ctypes ()) where

467 respond $ failWith WrongMethod

536 respond $ failWith WrongMethod

468 | otherwise = respond $ failWith NotFound

537 | otherwise = respond $ failWith NotFound

469

538

539+-- Add response headers

540+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where

541+ type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

542+ route Proxy action request respond

543+ | pathIsEmpty request && requestMethod request == methodPatch = do

544+ e <- runEitherT action

545+ respond $ case e of

546+ Right outpatch -> do

547+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

548+ headers = getHeaders outpatch

549+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

550+ Nothing -> failWith UnsupportedMediaType

551+ Just (contentT, body) -> succeedWith $

552+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

553+ Left (status, message) -> succeedWith $

554+ responseLBS (mkStatus status (cs message)) [] (cs message)

555+ | pathIsEmpty request && requestMethod request /= methodPatch =

556+ respond $ failWith WrongMethod

557+ | otherwise = respond $ failWith NotFound

558+

470-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

559-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

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

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

472-- that takes an argument of type @'Maybe' 'Text'@.

561-- that takes an argument of type @'Maybe' 'Text'@.

test/Servant/ServerSpec.hs+52−10

@@ -3,13 +3,16 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeSynonymInstances #-}

7+{-# LANGUAGE FlexibleInstances #-}

7module Servant.ServerSpec where

9module Servant.ServerSpec where

10−import Control.Monad (when)

12+import Control.Monad (forM_, when)

11import Control.Monad.Trans.Either (EitherT, left)

13import Control.Monad.Trans.Either (EitherT, left)

12import Data.Aeson (FromJSON, ToJSON, decode', encode)

14import Data.Aeson (FromJSON, ToJSON, decode', encode)

15+import Data.ByteString.Conversion ()

13import Data.Char (toUpper)

16import Data.Char (toUpper)

14import Data.Monoid ((<>))

17import Data.Monoid ((<>))

15import Data.Proxy (Proxy (Proxy))

18import Data.Proxy (Proxy (Proxy))

@@ -27,15 +30,17 @@ import Network.Wai (Application, Request, pathInfo,

27import Network.Wai.Test (defaultRequest, request,

30import Network.Wai.Test (defaultRequest, request,

28 runSession, simpleBody)

31 runSession, simpleBody)

29import Test.Hspec (Spec, describe, it, shouldBe)

32import Test.Hspec (Spec, describe, it, shouldBe)

30−import Test.Hspec.Wai (get, liftIO, matchStatus, post,

33+import Test.Hspec.Wai (get, liftIO, matchHeaders,

34+ matchStatus, post, request,

31− request, shouldRespondWith, with)

35+ shouldRespondWith, with, (<:>))

32−

36+

33−import Servant.API ((:<|>) (..), (:>), Capture, Delete,

37+import Servant.API ((:<|>) (..), (:>),

38+ AddHeader (addHeader), Capture,

39+ Delete, Get, Header (..), Headers,

34− Get, Header, JSON, MatrixFlag,

40+ JSON, MatrixFlag, MatrixParam,

35− MatrixParam, MatrixParams, Patch,

41+ MatrixParams, Patch, PlainText,

36− PlainText, Post, Put, QueryFlag,

42+ Post, Put, QueryFlag, QueryParam,

37− QueryParam, QueryParams, Raw,

43+ QueryParams, Raw, ReqBody)

38− ReqBody)

39import Servant.Server (Server, serve)

44import Servant.Server (Server, serve)

40import Servant.Server.Internal (RouteMismatch (..))

45import Servant.Server.Internal (RouteMismatch (..))

@@ -85,6 +90,7 @@ spec = do

85 rawSpec

90 rawSpec

86 unionSpec

91 unionSpec

87 errorsSpec

92 errorsSpec

93+ responseHeadersSpec

90type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal

96type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal

@@ -531,6 +537,42 @@ unionSpec = do

531 it "returns 404 if the path does not exist" $ do

537 it "returns 404 if the path does not exist" $ do

532 get "/nonexistent" `shouldRespondWith` 404

538 get "/nonexistent" `shouldRespondWith` 404

533

539

540+type ResponseHeadersApi =

541+ Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

542+ :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

543+ :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

544+ :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

545+

546+

547+responseHeadersServer :: Server ResponseHeadersApi

548+responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"

549+ in h :<|> h :<|> h :<|> h

550+

551+

552+responseHeadersSpec :: Spec

553+responseHeadersSpec = describe "ResponseHeaders" $ do

554+ with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do

555+

556+ let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]

557+

558+ it "includes the headers in the response" $

559+ forM_ methods $ \(method, expected) ->

560+ Test.Hspec.Wai.request method "/" [] ""

561+ `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]

562+ , matchStatus = expected

563+ }

564+

565+ it "responds with not found for non-existent endpoints" $

566+ forM_ methods $ \(method,_) ->

567+ Test.Hspec.Wai.request method "blahblah" [] ""

568+ `shouldRespondWith` 404

569+

570+ it "returns 415 if the Accept header is not supported" $

571+ forM_ methods $ \(method,_) ->

572+ Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

573+ `shouldRespondWith` 415

574+

575+

534-- | Test server error functionality.

576-- | Test server error functionality.

535errorsSpec :: Spec

577errorsSpec :: Spec

536errorsSpec = do

578errorsSpec = do