c110589 · typeable/servant

cabal.project+3−2

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

2525 doc/cookbook/custom-errors

2626 doc/cookbook/basic-streaming

2727 doc/cookbook/db-postgres-pool

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

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

2929 doc/cookbook/file-upload

3030 doc/cookbook/generic

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

32−-- doc/cookbook/https

32+ -- doc/cookbook/https

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

3434 doc/cookbook/pagination

3535 -- doc/cookbook/sentry

3636 doc/cookbook/testing

37+ doc/cookbook/uverb

3738 doc/cookbook/structuring-apis

3839 doc/cookbook/using-custom-monad

3940 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

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

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

8080 , safe >= 0.3.17 && < 0.4

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

8182

8283 hs-source-dirs: src

8384 default-language: Haskell2010

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

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

1818 -- * Client generation

1919 clientIn

2020 , HasClient(..)

21+ , foldMapUnion

22+ , matchUnion

2123

2224 -- * Request

2325 , Request

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

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

1+{-# LANGUAGE ConstraintKinds #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

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

78{-# LANGUAGE PolyKinds #-}

89{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

1012{-# LANGUAGE TypeFamilies #-}

1113{-# LANGUAGE TypeOperators #-}

1214{-# LANGUAGE UndecidableInstances #-}

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

1517 clientIn,

1618 HasClient (..),

1719 EmptyClient (..),

20+ foldMapUnion,

21+ matchUnion,

1822 ) where

1923

2024import Prelude ()

2125import Prelude.Compat

2226

27+import Control.Arrow

28+ (left, (+++))

2329import Control.Monad

2430 (unless)

2531import qualified Data.ByteString.Lazy as BL

32+import Data.Either

33+ (partitionEithers)

2634import Data.Foldable

2735 (toList)

2836import Data.List

2937 (foldl')

30−import Data.Proxy

31− (Proxy (Proxy))

3238import Data.Sequence

3339 (fromList)

3440import qualified Data.Text as T

3541import Network.HTTP.Media

3642 (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))

3752import Data.String

3853 (fromString)

3954import Data.Text

4055 (Text, pack)

56+import Data.Proxy

57+ (Proxy (Proxy))

4158import GHC.TypeLits

4259 (KnownSymbol, symbolVal)

60+import Network.HTTP.Types

61+ (Status)

4362import qualified Network.HTTP.Types as H

4463import Servant.API

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

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

5473 contentType, getHeadersHList, getResponse, toQueryParam,

5574 toUrlPiece)

5675import Servant.API.ContentTypes

57− (contentTypes)

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

5877import Servant.API.Modifiers

5978 (FoldRequired, RequiredArgument, foldRequiredArgument)

79+import Servant.API.UVerb

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

6081

6182import Servant.Client.Core.Auth

6283import Servant.Client.Core.BasicAuth

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

288309

289310 hoistClientMonad _ _ f ma = f ma

290311

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+

291377instance {-# OVERLAPPABLE #-}

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

293379 FramingUnrender framing, FromSourceIO chunk a

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

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

711797 Right val -> return val

712798 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

55 (

66 -- * HasClient

77 HasClient(..)

8+ , foldMapUnion

9+ , matchUnion

810

911 -- * Response (for @Raw@)

1012 , Response

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

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

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

88module Servant.Client.Core.RunClient (

99 RunClient (..),

10+ runRequest,

1011 RunStreamingClient (..),

1112 ClientF (..),

1213 ) where

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

1415import Prelude ()

1516import Prelude.Compat

1617

18+import Network.HTTP.Types.Status

19+ (Status)

1720import Control.Monad.Free

1821 (Free (..), liftF)

1922

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

2225import Servant.Client.Core.Response

2326

2427class Monad m => RunClient m where

25− -- | How to make a request.

26− runRequest :: Request -> m Response

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

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

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

2731 throwClientError :: ClientError -> m a

2832

33+-- | How to make a request.

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

35+runRequest = runRequestAcceptStatus Nothing

36+

2937class RunClient m => RunStreamingClient m where

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

3139

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

4149 | Throw ClientError

4250 deriving (Functor)

4351

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

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

45− runRequest req = liftF (RunRequest req id)

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

4655 throwClientError = liftF . Throw

servant-client/servant-client.cabal+1

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

108108 , kan-extensions

109109 , servant-client

110110 , servant-client-core

111+ , sop-core

111112 , stm

112113 , text

113114 , transformers

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

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

6565import Network.HTTP.Media

6666 (renderHeader)

6767import Network.HTTP.Types

68− (hContentType, renderQuery, statusCode)

68+ (hContentType, renderQuery, statusCode, Status)

6969import Servant.Client.Core

7070

7171import qualified Network.HTTP.Client as Client

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

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

156156

157157instance RunClient ClientM where

158− runRequest = performRequest

158+ runRequestAcceptStatus = performRequest

159159 throwClientError = throwError

160160

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

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

163163

164−performRequest :: Request -> ClientM Response

165−performRequest req = do

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

165+performRequest acceptStatus req = do

166166 ClientEnv m burl cookieJar' createClientRequest <- ask

167167 let clientRequest = createClientRequest burl req

168168 request <- case cookieJar' of

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

183183 let status = Client.responseStatus response

184184 status_code = statusCode status

185185 ourResponse = clientResponseToResponse id response

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

187− throwError $ mkFailureResponse burl req ourResponse

186+ goodStatus = case acceptStatus of

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

188+ Just good -> status `elem` good

189+ unless goodStatus $ do

190+ throwError $ mkFailureResponse burl req ourResponse

188191 return ourResponse

189192 where

190193 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

4747 (getCurrentTime)

4848import GHC.Generics

4949import Network.HTTP.Types

50− (statusCode)

50+ (Status, statusCode)

5151

5252import qualified Network.HTTP.Client as Client

5353

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

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

113113

114114instance RunClient ClientM where

115− runRequest = performRequest

115+ runRequestAcceptStatus = performRequest

116116 throwClientError = throwError

117117

118118instance RunStreamingClient ClientM where

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

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

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

138138

139−performRequest :: Request -> ClientM Response

140−performRequest req = do

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

140+performRequest acceptStatus req = do

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

142142 ClientEnv m burl cookieJar' createClientRequest <- ask

143143 let clientRequest = createClientRequest burl req

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

165165 let status = Client.responseStatus response

166166 status_code = statusCode status

167167 ourResponse = clientResponseToResponse id response

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

168+ goodStatus = case acceptStatus of

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

170+ Just good -> status `elem` good

171+ unless goodStatus $ do

169172 throwError $ mkFailureResponse burl req ourResponse

170173 return ourResponse

171174

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

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

173177performWithStreamingRequest req k = do

174178 m <- asks manager

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

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

99{-# LANGUAGE OverloadedStrings #-}

1010{-# LANGUAGE PolyKinds #-}

1111{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

1213{-# LANGUAGE TypeFamilies #-}

1314{-# LANGUAGE TypeOperators #-}

1415{-# LANGUAGE UndecidableInstances #-}

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

2627import Control.Monad.Error.Class

2728 (throwError)

2829import Data.Aeson

30+import qualified Data.ByteString.Lazy as LazyByteString

2931import Data.Char

3032 (chr, isPrint)

3133import Data.Monoid ()

3234import Data.Proxy

35+import Data.Text (Text)

36+import qualified Data.Text as Text

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

3338import GHC.Generics

3439 (Generic)

3540import qualified Network.HTTP.Client as C

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

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

4853 BasicAuthData (..), Capture, CaptureAll,

4954 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

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

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

55+ Headers, JSON, MimeRender(mimeRender),

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

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

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

59+ addHeader)

5260import Servant.Client

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

5462import Servant.Server

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

6371data Person = Person

6472 { _name :: String

6573 , _age :: Integer

66− } deriving (Eq, Show, Generic)

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

6775

6876instance ToJSON Person

6977instance FromJSON Person

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

7482instance Arbitrary Person where

7583 arbitrary = Person <$> arbitrary <*> arbitrary

7684

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+

7794alice :: Person

7895alice = Person "Alice" 42

7996

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

105122 :<|> "deleteContentType" :> DeleteNoContent

106123 :<|> "redirectWithCookie" :> Raw

107124 :<|> "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+

108131

109132api :: Proxy Api

110133api = Proxy

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

126149getRespHeaders :: ClientM (Headers TestHeaders Bool)

127150getDeleteContentType :: ClientM NoContent

128151getRedirectWithCookie :: HTTP.Method -> ClientM Response

152+uverbGetSuccessOrRedirect :: Bool

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

154+ WithStatus 301 Text])

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

129156

130157getRoot

131158 :<|> getGet

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

143170 :<|> getRespHeaders

144171 :<|> getDeleteContentType

145172 :<|> getRedirectWithCookie

146− :<|> EmptyClient = client api

173+ :<|> EmptyClient

174+ :<|> uverbGetSuccessOrRedirect

175+ :<|> uverbGetCreated = client api

147176

148177server :: Application

149178server = serve api (

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

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

167196 :<|> return NoContent

168197 :<|> (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+ )

170204

171205type FailApi =

172206 "get" :> Raw

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

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

88{-# LANGUAGE OverloadedStrings #-}

99{-# LANGUAGE PolyKinds #-}

1010{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

1112{-# LANGUAGE TypeFamilies #-}

1213{-# LANGUAGE TypeOperators #-}

1314{-# LANGUAGE UndecidableInstances #-}

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

3132import Data.Maybe

3233 (listToMaybe)

3334import Data.Monoid ()

35+import Data.Text

36+ (Text)

3437import qualified Network.HTTP.Client as C

3538import qualified Network.HTTP.Types as HTTP

3639import Test.Hspec

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

3942import Test.QuickCheck

4043

4144import Servant.API

42− (NoContent (NoContent), getHeaders)

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

4346import Servant.Client

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

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

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

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

152155 return $

153156 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

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

142142

143143instance RunClient ClientM where

144− runRequest = performRequest

144+ runRequestAcceptStatus = performRequest

145145 throwClientError = throwError

146146

147147instance RunStreamingClient ClientM where

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

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

156156 in f k

157157

158−performRequest :: Request -> ClientM Response

159−performRequest req = do

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

159+performRequest acceptStatus req = do

160160 ClientEnv burl conn <- ask

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

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

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

165165 let sc = Client.getStatusCode res'

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

167167 let res'' = clientResponseToResponse res' lbs

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

168+ goodStatus = case acceptStatus of

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

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

171+ if goodStatus

169172 then k (Right res'')

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

171174

servant-server/servant-server.cabal+3

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

5151 Servant.Server.Internal.RoutingApplication

5252 Servant.Server.Internal.ServerError

5353 Servant.Server.StaticFiles

54+ Servant.Server.UVerb

5455

5556 -- deprecated

5657 exposed-modules:

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

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

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

8687 , network >= 2.8 && < 3.2

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

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

8890 , resourcet >= 1.2.2 && < 1.3

8991 , tagged >= 0.8.6 && < 0.9

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

9496

9597 hs-source-dirs: src

9698 default-language: Haskell2010

99+

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

98101

99102executable greet

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

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

110110 -- * Re-exports

111111 , Application

112112 , Tagged (..)

113+ , module Servant.Server.UVerb

113114

114115 ) where

115116

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

122123import Network.Wai

123124 (Application)

124125import Servant.Server.Internal

126+import Servant.Server.UVerb

125127

126128

127129-- * Implementing Servers

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

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

6565 (SockAddr)

6666import Network.Wai

6767 (Application, Request, httpVersion, isSecure, lazyRequestBody,

68− queryString, remoteHost, requestBody, requestHeaders,

68+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,

6969 requestMethod, responseLBS, responseStream, vault)

7070import Prelude ()

7171import Prelude.Compat

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

681681 bodyCheck fromRS = withRequest $ \req -> do

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

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

684− let body = requestBody req

684+ let body = getRequestBodyChunk req

685685 let rs = S.fromAction B.null body

686686 let rs' = fromRS $ framingUnrender' rs

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

77{-# LANGUAGE ScopedTypeVariables #-}

88{-# LANGUAGE TypeFamilies #-}

99{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE TypeSynonymInstances #-}

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

1211

1312module Servant.ServerSpec where

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

4948import Servant.API

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

5150 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

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

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

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

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

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

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

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

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

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

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

56+ UVerb, Verb, addHeader)

5757import Servant.Server

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

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

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

60+ serveWithContext)

6061import Servant.Test.ComprehensiveAPI

6162import qualified Servant.Types.SourceT as S

6263import Test.Hspec

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

8788spec :: Spec

8889spec = do

8990 verbSpec

91+ uverbSpec

9092 captureSpec

9193 captureAllSpec

9294 queryParamSpec

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

253255

254256 with (return (serve

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

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

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

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

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

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

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

260262

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

305307

306308 with (return (serve

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

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

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

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

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

310312 it "consumes everything from pathInfo" $ do

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

312314

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

544546rawApi = Proxy

545547

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

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

548− respond $ responseLBS ok200 []

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

550+ sendResponse $ responseLBS ok200 []

549551 (cs $ show $ f request_)

550552

551553rawSpec :: Spec

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

706708basicAuthServer :: Server BasicAuthAPI

707709basicAuthServer =

708710 const (return jerry) :<|>

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

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

710712

711713basicAuthContext :: Context '[ BasicAuthCheck () ]

712714basicAuthContext =

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

751753

752754genAuthServer :: Server GenAuthAPI

753755genAuthServer = const (return tweety)

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

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

755757

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

757759

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

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

782784 get "/foo" `shouldRespondWith` 418

783785

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+

784853-- }}}

785854------------------------------------------------------------------------------

786855-- * Test data types {{{

servant/servant.cabal+8−1

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

5454 Servant.API.Stream

5555 Servant.API.Sub

5656 Servant.API.TypeLevel

57+ Servant.API.UVerb

58+ Servant.API.UVerb.Union

5759 Servant.API.Vault

5860 Servant.API.Verbs

5961 Servant.API.WithNamedContext

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

7880 base >= 4.9 && < 4.15

7981 , bytestring >= 0.10.8.1 && < 0.11

8082 , mtl >= 2.2.2 && < 2.3

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

8184 , transformers >= 0.5.2.0 && < 0.6

8285 , text >= 1.2.3.0 && < 1.3

8386

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

108111

109112 hs-source-dirs: src

110113 default-language: Haskell2010

111− other-extensions: CPP

114+ other-extensions: AllowAmbiguousTypes

115+ , CPP

112116 , ConstraintKinds

113117 , DataKinds

114118 , DeriveDataTypeable

115119 , DeriveGeneric

120+ , ExplicitNamespaces

116121 , FlexibleContexts

117122 , FlexibleInstances

118123 , FunctionalDependencies

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

121126 , MultiParamTypeClasses

122127 , OverloadedStrings

123128 , PolyKinds

129+ , RankNTypes

124130 , ScopedTypeVariables

125131 , TupleSections

126132 , TypeFamilies

127133 , TypeOperators

128134 , UndecidableInstances

135+

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

130137

131138test-suite spec

servant/src/Servant/API.hs+4

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

3232

3333 -- * Actual endpoints, distinguished by HTTP method

3434 module Servant.API.Verbs,

35+ module Servant.API.UVerb,

3536

3637 -- * Streaming endpoints, distinguished by HTTP method

3738 module Servant.API.Stream,

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

132133 PutCreated, PutNoContent, PutNonAuthoritative,

133134 ReflectMethod (reflectMethod), StdMethod (..),

134135 Verb, NoContentVerb)

136+import Servant.API.UVerb

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

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

135139import Servant.API.WithNamedContext

136140 (WithNamedContext)

137141import Servant.Links

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

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

419419 mimeUnrender _ = Right . toStrict

420420

421421

422−

423422-- $setup

424423-- >>> :set -XFlexibleInstances

425424-- >>> :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