@@ -1,12 +1,21 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE RecordWildCards #-}
8−{-# LANGUAGE StandaloneDeriving #-}
9−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+#if !MIN_VERSION_base(4,8,0)
10+{-# LANGUAGE OverlappingInstances #-}
11+#endif
12+{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE PolyKinds #-}
14+{-# LANGUAGE RecordWildCards #-}
15+{-# LANGUAGE StandaloneDeriving #-}
16+{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
1019{-# OPTIONS_GHC -fcontext-stack=100 #-}
1120{-# OPTIONS_GHC -fno-warn-orphans #-}
1221
@@ -20,20 +29,20 @@ import Control.Concurrent
2029import Control.Exception
2130import Control.Monad.Trans.Except
2231import Data.Aeson
23−import Data.ByteString.Lazy (ByteString)
2432import Data.Char
2533import Data.Foldable (forM_)
26−import Data.Monoid
34+import Data.Monoid hiding (getLast)
2735import Data.Proxy
2836import qualified Data.Text as T
2937import GHC.Generics
38+import GHC.TypeLits
3039import qualified Network.HTTP.Client as C
3140import Network.HTTP.Media
3241import Network.HTTP.Types hiding (Header)
33−import qualified Network.HTTP.Types as HTTP
3442import Network.Socket
3543import Network.Wai hiding (Response)
3644import Network.Wai.Handler.Warp
45+import System.IO.Unsafe (unsafePerformIO)
3746import Test.Hspec
3847import Test.Hspec.QuickCheck
3948import Test.HUnit
@@ -43,6 +52,12 @@ import Servant.API
4352import Servant.Client
4453import Servant.Server
4554
55+spec :: Spec
56+spec = describe "Servant.Client" $ do
57+ sucessSpec
58+ failSpec
59+ wrappedApiSpec
60+
4661-- * test data types
4762
4863data Person = Person {
@@ -122,8 +137,6 @@ server = serve api (
122137 :<|> return ()
123138 )
124139
125−withServer :: (BaseUrl -> IO a) -> IO a
126−withServer action = withWaiDaemon (return server) action
127140
128141type FailApi =
129142 "get" :> Raw
@@ -139,93 +152,72 @@ failServer = serve failApi (
139152 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
140153 )
141154
142−withFailServer :: (BaseUrl -> IO a) -> IO a
143−withFailServer action = withWaiDaemon (return failServer) action
144−
145−spec :: IO ()
146−spec = withServer $ \ baseUrl -> do
147− manager <- C.newManager C.defaultManagerSettings
148− let getGet :: ExceptT ServantError IO Person
149− getDeleteEmpty :: ExceptT ServantError IO ()
150− getCapture :: String -> ExceptT ServantError IO Person
151− getBody :: Person -> ExceptT ServantError IO Person
152− getQueryParam :: Maybe String -> ExceptT ServantError IO Person
153− getQueryParams :: [String] -> ExceptT ServantError IO [Person]
154− getQueryFlag :: Bool -> ExceptT ServantError IO Bool
155− getMatrixParam :: Maybe String -> ExceptT ServantError IO Person
156− getMatrixParams :: [String] -> ExceptT ServantError IO [Person]
157− getMatrixFlag :: Bool -> ExceptT ServantError IO Bool
158− getRawSuccess :: Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
159− getRawFailure :: Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
160− getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ExceptT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
161− getRespHeaders :: ExceptT ServantError IO (Headers TestHeaders Bool)
162− getDeleteContentType :: ExceptT ServantError IO ()
163− ( getGet
164− :<|> getDeleteEmpty
165− :<|> getCapture
166− :<|> getBody
167− :<|> getQueryParam
168− :<|> getQueryParams
169− :<|> getQueryFlag
170− :<|> getMatrixParam
171− :<|> getMatrixParams
172− :<|> getMatrixFlag
173− :<|> getRawSuccess
174− :<|> getRawFailure
175− :<|> getMultiple
176− :<|> getRespHeaders
177− :<|> getDeleteContentType)
178− = client api baseUrl manager
179−
180− hspec $ do
181− it "Servant.API.Get" $ do
155+{-# NOINLINE manager #-}
156+manager :: C.Manager
157+manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
158+
159+sucessSpec :: Spec
160+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
161+
162+ it "Servant.API.Get" $ \(_, baseUrl) -> do
163+ let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
182164 (left show <$> runExceptT getGet) `shouldReturn` Right alice
183165
184166 describe "Servant.API.Delete" $ do
185− it "allows empty content type" $ do
167+ it "allows empty content type" $ \(_, baseUrl) -> do
168+ let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
186169 (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
187170
188− it "allows content type" $ do
171+ it "allows content type" $ \(_, baseUrl) -> do
172+ let getDeleteContentType = getLast $ client api baseUrl manager
189173 (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
190174
191− it "Servant.API.Capture" $ do
175+ it "Servant.API.Capture" $ \(_, baseUrl) -> do
176+ let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
192177 (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
193178
194− it "Servant.API.ReqBody" $ do
179+ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
195180 let p = Person "Clara" 42
181+ getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager
196182 (left show <$> runExceptT (getBody p)) `shouldReturn` Right p
197183
198− it "Servant.API.QueryParam" $ do
184+ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
185+ let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager
199186 left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
200187 Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
201188 responseStatus `shouldBe` Status 400 "bob not found"
202189
203− it "Servant.API.QueryParam.QueryParams" $ do
190+ it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
191+ let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager
204192 (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
205193 (left show <$> runExceptT (getQueryParams ["alice", "bob"]))
206194 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
207195
208196 context "Servant.API.QueryParam.QueryFlag" $
209− forM_ [False, True] $ \ flag ->
210− it (show flag) $ do
197+ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
198+ let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager
211199 (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
212200
213− it "Servant.API.MatrixParam" $ do
201+ it "Servant.API.MatrixParam" $ \(_, baseUrl) -> do
202+ let getMatrixParam = getNth (Proxy :: Proxy 7) $ client api baseUrl manager
214203 left show <$> runExceptT (getMatrixParam (Just "alice")) `shouldReturn` Right alice
215204 Left FailureResponse{..} <- runExceptT (getMatrixParam (Just "bob"))
216205 responseStatus `shouldBe` Status 400 "bob not found"
217206
218− it "Servant.API.MatrixParam.MatrixParams" $ do
207+ it "Servant.API.MatrixParam.MatrixParams" $ \(_, baseUrl) -> do
208+ let getMatrixParams = getNth (Proxy :: Proxy 8) $ client api baseUrl manager
219209 left show <$> runExceptT (getMatrixParams []) `shouldReturn` Right []
220210 left show <$> runExceptT (getMatrixParams ["alice", "bob"])
221211 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
222212
223213 context "Servant.API.MatrixParam.MatrixFlag" $
224214 forM_ [False, True] $ \ flag ->
225− it (show flag) $ do
215+ it (show flag) $ \(_, baseUrl) -> do
216+ let getMatrixFlag = getNth (Proxy :: Proxy 9) $ client api baseUrl manager
226217 left show <$> runExceptT (getMatrixFlag flag) `shouldReturn` Right flag
227218
228− it "Servant.API.Raw on success" $ do
219+ it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
220+ let getRawSuccess = getNth (Proxy :: Proxy 10) $ client api baseUrl manager
229221 res <- runExceptT (getRawSuccess methodGet)
230222 case res of
231223 Left e -> assertFailure $ show e
@@ -234,7 +226,8 @@ spec = withServer $ \ baseUrl -> do
234226 C.responseBody response `shouldBe` body
235227 C.responseStatus response `shouldBe` ok200
236228
237− it "Servant.API.Raw on failure" $ do
229+ it "Servant.API.Raw on failure" $ \(_, baseUrl) -> do
230+ let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager
238231 res <- runExceptT (getRawFailure methodGet)
239232 case res of
240233 Left e -> assertFailure $ show e
@@ -243,81 +236,75 @@ spec = withServer $ \ baseUrl -> do
243236 C.responseBody response `shouldBe` body
244237 C.responseStatus response `shouldBe` badRequest400
245238
246− it "Returns headers appropriately" $ withServer $ \ _ -> do
239+ it "Returns headers appropriately" $ \(_, baseUrl) -> do
240+ let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager
247241 res <- runExceptT getRespHeaders
248242 case res of
249243 Left e -> assertFailure $ show e
250244 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
251245
252246 modifyMaxSuccess (const 20) $ do
253− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
254− property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
247+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
248+ let getMultiple = getNth (Proxy :: Proxy 12) $ client api baseUrl manager
249+ in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
255250 ioProperty $ do
256251 result <- left show <$> runExceptT (getMultiple cap num flag body)
257252 return $
258253 result === Right (cap, num, flag, body)
259254
260255
261− context "client correctly handles error status codes" $ do
262− let test :: (WrappedApi, String) -> Spec
263− test (WrappedApi api, desc) =
264− it desc $
265− withWaiDaemon (return (serve api (throwE $ ServantErr 500 "error message" "" []))) $
266− \ host -> do
267− let getResponse :: ExceptT ServantError IO ()
268− getResponse = client api host manager
269− Left FailureResponse{..} <- runExceptT getResponse
270− responseStatus `shouldBe` (Status 500 "error message")
271− mapM_ test $
256+wrappedApiSpec :: Spec
257+wrappedApiSpec = describe "error status codes" $ do
258+ let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
259+ context "are correctly handled by the client" $
260+ let test :: (WrappedApi, String) -> Spec
261+ test (WrappedApi api, desc) =
262+ it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
263+ let getResponse :: ExceptT ServantError IO ()
264+ getResponse = client api baseUrl manager
265+ Left FailureResponse{..} <- runExceptT getResponse
266+ responseStatus `shouldBe` (Status 500 "error message")
267+ in mapM_ test $
272268 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
273269 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
274270 (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
275271 (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
276272 []
277273
278−failSpec :: IO ()
279−failSpec = withFailServer $ \ baseUrl -> do
280− manager <- C.newManager C.defaultManagerSettings
281− let getGet :: ExceptT ServantError IO Person
282− getDeleteEmpty :: ExceptT ServantError IO ()
283− getCapture :: String -> ExceptT ServantError IO Person
284− getBody :: Person -> ExceptT ServantError IO Person
285− ( getGet
286− :<|> getDeleteEmpty
287− :<|> getCapture
288− :<|> getBody
289− :<|> _ )
290− = client api baseUrl manager
291− getGetWrongHost :: ExceptT ServantError IO Person
292− (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
293−
294− hspec $ do
274+failSpec :: Spec
275+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
276+
295277 context "client returns errors appropriately" $ do
296− it "reports FailureResponse" $ do
278+ it "reports FailureResponse" $ \(_, baseUrl) -> do
279+ let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager
297280 Left res <- runExceptT getDeleteEmpty
298281 case res of
299282 FailureResponse (Status 404 "Not Found") _ _ -> return ()
300283 _ -> fail $ "expected 404 response, but got " <> show res
301284
302− it "reports DecodeFailure" $ do
285+ it "reports DecodeFailure" $ \(_, baseUrl) -> do
286+ let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager
303287 Left res <- runExceptT (getCapture "foo")
304288 case res of
305289 DecodeFailure _ ("application/json") _ -> return ()
306290 _ -> fail $ "expected DecodeFailure, but got " <> show res
307291
308− it "reports ConnectionError" $ do
292+ it "reports ConnectionError" $ \_ -> do
293+ let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
309294 Left res <- runExceptT getGetWrongHost
310295 case res of
311296 ConnectionError _ -> return ()
312297 _ -> fail $ "expected ConnectionError, but got " <> show res
313298
314− it "reports UnsupportedContentType" $ do
299+ it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
300+ let (getGet :<|> _ ) = client api baseUrl manager
315301 Left res <- runExceptT getGet
316302 case res of
317303 UnsupportedContentType ("application/octet-stream") _ -> return ()
318304 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
319305
320− it "reports InvalidContentTypeHeader" $ do
306+ it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
307+ let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager
321308 Left res <- runExceptT (getBody alice)
322309 case res of
323310 InvalidContentTypeHeader "fooooo" _ -> return ()
@@ -331,36 +318,16 @@ data WrappedApi where
331318
332319-- * utils
333320
334−withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
335−withWaiDaemon mkApplication action = do
336− application <- mkApplication
337− bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
338− where
339− acquire application = do
340− (notifyStart, waitForStart) <- lvar
341− (notifyKilled, waitForKilled) <- lvar
342− thread <- forkIO $ (do
343− (krakenPort, socket) <- openTestSocket
344− let settings =
345− setPort krakenPort $ -- set here just for consistency, shouldn't be
346− -- used (it's set in the socket)
347− setBeforeMainLoop (notifyStart krakenPort)
348− defaultSettings
349− runSettingsSocket settings socket application)
350− `finally` notifyKilled ()
351− krakenPort <- waitForStart
352− let baseUrl = (BaseUrl Http "localhost" 80 ""){baseUrlPort = krakenPort}
353− return (thread, waitForKilled, baseUrl)
354− free (thread, waitForKilled, _) = do
355− killThread thread
356− waitForKilled
357−
358− lvar :: IO (a -> IO (), IO a)
359− lvar = do
360− mvar <- newEmptyMVar
361− let put = putMVar mvar
362− wait = readMVar mvar
363− return (put, wait)
321+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
322+startWaiApp app = do
323+ (port, socket) <- openTestSocket
324+ let settings = setPort port $ defaultSettings
325+ thread <- forkIO $ runSettingsSocket settings socket app
326+ return (thread, BaseUrl Http "localhost" port "")
327+
328+
329+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
330+endWaiApp (thread, _) = killThread thread
364331
365332openTestSocket :: IO (Port, Socket)
366333openTestSocket = do
@@ -378,3 +345,37 @@ pathGen = fmap NonEmpty path
378345 filter (not . (`elem` ("?%[]/#;" :: String))) $
379346 filter isPrint $
380347 map chr [0..127]
348+
349+class GetNth (n :: Nat) a b | n a -> b where
350+ getNth :: Proxy n -> a -> b
351+
352+instance
353+#if MIN_VERSION_base(4,8,0)
354+ {-# OVERLAPPING #-}
355+#endif
356+ GetNth 0 (x :<|> y) x where
357+ getNth _ (x :<|> _) = x
358+
359+instance
360+#if MIN_VERSION_base(4,8,0)
361+ {-# OVERLAPPING #-}
362+#endif
363+ (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where
364+ getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x
365+
366+class GetLast a b | a -> b where
367+ getLast :: a -> b
368+
369+instance
370+#if MIN_VERSION_base(4,8,0)
371+ {-# OVERLAPPING #-}
372+#endif
373+ (GetLast b c) => GetLast (a :<|> b) c where
374+ getLast (_ :<|> b) = getLast b
375+
376+instance
377+#if MIN_VERSION_base(4,8,0)
378+ {-# OVERLAPPING #-}
379+#endif
380+ GetLast a a where
381+ getLast a = a