git.iko.soy/typeable/servant
on servant-auth-uverb help sign in
typeable/servant/servant-http-streams/test/Servant/ClientSpec.hs
504 lines 20 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE RecordWildCards #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# OPTIONS_GHC -freduction-depth=100 #-}
20{-# OPTIONS_GHC -fno-warn-orphans #-}
21{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
23module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
25import Prelude ()
26import Prelude.Compat
28import Control.Arrow
29 (left)
30import Control.Concurrent
31 (ThreadId, forkIO, killThread)
32import Control.DeepSeq
33 (NFData (..))
34import Control.Exception
35 (bracket, fromException, IOException)
36import Control.Monad.Error.Class
37 (throwError)
38import Data.Aeson
39import Data.Char
40 (chr, isPrint)
41import Data.Foldable
42 (forM_, toList)
43import Data.Maybe
44 (isJust)
45import Data.Monoid ()
46import Data.Proxy
47import GHC.Generics
48 (Generic)
49import qualified Network.HTTP.Types as HTTP
50import Network.Socket
51import qualified Network.Wai as Wai
52import Network.Wai.Handler.Warp
53import Test.Hspec
54import Test.Hspec.QuickCheck
55import Test.HUnit
56import Test.QuickCheck
57import Web.FormUrlEncoded
58 (FromForm, ToForm)
60import Servant.API
61 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
62 BasicAuthData (..), Capture, CaptureAll, Delete,
63 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
64 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
65 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
66import qualified Servant.Client.Core.Auth as Auth
67import qualified Servant.Client.Core.Request as Req
68import Servant.HttpStreams
69import Servant.Server
70import Servant.Server.Experimental.Auth
71import Servant.Test.ComprehensiveAPI
73-- This declaration simply checks that all instances are in place.
74_ = client comprehensiveAPIWithoutStreaming
76spec :: Spec
77spec = describe "Servant.HttpStreams" $ do
78 successSpec
79 failSpec
80 wrappedApiSpec
81 basicAuthSpec
82 genAuthSpec
83 hoistClientSpec
84 connectionErrorSpec
86-- * test data types
88data Person = Person
89 { _name :: String
90 , _age :: Integer
91 } deriving (Eq, Show, Generic)
93instance NFData Person where
94 rnf (Person n a) = rnf n `seq` rnf a
96instance ToJSON Person
97instance FromJSON Person
99instance ToForm Person
100instance FromForm Person
102instance Arbitrary Person where
103 arbitrary = Person <$> arbitrary <*> arbitrary
105alice :: Person
106alice = Person "Alice" 42
108carol :: Person
109carol = Person "Carol" 17
111type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
113type Api =
114 Get '[JSON] Person
115 :<|> "get" :> Get '[JSON] Person
116 :<|> "deleteEmpty" :> DeleteNoContent
117 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
118 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
119 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
120 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
121 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
122 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
123 :<|> "rawSuccess" :> Raw
124 :<|> "rawFailure" :> Raw
125 :<|> "multiple" :>
126 Capture "first" String :>
127 QueryParam "second" Int :>
128 QueryFlag "third" :>
129 ReqBody '[JSON] [(String, [Rational])] :>
130 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
131 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
132 :<|> "deleteContentType" :> DeleteNoContent
133 :<|> "redirectWithCookie" :> Raw
134 :<|> "empty" :> EmptyAPI
136api :: Proxy Api
137api = Proxy
139getRoot :: ClientM Person
140getGet :: ClientM Person
141getDeleteEmpty :: ClientM NoContent
142getCapture :: String -> ClientM Person
143getCaptureAll :: [String] -> ClientM [Person]
144getBody :: Person -> ClientM Person
145getQueryParam :: Maybe String -> ClientM Person
146getQueryParams :: [String] -> ClientM [Person]
147getQueryFlag :: Bool -> ClientM Bool
148getRawSuccess :: HTTP.Method -> ClientM Response
149getRawFailure :: HTTP.Method -> ClientM Response
150getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
152getRespHeaders :: ClientM (Headers TestHeaders Bool)
153getDeleteContentType :: ClientM NoContent
154_getRedirectWithCookie :: HTTP.Method -> ClientM Response
156getRoot
157 :<|> getGet
158 :<|> getDeleteEmpty
159 :<|> getCapture
160 :<|> getCaptureAll
161 :<|> getBody
162 :<|> getQueryParam
163 :<|> getQueryParams
164 :<|> getQueryFlag
165 :<|> getRawSuccess
166 :<|> getRawFailure
167 :<|> getMultiple
168 :<|> getRespHeaders
169 :<|> getDeleteContentType
170 :<|> _getRedirectWithCookie
171 :<|> EmptyClient = client api
173server :: Application
174server = serve api (
175 return carol
176 :<|> return alice
177 :<|> return NoContent
178 :<|> (\ name -> return $ Person name 0)
179 :<|> (\ names -> return (zipWith Person names [0..]))
180 :<|> return
181 :<|> (\ name -> case name of
182 Just "alice" -> return alice
183 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
184 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
185 :<|> (\ names -> return (zipWith Person names [0..]))
186 :<|> return
187 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
188 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
189 :<|> (\ a b c d -> return (a, b, c, d))
190 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
191 :<|> return NoContent
192 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
193 :<|> emptyServer)
195type FailApi =
196 "get" :> Raw
197 :<|> "capture" :> Capture "name" String :> Raw
198 :<|> "body" :> Raw
199failApi :: Proxy FailApi
200failApi = Proxy
202failServer :: Application
203failServer = serve failApi (
204 (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
205 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
206 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
207 )
209-- * basic auth stuff
211type BasicAuthAPI =
212 BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
214basicAuthAPI :: Proxy BasicAuthAPI
215basicAuthAPI = Proxy
217basicAuthHandler :: BasicAuthCheck ()
218basicAuthHandler =
219 let check (BasicAuthData username password) =
220 if username == "servant" && password == "server"
221 then return (Authorized ())
222 else return Unauthorized
223 in BasicAuthCheck check
225basicServerContext :: Context '[ BasicAuthCheck () ]
226basicServerContext = basicAuthHandler :. EmptyContext
228basicAuthServer :: Application
229basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
231-- * general auth stuff
233type GenAuthAPI =
234 AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
236genAuthAPI :: Proxy GenAuthAPI
237genAuthAPI = Proxy
239type instance AuthServerData (AuthProtect "auth-tag") = ()
240type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
242genAuthHandler :: AuthHandler Wai.Request ()
243genAuthHandler =
244 let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
245 Nothing -> throwError (err401 { errBody = "Missing auth header" })
246 Just _ -> return ()
247 in mkAuthHandler handler
249genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
250genAuthServerContext = genAuthHandler :. EmptyContext
252genAuthServer :: Application
253genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
255runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)
256runClient x burl = withClientEnvIO burl (runClientM x)
258runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)
259runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
260 where
261 runClientMUnsafe x env = withClientM x env return
263successSpec :: Spec
264successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
265 it "Servant.API.Get root" $ \(_, baseUrl) -> do
266 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
268 it "Servant.API.Get" $ \(_, baseUrl) -> do
269 left show <$> runClient getGet baseUrl `shouldReturn` Right alice
271 describe "Servant.API.Delete" $ do
272 it "allows empty content type" $ \(_, baseUrl) -> do
273 left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
275 it "allows content type" $ \(_, baseUrl) -> do
276 left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
278 it "Servant.API.Capture" $ \(_, baseUrl) -> do
279 left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
281 it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
282 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
283 left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
285 it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
286 let p = Person "Clara" 42
287 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
289 it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
290 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
291 Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
292 Req.requestPath req `shouldBe` (baseUrl, "/param")
293 toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
294 Req.requestMethod req `shouldBe` HTTP.methodGet
296 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
297 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
298 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
299 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
301 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
302 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
303 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
304 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
306 context "Servant.API.QueryParam.QueryFlag" $
307 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
308 left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
310 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
311 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
312 case res of
313 Left e -> assertFailure $ show e
314 Right r -> do
315 responseStatusCode r `shouldBe` HTTP.status200
316 responseBody r `shouldBe` "rawSuccess"
318 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
319 res <- runClient (getRawFailure HTTP.methodGet) baseUrl
320 case res of
321 Right _ -> assertFailure "expected Left, but got Right"
322 Left (FailureResponse _ r) -> do
323 responseStatusCode r `shouldBe` HTTP.status400
324 responseBody r `shouldBe` "rawFailure"
325 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
327 it "Returns headers appropriately" $ \(_, baseUrl) -> do
328 res <- runClient getRespHeaders baseUrl
329 case res of
330 Left e -> assertFailure $ show e
331 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
333 modifyMaxSuccess (const 20) $ do
334 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
335 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
336 ioProperty $ do
337 result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
338 return $
339 result === Right (cap, num, flag, body)
342wrappedApiSpec :: Spec
343wrappedApiSpec = describe "error status codes" $ do
344 let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
345 context "are correctly handled by the client" $
346 let test :: (WrappedApi, String) -> Spec
347 test (WrappedApi api, desc) =
348 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
349 let getResponse :: ClientM ()
350 getResponse = client api
351 Left (FailureResponse _ r) <- runClient getResponse baseUrl
352 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
353 in mapM_ test $
354 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
355 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
356 (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
357 (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
358 []
360failSpec :: Spec
361failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
363 context "client returns errors appropriately" $ do
364 it "reports FailureResponse" $ \(_, baseUrl) -> do
365 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
366 Left res <- runClient getDeleteEmpty baseUrl
367 case res of
368 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
369 _ -> fail $ "expected 404 response, but got " <> show res
371 it "reports DecodeFailure" $ \(_, baseUrl) -> do
372 let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
373 Left res <- runClient (getCapture "foo") baseUrl
374 case res of
375 DecodeFailure _ _ -> return ()
376 _ -> fail $ "expected DecodeFailure, but got " <> show res
378 -- we don't catch IOException's
379 xit "reports ConnectionError" $ \_ -> do
380 let (getGetWrongHost :<|> _) = client api
381 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
382 case res of
383 ConnectionError _ -> return ()
384 _ -> fail $ "expected ConnectionError, but got " <> show res
386 it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
387 let (_ :<|> getGet :<|> _ ) = client api
388 Left res <- runClient getGet baseUrl
389 case res of
390 UnsupportedContentType ("application/octet-stream") _ -> return ()
391 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
393 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
394 let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
395 Left res <- runClient (getBody alice) baseUrl
396 case res of
397 InvalidContentTypeHeader _ -> return ()
398 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
400data WrappedApi where
401 WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
402 HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
403 Proxy api -> WrappedApi
405basicAuthSpec :: Spec
406basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
407 context "Authentication works when requests are properly authenticated" $ do
409 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
410 let getBasic = client basicAuthAPI
411 let basicAuthData = BasicAuthData "servant" "server"
412 left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
414 context "Authentication is rejected when requests are not authenticated properly" $ do
416 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
417 let getBasic = client basicAuthAPI
418 let basicAuthData = BasicAuthData "not" "password"
419 Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
420 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
422genAuthSpec :: Spec
423genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
424 context "Authentication works when requests are properly authenticated" $ do
426 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
427 let getProtected = client genAuthAPI
428 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
429 left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
431 context "Authentication is rejected when requests are not authenticated properly" $ do
433 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
434 let getProtected = client genAuthAPI
435 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
436 Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
437 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
439-- * hoistClient
441type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
443hoistClientAPI :: Proxy HoistClientAPI
444hoistClientAPI = Proxy
446hoistClientServer :: Application -- implements HoistClientAPI
447hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
449hoistClientSpec :: Spec
450hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
451 describe "Servant.Client.hoistClient" $ do
452 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
453 let (getInt :<|> postInt)
454 = hoistClient hoistClientAPI
455 (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)
456 (client hoistClientAPI)
458 getInt `shouldReturn` 5
459 postInt 5 `shouldReturn` 5
461-- * ConnectionError
462type ConnectionErrorAPI = Get '[JSON] Int
464connectionErrorAPI :: Proxy ConnectionErrorAPI
465connectionErrorAPI = Proxy
467connectionErrorSpec :: Spec
468connectionErrorSpec = describe "Servant.Client.ClientError" $
469 xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
470 let getInt = client connectionErrorAPI
471 let baseUrl' = BaseUrl Http "example.invalid" 80 ""
472 let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e
473 isHttpError _ = False
474 (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
476-- * utils
478startWaiApp :: Application -> IO (ThreadId, BaseUrl)
479startWaiApp app = do
480 (port, socket) <- openTestSocket
481 let settings = setPort port $ defaultSettings
482 thread <- forkIO $ runSettingsSocket settings socket app
483 return (thread, BaseUrl Http "127.0.0.1" port "")
486endWaiApp :: (ThreadId, BaseUrl) -> IO ()
487endWaiApp (thread, _) = killThread thread
489openTestSocket :: IO (Port, Socket)
490openTestSocket = do
491 s <- socket AF_INET Stream defaultProtocol
492 let localhost = tupleToHostAddress (127, 0, 0, 1)
493 bind s (SockAddrInet defaultPort localhost)
494 listen s 1
495 port <- socketPort s
496 return (fromIntegral port, s)
498pathGen :: Gen (NonEmptyList Char)
499pathGen = fmap NonEmpty path
500 where
501 path = listOf1 $ elements $
502 filter (not . (`elem` ("?%[]/#;" :: String))) $
503 filter isPrint $
504 map chr [0..127]