41129e9 · servant · git.iko.soy

30import Control.Exception (bracket)

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

32import Data.Aeson

33+import qualified Data.ByteString.Lazy as BS

33import Data.Char (chr, isPrint)

34import Data.Char (chr, isPrint)

34import Data.Foldable (forM_)

35import Data.Foldable (forM_)

35import Data.Monoid hiding (getLast)

36import Data.Monoid hiding (getLast)

36import Data.Proxy

37import Data.Proxy

37import qualified Data.Text as T

38import qualified Data.Text as T

38import GHC.Generics (Generic)

39import GHC.Generics (Generic)

39−import GHC.TypeLits

40import qualified Network.HTTP.Client as C

41import Network.HTTP.Media

42−import Network.HTTP.Types (Status (..), badRequest400,

42+import qualified Network.HTTP.Types as HTTP

43− methodGet, ok200, status400)

44import Network.Socket

43import Network.Socket

45import Network.Wai (Application, Request,

44import Network.Wai (Application, Request,

46 requestHeaders, responseLBS)

45 requestHeaders, responseLBS)

120api :: Proxy Api

119api :: Proxy Api

121api = Proxy

120api = Proxy

122

121

122+getGet :: SCR.ClientM Person

123+getDeleteEmpty :: SCR.ClientM NoContent

124+getCapture :: String

125+ -> SCR.ClientM Person

126+getBody :: Person

127+ -> SCR.ClientM Person

128+getQueryParam :: Maybe String

129+ -> SCR.ClientM Person

130+getQueryParams :: [String]

131+ -> SCR.ClientM [Person]

132+getQueryFlag :: Bool

133+ -> SCR.ClientM Bool

134+getRawSuccess :: HTTP.Method

135+ -> SCR.ClientM ( Int

136+ , BS.ByteString

137+ , MediaType

138+ , [HTTP.Header]

139+ , C.Response BS.ByteString )

140+getRawFailure :: HTTP.Method

141+ -> SCR.ClientM ( Int

142+ , BS.ByteString

143+ , MediaType

144+ , [HTTP.Header]

145+ , C.Response BS.ByteString )

146+getMultiple :: String

147+ -> Maybe Int

148+ -> Bool

149+ -> [(String, [Rational])]

150+ -> SCR.ClientM ( String

151+ , Maybe Int

152+ , Bool

153+ , [(String, [Rational])] )

154+getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)

155+getDeleteContentType :: SCR.ClientM NoContent

156+getGet

157+ :<|> getDeleteEmpty

158+ :<|> getCapture

159+ :<|> getBody

160+ :<|> getQueryParam

161+ :<|> getQueryParams

162+ :<|> getQueryFlag

163+ :<|> getRawSuccess

164+ :<|> getRawFailure

165+ :<|> getMultiple

166+ :<|> getRespHeaders

167+ :<|> getDeleteContentType = client api

168+

123server :: Application

169server :: Application

124server = serve api (

170server = serve api (

125 return alice

171 return alice

132 Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])

178 Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])

133 :<|> (\ names -> return (zipWith Person names [0..]))

179 :<|> (\ names -> return (zipWith Person names [0..]))

134 :<|> return

180 :<|> return

135− :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")

181+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")

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

182+ :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")

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

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

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

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

139 :<|> return NoContent

185 :<|> return NoContent

149

195

150failServer :: Application

196failServer :: Application

151failServer = serve failApi (

197failServer = serve failApi (

152− (\ _request respond -> respond $ responseLBS ok200 [] "")

198+ (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")

153− :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")

199+ :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")

154− :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

200+ :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

155 )

201 )

156

202

157-- * basic auth stuff

203-- * basic auth stuff

208sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

254sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

209

255

210 it "Servant.API.Get" $ \(_, baseUrl) -> do

256 it "Servant.API.Get" $ \(_, baseUrl) -> do

211− let getGet = getNth (Proxy :: Proxy 0) $ client api

212 (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice

257 (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice

213

258

214 describe "Servant.API.Delete" $ do

259 describe "Servant.API.Delete" $ do

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

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

216− let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api

217 (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent

261 (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent

218

262

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

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

220− let getDeleteContentType :: SCR.ClientM NoContent

221− getDeleteContentType = getLast $ client api

222 (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent

264 (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent

223

265

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

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

225− let getCapture = getNth (Proxy :: Proxy 2) $ client api

226 (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)

267 (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)

227

268

228 it "Servant.API.ReqBody" $ \(_, baseUrl) -> do

269 it "Servant.API.ReqBody" $ \(_, baseUrl) -> do

229 let p = Person "Clara" 42

270 let p = Person "Clara" 42

230− getBody = getNth (Proxy :: Proxy 3) $ client api

231 (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p

271 (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p

232

272

233 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

273 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

234− let getQueryParam = getNth (Proxy :: Proxy 4) $ client api

235 left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice

274 left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice

236 Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager

275 Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager

237− responseStatus `shouldBe` Status 400 "bob not found"

276+ responseStatus `shouldBe` HTTP.Status 400 "bob not found"

238

277

239 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

278 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

240− let getQueryParams = getNth (Proxy :: Proxy 5) $ client api

241 (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []

279 (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []

242 (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)

280 (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)

243 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]

281 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]

244

282

245 context "Servant.API.QueryParam.QueryFlag" $

283 context "Servant.API.QueryParam.QueryFlag" $

246 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do

284 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do

247− let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api

248 (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag

285 (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag

249

286

250 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

287 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

251− let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api

252− res <- SCR.runClientM (getRawSuccess methodGet) baseUrl manager

288+ res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager

253 case res of

289 case res of

254 Left e -> assertFailure $ show e

290 Left e -> assertFailure $ show e

255 Right (code, body, ct, _, response) -> do

291 Right (code, body, ct, _, response) -> do

256 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")

292 (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")

257 C.responseBody response `shouldBe` body

293 C.responseBody response `shouldBe` body

258− C.responseStatus response `shouldBe` ok200

294+ C.responseStatus response `shouldBe` HTTP.ok200

259

295

260 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do

296 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do

261− let getRawFailure = getNth (Proxy :: Proxy 8) $ client api

262− res <- SCR.runClientM (getRawFailure methodGet) baseUrl manager

297+ res <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager

263 case res of

298 case res of

264 Right _ -> assertFailure "expected Left, but got Right"

299 Right _ -> assertFailure "expected Left, but got Right"

265 Left e -> do

300 Left e -> do

266− Servant.Client.responseStatus e `shouldBe` status400

301+ Servant.Client.responseStatus e `shouldBe` HTTP.status400

267 Servant.Client.responseBody e `shouldBe` "rawFailure"

302 Servant.Client.responseBody e `shouldBe` "rawFailure"

268

303

269 it "Returns headers appropriately" $ \(_, baseUrl) -> do

304 it "Returns headers appropriately" $ \(_, baseUrl) -> do

270− let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api

271 res <- SCR.runClientM getRespHeaders baseUrl manager

305 res <- SCR.runClientM getRespHeaders baseUrl manager

272 case res of

306 case res of

273 Left e -> assertFailure $ show e

307 Left e -> assertFailure $ show e

275

309

276 modifyMaxSuccess (const 20) $ do

310 modifyMaxSuccess (const 20) $ do

277 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

311 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

278− let getMultiple = getNth (Proxy :: Proxy 9) $ client api

279− in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

312+ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

280 ioProperty $ do

313 ioProperty $ do

281 result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager

314 result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager

282 return $

315 return $

293 let getResponse :: SCR.ClientM ()

326 let getResponse :: SCR.ClientM ()

294 getResponse = client api

327 getResponse = client api

295 Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager

328 Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager

296− responseStatus `shouldBe` (Status 500 "error message")

329+ responseStatus `shouldBe` (HTTP.Status 500 "error message")

297 in mapM_ test $

330 in mapM_ test $

298 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

331 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

299 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

332 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

309 let (_ :<|> getDeleteEmpty :<|> _) = client api

342 let (_ :<|> getDeleteEmpty :<|> _) = client api

310 Left res <- SCR.runClientM getDeleteEmpty baseUrl manager

343 Left res <- SCR.runClientM getDeleteEmpty baseUrl manager

311 case res of

344 case res of

312− FailureResponse (Status 404 "Not Found") _ _ -> return ()

345+ FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()

313 _ -> fail $ "expected 404 response, but got " <> show res

346 _ -> fail $ "expected 404 response, but got " <> show res

314

347

315 it "reports DecodeFailure" $ \(_, baseUrl) -> do

348 it "reports DecodeFailure" $ \(_, baseUrl) -> do

360 let getBasic = client basicAuthAPI

393 let getBasic = client basicAuthAPI

361 let basicAuthData = BasicAuthData "not" "password"

394 let basicAuthData = BasicAuthData "not" "password"

362 Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager

395 Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager

363− responseStatus `shouldBe` Status 403 "Forbidden"

396+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"

364

397

365genAuthSpec :: Spec

398genAuthSpec :: Spec

366genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

399genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

377 let getProtected = client genAuthAPI

410 let getProtected = client genAuthAPI

378 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

411 let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

379 Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager

412 Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager

380− responseStatus `shouldBe` (Status 401 "Unauthorized")

413+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")

381

414

382-- * utils

415-- * utils

383

416

408 filter (not . (`elem` ("?%[]/#;" :: String))) $

441 filter (not . (`elem` ("?%[]/#;" :: String))) $

409 filter isPrint $

442 filter isPrint $

410 map chr [0..127]

443 map chr [0..127]

411−

412−class GetNth (n :: Nat) a b | n a -> b where

413− getNth :: Proxy n -> a -> b

414−

415−instance OVERLAPPING_

416− GetNth 0 (x :<|> y) x where

417− getNth _ (x :<|> _) = x

418−

419−instance OVERLAPPING_

420− (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where

421− getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x

422−

423−class GetLast a b | a -> b where

424− getLast :: a -> b

425−

426−instance OVERLAPPING_

427− (GetLast b c) => GetLast (a :<|> b) c where

428− getLast (_ :<|> b) = getLast b

429−

430−instance OVERLAPPING_

431− GetLast a a where

432− getLast a = a