c110589 · servant · git.iko.soy

cabal.project+3−2

compare with master

unifiedsplit

@@ -25,15 +25,16 @@ packages:

25 doc/cookbook/custom-errors

26 doc/cookbook/basic-streaming

27 doc/cookbook/db-postgres-pool

28−-- doc/cookbook/db-sqlite-simple

28+ -- doc/cookbook/db-sqlite-simple

29 doc/cookbook/file-upload

30 doc/cookbook/generic

31 -- doc/cookbook/hoist-server-with-context

32−-- doc/cookbook/https

32+ -- doc/cookbook/https

33 -- doc/cookbook/jwt-and-basic-auth/

34 doc/cookbook/pagination

35 -- doc/cookbook/sentry

36 doc/cookbook/testing

37+ doc/cookbook/uverb

37 doc/cookbook/structuring-apis

38 doc/cookbook/structuring-apis

38 doc/cookbook/using-custom-monad

39 doc/cookbook/using-custom-monad

39 doc/cookbook/using-free-client

40 doc/cookbook/using-free-client

doc/cookbook/uverb/UVerb.lhsnew file+217

@@ -0,0 +1,217 @@

1+# Listing alternative responses and exceptions in your API types

2+

3+Servant allows you to talk about the exceptions you throw in your API

4+types. This is not limited to actual exceptions, you can write

5+handlers that respond with arbitrary open unions of types.

6+

7+## Preliminaries

8+

9+```haskell

10+{-# LANGUAGE ConstraintKinds #-}

11+{-# LANGUAGE DataKinds #-}

12+{-# LANGUAGE DeriveAnyClass #-}

13+{-# LANGUAGE DeriveGeneric #-}

14+{-# LANGUAGE DerivingStrategies #-}

15+{-# LANGUAGE DerivingVia #-}

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE FlexibleInstances #-}

18+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

19+{-# LANGUAGE InstanceSigs #-}

20+{-# LANGUAGE MultiParamTypeClasses #-}

21+{-# LANGUAGE OverloadedStrings #-}

22+{-# LANGUAGE ScopedTypeVariables #-}

23+{-# LANGUAGE StandaloneDeriving #-}

24+{-# LANGUAGE TypeApplications #-}

25+{-# LANGUAGE TypeFamilies #-}

26+{-# LANGUAGE TypeOperators #-}

27+{-# LANGUAGE UndecidableInstances #-}

28+{-# OPTIONS_GHC -Wall -Wno-orphans #-}

29+

30+import Control.Concurrent (threadDelay)

31+import Control.Concurrent.Async (async)

32+import Control.Monad (when)

33+import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)

34+import Data.Aeson (FromJSON (..), ToJSON (..))

35+import Data.Aeson.Encode.Pretty (encodePretty)

36+import Data.String.Conversions (cs)

37+import Data.Swagger (ToSchema)

38+import Data.Typeable (Proxy (Proxy))

39+import qualified GHC.Generics as GHC

40+import qualified Network.HTTP.Client as Client

41+import qualified Network.Wai.Handler.Warp as Warp

42+import Servant.API

43+import Servant.Client

44+import Servant.Server

45+import Servant.Swagger

46+```

47+

48+## The API

49+

50+This looks like a `Verb`-based routing table, except that `UVerb` has

51+no status, and carries a list of response types rather than a single

52+one. Each entry in the list carries its own response code.

53+

54+```haskell

55+type API =

56+ "fisx" :> Capture "bool" Bool

57+ :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]

58+ :<|> "arian"

59+ :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]

60+```

61+

62+Here are the details:

63+

64+```haskell

65+data FisxUser = FisxUser {name :: String}

66+ deriving (Eq, Show, GHC.Generic)

67+

68+instance ToJSON FisxUser

69+instance FromJSON FisxUser

70+instance ToSchema FisxUser

71+

72+-- | 'HasStatus' allows us to can get around 'WithStatus' if we want

73+-- to, and associate the status code with our resource types directly.

74+--

75+-- (To avoid orphan instances and make it more explicit what's in the

76+-- API and what isn't, we could even introduce a newtype 'Resource'

77+-- that wraps all the types we're using in our routing table, and then

78+-- define lots of 'HasStatus' instances for @Resource This@ and

79+-- @Resource That@.)

80+instance HasStatus FisxUser where

81+ type StatusOf FisxUser = 203

82+

83+data ArianUser = ArianUser

84+ deriving (Eq, Show, GHC.Generic)

85+

86+instance ToJSON ArianUser

87+instance FromJSON ArianUser

88+instance ToSchema ArianUser

89+```

90+

91+## Server, Client, Swagger

92+

93+You can just respond with any of the elements of the union in handlers.

94+

95+```haskell

96+fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])

97+fisx True = respond (FisxUser "fisx")

98+fisx False = respond (WithStatus @303 ("still fisx" :: String))

99+

100+arian :: Handler (Union '[WithStatus 201 ArianUser])

101+arian = respond (WithStatus @201 ArianUser)

102+```

103+

104+You can create client functions like you're used to:

105+

106+```

107+fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])

108+arianClient :: ClientM (Union '[WithStatus 201 ArianUser])

109+(fisxClient :<|> arianClient) = client (Proxy @API)

110+```

111+

112+... and that's basically it! Here are a few sample commands that

113+show you how the swagger docs look like and how you can handle the

114+result unions in clients:

115+

116+```

117+main :: IO ()

118+main = do

119+ putStrLn . cs . encodePretty $ toSwagger (Proxy @API)

120+ _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)

121+ threadDelay 50000

122+ mgr <- Client.newManager Client.defaultManagerSettings

123+ let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")

124+ result <- runClientM (fisxClient True) cenv

125+ print $ foldMapUnion (Proxy @Show) show <$> result

126+ print $ matchUnion @FisxUser <$> result

127+ print $ matchUnion @(WithStatus 303 String) <$> result

128+ pure ()

129+```

130+

131+## Idiomatic exceptions

132+

133+Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.

134+

135+```haskell

136+newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }

137+ deriving newtype (Functor, Applicative, Monad, MonadTrans)

138+

139+-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use

140+-- underlying monad's instance.

141+instance MonadError e m => MonadError e (UVerbT xs m) where

142+ throwError = lift . throwError

143+ catchError (UVerbT act) h = UVerbT $ ExceptT $

144+ runExceptT act `catchError` (runExceptT . unUVerbT . h)

145+

146+-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler

147+-- may use the usual 'return'.

148+runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)

149+runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)

150+

151+-- | Short-circuit 'UVerbT' computation returning one of the response types.

152+throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a

153+throwUVerb = UVerbT . ExceptT . fmap Left . respond

154+```

155+

156+Example usage:

157+

158+```haskell

159+data Foo = Foo Int Int Int

160+ deriving (Show, Eq, GHC.Generic, ToJSON)

161+ deriving HasStatus via WithStatus 200 Foo

162+

163+data Bar = Bar

164+ deriving (Show, Eq, GHC.Generic, ToJSON)

165+

166+h :: Handler (Union '[Foo, WithStatus 400 Bar])

167+h = runUVerbT $ do

168+ when ({- something bad -} True) $

169+ throwUVerb $ WithStatus @400 Bar

170+

171+ when ({- really bad -} False) $

172+ throwError $ err500

173+

174+ -- a lot of code here...

175+

176+ return $ Foo 1 2 3

177+```

178+

179+## Related Work

180+

181+There is the [issue from

182+2017](https://github.com/haskell-servant/servant/issues/841) that was

183+resolved by the introduction of `UVerb`, with a long discussion on

184+alternative designs.

185+

186+[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)

187+is a good solution to the problem, but it restricts the user to JSON

188+and a very specific envelop encoding for the union type, which is

189+often not acceptable. (One good reason for this design choice is that

190+it makes writing clients easier, where you need to get to the union

191+type from one representative, and you don't want to run several

192+parsers in the hope that the ones that should will always error out so

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

194+

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

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

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

198+The README claims that

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

200+some code for generalized error handling.

201+

202+In an earier version of the `UVerb` implementation, we have used some

203+code from

204+[world-peace](https://hackage.haskell.org/package/world-peace), but

205+that package itself wasn't flexible enough, and we had to use

206+[sop-core](https://hackage.haskell.org/package/sop-core) to implement

207+the `HasServer` instance.

208+

209+Here is a blog post we found on the subject:

210+https://lukwagoallan.com/posts/unifying-servant-server-error-responses

211+

212+(If you have anything else, please add it here or let us know.)

213+

214+```haskell

215+main :: IO ()

216+main = return ()

217+```

doc/cookbook/uverb/uverb.cabalnew file+33

@@ -0,0 +1,33 @@

1+name: cookbook-uverb

2+version: 0.0.1

3+synopsis: How to use the 'UVerb' type.

4+description: Listing alternative responses and exceptions in your API types.

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

6+license: BSD3

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

8+author: Servant Contributors

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

10+category: Servant

11+build-type: Simple

12+cabal-version: >=1.10

13+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

14+

15+executable cookbook-uverb

16+ main-is: UVerb.lhs

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

18+ , aeson >= 1.2

19+ , aeson-pretty >= 0.8.8

20+ , async

21+ , http-client

22+ , mtl

23+ , servant

24+ , servant-client

25+ , servant-server

26+ , servant-swagger

27+ , string-conversions

28+ , swagger2

29+ , wai

30+ , warp

31+ default-language: Haskell2010

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

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

servant-client-core/servant-client-core.cabal+1

@@ -78,6 +78,7 @@ library

78 , http-types >= 0.12.2 && < 0.13

79 , network-uri >= 2.6.1.0 && < 2.7

80 , safe >= 0.3.17 && < 0.4

81+ , sop-core >= 0.4.0.0 && < 0.6

81

82

82 hs-source-dirs: src

83 hs-source-dirs: src

83 default-language: Haskell2010

84 default-language: Haskell2010

servant-client-core/src/Servant/Client/Core.hs+2

@@ -18,6 +18,8 @@ module Servant.Client.Core

18 -- * Client generation

19 clientIn

20 , HasClient(..)

21+ , foldMapUnion

22+ , matchUnion

21

23

22 -- * Request

24 -- * Request

23 , Request

25 , Request

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

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

1+{-# LANGUAGE ConstraintKinds #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

10{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

@@ -15,31 +17,48 @@ module Servant.Client.Core.HasClient (

15 clientIn,

17 clientIn,

16 HasClient (..),

18 HasClient (..),

17 EmptyClient (..),

19 EmptyClient (..),

20+ foldMapUnion,

21+ matchUnion,

18 ) where

22 ) where

19

23

20import Prelude ()

24import Prelude ()

21import Prelude.Compat

25import Prelude.Compat

22

26

27+import Control.Arrow

28+ (left, (+++))

23import Control.Monad

29import Control.Monad

24 (unless)

30 (unless)

25import qualified Data.ByteString.Lazy as BL

31import qualified Data.ByteString.Lazy as BL

32+import Data.Either

33+ (partitionEithers)

26import Data.Foldable

34import Data.Foldable

27 (toList)

35 (toList)

28import Data.List

36import Data.List

29 (foldl')

37 (foldl')

30−import Data.Proxy

31− (Proxy (Proxy))

32import Data.Sequence

38import Data.Sequence

33 (fromList)

39 (fromList)

34import qualified Data.Text as T

40import qualified Data.Text as T

35import Network.HTTP.Media

41import Network.HTTP.Media

36 (MediaType, matches, parseAccept, (//))

42 (MediaType, matches, parseAccept, (//))

43+import qualified Data.Sequence as Seq

44+import Data.SOP.BasicFunctors

45+ (I (I), (:.:) (Comp))

46+import Data.SOP.Constraint

47+ (All)

48+import Data.SOP.NP

49+ (NP (..), cpure_NP)

50+import Data.SOP.NS

51+ (NS (S))

37import Data.String

52import Data.String

38 (fromString)

53 (fromString)

39import Data.Text

54import Data.Text

40 (Text, pack)

55 (Text, pack)

56+import Data.Proxy

57+ (Proxy (Proxy))

41import GHC.TypeLits

58import GHC.TypeLits

42 (KnownSymbol, symbolVal)

59 (KnownSymbol, symbolVal)

60+import Network.HTTP.Types

61+ (Status)

43import qualified Network.HTTP.Types as H

62import qualified Network.HTTP.Types as H

44import Servant.API

63import Servant.API

45 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

64 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

@@ -54,9 +73,11 @@ import Servant.API

54 contentType, getHeadersHList, getResponse, toQueryParam,

73 contentType, getHeadersHList, getResponse, toQueryParam,

55 toUrlPiece)

74 toUrlPiece)

56import Servant.API.ContentTypes

75import Servant.API.ContentTypes

57− (contentTypes)

76+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

58import Servant.API.Modifiers

77import Servant.API.Modifiers

59 (FoldRequired, RequiredArgument, foldRequiredArgument)

78 (FoldRequired, RequiredArgument, foldRequiredArgument)

79+import Servant.API.UVerb

80+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

60

81

61import Servant.Client.Core.Auth

82import Servant.Client.Core.Auth

62import Servant.Client.Core.BasicAuth

83import Servant.Client.Core.BasicAuth

@@ -288,6 +309,71 @@ instance {-# OVERLAPPING #-}

288

309

289 hoistClientMonad _ _ f ma = f ma

310 hoistClientMonad _ _ f ma = f ma

290

311

312+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus

313+ deriving (Eq, Show)

314+

315+instance {-# OVERLAPPING #-}

316+ ( RunClient m,

317+ contentTypes ~ (contentType ': otherContentTypes),

318+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem

319+ -- allow this in instance types as of 8.8.3.)

320+ as ~ (a ': as'),

321+ AllMime contentTypes,

322+ ReflectMethod method,

323+ All (AllMimeUnrender contentTypes) as,

324+ All HasStatus as, HasStatuses as',

325+ Unique (Statuses as)

326+ ) =>

327+ HasClient m (UVerb method contentTypes as)

328+ where

329+ type Client m (UVerb method contentTypes as) = m (Union as)

330+

331+ clientWithRoute _ _ request = do

332+ let accept = Seq.fromList . allMime $ Proxy @contentTypes

333+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,

334+ -- we might not own the server implementation, and the server may choose to support

335+ -- only part of the api.

336+

337+ method = reflectMethod $ Proxy @method

338+ acceptStatus = statuses (Proxy @as)

339+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}

340+ responseContentType <- checkContentTypeHeader response

341+ unless (any (matches responseContentType) accept) $ do

342+ throwClientError $ UnsupportedContentType responseContentType response

343+

344+ let status = responseStatusCode response

345+ body = responseBody response

346+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body

347+ case res of

348+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response

349+ Right x -> return x

350+ where

351+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the

352+ -- failures it encountered along the way

353+ -- TODO; better name, rewrite haddocs.

354+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)

355+ tryParsers _ Nil = Left [ClientNoMatchingStatus]

356+ tryParsers status (Comp x :* xs)

357+ | status == statusOf (Comp x) =

358+ case partitionEithers x of

359+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs

360+ (_, (res : _)) -> Right . inject . I $ res

361+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for

362+ (ClientStatusMismatch :) +++ S $ tryParsers status xs

363+

364+ -- | Given a list of types, parses the given response body as each type

365+ mimeUnrenders ::

366+ forall cts xs.

367+ All (AllMimeUnrender cts) xs =>

368+ Proxy cts ->

369+ BL.ByteString ->

370+ NP ([] :.: Either (MediaType, String)) xs

371+ mimeUnrenders ctp body = cpure_NP

372+ (Proxy @(AllMimeUnrender cts))

373+ (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)

374+

375+ hoistClientMonad _ _ nt s = nt s

376+

291instance {-# OVERLAPPABLE #-}

377instance {-# OVERLAPPABLE #-}

292 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

378 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

293 FramingUnrender framing, FromSourceIO chunk a

379 FramingUnrender framing, FromSourceIO chunk a

@@ -710,4 +796,4 @@ decodedAs response ct = do

710 Left err -> throwClientError $ DecodeFailure (T.pack err) response

796 Left err -> throwClientError $ DecodeFailure (T.pack err) response

711 Right val -> return val

797 Right val -> return val

712 where

798 where

713− accept = toList $ contentTypes ct

799+ accept = toList $ contentTypes ct

servant-client-core/src/Servant/Client/Core/Reexport.hs+2

@@ -5,6 +5,8 @@ module Servant.Client.Core.Reexport

5 (

6 -- * HasClient

7 HasClient(..)

8+ , foldMapUnion

9+ , matchUnion

8

10

9 -- * Response (for @Raw@)

11 -- * Response (for @Raw@)

10 , Response

12 , Response

servant-client-core/src/Servant/Client/Core/RunClient.hs+12−3

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

7-- | Types for possible backends to run client-side `Request` queries

8module Servant.Client.Core.RunClient (

9 RunClient (..),

10+ runRequest,

10 RunStreamingClient (..),

11 RunStreamingClient (..),

11 ClientF (..),

12 ClientF (..),

12 ) where

13 ) where

@@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient (

14import Prelude ()

15import Prelude ()

15import Prelude.Compat

16import Prelude.Compat

16

17

18+import Network.HTTP.Types.Status

19+ (Status)

17import Control.Monad.Free

20import Control.Monad.Free

18 (Free (..), liftF)

21 (Free (..), liftF)

19

22

@@ -22,10 +25,15 @@ import Servant.Client.Core.Request

22import Servant.Client.Core.Response

25import Servant.Client.Core.Response

23

26

24class Monad m => RunClient m where

27class Monad m => RunClient m where

25− -- | How to make a request.

28+ -- | How to make a request, with an optional list of status codes to not throw exceptions

29+ -- for (default: [200..299]).

26− runRequest :: Request -> m Response

30+ runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response

27 throwClientError :: ClientError -> m a

31 throwClientError :: ClientError -> m a

28

32

33+-- | How to make a request.

34+runRequest :: RunClient m => Request -> m Response

35+runRequest = runRequestAcceptStatus Nothing

36+

29class RunClient m => RunStreamingClient m where

37class RunClient m => RunStreamingClient m where

30 withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a

38 withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a

31

39

@@ -41,6 +49,7 @@ data ClientF a

41 | Throw ClientError

49 | Throw ClientError

42 deriving (Functor)

50 deriving (Functor)

43

51

52+-- TODO: honour the accept-status argument.

44instance ClientF ~ f => RunClient (Free f) where

53instance ClientF ~ f => RunClient (Free f) where

45− runRequest req = liftF (RunRequest req id)

54+ runRequestAcceptStatus _ req = liftF (RunRequest req id)

46 throwClientError = liftF . Throw

55 throwClientError = liftF . Throw

servant-client/servant-client.cabal+1

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

108 , kan-extensions

109 , servant-client

110 , servant-client-core

111+ , sop-core

111 , stm

112 , stm

112 , text

113 , text

113 , transformers

114 , transformers

servant-client/src/Servant/Client/Internal/HttpClient.hs+9−6

@@ -65,7 +65,7 @@ import GHC.Generics

65import Network.HTTP.Media

66 (renderHeader)

67import Network.HTTP.Types

68− (hContentType, renderQuery, statusCode)

68+ (hContentType, renderQuery, statusCode, Status)

69import Servant.Client.Core

70

71import qualified Network.HTTP.Client as Client

@@ -155,14 +155,14 @@ instance Alt ClientM where

155 a <!> b = a `catchError` \_ -> b

156

157instance RunClient ClientM where

158− runRequest = performRequest

158+ runRequestAcceptStatus = performRequest

159 throwClientError = throwError

160

161runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)

162runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

163

164−performRequest :: Request -> ClientM Response

164+performRequest :: Maybe [Status] -> Request -> ClientM Response

165−performRequest req = do

165+performRequest acceptStatus req = do

166 ClientEnv m burl cookieJar' createClientRequest <- ask

167 let clientRequest = createClientRequest burl req

168 request <- case cookieJar' of

@@ -183,8 +183,11 @@ performRequest req = do

183 let status = Client.responseStatus response

184 status_code = statusCode status

185 ourResponse = clientResponseToResponse id response

186+ goodStatus = case acceptStatus of

186− unless (status_code >= 200 && status_code < 300) $

187+ Nothing -> status_code >= 200 && status_code < 300

188+ Just good -> status `elem` good

189+ unless goodStatus $ do

187− throwError $ mkFailureResponse burl req ourResponse

190+ throwError $ mkFailureResponse burl req ourResponse

188 return ourResponse

191 return ourResponse

189 where

192 where

190 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

193 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+9−5

@@ -47,7 +47,7 @@ import Data.Time.Clock

47 (getCurrentTime)

48import GHC.Generics

49import Network.HTTP.Types

50− (statusCode)

50+ (Status, statusCode)

51

52import qualified Network.HTTP.Client as Client

53

@@ -112,7 +112,7 @@ instance Alt ClientM where

112 a <!> b = a `catchError` \_ -> b

113

114instance RunClient ClientM where

115− runRequest = performRequest

115+ runRequestAcceptStatus = performRequest

116 throwClientError = throwError

117

118instance RunStreamingClient ClientM where

@@ -136,8 +136,8 @@ withClientM cm env k =

136runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)

137runClientM cm env = withClientM cm env (evaluate . force)

138

139−performRequest :: Request -> ClientM Response

139+performRequest :: Maybe [Status] -> Request -> ClientM Response

140−performRequest req = do

140+performRequest acceptStatus req = do

141 -- TODO: should use Client.withResponse here too

142 ClientEnv m burl cookieJar' createClientRequest <- ask

143 let clientRequest = createClientRequest burl req

@@ -165,10 +165,14 @@ performRequest req = do

165 let status = Client.responseStatus response

166 status_code = statusCode status

167 ourResponse = clientResponseToResponse id response

168+ goodStatus = case acceptStatus of

168− unless (status_code >= 200 && status_code < 300) $

169+ Nothing -> status_code >= 200 && status_code < 300

170+ Just good -> status `elem` good

171+ unless goodStatus $ do

169 throwError $ mkFailureResponse burl req ourResponse

172 throwError $ mkFailureResponse burl req ourResponse

170 return ourResponse

173 return ourResponse

171

174

175+-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

172performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

173performWithStreamingRequest req k = do

177performWithStreamingRequest req k = do

174 m <- asks manager

178 m <- asks manager

servant-client/test/Servant/ClientTestUtils.hs+39−5

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

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

@@ -26,10 +27,14 @@ import Control.Concurrent

26import Control.Monad.Error.Class

27import Control.Monad.Error.Class

27 (throwError)

28 (throwError)

28import Data.Aeson

29import Data.Aeson

30+import qualified Data.ByteString.Lazy as LazyByteString

29import Data.Char

31import Data.Char

30 (chr, isPrint)

32 (chr, isPrint)

31import Data.Monoid ()

33import Data.Monoid ()

32import Data.Proxy

34import Data.Proxy

35+import Data.Text (Text)

36+import qualified Data.Text as Text

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

33import GHC.Generics

38import GHC.Generics

34 (Generic)

39 (Generic)

35import qualified Network.HTTP.Client as C

40import qualified Network.HTTP.Client as C

@@ -47,8 +52,11 @@ import Servant.API

47 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

52 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

48 BasicAuthData (..), Capture, CaptureAll,

53 BasicAuthData (..), Capture, CaptureAll,

49 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

54 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

50− Headers, JSON, NoContent (NoContent), Post, QueryFlag,

55+ Headers, JSON, MimeRender(mimeRender),

56+ MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,

51− QueryParam, QueryParams, Raw, ReqBody, addHeader)

57+ Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,

58+ StdMethod(GET), Union, UVerb, WithStatus(WithStatus),

59+ addHeader)

52import Servant.Client

60import Servant.Client

53import qualified Servant.Client.Core.Auth as Auth

61import qualified Servant.Client.Core.Auth as Auth

54import Servant.Server

62import Servant.Server

@@ -63,7 +71,7 @@ _ = client comprehensiveAPIWithoutStreaming

63data Person = Person

71data Person = Person

64 { _name :: String

72 { _name :: String

65 , _age :: Integer

73 , _age :: Integer

66− } deriving (Eq, Show, Generic)

74+ } deriving (Eq, Show, Read, Generic)

67

75

68instance ToJSON Person

76instance ToJSON Person

69instance FromJSON Person

77instance FromJSON Person

@@ -74,6 +82,15 @@ instance FromForm Person

74instance Arbitrary Person where

82instance Arbitrary Person where

75 arbitrary = Person <$> arbitrary <*> arbitrary

83 arbitrary = Person <$> arbitrary <*> arbitrary

76

84

85+instance MimeRender PlainText Person where

86+ mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show

87+

88+instance MimeUnrender PlainText Person where

89+ mimeUnrender _ =

90+ -- This does not handle any errors, but it should be fine for tests

91+ Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict

92+

93+

77alice :: Person

94alice :: Person

78alice = Person "Alice" 42

95alice = Person "Alice" 42

79

96

@@ -105,6 +122,12 @@ type Api =

105 :<|> "deleteContentType" :> DeleteNoContent

122 :<|> "deleteContentType" :> DeleteNoContent

106 :<|> "redirectWithCookie" :> Raw

123 :<|> "redirectWithCookie" :> Raw

107 :<|> "empty" :> EmptyAPI

124 :<|> "empty" :> EmptyAPI

125+ :<|> "uverb-success-or-redirect" :>

126+ Capture "bool" Bool :>

127+ UVerb 'GET '[PlainText] '[WithStatus 200 Person,

128+ WithStatus 301 Text]

129+ :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

130+

108

131

109api :: Proxy Api

132api :: Proxy Api

110api = Proxy

133api = Proxy

@@ -126,6 +149,10 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

126getRespHeaders :: ClientM (Headers TestHeaders Bool)

149getRespHeaders :: ClientM (Headers TestHeaders Bool)

127getDeleteContentType :: ClientM NoContent

150getDeleteContentType :: ClientM NoContent

128getRedirectWithCookie :: HTTP.Method -> ClientM Response

151getRedirectWithCookie :: HTTP.Method -> ClientM Response

152+uverbGetSuccessOrRedirect :: Bool

153+ -> ClientM (Union '[WithStatus 200 Person,

154+ WithStatus 301 Text])

155+uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])

129

156

130getRoot

157getRoot

131 :<|> getGet

158 :<|> getGet

@@ -143,7 +170,9 @@ getRoot

143 :<|> getRespHeaders

170 :<|> getRespHeaders

144 :<|> getDeleteContentType

171 :<|> getDeleteContentType

145 :<|> getRedirectWithCookie

172 :<|> getRedirectWithCookie

146− :<|> EmptyClient = client api

173+ :<|> EmptyClient

174+ :<|> uverbGetSuccessOrRedirect

175+ :<|> uverbGetCreated = client api

147

176

148server :: Application

177server :: Application

149server = serve api (

178server = serve api (

@@ -166,7 +195,12 @@ server = serve api (

166 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

195 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

167 :<|> return NoContent

196 :<|> return NoContent

168 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

197 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

169− :<|> emptyServer)

198+ :<|> emptyServer

199+ :<|> (\shouldRedirect -> if shouldRedirect

200+ then respond (WithStatus @301 ("redirecting" :: Text))

201+ else respond (WithStatus @200 alice ))

202+ :<|> respond (WithStatus @201 carol)

203+ )

170

204

171type FailApi =

205type FailApi =

172 "get" :> Raw

206 "get" :> Raw

servant-client/test/Servant/SuccessSpec.hs+24−1

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

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

@@ -31,6 +32,8 @@ import Data.Foldable

31import Data.Maybe

32import Data.Maybe

32 (listToMaybe)

33 (listToMaybe)

33import Data.Monoid ()

34import Data.Monoid ()

35+import Data.Text

36+ (Text)

34import qualified Network.HTTP.Client as C

37import qualified Network.HTTP.Client as C

35import qualified Network.HTTP.Types as HTTP

38import qualified Network.HTTP.Types as HTTP

36import Test.Hspec

39import Test.Hspec

@@ -39,7 +42,7 @@ import Test.HUnit

39import Test.QuickCheck

42import Test.QuickCheck

40

43

41import Servant.API

44import Servant.API

42− (NoContent (NoContent), getHeaders)

45+ (NoContent (NoContent), WithStatus(WithStatus), getHeaders)

43import Servant.Client

46import Servant.Client

44import qualified Servant.Client.Core.Request as Req

47import qualified Servant.Client.Core.Request as Req

45import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)

48import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)

@@ -151,3 +154,23 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

151 result <- left show <$> runClient (getMultiple cap num flag body) baseUrl

154 result <- left show <$> runClient (getMultiple cap num flag body) baseUrl

152 return $

155 return $

153 result === Right (cap, num, flag, body)

156 result === Right (cap, num, flag, body)

157+

158+ context "With a route that can either return success or redirect" $ do

159+ it "Redirects when appropriate" $ \(_, baseUrl) -> do

160+ eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl

161+ case eitherResponse of

162+ Left clientError -> fail $ show clientError

163+ Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")

164+

165+ it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do

166+ eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl

167+ case eitherResponse of

168+ Left clientError -> fail $ show clientError

169+ Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)

170+

171+ context "with a route that uses uverb but only has a single response" $

172+ it "returns the expected response" $ \(_, baseUrl) -> do

173+ eitherResponse <- runClient (uverbGetCreated) baseUrl

174+ case eitherResponse of

175+ Left clientError -> fail $ show clientError

176+ Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)

servant-http-streams/src/Servant/HttpStreams/Internal.hs+7−4

@@ -141,7 +141,7 @@ instance Alt ClientM where

141 a <!> b = a `catchError` \_ -> b

142

143instance RunClient ClientM where

144− runRequest = performRequest

144+ runRequestAcceptStatus = performRequest

145 throwClientError = throwError

146

147instance RunStreamingClient ClientM where

@@ -155,8 +155,8 @@ withClientM cm env k =

155 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm

156 in f k

157

158−performRequest :: Request -> ClientM Response

158+performRequest :: Maybe [Status] -> Request -> ClientM Response

159−performRequest req = do

159+performRequest acceptStatus req = do

160 ClientEnv burl conn <- ask

161 let (req', body) = requestToClientRequest burl req

162 x <- ClientM $ lift $ lift $ Codensity $ \k -> do

@@ -165,7 +165,10 @@ performRequest req = do

165 let sc = Client.getStatusCode res'

166 lbs <- BSL.fromChunks <$> Streams.toList body'

167 let res'' = clientResponseToResponse res' lbs

168+ goodStatus = case acceptStatus of

168− if sc >= 200 && sc < 300

169+ Nothing -> sc >= 200 && sc < 300

170+ Just good -> sc `elem` (statusCode <$> good)

171+ if goodStatus

169 then k (Right res'')

172 then k (Right res'')

170 else k (Left (mkFailureResponse burl req res''))

173 else k (Left (mkFailureResponse burl req res''))

171

174

servant-server/servant-server.cabal+3

@@ -51,6 +51,7 @@ library

51 Servant.Server.Internal.RoutingApplication

52 Servant.Server.Internal.ServerError

53 Servant.Server.StaticFiles

54+ Servant.Server.UVerb

54

55

55 -- deprecated

56 -- deprecated

56 exposed-modules:

57 exposed-modules:

@@ -84,6 +85,7 @@ library

84 , network-uri >= 2.6.1.0 && < 2.8

85 , network-uri >= 2.6.1.0 && < 2.8

85 , monad-control >= 1.0.2.3 && < 1.1

86 , monad-control >= 1.0.2.3 && < 1.1

86 , network >= 2.8 && < 3.2

87 , network >= 2.8 && < 3.2

88+ , sop-core >= 0.4.0.0 && < 0.6

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

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

88 , resourcet >= 1.2.2 && < 1.3

90 , resourcet >= 1.2.2 && < 1.3

89 , tagged >= 0.8.6 && < 0.9

91 , tagged >= 0.8.6 && < 0.9

@@ -94,6 +96,7 @@ library

94

96

95 hs-source-dirs: src

97 hs-source-dirs: src

96 default-language: Haskell2010

98 default-language: Haskell2010

99+

97 ghc-options: -Wall -Wno-redundant-constraints

100 ghc-options: -Wall -Wno-redundant-constraints

98

101

99executable greet

102executable greet

servant-server/src/Servant/Server.hs+2

@@ -110,6 +110,7 @@ module Servant.Server

110 -- * Re-exports

111 , Application

112 , Tagged (..)

113+ , module Servant.Server.UVerb

113

114

114 ) where

115 ) where

115

116

@@ -122,6 +123,7 @@ import Data.Text

122import Network.Wai

123import Network.Wai

123 (Application)

124 (Application)

124import Servant.Server.Internal

125import Servant.Server.Internal

126+import Servant.Server.UVerb

125

127

126

128

127-- * Implementing Servers

129-- * Implementing Servers

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

@@ -65,7 +65,7 @@ import Network.Socket

65 (SockAddr)

66import Network.Wai

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

68− queryString, remoteHost, requestBody, requestHeaders,

68+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,

69 requestMethod, responseLBS, responseStream, vault)

70import Prelude ()

71import Prelude.Compat

@@ -681,7 +681,7 @@ instance

681 bodyCheck fromRS = withRequest $ \req -> do

682 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk

683 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk

684− let body = requestBody req

684+ let body = getRequestBodyChunk req

685 let rs = S.fromAction B.null body

686 let rs' = fromRS $ framingUnrender' rs

687 return rs'

servant-server/src/Servant/Server/UVerb.hsnew file+96

@@ -0,0 +1,96 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+

16+{-# OPTIONS_GHC -Wno-orphans #-}

17+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

18+

19+module Servant.Server.UVerb

20+ ( respond,

21+ IsServerResource,

22+ )

23+where

24+

25+import Data.Proxy (Proxy (Proxy))

26+import Data.SOP (I (I))

27+import Data.SOP.Constraint (All, And)

28+import Data.String.Conversions (LBS, cs)

29+import Network.HTTP.Types (Status, hContentType)

30+import Network.Wai (responseLBS)

31+import Servant.API (ReflectMethod, reflectMethod)

32+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

33+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)

34+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

35+

36+

37+-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,

38+-- and will construct a union value in an 'Applicative' (eg. 'Server').

39+respond ::

40+ forall (x :: *) (xs :: [*]) (f :: * -> *).

41+ (Applicative f, HasStatus x, IsMember x xs) =>

42+ x ->

43+ f (Union xs)

44+respond = pure . inject . I

45+

46+-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.

47+type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus

48+

49+instance

50+ ( ReflectMethod method,

51+ AllMime contentTypes,

52+ All (IsServerResource contentTypes) as,

53+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

54+ -- wihtout; client is a bit of a corner case, because it dispatches

55+ -- the parser based on the status code. with this uniqueness

56+ -- constraint it won't have to run more than one parser in weird

57+ -- corner cases.

58+ ) =>

59+ HasServer (UVerb method contentTypes as) context

60+ where

61+ type ServerT (UVerb method contentTypes as) m = m (Union as)

62+

63+ hoistServerWithContext _ _ nt s = nt s

64+

65+ route ::

66+ forall env.

67+ Proxy (UVerb method contentTypes as) ->

68+ Context context ->

69+ Delayed env (Server (UVerb method contentTypes as)) ->

70+ Router env

71+ route _proxy _ctx action = leafRouter route'

72+ where

73+ method = reflectMethod (Proxy @method)

74+ route' env request cont = do

75+ let action' :: Delayed env (Handler (Union as))

76+ action' =

77+ action

78+ `addMethodCheck` methodCheck method request

79+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

80+ mkProxy :: a -> Proxy a

81+ mkProxy _ = Proxy

82+

83+ runAction action' env request cont $ \(output :: Union as) -> do

84+ let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))

85+ encodeResource res =

86+ ( statusOf $ mkProxy res,

87+ handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res

88+ )

89+ pickResource :: Union as -> (Status, Maybe (LBS, LBS))

90+ pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource

91+

92+ case pickResource output of

93+ (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

94+ (status, Just (contentT, body)) ->

95+ let bdy = if allowedMethodHead method request then "" else body

96+ in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy

servant-server/test/Servant/ServerSpec.hs+84−15

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

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE TypeSynonymInstances #-}

11{-# OPTIONS_GHC -freduction-depth=100 #-}

10{-# OPTIONS_GHC -freduction-depth=100 #-}

12

11

13module Servant.ServerSpec where

12module Servant.ServerSpec where

@@ -49,14 +48,16 @@ import Network.Wai.Test

49import Servant.API

48import Servant.API

50 ((:<|>) (..), (:>), AuthProtect, BasicAuth,

49 ((:<|>) (..), (:>), AuthProtect, BasicAuth,

51 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

50 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

52− Delete, EmptyAPI, Get, Header, Headers, HttpVersion,

51+ Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,

53− IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,

52+ HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),

54− NoFraming, OctetStream, Patch, PlainText, Post, Put,

53+ NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,

55− QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,

54+ Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,

56− SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)

55+ ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,

56+ UVerb, Verb, addHeader)

57import Servant.Server

58 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

59− emptyServer, err401, err403, err404, serve, serveWithContext)

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

60+ serveWithContext)

60import Servant.Test.ComprehensiveAPI

61import Servant.Test.ComprehensiveAPI

61import qualified Servant.Types.SourceT as S

62import qualified Servant.Types.SourceT as S

62import Test.Hspec

63import Test.Hspec

@@ -87,6 +88,7 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

87spec :: Spec

88spec :: Spec

88spec = do

89spec = do

89 verbSpec

90 verbSpec

91+ uverbSpec

90 captureSpec

92 captureSpec

91 captureAllSpec

93 captureAllSpec

92 queryParamSpec

94 queryParamSpec

@@ -253,8 +255,8 @@ captureSpec = do

253

255

254 with (return (serve

256 with (return (serve

255 (Proxy :: Proxy (Capture "captured" String :> Raw))

257 (Proxy :: Proxy (Capture "captured" String :> Raw))

256− (\ "captured" -> Tagged $ \request_ respond ->

258+ (\ "captured" -> Tagged $ \request_ sendResponse ->

257− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

259+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

258 it "strips the captured path snippet from pathInfo" $ do

260 it "strips the captured path snippet from pathInfo" $ do

259 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

261 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

260

262

@@ -305,8 +307,8 @@ captureAllSpec = do

305

307

306 with (return (serve

308 with (return (serve

307 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

309 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

308− (\ _captured -> Tagged $ \request_ respond ->

310+ (\ _captured -> Tagged $ \request_ sendResponse ->

309− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

311+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

310 it "consumes everything from pathInfo" $ do

312 it "consumes everything from pathInfo" $ do

311 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

313 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

312

314

@@ -544,8 +546,8 @@ rawApi :: Proxy RawApi

544rawApi = Proxy

546rawApi = Proxy

545

547

546rawApplication :: Show a => (Request -> a) -> Tagged m Application

548rawApplication :: Show a => (Request -> a) -> Tagged m Application

547−rawApplication f = Tagged $ \request_ respond ->

549+rawApplication f = Tagged $ \request_ sendResponse ->

548− respond $ responseLBS ok200 []

550+ sendResponse $ responseLBS ok200 []

549 (cs $ show $ f request_)

551 (cs $ show $ f request_)

550

552

551rawSpec :: Spec

553rawSpec :: Spec

@@ -706,7 +708,7 @@ basicAuthApi = Proxy

706basicAuthServer :: Server BasicAuthAPI

708basicAuthServer :: Server BasicAuthAPI

707basicAuthServer =

709basicAuthServer =

708 const (return jerry) :<|>

710 const (return jerry) :<|>

709− (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")

711+ (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")

710

712

711basicAuthContext :: Context '[ BasicAuthCheck () ]

713basicAuthContext :: Context '[ BasicAuthCheck () ]

712basicAuthContext =

714basicAuthContext =

@@ -751,7 +753,7 @@ genAuthApi = Proxy

751

753

752genAuthServer :: Server GenAuthAPI

754genAuthServer :: Server GenAuthAPI

753genAuthServer = const (return tweety)

755genAuthServer = const (return tweety)

754− :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")

756+ :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")

755

757

756type instance AuthServerData (AuthProtect "auth") = ()

758type instance AuthServerData (AuthProtect "auth") = ()

757

759

@@ -781,6 +783,73 @@ genAuthSpec = do

781 it "plays nice with subsequent Raw endpoints" $ do

783 it "plays nice with subsequent Raw endpoints" $ do

782 get "/foo" `shouldRespondWith` 418

784 get "/foo" `shouldRespondWith` 418

783

785

786+-- }}}

787+------------------------------------------------------------------------------

788+-- * UVerb {{{

789+------------------------------------------------------------------------------

790+

791+newtype PersonResponse = PersonResponse Person

792+ deriving Generic

793+instance ToJSON PersonResponse

794+instance HasStatus PersonResponse where

795+ type StatusOf PersonResponse = 200

796+

797+newtype RedirectResponse = RedirectResponse String

798+ deriving Generic

799+instance ToJSON RedirectResponse

800+instance HasStatus RedirectResponse where

801+ type StatusOf RedirectResponse = 301

802+

803+newtype AnimalResponse = AnimalResponse Animal

804+ deriving Generic

805+instance ToJSON AnimalResponse

806+instance HasStatus AnimalResponse where

807+ type StatusOf AnimalResponse = 203

808+

809+

810+type UVerbApi

811+ = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]

812+ :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]

813+

814+uverbSpec :: Spec

815+uverbSpec = describe "Servant.API.UVerb " $ do

816+ let

817+ joe = Person "joe" 42

818+ mouse = Animal "Mouse" 7

819+

820+ personHandler

821+ :: Bool

822+ -> Handler (Union '[PersonResponse

823+ ,RedirectResponse])

824+ personHandler True = respond $ RedirectResponse "over there!"

825+ personHandler False = respond $ PersonResponse joe

826+

827+ animalHandler = respond $ AnimalResponse mouse

828+

829+ server :: Server UVerbApi

830+ server = personHandler :<|> animalHandler

831+

832+ with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do

833+ context "A route returning either 301/String or 200/Person" $ do

834+ context "when requesting the person" $ do

835+ let theRequest = THW.get "/person/false"

836+ it "returns status 200" $

837+ theRequest `shouldRespondWith` 200

838+ it "returns a person" $ do

839+ response <- theRequest

840+ liftIO $ decode' (simpleBody response) `shouldBe` Just joe

841+ context "requesting the redirect" $

842+ it "returns a message and status 301" $

843+ THW.get "/person/true"

844+ `shouldRespondWith` "\"over there!\"" {matchStatus = 301}

845+ context "a route with a single response type" $ do

846+ let theRequest = THW.get "/animal"

847+ it "should return the defined status code" $

848+ theRequest `shouldRespondWith` 203

849+ it "should return the expected response" $ do

850+ response <- theRequest

851+ liftIO $ decode' (simpleBody response) `shouldBe` Just mouse

852+

784-- }}}

853-- }}}

785------------------------------------------------------------------------------

854------------------------------------------------------------------------------

786-- * Test data types {{{

855-- * Test data types {{{

servant/servant.cabal+8−1

@@ -54,6 +54,8 @@ library

54 Servant.API.Stream

55 Servant.API.Sub

56 Servant.API.TypeLevel

57+ Servant.API.UVerb

58+ Servant.API.UVerb.Union

57 Servant.API.Vault

59 Servant.API.Vault

58 Servant.API.Verbs

60 Servant.API.Verbs

59 Servant.API.WithNamedContext

61 Servant.API.WithNamedContext

@@ -78,6 +80,7 @@ library

78 base >= 4.9 && < 4.15

80 base >= 4.9 && < 4.15

79 , bytestring >= 0.10.8.1 && < 0.11

81 , bytestring >= 0.10.8.1 && < 0.11

80 , mtl >= 2.2.2 && < 2.3

82 , mtl >= 2.2.2 && < 2.3

83+ , sop-core >= 0.4.0.0 && < 0.6

81 , transformers >= 0.5.2.0 && < 0.6

84 , transformers >= 0.5.2.0 && < 0.6

82 , text >= 1.2.3.0 && < 1.3

85 , text >= 1.2.3.0 && < 1.3

83

86

@@ -108,11 +111,13 @@ library

108

111

109 hs-source-dirs: src

112 hs-source-dirs: src

110 default-language: Haskell2010

113 default-language: Haskell2010

111− other-extensions: CPP

114+ other-extensions: AllowAmbiguousTypes

115+ , CPP

112 , ConstraintKinds

116 , ConstraintKinds

113 , DataKinds

117 , DataKinds

114 , DeriveDataTypeable

118 , DeriveDataTypeable

115 , DeriveGeneric

119 , DeriveGeneric

120+ , ExplicitNamespaces

116 , FlexibleContexts

121 , FlexibleContexts

117 , FlexibleInstances

122 , FlexibleInstances

118 , FunctionalDependencies

123 , FunctionalDependencies

@@ -121,11 +126,13 @@ library

121 , MultiParamTypeClasses

126 , MultiParamTypeClasses

122 , OverloadedStrings

127 , OverloadedStrings

123 , PolyKinds

128 , PolyKinds

129+ , RankNTypes

124 , ScopedTypeVariables

130 , ScopedTypeVariables

125 , TupleSections

131 , TupleSections

126 , TypeFamilies

132 , TypeFamilies

127 , TypeOperators

133 , TypeOperators

128 , UndecidableInstances

134 , UndecidableInstances

135+

129 ghc-options: -Wall -Wno-redundant-constraints

136 ghc-options: -Wall -Wno-redundant-constraints

130

137

131test-suite spec

138test-suite spec

servant/src/Servant/API.hs+4

@@ -32,6 +32,7 @@ module Servant.API (

32

33 -- * Actual endpoints, distinguished by HTTP method

34 module Servant.API.Verbs,

35+ module Servant.API.UVerb,

35

36

36 -- * Streaming endpoints, distinguished by HTTP method

37 -- * Streaming endpoints, distinguished by HTTP method

37 module Servant.API.Stream,

38 module Servant.API.Stream,

@@ -132,6 +133,9 @@ import Servant.API.Verbs

132 PutCreated, PutNoContent, PutNonAuthoritative,

133 PutCreated, PutNoContent, PutNonAuthoritative,

133 ReflectMethod (reflectMethod), StdMethod (..),

134 ReflectMethod (reflectMethod), StdMethod (..),

134 Verb, NoContentVerb)

135 Verb, NoContentVerb)

136+import Servant.API.UVerb

137+ (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,

138+ WithStatus (..), IsMember, Unique, inject)

135import Servant.API.WithNamedContext

139import Servant.API.WithNamedContext

136 (WithNamedContext)

140 (WithNamedContext)

137import Servant.Links

141import Servant.Links

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

@@ -419,7 +419,6 @@ instance MimeUnrender OctetStream BS.ByteString where

419 mimeUnrender _ = Right . toStrict

420

421

422−

423-- $setup

422-- $setup

424-- >>> :set -XFlexibleInstances

423-- >>> :set -XFlexibleInstances

425-- >>> :set -XMultiParamTypeClasses

424-- >>> :set -XMultiParamTypeClasses

servant/src/Servant/API/UVerb.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+

16+-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an

17+-- open union of types, and specific status codes for each type in this union. (`UVerb` is

18+-- short for `UnionVerb`)

19+--

20+-- This can be used for returning (rather than throwing) exceptions in a server as in, say

21+-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or

22+-- 201 created with a different body type, depending on the circumstances. (All of this can

23+-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in

24+-- the API types without something like `UVerb`.)

25+--

26+-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.

27+module Servant.API.UVerb

28+ ( UVerb,

29+ HasStatus (StatusOf),

30+ statusOf,

31+ HasStatuses (Statuses, statuses),

32+ WithStatus (..),

33+ module Servant.API.UVerb.Union,

34+ )

35+where

36+

37+import Data.Aeson (FromJSON, ToJSON)

38+import Data.Proxy (Proxy (Proxy))

39+import qualified GHC.Generics as GHC

40+import GHC.TypeLits (Nat)

41+import Network.HTTP.Types (Status, StdMethod)

42+import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)

43+import Servant.API.Status (KnownStatus, statusVal)

44+import Servant.API.UVerb.Union

45+

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

47+ type StatusOf (a :: *) :: Nat

48+

49+statusOf :: forall a proxy. HasStatus a => proxy a -> Status

50+statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))

51+

52+instance KnownStatus n => HasStatus (WithStatus n a) where

53+ type StatusOf (WithStatus n a) = n

54+

55+-- | If an API can respond with 'NoContent' we assume that this will happen

56+-- with the status code 204 No Content. If this needs to be overridden,

57+-- 'WithStatus' can be used.

58+instance HasStatus NoContent where

59+ type StatusOf NoContent = 204

60+

61+class HasStatuses (as :: [*]) where

62+ type Statuses (as :: [*]) :: [Nat]

63+ statuses :: Proxy as -> [Status]

64+

65+instance HasStatuses '[] where

66+ type Statuses '[] = '[]

67+ statuses _ = []

68+

69+instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where

70+ type Statuses (a ': as) = StatusOf a ': Statuses as

71+ statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)

72+

73+newtype WithStatus (k :: Nat) a = WithStatus a

74+ deriving (Eq, Show, GHC.Generic)

75+

76+instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)

77+

78+instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)

79+

80+instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where

81+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a

82+

83+instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where

84+ mimeUnrender contentTypeProxy input =

85+ WithStatus <$> mimeUnrender contentTypeProxy input

86+

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

88+--

89+-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write

90+-- instances for 'HasServer' etc. for the latter, getting them for the former for free.

91+-- Something like:

92+--

93+-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@

94+--

95+-- Backwards compatibility is tricky, though: this type alias would mean people would have to

96+-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.

97+data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])

servant/src/Servant/API/UVerb/Union.hsnew file+147

@@ -0,0 +1,147 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExplicitNamespaces #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+

14+{-

15+

17+

19+

20+Redistribution and use in source and binary forms, with or without

21+modification, are permitted provided that the following conditions are met:

22+

23+ * Redistributions of source code must retain the above copyright

24+ notice, this list of conditions and the following disclaimer.

25+

26+ * Redistributions in binary form must reproduce the above

27+ copyright notice, this list of conditions and the following

28+ disclaimer in the documentation and/or other materials provided

29+ with the distribution.

30+

31+ * Neither the name of Author name here nor the names of other

32+ contributors may be used to endorse or promote products derived

33+ from this software without specific prior written permission.

34+

35+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

36+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

37+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

38+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

39+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

40+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

41+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

42+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

43+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

44+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

45+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

46+

47+-}

48+

49+-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by

50+-- [world-piece](https://github.com/cdepillabout/world-peace).

51+module Servant.API.UVerb.Union

52+( IsMember

53+, Unique

54+, Union

55+, inject

56+, eject

57+, foldMapUnion

58+, matchUnion

59+)

60+where

61+

62+import Data.Proxy (Proxy)

63+import Data.SOP.BasicFunctors (I, unI)

64+import Data.SOP.Constraint

65+import Data.SOP.NS

66+import Data.Type.Bool (If)

67+import Data.Type.Equality (type (==))

68+import GHC.TypeLits

69+

70+type Union = NS I

71+

72+-- | Convenience function to apply a function to an unknown union element using a type class.

73+-- All elements of the union must have instances in the type class, and the function is

74+-- applied unconditionally.

75+--

76+-- See also: 'matchUnion'.

77+foldMapUnion ::

78+ forall (c :: * -> Constraint) (a :: *) (as :: [*]).

79+ All c as =>

80+ Proxy c ->

81+ (forall x. c x => x -> a) ->

82+ Union as ->

83+ a

84+foldMapUnion proxy go = cfoldMap_NS proxy (go . unI)

85+

86+-- | Convenience function to extract a union element using 'cast', ie. return the value if the

87+-- selected type happens to be the actual type of the union in this value, or 'Nothing'

88+-- otherwise.

89+--

90+-- See also: 'foldMapUnion'.

91+matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a

92+matchUnion = fmap unI . eject

93+

94+-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop

95+

96+-- (this could to go sop-core, except it's probably too specialized to the servant use-case.)

97+

98+type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as)

99+

100+class UElem x xs where

101+ inject :: f x -> NS f xs

102+ eject :: NS f xs -> Maybe (f x)

103+

104+instance {-# OVERLAPPING #-} UElem x (x ': xs) where

105+ inject = Z

106+ eject (Z x) = Just x

107+ eject _ = Nothing

108+

109+instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where

110+ inject = S . inject

111+ eject (Z _) = Nothing

112+ eject (S ns) = eject ns

113+

114+-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the

115+-- list, or if there is a duplicate in the list.

116+type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where

117+ CheckElemIsMember a as =

118+ If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as))

119+

120+type NoElementError (r :: k) (rs :: [k]) =

121+ 'Text "Expected one of:"

122+ ':$$: 'Text " " ':<>: 'ShowType rs

123+ ':$$: 'Text "But got:"

124+ ':$$: 'Text " " ':<>: 'ShowType r

125+

126+type DuplicateElementError (rs :: [k]) =

127+ 'Text "Duplicate element in list:"

128+ ':$$: 'Text " " ':<>: 'ShowType rs

129+

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

131+ Elem _ '[] = 'False

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

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

134+

135+type family Unique xs :: Constraint where

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

137+

138+type family Nubbed xs :: Bool where

139+ Nubbed '[] = 'True

140+ Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs)

141+

142+_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False

143+ , Nubbed '[Int, Int, Bool] ~ 'False

144+ , Nubbed '[Int, Bool] ~ 'True

145+ )

146+ => a) -> a

147+_testNubbed = id