master..a2e0033 · servant

changelog.d/1571deleted−10

since splitsnapshots

unifiedsplit

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

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−}

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

@@ -129,7 +129,6 @@ 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

133 other-modules:

132 other-modules:

134 Servant.Auth.ServerSpec

133 Servant.Auth.ServerSpec

135 default-language: Haskell2010

134 default-language: Haskell2010

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

@@ -54,12 +54,15 @@ 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`) $

57− case authResult of

59+ case authResult of

58− (Authenticated v) -> do

60+ (Authenticated v) -> do

59− ejwt <- makeSessionCookie cookieSettings jwtSettings v

61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

60− xsrf <- makeXsrfCookie cookieSettings

62+ case ejwt of

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

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

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

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

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

63

66

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

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

65 -> (AuthResult v, SetCookieList n)

68 -> (AuthResult v, SetCookieList n)

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

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

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14−import Servant.API.UVerb.Union

15import Servant.API.Generic

14import Servant.API.Generic

16import Servant.Server.Generic

15import Servant.Server.Generic

17import Web.Cookie

16import Web.Cookie

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

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

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

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

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

36

35

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−

43type family AddSetCookieApi a :: *

36type family AddSetCookieApi a :: *

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

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

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

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

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

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

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

48−#endif

49type instance AddSetCookieApi (Verb method stat ctyps a)

40type instance AddSetCookieApi (Verb method stat ctyps a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

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

55type instance AddSetCookieApi Raw = Raw

42type instance AddSetCookieApi Raw = Raw

56#if MIN_VERSION_servant_server(0,15,0)

43#if MIN_VERSION_servant_server(0,15,0)

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

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

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

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

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

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

58 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

72

59

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

60+instance AddSetCookies 'Z orig orig where

74 addSetCookies _ = id

61 addSetCookies _ = id

75

62

76instance {-# OVERLAPPABLE #-}

63instance {-# OVERLAPPABLE #-}

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

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeApplications #-}

3module Servant.Auth.ServerSpec (spec) where

2module Servant.Auth.ServerSpec (spec) where

4

3

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

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

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

25import Data.Aeson.Lens (_JSON)

24import Data.Aeson.Lens (_JSON)

26import qualified Data.ByteString as BS

25import qualified Data.ByteString as BS

27import qualified Data.ByteString.Lazy as BSL

26import qualified Data.ByteString.Lazy as BSL

28−import Data.Text (Text, pack)

29import Data.CaseInsensitive (mk)

27import Data.CaseInsensitive (mk)

30import Data.Foldable (find)

28import Data.Foldable (find)

31import Data.Monoid

29import Data.Monoid

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

41import Network.Wai (responseLBS)

39import Network.Wai (responseLBS)

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

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

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

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

44− checkResponse,

45 cookieExpiryTime, cookies,

42 cookieExpiryTime, cookies,

46 defaults, get, getWith, postWith,

43 defaults, get, getWith, postWith,

47 header, oauth2Bearer,

44 header, oauth2Bearer,

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

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

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

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

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

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

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

188− opts' <- addJwtToCookie cookieCfg jwt

185+ opts <- addJwtToCookie cookieCfg jwt

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

190− resp <- getWith opts (url port)

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

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−

203

187

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

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

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

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

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

421 = Auth auths User :>

405 = Auth auths User :>

422 ( Get '[JSON] Int

406 ( Get '[JSON] Int

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

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

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

408+ :<|> NamedRoutes DummyRoutes

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

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

426#if MIN_VERSION_servant_server(0,15,0)

410#if MIN_VERSION_servant_server(0,15,0)

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

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

428#endif

412#endif

429 :<|> "raw" :> Raw

413 :<|> "raw" :> Raw

430 )

414 )

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

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

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

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

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

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

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

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

506 :<|> raw

489 :<|> raw

507 Indefinite -> throwAll err401

490 Indefinite -> throwAll err401

508 _ -> throwAll err403

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

514 )

492 )

515 :<|> getLogin

493 :<|> getLogin

516 :<|> getLogout

494 :<|> getLogout

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

591 = fmap cookie_name (destroyCookieJar cj)

569 = fmap cookie_name (destroyCookieJar cj)

592 `shouldMatchList` patterns

570 `shouldMatchList` patterns

593

571

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−

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

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

601shouldMatchCookieNameValues cj patterns

573shouldMatchCookieNameValues cj patterns

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

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

servant-client-core/src/Servant/Client/Core/HasClient.hs+1−11

@@ -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, RawM,

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

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

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

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

@@ -674,16 +674,6 @@ 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−

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

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

688-- the corresponding querying function will automatically take

678-- the corresponding querying function will automatically take

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

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

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

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

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE PolyKinds #-}

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

66import Network.Socket

65import Network.Socket

67 (SockAddr)

66 (SockAddr)

68import Network.Wai

67import Network.Wai

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

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

70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

69 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

71 requestMethod, responseLBS, responseStream, vault)

70 requestMethod, responseLBS, responseStream, vault)

72import Prelude ()

71import Prelude ()

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

76 CaptureAll, Description, EmptyAPI, Fragment,

75 CaptureAll, Description, EmptyAPI, Fragment,

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

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

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

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

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

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

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

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

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

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

82 WithNamedContext, WithResource, NamedRoutes)

81 WithNamedContext, WithResource, NamedRoutes)

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

653 Fail a -> respond $ Fail a

652 Fail a -> respond $ Fail a

654 FailFatal e -> respond $ FailFatal e

653 FailFatal e -> respond $ FailFatal e

655

654

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−

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

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

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

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

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

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

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

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

17

18import Control.Monad

19 (forM_, unless, when)

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

21import Control.Monad.Error.Class

20import Control.Monad.Error.Class

22 (MonadError (..))

21 (MonadError (..))

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

24import Data.Aeson

22import Data.Aeson

25 (FromJSON, ToJSON, decode', encode)

23 (FromJSON, ToJSON, decode', encode)

26import Data.Acquire

24import Data.Acquire

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

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

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

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

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

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

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

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

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

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

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

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

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

62import Servant.Server

60import Servant.Server

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

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

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

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

65 serveWithContext)

63 serveWithContext)

66import Servant.Test.ComprehensiveAPI

64import Servant.Test.ComprehensiveAPI

67import qualified Servant.Types.SourceT as S

65import qualified Servant.Types.SourceT as S

68import Test.Hspec

66import Test.Hspec

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

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

70import Test.Hspec.Wai

68import Test.Hspec.Wai

71− (get, matchHeaders, matchStatus, shouldRespondWith,

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

72 with, (<:>))

70 with, (<:>))

73import qualified Test.Hspec.Wai as THW

71import qualified Test.Hspec.Wai as THW

74

72

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

104 reqBodySpec

102 reqBodySpec

105 headerSpec

103 headerSpec

106 rawSpec

104 rawSpec

107− rawMSpec

108 alternativeSpec

105 alternativeSpec

109 responseHeadersSpec

106 responseHeadersSpec

110 uverbResponseHeadersSpec

107 uverbResponseHeadersSpec

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

613

610

614-- }}}

611-- }}}

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

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

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

656-- * alternativeSpec {{{

613-- * alternativeSpec {{{

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

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

658type AlternativeApi =

615type 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, RawM)

122+ (Raw)

123import Servant.API.RemoteHost

124 (RemoteHost)

125import Servant.API.ReqBody

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

@@ -15,6 +15,3 @@ 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,7 +8,6 @@

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeFamilyDependencies #-}

12{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

14{-# OPTIONS_HADDOCK not-home #-}

13{-# OPTIONS_HADDOCK not-home #-}

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

52import Prelude.Compat

51import Prelude.Compat

53import Servant.API.Header

52import Servant.API.Header

54 (Header)

53 (Header)

55−import Servant.API.UVerb.Union

56−import qualified Data.SOP.BasicFunctors as SOP

57−import qualified Data.SOP.NS as SOP

58

54

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

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

60-- Instead, use 'addOptionalHeader'.

56-- Instead, use 'addOptionalHeader'.

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

174 => AddHeader h v a new where

170 => AddHeader h v a new where

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

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

176

172

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−

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

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

197-- the value in the following ways:

174-- the value in the following ways:

198--

175--

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

@@ -53,6 +53,9 @@ statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))

53instance HasStatus NoContent where

54 type StatusOf NoContent = 204

55

56+instance HasStatus a => HasStatus (Headers hs a) where

57+ type StatusOf (Headers hs a) = StatusOf a

58+

56class HasStatuses (as :: [*]) where

59class HasStatuses (as :: [*]) where

57 type Statuses (as :: [*]) :: [Nat]

60 type Statuses (as :: [*]) :: [Nat]

58 statuses :: Proxy as -> [Status]

61 statuses :: Proxy as -> [Status]

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

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

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

88 type StatusOf (WithStatus n a) = n

91 type StatusOf (WithStatus n a) = n

89

92

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

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

92

93

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

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

94--

95--

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

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

175import Servant.API.QueryParam

176 (QueryFlag, QueryParam', QueryParams)

177import Servant.API.Raw

178− (Raw, RawM)

178+ (Raw)

179import Servant.API.RemoteHost

180 (RemoteHost)

181import Servant.API.ReqBody

@@ -589,10 +589,6 @@ 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−

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

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

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

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

598 toLink toA _ = toA

594 toLink toA _ = toA