357cc83 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #276 from haskell-servant/jkarni/emptyWithHeaders

357cc83Julian Arni11 years ago

servant-client/src/Servant/Client.hs+44−125

compare with master

unifiedsplit

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

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE InstanceSigs #-}

6{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

@@ -23,7 +24,6 @@ module Servant.Client

23#if !MIN_VERSION_base(4,8,0)

24#if !MIN_VERSION_base(4,8,0)

24import Control.Applicative ((<$>))

25import Control.Applicative ((<$>))

25#endif

26#endif

26−import Control.Monad

27import Control.Monad.Trans.Except

28import Data.ByteString.Lazy (ByteString)

29import Data.List

@@ -44,7 +44,7 @@ import Servant.Common.Req

44-- | 'client' allows you to produce operations to query an API from a client.

45--

46-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

47−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books

47+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

48-- >

49-- > myApi :: Proxy MyApi

50-- > myApi = Proxy

@@ -118,62 +118,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)

118

119 where p = unpack (toUrlPiece val)

120

121−-- | If you have a 'Delete' endpoint in your API, the client

122−-- side querying function that is created when calling 'client'

123−-- will just require an argument that specifies the scheme, host

124−-- and port to send the request to.

125instance OVERLAPPABLE_

121instance OVERLAPPABLE_

122+ -- Note [Non-Empty Content Types]

126− (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where

123+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

124+ ) => HasClient (Verb method status cts' a) where

127− type Client (Delete cts' a) = ExceptT ServantError IO a

125+ type Client (Verb method status cts' a) = ExceptT ServantError IO a

128 clientWithRoute Proxy req baseurl manager =

126 clientWithRoute Proxy req baseurl manager =

129− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager

127+ snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager

128+ where method = reflectMethod (Proxy :: Proxy method)

130

129

131instance OVERLAPPING_

130instance OVERLAPPING_

132− HasClient (Delete cts ()) where

131+ (ReflectMethod method) => HasClient (Verb method status cts NoContent) where

133− type Client (Delete cts ()) = ExceptT ServantError IO ()

132+ type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent

134 clientWithRoute Proxy req baseurl manager =

133 clientWithRoute Proxy req baseurl manager =

135− void $ performRequestNoBody H.methodDelete req baseurl manager

134+ performRequestNoBody method req baseurl manager >> return NoContent

135+ where method = reflectMethod (Proxy :: Proxy method)

136

137−-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the

138−-- corresponding headers.

139instance OVERLAPPING_

137instance OVERLAPPING_

138+ -- Note [Non-Empty Content Types]

140− ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)

139+ ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)

141− ) => HasClient (Delete cts' (Headers ls a)) where

140+ ) => HasClient (Verb method status cts' (Headers ls a)) where

141+ type Client (Verb method status cts' (Headers ls a))

142− type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

142+ = ExceptT ServantError IO (Headers ls a)

143 clientWithRoute Proxy req baseurl manager = do

144+ let method = reflectMethod (Proxy :: Proxy method)

144− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager

145+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager

145 return $ Headers { getResponse = resp

146 return $ Headers { getResponse = resp

146 , getHeadersHList = buildHeadersTo hdrs

147 , getHeadersHList = buildHeadersTo hdrs

147 }

148 }

148

149

149−-- | If you have a 'Get' endpoint in your API, the client

150−-- side querying function that is created when calling 'client'

151−-- will just require an argument that specifies the scheme, host

152−-- and port to send the request to.

153−instance OVERLAPPABLE_

154− (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where

155− type Client (Get (ct ': cts) result) = ExceptT ServantError IO result

156− clientWithRoute Proxy req baseurl manager =

157− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager

158−

159−instance OVERLAPPING_

160− HasClient (Get (ct ': cts) ()) where

161− type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()

162− clientWithRoute Proxy req baseurl manager =

163− performRequestNoBody H.methodGet req baseurl manager

164−

165−-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the

166−-- corresponding headers.

167instance OVERLAPPING_

150instance OVERLAPPING_

168− ( MimeUnrender ct a, BuildHeadersTo ls

151+ ( BuildHeadersTo ls, ReflectMethod method

169− ) => HasClient (Get (ct ': cts) (Headers ls a)) where

152+ ) => HasClient (Verb method status cts (Headers ls NoContent)) where

153+ type Client (Verb method status cts (Headers ls NoContent))

170− type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

154+ = ExceptT ServantError IO (Headers ls NoContent)

171 clientWithRoute Proxy req baseurl manager = do

155 clientWithRoute Proxy req baseurl manager = do

172− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager

156+ let method = reflectMethod (Proxy :: Proxy method)

157+ hdrs <- performRequestNoBody method req baseurl manager

173− return $ Headers { getResponse = resp

158+ return $ Headers { getResponse = NoContent

174 , getHeadersHList = buildHeadersTo hdrs

159 , getHeadersHList = buildHeadersTo hdrs

175 }

160 }

176

161

162+

177-- | If you use a 'Header' in one of your endpoints in your API,

163-- | If you use a 'Header' in one of your endpoints in your API,

178-- the corresponding querying function will automatically take

164-- the corresponding querying function will automatically take

179-- an additional argument of the type specified by your 'Header',

165-- an additional argument of the type specified by your 'Header',

@@ -217,90 +203,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)

217

203

218 where hname = symbolVal (Proxy :: Proxy sym)

204 where hname = symbolVal (Proxy :: Proxy sym)

219

205

220−-- | If you have a 'Post' endpoint in your API, the client

221−-- side querying function that is created when calling 'client'

222−-- will just require an argument that specifies the scheme, host

223−-- and port to send the request to.

224−instance OVERLAPPABLE_

225− (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where

226− type Client (Post (ct ': cts) a) = ExceptT ServantError IO a

227− clientWithRoute Proxy req baseurl manager =

228− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager

229−

230−instance OVERLAPPING_

231− HasClient (Post (ct ': cts) ()) where

232− type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()

233− clientWithRoute Proxy req baseurl manager =

234− void $ performRequestNoBody H.methodPost req baseurl manager

235−

236−-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the

237−-- corresponding headers.

238−instance OVERLAPPING_

239− ( MimeUnrender ct a, BuildHeadersTo ls

240− ) => HasClient (Post (ct ': cts) (Headers ls a)) where

241− type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

242− clientWithRoute Proxy req baseurl manager = do

243− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager

244− return $ Headers { getResponse = resp

245− , getHeadersHList = buildHeadersTo hdrs

246− }

247−

248−-- | If you have a 'Put' endpoint in your API, the client

249−-- side querying function that is created when calling 'client'

250−-- will just require an argument that specifies the scheme, host

251−-- and port to send the request to.

252−instance OVERLAPPABLE_

253− (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where

254− type Client (Put (ct ': cts) a) = ExceptT ServantError IO a

255− clientWithRoute Proxy req baseurl manager =

256− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager

257−

258−instance OVERLAPPING_

259− HasClient (Put (ct ': cts) ()) where

260− type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()

261− clientWithRoute Proxy req baseurl manager =

262− void $ performRequestNoBody H.methodPut req baseurl manager

263−

264−-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the

265−-- corresponding headers.

266−instance OVERLAPPING_

267− ( MimeUnrender ct a, BuildHeadersTo ls

268− ) => HasClient (Put (ct ': cts) (Headers ls a)) where

269− type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

270− clientWithRoute Proxy req baseurl manager= do

271− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager

272− return $ Headers { getResponse = resp

273− , getHeadersHList = buildHeadersTo hdrs

274− }

275−

276−-- | If you have a 'Patch' endpoint in your API, the client

277−-- side querying function that is created when calling 'client'

278−-- will just require an argument that specifies the scheme, host

279−-- and port to send the request to.

280−instance OVERLAPPABLE_

281− (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where

282− type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a

283− clientWithRoute Proxy req baseurl manager =

284− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager

285−

286−instance OVERLAPPING_

287− HasClient (Patch (ct ': cts) ()) where

288− type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()

289− clientWithRoute Proxy req baseurl manager =

290− void $ performRequestNoBody H.methodPatch req baseurl manager

291−

292−-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the

293−-- corresponding headers.

294−instance OVERLAPPING_

295− ( MimeUnrender ct a, BuildHeadersTo ls

296− ) => HasClient (Patch (ct ': cts) (Headers ls a)) where

297− type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

298− clientWithRoute Proxy req baseurl manager = do

299− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager

300− return $ Headers { getResponse = resp

301− , getHeadersHList = buildHeadersTo hdrs

302− }

303−

304-- | If you use a 'QueryParam' in one of your endpoints in your API,

206-- | If you use a 'QueryParam' in one of your endpoints in your API,

305-- the corresponding querying function will automatically take

207-- the corresponding querying function will automatically take

306-- an additional argument of the type specified by your 'QueryParam',

208-- an additional argument of the type specified by your 'QueryParam',

@@ -503,3 +405,20 @@ instance HasClient api => HasClient (IsSecure :> api) where

503

405

504 clientWithRoute Proxy req baseurl manager =

406 clientWithRoute Proxy req baseurl manager =

505 clientWithRoute (Proxy :: Proxy api) req baseurl manager

407 clientWithRoute (Proxy :: Proxy api) req baseurl manager

408+

409+

410+{- Note [Non-Empty Content Types]

411+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

412+Rather than have

413+

414+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...

415+

416+It may seem to make more sense to have:

417+

418+ instance (...) => ... (ct ': cts) ...

419+

420+But this means that if another instance exists that does *not* require

421+non-empty lists, but is otherwise more specific, no instance will be overall

422+more specific. This in turn generally means adding yet another instance (one

423+for empty and one for non-empty lists).

424+-}

servant-client/src/Servant/Common/Req.hs+11−8

@@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do

142 Right response -> do

143 let status = Client.responseStatus response

144 body = Client.responseBody response

145− hrds = Client.responseHeaders response

145+ hdrs = Client.responseHeaders response

146 status_code = statusCode status

147 ct <- case lookup "Content-Type" $ Client.responseHeaders response of

148 Nothing -> pure $ "application"//"octet-stream"

@@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do

151 Just t' -> pure t'

152 unless (status_code >= 200 && status_code < 300) $

153 throwE $ FailureResponse status ct body

154− return (status_code, body, ct, hrds, response)

154+ return (status_code, body, ct, hdrs, response)

155

156

157performRequestCT :: MimeUnrender ct result =>

158+ Proxy ct -> Method -> Req -> BaseUrl -> Manager

158− Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)

159+ -> ExceptT ServantError IO ([HTTP.Header], result)

159performRequestCT ct reqMethod req reqHost manager = do

160performRequestCT ct reqMethod req reqHost manager = do

160 let acceptCT = contentType ct

161 let acceptCT = contentType ct

161− (_status, respBody, respCT, hrds, _response) <-

162+ (_status, respBody, respCT, hdrs, _response) <-

162 performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager

163 performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager

163 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody

164 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody

164 case mimeUnrender ct respBody of

165 case mimeUnrender ct respBody of

165 Left err -> throwE $ DecodeFailure err respCT respBody

166 Left err -> throwE $ DecodeFailure err respCT respBody

166− Right val -> return (hrds, val)

167+ Right val -> return (hdrs, val)

167

168

168−performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()

169+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager

169−performRequestNoBody reqMethod req reqHost manager =

170+ -> ExceptT ServantError IO [HTTP.Header]

171+performRequestNoBody reqMethod req reqHost manager = do

170− void $ performRequest reqMethod req reqHost manager

172+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager

173+ return hdrs

171

174

172catchConnectionError :: IO a -> IO (Either ServantError a)

175catchConnectionError :: IO a -> IO (Either ServantError a)

173catchConnectionError action =

176catchConnectionError action =

servant-client/test/Servant/ClientSpec.hs+7−7

@@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

91type Api =

92 "get" :> Get '[JSON] Person

93− :<|> "deleteEmpty" :> Delete '[] ()

93+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

94 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

95 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

96 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

@@ -105,14 +105,14 @@ type Api =

105 ReqBody '[JSON] [(String, [Rational])] :>

106 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

107 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

108− :<|> "deleteContentType" :> Delete '[JSON] ()

108+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent

109api :: Proxy Api

110api = Proxy

111

112server :: Application

113server = serve api (

114 return alice

115− :<|> return ()

115+ :<|> return NoContent

116 :<|> (\ name -> return $ Person name 0)

117 :<|> return

118 :<|> (\ name -> case name of

@@ -125,7 +125,7 @@ server = serve api (

125 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")

126 :<|> (\ a b c d -> return (a, b, c, d))

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

128− :<|> return ()

128+ :<|> return NoContent

129 )

130

131

@@ -157,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

157 describe "Servant.API.Delete" $ do

158 it "allows empty content type" $ \(_, baseUrl) -> do

159 let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager

160− (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()

160+ (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent

161

162 it "allows content type" $ \(_, baseUrl) -> do

163 let getDeleteContentType = getLast $ client api baseUrl manager

164− (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()

164+ (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent

165

166 it "Servant.API.Capture" $ \(_, baseUrl) -> do

167 let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager

@@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

283 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

284

285data WrappedApi where

286− WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,

286+ WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,

287 HasClient api, Client api ~ ExceptT ServantError IO ()) =>

288 Proxy api -> WrappedApi

289

servant-docs/src/Servant/Docs.hs+1−2

@@ -41,8 +41,7 @@ module Servant.Docs

41 , ToCapture(..)

43 , -- * ADTs to represent an 'API'

44− Method(..)

45− , Endpoint, path, method, defEndpoint

44+ Endpoint, path, method, defEndpoint

46 , API, apiIntros, apiEndpoints, emptyAPI

45 , API, apiIntros, apiEndpoints, emptyAPI

47 , DocCapture(..), capSymbol, capDesc

46 , DocCapture(..), capSymbol, capDesc

48 , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind

47 , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind

servant-docs/src/Servant/Docs/Internal.hs+31−133

@@ -36,7 +36,7 @@ import Data.Monoid

36import Data.Ord (comparing)

37import Data.Proxy (Proxy(Proxy))

38import Data.String.Conversions (cs)

39−import Data.Text (Text, pack, unpack)

39+import Data.Text (Text, unpack)

40import GHC.Exts (Constraint)

41import GHC.Generics

42import GHC.TypeLits

@@ -49,21 +49,6 @@ import qualified Data.Text as T

49import qualified Network.HTTP.Media as M

50import qualified Network.HTTP.Types as HTTP

52−-- | Supported HTTP request methods

53−data Method = DocDELETE -- ^ the DELETE method

54− | DocGET -- ^ the GET method

55− | DocPOST -- ^ the POST method

56− | DocPUT -- ^ the PUT method

57− deriving (Eq, Ord, Generic)

58−

59−instance Show Method where

60− show DocGET = "GET"

61− show DocPOST = "POST"

62− show DocDELETE = "DELETE"

63− show DocPUT = "PUT"

64−

65−instance Hashable Method

66−

67-- | An 'Endpoint' type that holds the 'path' and the 'method'.

52-- | An 'Endpoint' type that holds the 'path' and the 'method'.

68--

53--

69-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'

54-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'

@@ -75,12 +60,12 @@ instance Hashable Method

75-- GET /

60-- GET /

76-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

61-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

77-- GET /foo

62-- GET /foo

78−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'

63+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'

79-- POST /foo

64-- POST /foo

80-- @

65-- @

81data Endpoint = Endpoint

66data Endpoint = Endpoint

82− { _path :: [String] -- type collected

67+ { _path :: [String] -- type collected

83− , _method :: Method -- type collected

68+ , _method :: HTTP.Method -- type collected

84 } deriving (Eq, Ord, Generic)

69 } deriving (Eq, Ord, Generic)

86instance Show Endpoint where

71instance Show Endpoint where

@@ -94,7 +79,7 @@ showPath :: [String] -> String

94showPath [] = "/"

79showPath [] = "/"

95showPath ps = concatMap ('/' :) ps

80showPath ps = concatMap ('/' :) ps

97−-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'

82+-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@

98--

83--

99-- Here's how you can modify it:

84-- Here's how you can modify it:

100--

85--

@@ -103,11 +88,11 @@ showPath ps = concatMap ('/' :) ps

103-- GET /

88-- GET /

104-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

89-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

105-- GET /foo

90-- GET /foo

106−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'

91+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'

107-- POST /foo

92-- POST /foo

108-- @

93-- @

109defEndpoint :: Endpoint

94defEndpoint :: Endpoint

110−defEndpoint = Endpoint [] DocGET

95+defEndpoint = Endpoint [] HTTP.methodGet

111

112instance Hashable Endpoint

97instance Hashable Endpoint

113

@@ -476,8 +461,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)

476

461

477-- | Synthesise a sample value of a type, encoded in the specified media types.

462-- | Synthesise a sample value of a type, encoded in the specified media types.

478sampleByteString

463sampleByteString

479− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)

464+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)

480− => Proxy ctypes

465+ => Proxy (ct ': cts)

481 -> Proxy a

466 -> Proxy a

482 -> [(M.MediaType, ByteString)]

467 -> [(M.MediaType, ByteString)]

483sampleByteString ctypes@Proxy Proxy =

468sampleByteString ctypes@Proxy Proxy =

@@ -486,8 +471,8 @@ sampleByteString ctypes@Proxy Proxy =

486-- | Synthesise a list of sample values of a particular type, encoded in the

471-- | Synthesise a list of sample values of a particular type, encoded in the

487-- specified media types.

472-- specified media types.

488sampleByteStrings

473sampleByteStrings

489− :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)

474+ :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)

490− => Proxy ctypes

475+ => Proxy (ct ': cts)

491 -> Proxy a

476 -> Proxy a

492 -> [(Text, M.MediaType, ByteString)]

477 -> [(Text, M.MediaType, ByteString)]

493sampleByteStrings ctypes@Proxy Proxy =

478sampleByteStrings ctypes@Proxy Proxy =

@@ -689,124 +674,37 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)

689

674

690

675

691instance OVERLAPPABLE_

676instance OVERLAPPABLE_

692− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

677+ (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

693− => HasDocs (Delete cts a) where

678+ , ReflectMethod method)

694− docsFor Proxy (endpoint, action) DocOptions{..} =

679+ => HasDocs (Verb method status (ct ': cts) a) where

695− single endpoint' action'

696−

697− where endpoint' = endpoint & method .~ DocDELETE

698− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

699− & response.respTypes .~ allMime t

700− t = Proxy :: Proxy cts

701− p = Proxy :: Proxy a

702−

703−instance OVERLAPPING_

704− (ToSample a, IsNonEmpty cts, AllMimeRender cts a

705− , AllHeaderSamples ls , GetHeaders (HList ls) )

706− => HasDocs (Delete cts (Headers ls a)) where

707− docsFor Proxy (endpoint, action) DocOptions{..} =

708− single endpoint' action'

709−

710− where hdrs = allHeaderToSample (Proxy :: Proxy ls)

711− endpoint' = endpoint & method .~ DocDELETE

712− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

713− & response.respTypes .~ allMime t

714− & response.respHeaders .~ hdrs

715− t = Proxy :: Proxy cts

716− p = Proxy :: Proxy a

717−

718−instance OVERLAPPABLE_

719− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

720− => HasDocs (Get cts a) where

721− docsFor Proxy (endpoint, action) DocOptions{..} =

722− single endpoint' action'

723−

724− where endpoint' = endpoint & method .~ DocGET

725− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

726− & response.respTypes .~ allMime t

727− t = Proxy :: Proxy cts

728− p = Proxy :: Proxy a

729−

730−instance OVERLAPPING_

731− (ToSample a, IsNonEmpty cts, AllMimeRender cts a

732− , AllHeaderSamples ls , GetHeaders (HList ls) )

733− => HasDocs (Get cts (Headers ls a)) where

734− docsFor Proxy (endpoint, action) DocOptions{..} =

735− single endpoint' action'

736−

737− where hdrs = allHeaderToSample (Proxy :: Proxy ls)

738− endpoint' = endpoint & method .~ DocGET

739− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

740− & response.respTypes .~ allMime t

741− & response.respHeaders .~ hdrs

742− t = Proxy :: Proxy cts

743− p = Proxy :: Proxy a

744−

745−instance (KnownSymbol sym, HasDocs sublayout)

746− => HasDocs (Header sym a :> sublayout) where

747− docsFor Proxy (endpoint, action) =

748− docsFor sublayoutP (endpoint, action')

749−

750− where sublayoutP = Proxy :: Proxy sublayout

751− action' = over headers (|> headername) action

752− headername = pack $ symbolVal (Proxy :: Proxy sym)

753−

754−instance OVERLAPPABLE_

755− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

756− => HasDocs (Post cts a) where

757− docsFor Proxy (endpoint, action) DocOptions{..} =

758− single endpoint' action'

759−

760− where endpoint' = endpoint & method .~ DocPOST

761− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

762− & response.respTypes .~ allMime t

763− & response.respStatus .~ 201

764− t = Proxy :: Proxy cts

765− p = Proxy :: Proxy a

766−

767−instance OVERLAPPING_

768− (ToSample a, IsNonEmpty cts, AllMimeRender cts a

769− , AllHeaderSamples ls , GetHeaders (HList ls) )

770− => HasDocs (Post cts (Headers ls a)) where

771− docsFor Proxy (endpoint, action) DocOptions{..} =

772− single endpoint' action'

773−

774− where hdrs = allHeaderToSample (Proxy :: Proxy ls)

775− endpoint' = endpoint & method .~ DocPOST

776− action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

777− & response.respTypes .~ allMime t

778− & response.respStatus .~ 201

779− & response.respHeaders .~ hdrs

780− t = Proxy :: Proxy cts

781− p = Proxy :: Proxy a

782−

783−instance OVERLAPPABLE_

784− (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

785− => HasDocs (Put cts a) where

786 docsFor Proxy (endpoint, action) DocOptions{..} =

680 docsFor Proxy (endpoint, action) DocOptions{..} =

787 single endpoint' action'

681 single endpoint' action'

788

682

789− where endpoint' = endpoint & method .~ DocPUT

683+ where endpoint' = endpoint & method .~ method'

790 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

684 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

791 & response.respTypes .~ allMime t

685 & response.respTypes .~ allMime t

792− & response.respStatus .~ 200

686+ & response.respStatus .~ status

793− t = Proxy :: Proxy cts

687+ t = Proxy :: Proxy (ct ': cts)

688+ method' = reflectMethod (Proxy :: Proxy method)

689+ status = fromInteger $ natVal (Proxy :: Proxy status)

794 p = Proxy :: Proxy a

690 p = Proxy :: Proxy a

795

691

796instance OVERLAPPING_

692instance OVERLAPPING_

797− ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,

693+ (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

798− AllHeaderSamples ls , GetHeaders (HList ls) )

694+ , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))

799− => HasDocs (Put cts (Headers ls a)) where

695+ => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where

800 docsFor Proxy (endpoint, action) DocOptions{..} =

696 docsFor Proxy (endpoint, action) DocOptions{..} =

801 single endpoint' action'

697 single endpoint' action'

802

698

803− where hdrs = allHeaderToSample (Proxy :: Proxy ls)

804− endpoint' = endpoint & method .~ DocPUT

699+ where endpoint' = endpoint & method .~ method'

805 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

700 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

806 & response.respTypes .~ allMime t

701 & response.respTypes .~ allMime t

807− & response.respStatus .~ 200

702+ & response.respStatus .~ status

808 & response.respHeaders .~ hdrs

703 & response.respHeaders .~ hdrs

809− t = Proxy :: Proxy cts

704+ t = Proxy :: Proxy (ct ': cts)

705+ hdrs = allHeaderToSample (Proxy :: Proxy ls)

706+ method' = reflectMethod (Proxy :: Proxy method)

707+ status = fromInteger $ natVal (Proxy :: Proxy status)

810 p = Proxy :: Proxy a

708 p = Proxy :: Proxy a

811

709

812instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)

710instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)

@@ -849,8 +747,8 @@ instance HasDocs Raw where

849-- example data. However, there's no reason to believe that the instances of

747-- example data. However, there's no reason to believe that the instances of

850-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that

748-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that

851-- both are even defined) for any particular type.

749-- both are even defined) for any particular type.

852−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)

750+instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)

853− => HasDocs (ReqBody cts a :> sublayout) where

751+ => HasDocs (ReqBody (ct ': cts) a :> sublayout) where

854

752

855 docsFor Proxy (endpoint, action) =

753 docsFor Proxy (endpoint, action) =

856 docsFor sublayoutP (endpoint, action')

754 docsFor sublayoutP (endpoint, action')

@@ -858,7 +756,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)

858 where sublayoutP = Proxy :: Proxy sublayout

756 where sublayoutP = Proxy :: Proxy sublayout

859 action' = action & rqbody .~ sampleByteString t p

757 action' = action & rqbody .~ sampleByteString t p

860 & rqtypes .~ allMime t

758 & rqtypes .~ allMime t

861− t = Proxy :: Proxy cts

759+ t = Proxy :: Proxy (ct ': cts)

862 p = Proxy :: Proxy a

760 p = Proxy :: Proxy a

863

761

864instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where

762instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where

servant-docs/test/Servant/DocsSpec.hs−1

@@ -71,7 +71,6 @@ spec = describe "Servant.Docs" $ do

72 it "mentions status codes" $ do

73 md `shouldContain` "Status code 200"

74− md `shouldContain` "Status code 201"

76 it "mentions methods" $ do

75 it "mentions methods" $ do

77 md `shouldContain` "POST"

76 md `shouldContain` "POST"

servant-foreign/servant-foreign.cabal+6−4

@@ -27,10 +27,11 @@ source-repository head

28library

29 exposed-modules: Servant.Foreign, Servant.Foreign.Internal

30− build-depends: base == 4.*

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

31− , lens == 4.*

31+ , lens == 4.*

32− , servant == 0.5.*

32+ , servant == 0.5.*

33− , text >= 1.2 && < 1.3

33+ , text >= 1.2 && < 1.3

34+ , http-types

34 hs-source-dirs: src

35 hs-source-dirs: src

35 default-language: Haskell2010

36 default-language: Haskell2010

36 ghc-options: -Wall

37 ghc-options: -Wall

@@ -41,6 +42,7 @@ test-suite spec

41 type: exitcode-stdio-1.0

42 type: exitcode-stdio-1.0

42 hs-source-dirs: test

43 hs-source-dirs: test

43 ghc-options: -Wall

44 ghc-options: -Wall

45+ include-dirs: include

44 main-is: Spec.hs

46 main-is: Spec.hs

45 other-modules:

47 other-modules:

46 Servant.ForeignSpec

48 Servant.ForeignSpec

servant-foreign/src/Servant/Foreign/Internal.hs+18−48

@@ -13,18 +13,21 @@

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE OverloadedStrings #-}

16+{-# LANGUAGE PolyKinds #-}

17-- | Generalizes all the data needed to make code generation work with

18-- | Generalizes all the data needed to make code generation work with

18-- arbitrary programming languages.

19-- arbitrary programming languages.

19module Servant.Foreign.Internal where

20module Servant.Foreign.Internal where

21−import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))

22+import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))

22−import qualified Data.Char as C

23+import qualified Data.Char as C

23import Data.Proxy

24import Data.Proxy

24import Data.Text

25import Data.Text

26+import Data.Text.Encoding (decodeUtf8)

25−import GHC.Exts (Constraint)

27+import GHC.Exts (Constraint)

26import GHC.TypeLits

28import GHC.TypeLits

29+import qualified Network.HTTP.Types as HTTP

27−import Prelude hiding (concat)

30+import Prelude hiding (concat)

28import Servant.API

31import Servant.API

30-- | Function name builder that simply concat each part together

33-- | Function name builder that simply concat each part together

@@ -86,11 +89,10 @@ defUrl :: Url

86defUrl = Url [] []

89defUrl = Url [] []

88type FunctionName = [Text]

91type FunctionName = [Text]

89−type Method = Text

91data Req = Req

93data Req = Req

92 { _reqUrl :: Url

94 { _reqUrl :: Url

93− , _reqMethod :: Method

95+ , _reqMethod :: HTTP.Method

94 , _reqHeaders :: [HeaderArg]

96 , _reqHeaders :: [HeaderArg]

95 , _reqBody :: Maybe ForeignType

97 , _reqBody :: Maybe ForeignType

96 , _reqReturnType :: ForeignType

98 , _reqReturnType :: ForeignType

@@ -185,27 +187,18 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

185 str = pack . symbolVal $ (Proxy :: Proxy sym)

187 str = pack . symbolVal $ (Proxy :: Proxy sym)

186 arg = (str, typeFor lang (Proxy :: Proxy a))

188 arg = (str, typeFor lang (Proxy :: Proxy a))

187

189

188−instance (Elem JSON list, HasForeignType lang a)

190+instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)

189− => HasForeign lang (Delete list a) where

191+ => HasForeign lang (Verb method status list a) where

190− type Foreign (Delete list a) = Req

192+ type Foreign (Verb method status list a) = Req

191

193

192 foreignFor lang Proxy req =

194 foreignFor lang Proxy req =

193− req & funcName %~ ("delete" :)

195+ req & funcName %~ (methodLC :)

194− & reqMethod .~ "DELETE"

195− & reqReturnType .~ retType

196− where

197− retType = typeFor lang (Proxy :: Proxy a)

198−

199−instance (Elem JSON list, HasForeignType lang a)

200− => HasForeign lang (Get list a) where

201− type Foreign (Get list a) = Req

202−

203− foreignFor lang Proxy req =

204− req & funcName %~ ("get" :)

205− & reqMethod .~ "GET"

196+ & reqMethod .~ method

206 & reqReturnType .~ retType

197 & reqReturnType .~ retType

207 where

198 where

208− retType = typeFor lang (Proxy :: Proxy a)

199+ retType = typeFor lang (Proxy :: Proxy a)

200+ method = reflectMethod (Proxy :: Proxy method)

201+ methodLC = toLower $ decodeUtf8 method

209

202

210instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

203instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

211 => HasForeign lang (Header sym a :> sublayout) where

204 => HasForeign lang (Header sym a :> sublayout) where

@@ -220,28 +213,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

220 arg = (hname, typeFor lang (Proxy :: Proxy a))

213 arg = (hname, typeFor lang (Proxy :: Proxy a))

221 subP = Proxy :: Proxy sublayout

214 subP = Proxy :: Proxy sublayout

222

215

223−instance (Elem JSON list, HasForeignType lang a)

224− => HasForeign lang (Post list a) where

225− type Foreign (Post list a) = Req

226−

227− foreignFor lang Proxy req =

228− req & funcName %~ ("post" :)

229− & reqMethod .~ "POST"

230− & reqReturnType .~ retType

231− where

232− retType = typeFor lang (Proxy :: Proxy a)

233−

234−instance (Elem JSON list, HasForeignType lang a)

235− => HasForeign lang (Put list a) where

236− type Foreign (Put list a) = Req

237−

238− foreignFor lang Proxy req =

239− req & funcName %~ ("put" :)

240− & reqMethod .~ "PUT"

241− & reqReturnType .~ retType

242− where

243− retType = typeFor lang (Proxy :: Proxy a)

244−

245instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

216instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

246 => HasForeign lang (QueryParam sym a :> sublayout) where

217 => HasForeign lang (QueryParam sym a :> sublayout) where

247 type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout

218 type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout

@@ -279,10 +250,10 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl

279 arg = (str, typeFor lang (Proxy :: Proxy a))

250 arg = (str, typeFor lang (Proxy :: Proxy a))

280

251

281instance HasForeign lang Raw where

252instance HasForeign lang Raw where

282− type Foreign Raw = Method -> Req

253+ type Foreign Raw = HTTP.Method -> Req

283

254

284 foreignFor _ Proxy req method =

255 foreignFor _ Proxy req method =

285− req & funcName %~ ((toLower method) :)

256+ req & funcName %~ ((toLower $ decodeUtf8 method) :)

286 & reqMethod .~ method

257 & reqMethod .~ method

287

258

288instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)

259instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)

@@ -346,4 +317,3 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res

346-- describing one endpoint from your API type.

317-- describing one endpoint from your API type.

347listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]

318listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]

348listFromAPI lang p = generateList (foreignFor lang p defReq)

319listFromAPI lang p = generateList (foreignFor lang p defReq)

349−

servant-foreign/test/Servant/ForeignSpec.hs+4−5

@@ -7,9 +7,8 @@

7{-# LANGUAGE TypeSynonymInstances #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE CPP #-}

10−#if __GLASGOW_HASKELL__ < 710

10+

11−{-# LANGUAGE OverlappingInstances #-}

11+#include "overlapping-compat.h"

12−#endif

14module Servant.ForeignSpec where

13module Servant.ForeignSpec where

@@ -41,9 +40,9 @@ instance HasForeignType LangX Int where

41 typeFor _ _ = "intX"

40 typeFor _ _ = "intX"

42instance HasForeignType LangX Bool where

41instance HasForeignType LangX Bool where

43 typeFor _ _ = "boolX"

42 typeFor _ _ = "boolX"

44−instance {-# Overlapping #-} HasForeignType LangX String where

43+instance OVERLAPPING_ HasForeignType LangX String where

45 typeFor _ _ = "stringX"

44 typeFor _ _ = "stringX"

46−instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where

45+instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where

47 typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)

46 typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)

49type TestApi

48type TestApi

servant-js/src/Servant/JS/Angular.hs+2−1

@@ -6,6 +6,7 @@ import Data.Maybe (isJust)

6import Data.Monoid

7import qualified Data.Text as T

8import Data.Text (Text)

9+import Data.Text.Encoding (decodeUtf8)

9import Servant.Foreign

10import Servant.Foreign

10import Servant.JS.Internal

11import Servant.JS.Internal

@@ -68,7 +69,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>

68 <> " { url: " <> url <> "\n"

69 <> " { url: " <> url <> "\n"

69 <> dataBody

70 <> dataBody

70 <> reqheaders

71 <> reqheaders

71− <> " , method: '" <> method <> "'\n"

72+ <> " , method: '" <> decodeUtf8 method <> "'\n"

72 <> " });\n"

73 <> " });\n"

73 <> "}\n"

74 <> "}\n"

servant-js/src/Servant/JS/Axios.hs+2−1

@@ -5,6 +5,7 @@ import Control.Lens

5import Data.Maybe (isJust)

6import Data.Monoid

7import Data.Text (Text)

8+import Data.Text.Encoding (decodeUtf8)

8import qualified Data.Text as T

9import qualified Data.Text as T

9import Servant.Foreign

10import Servant.Foreign

10import Servant.JS.Internal

11import Servant.JS.Internal

@@ -117,7 +118,7 @@ generateAxiosJSWith aopts opts req = "\n" <>

117

118

118 fname = namespace <> (functionNameBuilder opts $ req ^. funcName)

119 fname = namespace <> (functionNameBuilder opts $ req ^. funcName)

119

120

120− method = T.toLower $ req ^. reqMethod

121+ method = T.toLower . decodeUtf8 $ req ^. reqMethod

121 url = if url' == "'" then "'/'" else url'

122 url = if url' == "'" then "'/'" else url'

122 url' = "'"

123 url' = "'"

123 <> urlPrefix opts

124 <> urlPrefix opts

servant-js/src/Servant/JS/JQuery.hs+2−1

@@ -6,6 +6,7 @@ import Data.Maybe (isJust)

6import Data.Monoid

7import qualified Data.Text as T

8import Data.Text (Text)

9+import Data.Text.Encoding (decodeUtf8)

9import Servant.Foreign

10import Servant.Foreign

10import Servant.JS.Internal

11import Servant.JS.Internal

@@ -35,7 +36,7 @@ generateJQueryJSWith opts req = "\n" <>

35 <> dataBody

36 <> dataBody

36 <> reqheaders

37 <> reqheaders

37 <> " , error: " <> onError <> "\n"

38 <> " , error: " <> onError <> "\n"

38− <> " , type: '" <> method <> "'\n"

39+ <> " , type: '" <> decodeUtf8 method <> "'\n"

39 <> " });\n"

40 <> " });\n"

40 <> "}\n"

41 <> "}\n"

servant-js/src/Servant/JS/Vanilla.hs+2−1

@@ -4,6 +4,7 @@ module Servant.JS.Vanilla where

4import Control.Lens

5import Data.Maybe (isJust)

6import Data.Text (Text)

7+import Data.Text.Encoding (decodeUtf8)

7import qualified Data.Text as T

8import qualified Data.Text as T

8import Data.Monoid

9import Data.Monoid

9import Servant.Foreign

10import Servant.Foreign

@@ -31,7 +32,7 @@ generateVanillaJSWith opts req = "\n" <>

31 fname <> " = function(" <> argsStr <> ")\n"

32 fname <> " = function(" <> argsStr <> ")\n"

32 <> "{\n"

33 <> "{\n"

33 <> " var xhr = new XMLHttpRequest();\n"

34 <> " var xhr = new XMLHttpRequest();\n"

34− <> " xhr.open('" <> method <> "', " <> url <> ", true);\n"

35+ <> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n"

35 <> reqheaders

36 <> reqheaders

36 <> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n"

37 <> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n"

37 <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "")

38 <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "")

servant-mock/src/Servant/Mock.hs+2−13

@@ -139,19 +139,8 @@ instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where

139instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where

140 mock _ = \_ -> mock (Proxy :: Proxy rest)

141

142−instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where

142+instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)

143− mock _ = mockArbitrary

143+ => HasMock (Verb method status ctypes a) where

144−

145−instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where

146− mock _ = mockArbitrary

147−

148−instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where

149− mock _ = mockArbitrary

150−

151−instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where

152− mock _ = mockArbitrary

153−

154−instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where

155 mock _ = mockArbitrary

144 mock _ = mockArbitrary

156

145

157instance HasMock Raw where

146instance HasMock Raw where

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

@@ -21,26 +21,33 @@ module Servant.Server.Internal

21#if !MIN_VERSION_base(4,8,0)

22import Control.Applicative ((<$>))

23#endif

24−import Control.Monad.Trans.Except (ExceptT)

24+import Control.Monad.Trans.Except (ExceptT)

25−import qualified Data.ByteString as B

25+import qualified Data.ByteString as B

26−import qualified Data.ByteString.Lazy as BL

26+import qualified Data.ByteString.Lazy as BL

27−import qualified Data.Map as M

27+import qualified Data.Map as M

28−import Data.Maybe (fromMaybe, mapMaybe)

28+import Data.Maybe (fromMaybe, mapMaybe)

29−import Data.String (fromString)

29+import Data.String (fromString)

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

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

31−import Data.Text (Text)

31+import Data.Text (Text)

32import Data.Typeable

33−import GHC.TypeLits (KnownSymbol, symbolVal)

33+import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

34+ symbolVal)

34−import Network.HTTP.Types hiding (Header, ResponseHeaders)

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

35−import Network.Socket (SockAddr)

36+import Network.Socket (SockAddr)

36−import Network.Wai (Application, lazyRequestBody,

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

38+ httpVersion, isSecure,

39+ lazyRequestBody, pathInfo,

37− rawQueryString, requestHeaders,

40+ rawQueryString, remoteHost,

41+ requestHeaders, requestMethod,

38− requestMethod, responseLBS, remoteHost,

42+ responseLBS, vault)

39− isSecure, vault, httpVersion, Response,

43+import Web.HttpApiData (FromHttpApiData)

40− Request, pathInfo)

44+import Web.HttpApiData.Internal (parseHeaderMaybe,

45+ parseQueryParamMaybe,

46+ parseUrlPieceMaybe)

47+

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

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

42− Delete, Get, Header,

49+ Verb, ReflectMethod(reflectMethod),

43− IsSecure(..), Patch, Post, Put,

50+ IsSecure(..), Header,

44 QueryFlag, QueryParam, QueryParams,

51 QueryFlag, QueryParam, QueryParams,

45 Raw, RemoteHost, ReqBody, Vault)

52 Raw, RemoteHost, ReqBody, Vault)

46import Servant.API.ContentTypes (AcceptHeader (..),

53import Servant.API.ContentTypes (AcceptHeader (..),

@@ -55,8 +62,6 @@ import Servant.Server.Internal.Router

55import Servant.Server.Internal.RoutingApplication

62import Servant.Server.Internal.RoutingApplication

56import Servant.Server.Internal.ServantErr

63import Servant.Server.Internal.ServantErr

58−import Web.HttpApiData (FromHttpApiData)

59−import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)

61class HasServer layout where

66class HasServer layout where

62 type ServerT layout (m :: * -> *) :: *

67 type ServerT layout (m :: * -> *) :: *

@@ -129,8 +134,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request

129allowedMethod :: Method -> Request -> Bool

134allowedMethod :: Method -> Request -> Bool

130allowedMethod method request = allowedMethodHead method request || requestMethod request == method

135allowedMethod method request = allowedMethodHead method request || requestMethod request == method

131

136

132−processMethodRouter :: forall a. ConvertibleStrings a B.ByteString

133− => Maybe (a, BL.ByteString) -> Status -> Method

137+processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method

134 -> Maybe [(HeaderName, B.ByteString)]

138 -> Maybe [(HeaderName, B.ByteString)]

135 -> Request -> RouteResult Response

139 -> Request -> RouteResult Response

136processMethodRouter handleA status method headers request = case handleA of

140processMethodRouter handleA status method headers request = case handleA of

@@ -160,7 +164,7 @@ methodRouter method proxy status action = LeafRouter route'

160 | pathIsEmpty request =

164 | pathIsEmpty request =

161 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

165 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

162 in runAction (action `addMethodCheck` methodCheck method request

166 in runAction (action `addMethodCheck` methodCheck method request

163− `addAcceptCheck` acceptCheck proxy accH

167+ `addAcceptCheck` acceptCheck proxy accH

164 ) respond $ \ output -> do

168 ) respond $ \ output -> do

165 let handleA = handleAcceptH proxy (AcceptHeader accH) output

169 let handleA = handleAcceptH proxy (AcceptHeader accH) output

166 processMethodRouter handleA status method Nothing request

170 processMethodRouter handleA status method Nothing request

@@ -176,95 +180,33 @@ methodRouterHeaders method proxy status action = LeafRouter route'

176 | pathIsEmpty request =

180 | pathIsEmpty request =

177 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

181 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

178 in runAction (action `addMethodCheck` methodCheck method request

182 in runAction (action `addMethodCheck` methodCheck method request

179− `addAcceptCheck` acceptCheck proxy accH

183+ `addAcceptCheck` acceptCheck proxy accH

180 ) respond $ \ output -> do

184 ) respond $ \ output -> do

181 let headers = getHeaders output

185 let headers = getHeaders output

182 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

186 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

183 processMethodRouter handleA status method (Just headers) request

187 processMethodRouter handleA status method (Just headers) request

184 | otherwise = respond $ Fail err404

188 | otherwise = respond $ Fail err404

185

189

186−methodRouterEmpty :: Method

187− -> Delayed (ExceptT ServantErr IO ())

188− -> Router

189−methodRouterEmpty method action = LeafRouter route'

190− where

191− route' request respond

192− | pathIsEmpty request = do

193− runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->

194− Route $! responseLBS noContent204 [] ""

195− | otherwise = respond $ Fail err404

196−

197−-- | If you have a 'Delete' endpoint in your API,

198−-- the handler for this endpoint is meant to delete

199−-- a resource.

200−--

201−-- The code of the handler will, just like

202−-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and

203−-- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@.

204−-- The 'Int' represents the status code and the 'String' a message

205−-- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to

206−-- painlessly error out if the conditions for a successful deletion

207−-- are not met.

208instance OVERLAPPABLE_

190instance OVERLAPPABLE_

209− ( AllCTRender ctypes a

191+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

210− ) => HasServer (Delete ctypes a) where

192+ ) => HasServer (Verb method status ctypes a) where

211−

212− type ServerT (Delete ctypes a) m = m a

213−

214− route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200

215

193

216−instance OVERLAPPING_

217− HasServer (Delete ctypes ()) where

218−

219− type ServerT (Delete ctypes ()) m = m ()

194+ type ServerT (Verb method status ctypes a) m = m a

220

195

221− route Proxy = methodRouterEmpty methodDelete

196+ route Proxy = methodRouter method (Proxy :: Proxy ctypes) status

197+ where method = reflectMethod (Proxy :: Proxy method)

198+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

222

199

223−-- Add response headers

224instance OVERLAPPING_

200instance OVERLAPPING_

225− ( GetHeaders (Headers h v), AllCTRender ctypes v

201+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

202+ , GetHeaders (Headers h a)

226− ) => HasServer (Delete ctypes (Headers h v)) where

203+ ) => HasServer (Verb method status ctypes (Headers h a)) where

227−

228− type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

229−

230− route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200

231

204

232−-- | When implementing the handler for a 'Get' endpoint,

205+ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)

233−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

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

235−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents

236−-- the status code and the 'String' a message, returned in case of

237−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'

238−-- to quickly fail if some conditions are not met.

239−--

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

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

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

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

244−-- list.

245−instance OVERLAPPABLE_

246− ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where

247

206

248− type ServerT (Get ctypes a) m = m a

249−

250− route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200

251−

252−-- '()' ==> 204 No Content

253−instance OVERLAPPING_

254− HasServer (Get ctypes ()) where

255−

256− type ServerT (Get ctypes ()) m = m ()

257−

258− route Proxy = methodRouterEmpty methodGet

259−

260−-- Add response headers

261−instance OVERLAPPING_

262− ( GetHeaders (Headers h v), AllCTRender ctypes v

263− ) => HasServer (Get ctypes (Headers h v)) where

264−

265− type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

266−

267− route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200

207+ route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status

208+ where method = reflectMethod (Proxy :: Proxy method)

209+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

268

210

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

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

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

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

@@ -297,113 +239,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

297 in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)

239 in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)

298 where str = fromString $ symbolVal (Proxy :: Proxy sym)

240 where str = fromString $ symbolVal (Proxy :: Proxy sym)

299

241

300−-- | When implementing the handler for a 'Post' endpoint,

301−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

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

303−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents

304−-- the status code and the 'String' a message, returned in case of

305−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'

306−-- to quickly fail if some conditions are not met.

307−--

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

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

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

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

312−-- list.

313−instance OVERLAPPABLE_

314− ( AllCTRender ctypes a

315− ) => HasServer (Post ctypes a) where

316−

317− type ServerT (Post ctypes a) m = m a

318−

319− route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201

320−

321−instance OVERLAPPING_

322− HasServer (Post ctypes ()) where

323−

324− type ServerT (Post ctypes ()) m = m ()

325−

326− route Proxy = methodRouterEmpty methodPost

327−

328−-- Add response headers

329−instance OVERLAPPING_

330− ( GetHeaders (Headers h v), AllCTRender ctypes v

331− ) => HasServer (Post ctypes (Headers h v)) where

332−

333− type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

334−

335− route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201

336−

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

338−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

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

340−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents

341−-- the status code and the 'String' a message, returned in case of

342−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'

343−-- to quickly fail if some conditions are not met.

344−--

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

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

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

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

349−-- list.

350−instance OVERLAPPABLE_

351− ( AllCTRender ctypes a) => HasServer (Put ctypes a) where

352−

353− type ServerT (Put ctypes a) m = m a

354−

355− route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200

356−

357−instance OVERLAPPING_

358− HasServer (Put ctypes ()) where

359−

360− type ServerT (Put ctypes ()) m = m ()

361−

362− route Proxy = methodRouterEmpty methodPut

363−

364−-- Add response headers

365−instance OVERLAPPING_

366− ( GetHeaders (Headers h v), AllCTRender ctypes v

367− ) => HasServer (Put ctypes (Headers h v)) where

368−

369− type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

370−

371− route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200

372−

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

374−-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

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

376−-- @ExceptT ServantErr IO@ monad, where the 'Int' represents

377−-- the status code and the 'String' a message, returned in case of

378−-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'

379−-- to quickly fail if some conditions are not met.

380−--

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

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

383−-- yielding status code 200 along the way.

384−instance OVERLAPPABLE_

385− ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where

386−

387− type ServerT (Patch ctypes a) m = m a

388−

389− route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200

390−

391−instance OVERLAPPING_

392− HasServer (Patch ctypes ()) where

393−

394− type ServerT (Patch ctypes ()) m = m ()

395−

396− route Proxy = methodRouterEmpty methodPatch

397−

398−-- Add response headers

399−instance OVERLAPPING_

400− ( GetHeaders (Headers h v), AllCTRender ctypes v

401− ) => HasServer (Patch ctypes (Headers h v)) where

402−

403− type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

404−

405− route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200

406−

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

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

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

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

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

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

servant-server/test/Servant/Server/ErrorSpec.hs+1−1

@@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search"

162

163 it "should continue when URLs don't match" $ do

164 request methodPost "" [jsonCT, jsonAccept] jsonBody

165− `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }

165+ `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }

166

167 it "should continue when methods don't match" $ do

168 request methodGet "a" [jsonCT, jsonAccept] jsonBody

servant-server/test/Servant/Server/Internal/EnterSpec.hs+1−1

@@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do

53 it "allows running arbitrary monads" $ do

54 get "int" `shouldRespondWith` "1797"

55− post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }

55+ post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }

57 with (return (serve combinedAPI combinedReaderServer)) $ do

58 it "allows combnation of enters" $ do

servant-server/test/Servant/ServerSpec.hs+226−252

@@ -3,8 +3,10 @@

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeSynonymInstances #-}

10{-# LANGUAGE TypeSynonymInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

11{-# LANGUAGE FlexibleInstances #-}

@@ -13,7 +15,7 @@ module Servant.ServerSpec where

13#if !MIN_VERSION_base(4,8,0)

15#if !MIN_VERSION_base(4,8,0)

14import Control.Applicative ((<$>))

16import Control.Applicative ((<$>))

15#endif

17#endif

16−import Control.Monad (forM_, when)

18+import Control.Monad (forM_, when, unless)

17import Control.Monad.Trans.Except (ExceptT, throwE)

19import Control.Monad.Trans.Except (ExceptT, throwE)

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

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

19import Data.ByteString.Conversion ()

21import Data.ByteString.Conversion ()

@@ -23,82 +25,144 @@ import Data.String (fromString)

23import Data.String.Conversions (cs)

25import Data.String.Conversions (cs)

24import qualified Data.Text as T

26import qualified Data.Text as T

25import GHC.Generics (Generic)

27import GHC.Generics (Generic)

26−import Network.HTTP.Types (hAccept, hContentType,

28+import Network.HTTP.Types (Status (..), hAccept, hContentType,

27− methodDelete, methodGet, methodHead,

29+ methodDelete, methodGet,

30+ methodHead, methodPatch,

28− methodPatch, methodPost, methodPut,

31+ methodPost, methodPut, ok200,

29− ok200, parseQuery, Status(..))

32+ parseQuery)

30import Network.Wai (Application, Request, pathInfo,

33import Network.Wai (Application, Request, pathInfo,

31 queryString, rawQueryString,

34 queryString, rawQueryString,

32− responseLBS, responseBuilder)

35+ responseBuilder, responseLBS)

33−import Network.Wai.Internal (Response(ResponseBuilder))

36+import Network.Wai.Internal (Response (ResponseBuilder))

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

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

35− runSession, simpleBody)

38+ runSession, simpleBody,

39+ simpleHeaders, simpleStatus)

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

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

37− Get, Header (..), Headers,

41+ Get, Header (..),

42+ Headers, HttpVersion,

38− HttpVersion, IsSecure (..), JSON,

43+ IsSecure (..), JSON,

39− Patch, PlainText, Post, Put,

44+ NoContent (..), Patch, PlainText,

45+ Post, Put,

40 QueryFlag, QueryParam, QueryParams,

46 QueryFlag, QueryParam, QueryParams,

41 Raw, RemoteHost, ReqBody,

47 Raw, RemoteHost, ReqBody,

42− addHeader)

48+ StdMethod (..), Verb, addHeader)

43−import Servant.Server (Server, serve, ServantErr(..), err404)

49+import Servant.Server (ServantErr (..), Server, err404,

50+ serve)

44−import Test.Hspec (Spec, describe, it, shouldBe)

51+import Test.Hspec (Spec, context, describe, it,

52+ shouldBe, shouldContain)

45import Test.Hspec.Wai (get, liftIO, matchHeaders,

53import Test.Hspec.Wai (get, liftIO, matchHeaders,

46− matchStatus, post, request,

54+ matchStatus, request,

47 shouldRespondWith, with, (<:>))

55 shouldRespondWith, with, (<:>))

56+

48−import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))

57+import Servant.Server.Internal.RoutingApplication

58+ (toApplication, RouteResult(..))

49import Servant.Server.Internal.Router

59import Servant.Server.Internal.Router

50 (tweakResponse, runRouter,

60 (tweakResponse, runRouter,

51 Router, Router'(LeafRouter))

61 Router, Router'(LeafRouter))

54−-- * test data types

64+-- * Specs

55−

56−data Person = Person {

57− name :: String,

58− age :: Integer

59− }

60− deriving (Eq, Show, Generic)

61−

62−instance ToJSON Person

63−instance FromJSON Person

64−

65−alice :: Person

66−alice = Person "Alice" 42

67−

68−data Animal = Animal {

69− species :: String,

70− numberOfLegs :: Integer

71− }

72− deriving (Eq, Show, Generic)

73−

74−instance ToJSON Animal

75−instance FromJSON Animal

76−

77−jerry :: Animal

78−jerry = Animal "Mouse" 4

79−

80−tweety :: Animal

81−tweety = Animal "Bird" 2

82−

83−

84−-- * specs

86spec :: Spec

66spec :: Spec

87spec = do

67spec = do

68+ verbSpec

88 captureSpec

69 captureSpec

89− getSpec

90− headSpec

91− postSpec

92− putSpec

93− patchSpec

94 queryParamSpec

70 queryParamSpec

71+ reqBodySpec

95 headerSpec

72 headerSpec

96 rawSpec

73 rawSpec

97− unionSpec

74+ alternativeSpec

98− routerSpec

99 responseHeadersSpec

75 responseHeadersSpec

100− miscReqCombinatorsSpec

76+ routerSpec

101−

77+ miscCombinatorSpec

78+

79+------------------------------------------------------------------------------

80+-- * verbSpec {{{

81+------------------------------------------------------------------------------

82+

83+type VerbApi method status

84+ = Verb method status '[JSON] Person

85+ :<|> "noContent" :> Verb method status '[JSON] NoContent

86+ :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)

87+ :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)

88+

89+verbSpec :: Spec

90+verbSpec = describe "Servant.API.Verb" $ do

91+ let server :: Server (VerbApi method status)

92+ server = return alice

93+ :<|> return NoContent

94+ :<|> return (addHeader 5 alice)

95+ :<|> return (addHeader 10 NoContent)

96+ get200 = Proxy :: Proxy (VerbApi 'GET 200)

97+ post210 = Proxy :: Proxy (VerbApi 'POST 210)

98+ put203 = Proxy :: Proxy (VerbApi 'PUT 203)

99+ delete280 = Proxy :: Proxy (VerbApi 'DELETE 280)

100+ patch214 = Proxy :: Proxy (VerbApi 'PATCH 214)

101+ wrongMethod m = if m == methodPatch then methodPost else methodPatch

102+ test desc api method (status :: Int) = context desc $

103+

104+ with (return $ serve api server) $ do

105+

106+ -- HEAD and 214/215 need not return bodies

107+ unless (status `elem` [214, 215] || method == methodHead) $

108+ it "returns the person" $ do

109+ response <- Test.Hspec.Wai.request method "/" [] ""

110+ liftIO $ statusCode (simpleStatus response) `shouldBe` status

111+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

112+

113+ it "returns no content on NoContent" $ do

114+ response <- Test.Hspec.Wai.request method "/noContent" [] ""

115+ liftIO $ statusCode (simpleStatus response) `shouldBe` status

116+ liftIO $ simpleBody response `shouldBe` ""

117+

118+ -- HEAD should not return body

119+ when (method == methodHead) $

120+ it "HEAD returns no content body" $ do

121+ response <- Test.Hspec.Wai.request method "/" [] ""

122+ liftIO $ simpleBody response `shouldBe` ""

123+

124+ it "throws 405 on wrong method " $ do

125+ Test.Hspec.Wai.request (wrongMethod method) "/" [] ""

126+ `shouldRespondWith` 405

127+

128+ it "returns headers" $ do

129+ response1 <- Test.Hspec.Wai.request method "/header" [] ""

130+ liftIO $ statusCode (simpleStatus response1) `shouldBe` status

131+ liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]

132+

133+ response2 <- Test.Hspec.Wai.request method "/header" [] ""

134+ liftIO $ statusCode (simpleStatus response2) `shouldBe` status

135+ liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]

136+

137+ it "handles trailing '/' gracefully" $ do

138+ response <- Test.Hspec.Wai.request method "/headerNC/" [] ""

139+ liftIO $ statusCode (simpleStatus response) `shouldBe` status

140+

141+ it "returns 406 if the Accept header is not supported" $ do

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

143+ `shouldRespondWith` 406

144+

145+ it "responds if the Accept header is supported" $ do

146+ response <- Test.Hspec.Wai.request method ""

147+ [(hAccept, "application/json")] ""

148+ liftIO $ statusCode (simpleStatus response) `shouldBe` status

149+

150+ it "sets the Content-Type header" $ do

151+ response <- Test.Hspec.Wai.request method "" [] ""

152+ liftIO $ simpleHeaders response `shouldContain`

153+ [("Content-Type", "application/json")]

154+

155+ test "GET 200" get200 methodGet 200

156+ test "POST 210" post210 methodPost 210

157+ test "PUT 203" put203 methodPut 203

158+ test "DELETE 280" delete280 methodDelete 280

159+ test "PATCH 214" patch214 methodPatch 214

160+ test "GET 200 with HEAD" get200 methodHead 200

161+

162+-- }}}

163+------------------------------------------------------------------------------

164+-- * captureSpec {{{

165+------------------------------------------------------------------------------

102

166

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

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

104captureApi :: Proxy CaptureApi

168captureApi :: Proxy CaptureApi

@@ -128,63 +192,10 @@ captureSpec = do

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

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

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

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

130

194

131−

195+-- }}}

132−type GetApi = Get '[JSON] Person

196+------------------------------------------------------------------------------

133− :<|> "empty" :> Get '[] ()

197+-- * queryParamSpec {{{

134− :<|> "post" :> Post '[] ()

198+------------------------------------------------------------------------------

135−getApi :: Proxy GetApi

136−getApi = Proxy

137−

138−getSpec :: Spec

139−getSpec = do

140− describe "Servant.API.Get" $ do

141− let server = return alice :<|> return () :<|> return ()

142− with (return $ serve getApi server) $ do

143−

144− it "allows to GET a Person" $ do

145− response <- get "/"

146− return response `shouldRespondWith` 200

147− liftIO $ decode' (simpleBody response) `shouldBe` Just alice

148−

149− it "throws 405 (wrong method) on POSTs" $ do

150− post "/" "" `shouldRespondWith` 405

151− post "/empty" "" `shouldRespondWith` 405

152−

153− it "returns 204 if the type is '()'" $ do

154− get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }

155−

156− it "returns 406 if the Accept header is not supported" $ do

157− Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""

158− `shouldRespondWith` 406

159−

160−

161−headSpec :: Spec

162−headSpec = do

163− describe "Servant.API.Head" $ do

164− let server = return alice :<|> return () :<|> return ()

165− with (return $ serve getApi server) $ do

166−

167− it "allows to GET a Person" $ do

168− response <- Test.Hspec.Wai.request methodHead "/" [] ""

169− return response `shouldRespondWith` 200

170− liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)

171−

172− it "does not allow HEAD to POST route" $ do

173− response <- Test.Hspec.Wai.request methodHead "/post" [] ""

174− return response `shouldRespondWith` 405

175−

176− it "throws 405 (wrong method) on POSTs" $ do

177− post "/" "" `shouldRespondWith` 405

178− post "/empty" "" `shouldRespondWith` 405

179−

180− it "returns 204 if the type is '()'" $ do

181− response <- Test.Hspec.Wai.request methodHead "/empty" [] ""

182− return response `shouldRespondWith` ""{ matchStatus = 204 }

183−

184− it "returns 406 if the Accept header is not supported" $ do

185− Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""

186− `shouldRespondWith` 406

187−

188

199

189type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

200type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

190 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person

201 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person

@@ -269,131 +280,41 @@ queryParamSpec = do

269 name = "Alice"

280 name = "Alice"

270 }

281 }

271

282

272−type PostApi =

283+-- }}}

273− ReqBody '[JSON] Person :> Post '[JSON] Integer

284+------------------------------------------------------------------------------

274− :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer

285+-- * reqBodySpec {{{

275− :<|> "empty" :> Post '[] ()

286+------------------------------------------------------------------------------

276−

277−postApi :: Proxy PostApi

278−postApi = Proxy

279−

280−postSpec :: Spec

281−postSpec = do

282− describe "Servant.API.Post and .ReqBody" $ do

283− let server = return . age :<|> return . age :<|> return ()

284− with (return $ serve postApi server) $ do

285− let post' x = Test.Hspec.Wai.request methodPost x [(hContentType

286− , "application/json;charset=utf-8")]

287−

288− it "allows to POST a Person" $ do

289− post' "/" (encode alice) `shouldRespondWith` "42"{

290− matchStatus = 201

291− }

292−

293− it "allows alternative routes if all have request bodies" $ do

294− post' "/bla" (encode alice) `shouldRespondWith` "42"{

295− matchStatus = 201

296− }

297−

298− it "handles trailing '/' gracefully" $ do

299− post' "/bla/" (encode alice) `shouldRespondWith` "42"{

300− matchStatus = 201

301− }

302−

303− it "correctly rejects invalid request bodies with status 400" $ do

304− post' "/" "some invalid body" `shouldRespondWith` 400

305−

306− it "returns 204 if the type is '()'" $ do

307− post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

308−

309− it "responds with 415 if the request body media type is unsupported" $ do

310− let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType

311− , "application/nonsense")]

312− post'' "/" "anything at all" `shouldRespondWith` 415

313−

314−type PutApi =

315− ReqBody '[JSON] Person :> Put '[JSON] Integer

287+type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person

316− :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer

288+ :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer

317− :<|> "empty" :> Put '[] ()

318−

319−putApi :: Proxy PutApi

320−putApi = Proxy

321−

322−putSpec :: Spec

323−putSpec = do

324− describe "Servant.API.Put and .ReqBody" $ do

325− let server = return . age :<|> return . age :<|> return ()

326− with (return $ serve putApi server) $ do

327− let put' x = Test.Hspec.Wai.request methodPut x [(hContentType

328− , "application/json;charset=utf-8")]

329

289

330− it "allows to put a Person" $ do

290+reqBodyApi :: Proxy ReqBodyApi

331− put' "/" (encode alice) `shouldRespondWith` "42"{

291+reqBodyApi = Proxy

332− matchStatus = 200

333− }

334−

335− it "allows alternative routes if all have request bodies" $ do

336− put' "/bla" (encode alice) `shouldRespondWith` "42"{

337− matchStatus = 200

338− }

339

292

340− it "handles trailing '/' gracefully" $ do

293+reqBodySpec :: Spec

341− put' "/bla/" (encode alice) `shouldRespondWith` "42"{

294+reqBodySpec = describe "Servant.API.ReqBody" $ do

342− matchStatus = 200

343− }

344

295

345− it "correctly rejects invalid request bodies with status 400" $ do

296+ let server :: Server ReqBodyApi

346− put' "/" "some invalid body" `shouldRespondWith` 400

297+ server = return :<|> return . age

298+ mkReq method x = Test.Hspec.Wai.request method x

299+ [(hContentType, "application/json;charset=utf-8")]

347

300

348− it "returns 204 if the type is '()'" $ do

301+ with (return $ serve reqBodyApi server) $ do

349− put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

350

302

351− it "responds with 415 if the request body media type is unsupported" $ do

303+ it "passes the argument to the handler" $ do

352− let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType

304+ response <- mkReq methodPost "" (encode alice)

353− , "application/nonsense")]

305+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

354− put'' "/" "anything at all" `shouldRespondWith` 415

355

306

356−type PatchApi =

307+ it "rejects invalid request bodies with status 400" $ do

357− ReqBody '[JSON] Person :> Patch '[JSON] Integer

308+ mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400

358− :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer

359− :<|> "empty" :> Patch '[] ()

360

309

361−patchApi :: Proxy PatchApi

310+ it "responds with 415 if the request body media type is unsupported" $ do

362−patchApi = Proxy

311+ Test.Hspec.Wai.request methodPost "/"

312+ [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415

363

313

364−patchSpec :: Spec

314+-- }}}

365−patchSpec = do

315+------------------------------------------------------------------------------

366− describe "Servant.API.Patch and .ReqBody" $ do

316+-- * headerSpec {{{

367− let server = return . age :<|> return . age :<|> return ()

317+------------------------------------------------------------------------------

368− with (return $ serve patchApi server) $ do

369− let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType

370− , "application/json;charset=utf-8")]

371−

372− it "allows to patch a Person" $ do

373− patch' "/" (encode alice) `shouldRespondWith` "42"{

374− matchStatus = 200

375− }

376−

377− it "allows alternative routes if all have request bodies" $ do

378− patch' "/bla" (encode alice) `shouldRespondWith` "42"{

379− matchStatus = 200

380− }

381−

382− it "handles trailing '/' gracefully" $ do

383− patch' "/bla/" (encode alice) `shouldRespondWith` "42"{

384− matchStatus = 200

385− }

386−

387− it "correctly rejects invalid request bodies with status 400" $ do

388− patch' "/" "some invalid body" `shouldRespondWith` 400

389−

390− it "returns 204 if the type is '()'" $ do

391− patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

392−

393− it "responds with 415 if the request body media type is unsupported" $ do

394− let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType

395− , "application/nonsense")]

396− patch'' "/" "anything at all" `shouldRespondWith` 415

397

318

398type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()

319type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()

399headerApi :: Proxy (HeaderApi a)

320headerApi :: Proxy (HeaderApi a)

@@ -411,23 +332,30 @@ headerSpec = describe "Servant.API.Header" $ do

411 expectsString Nothing = error "Expected a string"

332 expectsString Nothing = error "Expected a string"

412

333

413 with (return (serve headerApi expectsInt)) $ do

334 with (return (serve headerApi expectsInt)) $ do

414− let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]

335+ let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]

415

336

416 it "passes the header to the handler (Int)" $

337 it "passes the header to the handler (Int)" $

417− delete' "/" "" `shouldRespondWith` 204

338+ delete' "/" "" `shouldRespondWith` 200

418

339

419 with (return (serve headerApi expectsString)) $ do

340 with (return (serve headerApi expectsString)) $ do

420− let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]

341+ let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]

421

342

422 it "passes the header to the handler (String)" $

343 it "passes the header to the handler (String)" $

423− delete' "/" "" `shouldRespondWith` 204

344+ delete' "/" "" `shouldRespondWith` 200

424

345

346+-- }}}

347+------------------------------------------------------------------------------

348+-- * rawSpec {{{

349+------------------------------------------------------------------------------

425

350

426type RawApi = "foo" :> Raw

351type RawApi = "foo" :> Raw

352+

427rawApi :: Proxy RawApi

353rawApi :: Proxy RawApi

428rawApi = Proxy

354rawApi = Proxy

355+

429rawApplication :: Show a => (Request -> a) -> Application

356rawApplication :: Show a => (Request -> a) -> Application

430−rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)

357+rawApplication f request_ respond = respond $ responseLBS ok200 []

358+ (cs $ show $ f request_)

431

359

432rawSpec :: Spec

360rawSpec :: Spec

433rawSpec = do

361rawSpec = do

@@ -448,7 +376,10 @@ rawSpec = do

448 liftIO $ do

376 liftIO $ do

449 simpleBody response `shouldBe` cs (show ["bar" :: String])

377 simpleBody response `shouldBe` cs (show ["bar" :: String])

450

378

451−

379+-- }}}

380+------------------------------------------------------------------------------

381+-- * alternativeSpec {{{

382+------------------------------------------------------------------------------

452type AlternativeApi =

383type AlternativeApi =

453 "foo" :> Get '[JSON] Person

384 "foo" :> Get '[JSON] Person

454 :<|> "bar" :> Get '[JSON] Animal

385 :<|> "bar" :> Get '[JSON] Animal

@@ -456,11 +387,12 @@ type AlternativeApi =

456 :<|> "bar" :> Post '[JSON] Animal

387 :<|> "bar" :> Post '[JSON] Animal

457 :<|> "bar" :> Put '[JSON] Animal

388 :<|> "bar" :> Put '[JSON] Animal

458 :<|> "bar" :> Delete '[JSON] ()

389 :<|> "bar" :> Delete '[JSON] ()

459−unionApi :: Proxy AlternativeApi

460−unionApi = Proxy

461

390

391+alternativeApi :: Proxy AlternativeApi

392+alternativeApi = Proxy

393+

462−unionServer :: Server AlternativeApi

394+alternativeServer :: Server AlternativeApi

463−unionServer =

395+alternativeServer =

464 return alice

396 return alice

465 :<|> return jerry

397 :<|> return jerry

466 :<|> return "a string"

398 :<|> return "a string"

@@ -468,10 +400,10 @@ unionServer =

468 :<|> return jerry

400 :<|> return jerry

469 :<|> return ()

401 :<|> return ()

470

402

471−unionSpec :: Spec

403+alternativeSpec :: Spec

472−unionSpec = do

404+alternativeSpec = do

473 describe "Servant.API.Alternative" $ do

405 describe "Servant.API.Alternative" $ do

474− with (return $ serve unionApi unionServer) $ do

406+ with (return $ serve alternativeApi alternativeServer) $ do

475

407

476 it "unions endpoints" $ do

408 it "unions endpoints" $ do

477 response <- get "/foo"

409 response <- get "/foo"

@@ -488,7 +420,10 @@ unionSpec = do

488

420

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

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

490 get "/nonexistent" `shouldRespondWith` 404

422 get "/nonexistent" `shouldRespondWith` 404

491−

423+-- }}}

424+------------------------------------------------------------------------------

425+-- * responseHeaderSpec {{{

426+------------------------------------------------------------------------------

492type ResponseHeadersApi =

427type ResponseHeadersApi =

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

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

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

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

@@ -505,26 +440,29 @@ responseHeadersSpec :: Spec

505responseHeadersSpec = describe "ResponseHeaders" $ do

440responseHeadersSpec = describe "ResponseHeaders" $ do

506 with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do

441 with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do

507

442

508− let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]

443+ let methods = [methodGet, methodPost, methodPut, methodPatch]

509

444

510 it "includes the headers in the response" $

445 it "includes the headers in the response" $

511− forM_ methods $ \(method, expected) ->

446+ forM_ methods $ \method ->

512 Test.Hspec.Wai.request method "/" [] ""

447 Test.Hspec.Wai.request method "/" [] ""

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

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

514− , matchStatus = expected

449+ , matchStatus = 200

515 }

450 }

516

451

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

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

518− forM_ methods $ \(method,_) ->

453+ forM_ methods $ \method ->

519 Test.Hspec.Wai.request method "blahblah" [] ""

454 Test.Hspec.Wai.request method "blahblah" [] ""

520 `shouldRespondWith` 404

455 `shouldRespondWith` 404

521

456

522 it "returns 406 if the Accept header is not supported" $

457 it "returns 406 if the Accept header is not supported" $

523− forM_ methods $ \(method,_) ->

458+ forM_ methods $ \method ->

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

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

525 `shouldRespondWith` 406

460 `shouldRespondWith` 406

526

461

527−

462+-- }}}

463+------------------------------------------------------------------------------

464+-- * routerSpec {{{

465+------------------------------------------------------------------------------

528routerSpec :: Spec

466routerSpec :: Spec

529routerSpec = do

467routerSpec = do

530 describe "Servant.Server.Internal.Router" $ do

468 describe "Servant.Server.Internal.Router" $ do

@@ -543,6 +481,10 @@ routerSpec = do

543 it "calls f on route result" $ do

481 it "calls f on route result" $ do

544 get "" `shouldRespondWith` 202

482 get "" `shouldRespondWith` 202

545

483

484+-- }}}

485+------------------------------------------------------------------------------

486+-- * miscCombinatorSpec {{{

487+------------------------------------------------------------------------------

546type MiscCombinatorsAPI

488type MiscCombinatorsAPI

547 = "version" :> HttpVersion :> Get '[JSON] String

489 = "version" :> HttpVersion :> Get '[JSON] String

548 :<|> "secure" :> IsSecure :> Get '[JSON] String

490 :<|> "secure" :> IsSecure :> Get '[JSON] String

@@ -561,8 +503,8 @@ miscServ = versionHandler

561 secureHandler NotSecure = return "not secure"

503 secureHandler NotSecure = return "not secure"

562 hostHandler = return . show

504 hostHandler = return . show

563

505

564−miscReqCombinatorsSpec :: Spec

506+miscCombinatorSpec :: Spec

565−miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $

507+miscCombinatorSpec = with (return $ serve miscApi miscServ) $

566 describe "Misc. combinators for request inspection" $ do

508 describe "Misc. combinators for request inspection" $ do

567 it "Successfully gets the HTTP version specified in the request" $

509 it "Successfully gets the HTTP version specified in the request" $

568 go "/version" "\"HTTP/1.0\""

510 go "/version" "\"HTTP/1.0\""

@@ -574,3 +516,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $

574 go "/host" "\"0.0.0.0:0\""

516 go "/host" "\"0.0.0.0:0\""

575

517

576 where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res

518 where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res

519+-- }}}

520+------------------------------------------------------------------------------

521+-- * Test data types {{{

522+------------------------------------------------------------------------------

523+

524+data Person = Person {

525+ name :: String,

526+ age :: Integer

527+ }

528+ deriving (Eq, Show, Generic)

529+

530+instance ToJSON Person

531+instance FromJSON Person

532+

533+alice :: Person

534+alice = Person "Alice" 42

535+

536+data Animal = Animal {

537+ species :: String,

538+ numberOfLegs :: Integer

539+ }

540+ deriving (Eq, Show, Generic)

541+

542+instance ToJSON Animal

543+instance FromJSON Animal

544+

545+jerry :: Animal

546+jerry = Animal "Mouse" 4

547+

548+tweety :: Animal

549+tweety = Animal "Bird" 2

550+-- }}}

servant-server/test/Servant/Utils/StaticFilesSpec.hs+1−6

@@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)

15import Test.Hspec (Spec, around_, describe, it)

16import Test.Hspec.Wai (get, shouldRespondWith, with)

18−import Servant.API (JSON)

18+import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)

19−import Servant.API.Alternative ((:<|>) ((:<|>)))

20−import Servant.API.Capture (Capture)

21−import Servant.API.Get (Get)

22−import Servant.API.Raw (Raw)

23−import Servant.API.Sub ((:>))

24import Servant.Server (Server, serve)

19import Servant.Server (Server, serve)

25import Servant.ServerSpec (Person (Person))

20import Servant.ServerSpec (Person (Person))

26import Servant.Utils.StaticFiles (serveDirectory)

21import Servant.Utils.StaticFiles (serveDirectory)

servant/CHANGELOG.md+2

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

7* Use `http-api-data` instead of `Servant.Common.Text`

8* Remove matrix params.

9* Add PlainText String MimeRender and MimeUnrender instances.

10+* Add new `Verbs` combinator, and make all existing and new verb combinators

11+type synonyms of it.

110.4.2

130.4.2

12-----

14-----

servant/servant.cabal+1−5

@@ -29,14 +29,9 @@ library

29 Servant.API.Alternative

30 Servant.API.Capture

31 Servant.API.ContentTypes

32− Servant.API.Delete

33− Servant.API.Get

34 Servant.API.Header

32 Servant.API.Header

35 Servant.API.HttpVersion

33 Servant.API.HttpVersion

36 Servant.API.IsSecure

34 Servant.API.IsSecure

37− Servant.API.Patch

38− Servant.API.Post

39− Servant.API.Put

40 Servant.API.QueryParam

35 Servant.API.QueryParam

41 Servant.API.Raw

36 Servant.API.Raw

42 Servant.API.RemoteHost

37 Servant.API.RemoteHost

@@ -44,6 +39,7 @@ library

44 Servant.API.ResponseHeaders

39 Servant.API.ResponseHeaders

45 Servant.API.Sub

40 Servant.API.Sub

46 Servant.API.Vault

41 Servant.API.Vault

42+ Servant.API.Verbs

47 Servant.Utils.Links

43 Servant.Utils.Links

48 build-depends:

44 build-depends:

49 base >=4.7 && <5

45 base >=4.7 && <5

servant/src/Servant/API.hs+22−18

@@ -25,16 +25,7 @@ module Servant.API (

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

27 -- * Actual endpoints, distinguished by HTTP method

28− module Servant.API.Get,

28+ module Servant.API.Verbs,

29− -- | @GET@ requests

30− module Servant.API.Post,

31− -- | @POST@ requests

32− module Servant.API.Delete,

33− -- | @DELETE@ requests

34− module Servant.API.Put,

35− -- | @PUT@ requests

36− module Servant.API.Patch,

37− -- | @PATCH@ requests

39 -- * Content Types

30 -- * Content Types

40 module Servant.API.ContentTypes,

31 module Servant.API.ContentTypes,

@@ -61,17 +52,12 @@ import Servant.API.Alternative ((:<|>) (..))

61import Servant.API.Capture (Capture)

52import Servant.API.Capture (Capture)

62import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

53import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

63 FromFormUrlEncoded (..), JSON,

54 FromFormUrlEncoded (..), JSON,

64− MimeRender (..),

55+ MimeRender (..), NoContent (NoContent),

65 MimeUnrender (..), OctetStream,

56 MimeUnrender (..), OctetStream,

66 PlainText, ToFormUrlEncoded (..))

57 PlainText, ToFormUrlEncoded (..))

67−import Servant.API.Delete (Delete)

68−import Servant.API.Get (Get)

69import Servant.API.Header (Header (..))

58import Servant.API.Header (Header (..))

70import Servant.API.HttpVersion (HttpVersion (..))

59import Servant.API.HttpVersion (HttpVersion (..))

71import Servant.API.IsSecure (IsSecure (..))

60import Servant.API.IsSecure (IsSecure (..))

72−import Servant.API.Patch (Patch)

73−import Servant.API.Post (Post)

74−import Servant.API.Put (Put)

75import Servant.API.QueryParam (QueryFlag, QueryParam,

61import Servant.API.QueryParam (QueryFlag, QueryParam,

76 QueryParams)

62 QueryParams)

77import Servant.API.Raw (Raw)

63import Servant.API.Raw (Raw)

@@ -84,7 +70,25 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),

84 getHeadersHList, getResponse)

70 getHeadersHList, getResponse)

85import Servant.API.Sub ((:>))

71import Servant.API.Sub ((:>))

86import Servant.API.Vault (Vault)

72import Servant.API.Vault (Vault)

87−import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))

73+import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,

74+ DeleteNoContent,

75+ DeleteNonAuthoritative, Get,

76+ GetAccepted, GetNoContent,

77+ GetNonAuthoritative,

78+ GetPartialContent,

79+ GetResetContent,

80+ Patch,

81+ PatchAccepted, PatchNoContent,

82+ PatchNoContent,

83+ PatchNonAuthoritative, Post,

84+ PostAccepted, PostNoContent,

85+ PostNonAuthoritative,

86+ PostResetContent, Put,

87+ PutAccepted, PutNoContent,

88+ PutNoContent, PutNonAuthoritative,

89+ ReflectMethod (reflectMethod),

90+ Verb, StdMethod(..))

88import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

91import Servant.Utils.Links (HasLink (..), IsElem, IsElem',

89 URI (..), safeLink)

92 URI (..), safeLink)

90−

93+import Web.HttpApiData (FromHttpApiData (..),

94+ ToHttpApiData (..))

servant/src/Servant/API/ContentTypes.hs+38−23

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

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DeriveDataTypeable #-}

5+{-# LANGUAGE DeriveGeneric #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE OverloadedStrings #-}

@@ -12,6 +13,8 @@

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13{-# OPTIONS_HADDOCK not-home #-}

14{-# OPTIONS_HADDOCK not-home #-}

16+#include "overlapping-compat.h"

17+

15-- | A collection of basic Content-Types (also known as Internet Media

18-- | A collection of basic Content-Types (also known as Internet Media

16-- Types, or MIME types). Additionally, this module provides classes that

19-- Types, or MIME types). Additionally, this module provides classes that

17-- encapsulate how to serialize or deserialize values to or from

20-- encapsulate how to serialize or deserialize values to or from

@@ -19,7 +22,7 @@

19--

22--

20-- Content-Types are used in `ReqBody` and the method combinators:

23-- Content-Types are used in `ReqBody` and the method combinators:

21--

24--

22−-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book

25+-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book

23--

26--

24-- Meaning the endpoint accepts requests of Content-Type @application/json@

27-- Meaning the endpoint accepts requests of Content-Type @application/json@

25-- or @text/plain;charset-utf8@, and returns data in either one of those

28-- or @text/plain;charset-utf8@, and returns data in either one of those

@@ -53,6 +56,9 @@ module Servant.API.ContentTypes

53 , MimeRender(..)

56 , MimeRender(..)

54 , MimeUnrender(..)

57 , MimeUnrender(..)

59+ -- * NoContent

60+ , NoContent(..)

61+

56 -- * Internal

62 -- * Internal

57 , AcceptHeader(..)

63 , AcceptHeader(..)

58 , AllCTRender(..)

64 , AllCTRender(..)

@@ -62,7 +68,6 @@ module Servant.API.ContentTypes

62 , AllMimeUnrender(..)

68 , AllMimeUnrender(..)

63 , FromFormUrlEncoded(..)

69 , FromFormUrlEncoded(..)

64 , ToFormUrlEncoded(..)

70 , ToFormUrlEncoded(..)

65− , IsNonEmpty

66 , eitherDecodeLenient

71 , eitherDecodeLenient

67 , canHandleAcceptH

72 , canHandleAcceptH

68 ) where

73 ) where

@@ -72,8 +77,7 @@ import Control.Applicative ((*>), (<*))

72#endif

77#endif

73import Control.Arrow (left)

78import Control.Arrow (left)

74import Control.Monad

79import Control.Monad

75−import Data.Aeson (FromJSON, ToJSON, encode,

80+import Data.Aeson (FromJSON(..), ToJSON(..), encode)

76− parseJSON)

77import Data.Aeson.Parser (value)

81import Data.Aeson.Parser (value)

78import Data.Aeson.Types (parseEither)

82import Data.Aeson.Types (parseEither)

79import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,

83import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,

@@ -91,7 +95,7 @@ import qualified Data.Text.Encoding as TextS

91import qualified Data.Text.Lazy as TextL

95import qualified Data.Text.Lazy as TextL

92import qualified Data.Text.Lazy.Encoding as TextL

96import qualified Data.Text.Lazy.Encoding as TextL

93import Data.Typeable

97import Data.Typeable

94−import GHC.Exts (Constraint)

98+import GHC.Generics (Generic)

95import qualified Network.HTTP.Media as M

99import qualified Network.HTTP.Media as M

96import Network.URI (escapeURIString,

100import Network.URI (escapeURIString,

97 isUnreserved, unEscapeString)

101 isUnreserved, unEscapeString)

@@ -137,7 +141,7 @@ instance Accept OctetStream where

137 contentType _ = "application" M.// "octet-stream"

141 contentType _ = "application" M.// "octet-stream"

138

142

139newtype AcceptHeader = AcceptHeader BS.ByteString

143newtype AcceptHeader = AcceptHeader BS.ByteString

140− deriving (Eq, Show)

144+ deriving (Eq, Show, Read, Typeable, Generic)

141

145

142-- * Render (serializing)

146-- * Render (serializing)

143

147

@@ -159,19 +163,19 @@ newtype AcceptHeader = AcceptHeader BS.ByteString

159class Accept ctype => MimeRender ctype a where

163class Accept ctype => MimeRender ctype a where

160 mimeRender :: Proxy ctype -> a -> ByteString

164 mimeRender :: Proxy ctype -> a -> ByteString

161

165

162−class (AllMimeRender list a) => AllCTRender (list :: [*]) a where

166+class (AllMime list) => AllCTRender (list :: [*]) a where

163 -- If the Accept header can be matched, returns (Just) a tuple of the

167 -- If the Accept header can be matched, returns (Just) a tuple of the

164 -- Content-Type and response (serialization of @a@ into the appropriate

168 -- Content-Type and response (serialization of @a@ into the appropriate

165 -- mimetype).

169 -- mimetype).

166 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)

170 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)

167

171

172+instance OVERLAPPABLE_

168−instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where

173+ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where

169 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept

174 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept

170− where pctyps = Proxy :: Proxy ctyps

175+ where pctyps = Proxy :: Proxy (ct ': cts)

171 amrs = allMimeRender pctyps val

176 amrs = allMimeRender pctyps val

172 lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs

177 lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs

173

178

174−

175--------------------------------------------------------------------------

179--------------------------------------------------------------------------

176-- * Unrender

180-- * Unrender

177

181

@@ -199,14 +203,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where

199class Accept ctype => MimeUnrender ctype a where

203class Accept ctype => MimeUnrender ctype a where

200 mimeUnrender :: Proxy ctype -> ByteString -> Either String a

204 mimeUnrender :: Proxy ctype -> ByteString -> Either String a

201

205

202−class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where

206+class AllCTUnrender (list :: [*]) a where

203 handleCTypeH :: Proxy list

207 handleCTypeH :: Proxy list

204 -> ByteString -- Content-Type header

208 -> ByteString -- Content-Type header

205 -> ByteString -- Request body

209 -> ByteString -- Request body

206 -> Maybe (Either String a)

210 -> Maybe (Either String a)

207

211

208−instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps

209− ) => AllCTUnrender ctyps a where

212+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where

210 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)

213 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)

211 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body

214 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body

212

215

@@ -235,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where

235 -> a -- value to serialize

238 -> a -- value to serialize

236 -> [(M.MediaType, ByteString)] -- content-types/response pairs

239 -> [(M.MediaType, ByteString)] -- content-types/response pairs

237

240

238−instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where

241+instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where

239 allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]

242 allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]

240 where pctyp = Proxy :: Proxy ctyp

243 where pctyp = Proxy :: Proxy ctyp

241

244

245+instance OVERLAPPABLE_

242−instance ( MimeRender ctyp a

246+ ( MimeRender ctyp a

243 , AllMimeRender (ctyp' ': ctyps) a

247 , AllMimeRender (ctyp' ': ctyps) a

244 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where

248 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where

245 allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)

249 allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)

@@ -248,8 +252,17 @@ instance ( MimeRender ctyp a

248 pctyps = Proxy :: Proxy (ctyp' ': ctyps)

252 pctyps = Proxy :: Proxy (ctyp' ': ctyps)

249

253

250

254

255+-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and

256+-- then this would be taken care of. However there is no more specific instance

257+-- between that and 'MimeRender JSON a', so we do this instead

251−instance AllMimeRender '[] a where

258+instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

252− allMimeRender _ _ = []

259+ allMimeRender _ _ = [(contentType pctyp, "")]

260+ where pctyp = Proxy :: Proxy ctyp

261+

262+instance OVERLAPPING_

263+ ( AllMime (ctyp ': ctyp' ': ctyps)

264+ ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where

265+ allMimeRender p _ = zip (allMime p) (repeat "")

253

266

254--------------------------------------------------------------------------

267--------------------------------------------------------------------------

255-- Check that all elements of list are instances of MimeUnrender

268-- Check that all elements of list are instances of MimeUnrender

@@ -270,21 +283,19 @@ instance ( MimeUnrender ctyp a

270 where pctyp = Proxy :: Proxy ctyp

283 where pctyp = Proxy :: Proxy ctyp

271 pctyps = Proxy :: Proxy ctyps

284 pctyps = Proxy :: Proxy ctyps

272

285

273−type family IsNonEmpty (list :: [*]) :: Constraint where

274− IsNonEmpty (x ': xs) = ()

275−

276−

277--------------------------------------------------------------------------

286--------------------------------------------------------------------------

278-- * MimeRender Instances

287-- * MimeRender Instances

279

288

280-- | `encode`

289-- | `encode`

290+instance OVERLAPPABLE_

281−instance ToJSON a => MimeRender JSON a where

291+ ToJSON a => MimeRender JSON a where

282 mimeRender _ = encode

292 mimeRender _ = encode

283

293

284-- | @encodeFormUrlEncoded . toFormUrlEncoded@

294-- | @encodeFormUrlEncoded . toFormUrlEncoded@

285-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

295-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

286-- holds if every element of x is non-null (i.e., not @("", "")@)

296-- holds if every element of x is non-null (i.e., not @("", "")@)

297+instance OVERLAPPABLE_

287−instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where

298+ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where

288 mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded

299 mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded

289

300

290-- | `TextL.encodeUtf8`

301-- | `TextL.encodeUtf8`

@@ -307,6 +318,10 @@ instance MimeRender OctetStream ByteString where

307instance MimeRender OctetStream BS.ByteString where

318instance MimeRender OctetStream BS.ByteString where

308 mimeRender _ = fromStrict

319 mimeRender _ = fromStrict

309

320

321+-- | A type for responses without content-body.

322+data NoContent = NoContent

323+ deriving (Show, Eq, Read)

324+

310

325

311--------------------------------------------------------------------------

326--------------------------------------------------------------------------

312-- * MimeUnrender Instances

327-- * MimeUnrender Instances

servant/src/Servant/API/Delete.hsdeleted−24

@@ -1,24 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Delete (Delete) where

6−

7−import Data.Typeable (Typeable)

8−

9−-- | Combinator for DELETE requests.

10−--

11−-- Example:

12−--

13−-- >>> -- DELETE /books/:isbn

14−-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] ()

15−data Delete (contentTypes :: [*]) a

16− deriving Typeable

17−

18−

19−-- $setup

20−-- >>> import Servant.API

21−-- >>> import Data.Aeson

22−-- >>> import Data.Text

23−-- >>> data Book

24−-- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/Get.hsdeleted−22

@@ -1,22 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Get (Get) where

6−

7−import Data.Typeable (Typeable)

8−

9−-- | Endpoint for simple GET requests. Serves the result as JSON.

10−--

11−-- Example:

12−--

13−-- >>> type MyApi = "books" :> Get '[JSON] [Book]

14−data Get (contentTypes :: [*]) a

15− deriving Typeable

16−

17−-- $setup

18−-- >>> import Servant.API

19−-- >>> import Data.Aeson

20−-- >>> import Data.Text

21−-- >>> data Book

22−-- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/Patch.hsdeleted−29

@@ -1,29 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Patch (Patch) where

6−

7−import Data.Typeable (Typeable)

8−

9−-- | Endpoint for PATCH requests. The type variable represents the type of the

10−-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for

11−-- that).

12−--

13−-- If the HTTP response is empty, only () is supported.

14−--

15−-- Example:

16−--

17−-- >>> -- PATCH /books

18−-- >>> -- with a JSON encoded Book as the request body

19−-- >>> -- returning the just-created Book

20−-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book

21−data Patch (contentTypes :: [*]) a

22− deriving Typeable

23−

24−-- $setup

25−-- >>> import Servant.API

26−-- >>> import Data.Aeson

27−-- >>> import Data.Text

28−-- >>> data Book

29−-- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/Post.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Post (Post) where

6−

7−import Data.Typeable (Typeable)

8−

9−-- | Endpoint for POST requests. The type variable represents the type of the

10−-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for

11−-- that).

12−--

13−-- Example:

14−--

15−-- >>> -- POST /books

16−-- >>> -- with a JSON encoded Book as the request body

17−-- >>> -- returning the just-created Book

18−-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

19−data Post (contentTypes :: [*]) a

20− deriving Typeable

21−

22−-- $setup

23−-- >>> import Servant.API

24−-- >>> import Data.Aeson

25−-- >>> import Data.Text

26−-- >>> data Book

27−-- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/Put.hsdeleted−25

@@ -1,25 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Put (Put) where

6−

7−import Data.Typeable (Typeable)

8−

9−-- | Endpoint for PUT requests, usually used to update a ressource.

10−-- The type @a@ is the type of the response body that's returned.

11−--

12−-- Example:

13−--

14−-- >>> -- PUT /books/:isbn

15−-- >>> -- with a Book as request body, returning the updated Book

16−-- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book

17−data Put (contentTypes :: [*]) a

18− deriving Typeable

19−

20−-- $setup

21−-- >>> import Servant.API

22−-- >>> import Data.Aeson

23−-- >>> import Data.Text

24−-- >>> data Book

25−-- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/Verbs.hsnew file+169

@@ -0,0 +1,169 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE PolyKinds #-}

6+module Servant.API.Verbs

7+ ( module Servant.API.Verbs

8+ , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)

9+ ) where

10+

11+import Data.Typeable (Typeable)

12+import Data.Proxy (Proxy)

13+import GHC.Generics (Generic)

14+import GHC.TypeLits (Nat)

15+import Network.HTTP.Types.Method (Method, StdMethod (..),

16+ methodDelete, methodGet, methodHead,

17+ methodPatch, methodPost, methodPut)

18+

19+-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For

20+-- convenience, type synonyms for each verb with a 200 response code are

21+-- provided, but you are free to define your own:

22+--

23+-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a

24+data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a

25+ deriving (Typeable, Generic)

26+

27+-- * 200 responses

28+--

29+-- The 200 response is the workhorse of web servers, but also fairly generic.

30+-- When appropriate, you should prefer the more specific success combinators.

31+-- More information about the definitions of status codes can be found in

32+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC2615> and

33+-- <https://tools.ietf.org/html/rfc7231#section-6 RFC7231 Section 6>;

34+-- the relevant information is summarily presented here.

35+

36+-- | 'GET' with 200 status code.

37+type Get contentTypes a = Verb 'GET 200 contentTypes a

38+-- | 'POST' with 200 status code.

39+type Post contentTypes a = Verb 'POST 200 contentTypes a

40+-- | 'PUT' with 200 status code.

41+type Put contentTypes a = Verb 'PUT 200 contentTypes a

42+-- | 'DELETE' with 200 status code.

43+type Delete contentTypes a = Verb 'DELETE 200 contentTypes a

44+-- | 'PATCH' with 200 status code.

45+type Patch contentTypes a = Verb 'PATCH 200 contentTypes a

46+

47+-- * Other responses

48+

49+-- ** 201 Created

50+--

51+-- Indicates that a new resource has been created. The URI corresponding to the

52+-- resource should be given in the @Location@ header field.

53+--

54+-- If the resource cannot be created immediately, use 'PostAccepted'.

55+--

56+-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header

57+-- field.

58+

59+-- | 'POST' with 201 status code.

60+--

61+type PostCreated contentTypes a = Verb 'POST 201 contentTypes a

62+

63+

64+-- ** 202 Accepted

65+--

66+-- Indicates that the request has been accepted for processing, but the

67+-- processing has not yet completed. The status of the processing should be

68+-- included, as well as either a link to a status monitoring endpoint or an

69+-- estimate of when the processing will be finished.

70+

71+-- | 'GET' with 202 status code.

72+type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a

73+-- | 'POST' with 202 status code.

74+type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a

75+-- | 'DELETE' with 202 status code.

76+type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a

77+-- | 'PATCH' with 202 status code.

78+type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a

79+-- | 'PUT' with 202 status code.

80+type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a

81+

82+

83+-- ** 203 Non-Authoritative Information

84+--

85+-- Indicates that the request has been successfully processed, but the

86+-- information may come from a third-party.

87+

88+-- | 'GET' with 203 status code.

89+type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a

90+-- | 'POST' with 203 status code.

91+type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a

92+-- | 'DELETE' with 203 status code.

93+type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a

94+-- | 'PATCH' with 203 status code.

95+type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a

96+-- | 'PUT' with 203 status code.

97+type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a

98+

99+

100+-- ** 204 No Content

101+--

102+-- Indicates that no response body is being returned. Handlers for these should

103+-- return 'NoContent', possibly with headers.

104+--

105+-- If the document view should be reset, use @205 Reset Content@.

106+

107+-- | 'GET' with 204 status code.

108+type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent

109+-- | 'POST' with 204 status code.

110+type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent

111+-- | 'DELETE' with 204 status code.

112+type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent

113+-- | 'PATCH' with 204 status code.

114+type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent

115+-- | 'PUT' with 204 status code.

116+type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent

117+

118+

119+-- ** 205 Reset Content

120+--

121+-- Indicates that no response body is being returned. Handlers for these should

122+-- return 'NoContent', possibly with Headers.

123+--

124+-- If the document view should not be reset, use @204 No Content@.

125+

126+-- | 'GET' with 205 status code.

127+type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent

128+-- | 'POST' with 205 status code.

129+type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent

130+-- | 'DELETE' with 205 status code.

131+type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent

132+-- | 'PATCH' with 205 status code.

133+type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent

134+-- | 'PUT' with 205 status code.

135+type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent

136+

137+

138+-- ** 206 Partial Content

139+--

140+-- Indicates that the server is delivering part of the resource due to a range

141+-- header in the request.

142+--

143+-- For more information, see <https://tools.ietf.org/html/rfc7233#section-4.1

144+-- RFC7233 Section 4.1>

145+

146+-- | 'GET' with 206 status code.

147+type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent

148+

149+

150+class ReflectMethod a where

151+ reflectMethod :: Proxy a -> Method

152+

153+instance ReflectMethod 'GET where

154+ reflectMethod _ = methodGet

155+

156+instance ReflectMethod 'POST where

157+ reflectMethod _ = methodPost

158+

159+instance ReflectMethod 'PUT where

160+ reflectMethod _ = methodPut

161+

162+instance ReflectMethod 'DELETE where

163+ reflectMethod _ = methodDelete

164+

165+instance ReflectMethod 'PATCH where

166+ reflectMethod _ = methodPatch

167+

168+instance ReflectMethod 'HEAD where

169+ reflectMethod _ = methodHead

servant/src/Servant/Utils/Links.hs+6−29

@@ -74,7 +74,7 @@

74-- >>> safeLink api bad_link

75-- ...

76-- Could not deduce (Or

77−-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))

77+-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))

78-- (IsElem'

79-- ("hello" :> Delete '[JSON] ())

80-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))

@@ -119,11 +119,7 @@ import Servant.API.Capture ( Capture )

119import Servant.API.ReqBody ( ReqBody )

120import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )

121import Servant.API.Header ( Header )

122−import Servant.API.Get ( Get )

122+import Servant.API.Verbs ( Verb )

123−import Servant.API.Post ( Post )

124−import Servant.API.Put ( Put )

125−import Servant.API.Patch ( Patch )

126−import Servant.API.Delete ( Delete )

127import Servant.API.Sub ( type (:>) )

123import Servant.API.Sub ( type (:>) )

128import Servant.API.Raw ( Raw )

124import Servant.API.Raw ( Raw )

129import Servant.API.Alternative ( type (:<|>) )

125import Servant.API.Alternative ( type (:<|>) )

@@ -177,11 +173,8 @@ type family IsElem endpoint api :: Constraint where

177 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

173 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

178 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

174 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

179 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

175 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

180− IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'

176+ IsElem (Verb m s ct typ) (Verb m s ct' typ)

181− IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'

182− IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'

183− IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'

184− IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'

177+ = IsSubList ct ct'

185 IsElem e e = ()

178 IsElem e e = ()

186 IsElem e a = IsElem' e a

179 IsElem e a = IsElem' e a

187

180

@@ -303,24 +296,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where

303 toLink _ = toLink (Proxy :: Proxy sub)

296 toLink _ = toLink (Proxy :: Proxy sub)

304

297

305-- Verb (terminal) instances

298-- Verb (terminal) instances

306−instance HasLink (Get y r) where

299+instance HasLink (Verb m s ct a) where

307− type MkLink (Get y r) = URI

308− toLink _ = linkURI

309−

310−instance HasLink (Post y r) where

311− type MkLink (Post y r) = URI

300+ type MkLink (Verb m s ct a) = URI

312− toLink _ = linkURI

313−

314−instance HasLink (Put y r) where

315− type MkLink (Put y r) = URI

316− toLink _ = linkURI

317−

318−instance HasLink (Patch y r) where

319− type MkLink (Patch y r) = URI

320− toLink _ = linkURI

321−

322−instance HasLink (Delete y r) where

323− type MkLink (Delete y r) = URI

324 toLink _ = linkURI

301 toLink _ = linkURI

325

302

326instance HasLink Raw where

303instance HasLink Raw where