git.iko.soy/typeable/servant
on master help sign in
Merge pull request #245 from arianvp/servant-client-hspec-discover-fix
444a72eAlp Mestanogullari
servant-client/src/Servant/Common/BaseUrl.hs+9−2
compare with master
unifiedsplit
@@ -32,12 +32,19 @@ data BaseUrl = BaseUrl
32 , baseUrlHost :: String -- ^ host (eg "haskell.org")
32 , baseUrlHost :: String -- ^ host (eg "haskell.org")
33 , baseUrlPort :: Int -- ^ port (eg 80)
33 , baseUrlPort :: Int -- ^ port (eg 80)
34 , baseUrlPath :: String -- ^ path (eg "/a/b/c")
34 , baseUrlPath :: String -- ^ path (eg "/a/b/c")
35− } deriving (Show, Eq, Ord, Generic)
35+ } deriving (Show, Ord, Generic)
36+
37+instance Eq BaseUrl where
38+ BaseUrl a b c path == BaseUrl a' b' c' path'
39+ = a == a' && b == b' && c == c' && s path == s path'
40+ where s ('/':x) = x
41+ s x = x
36
42
37showBaseUrl :: BaseUrl -> String
43showBaseUrl :: BaseUrl -> String
38showBaseUrl (BaseUrl urlscheme host port path) =
44showBaseUrl (BaseUrl urlscheme host port path) =
39− schemeString ++ "//" ++ host ++ portString ++ path
45+ schemeString ++ "//" ++ host ++ (portString </> path)
40 where
46 where
47+ a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
41 schemeString = case urlscheme of
48 schemeString = case urlscheme of
42 Http -> "http:"
49 Http -> "http:"
43 Https -> "https:"
50 Https -> "https:"
servant-client/test/Servant/ClientSpec.hs+134−133
@@ -1,12 +1,21 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+#if !MIN_VERSION_base(4,8,0)
10+{-# LANGUAGE OverlappingInstances #-}
11+#endif
12+{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE RecordWildCards #-}
14+{-# LANGUAGE RecordWildCards #-}
8−{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE StandaloneDeriving #-}
16+{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
10{-# OPTIONS_GHC -fcontext-stack=100 #-}
19{-# OPTIONS_GHC -fcontext-stack=100 #-}
11{-# OPTIONS_GHC -fno-warn-orphans #-}
20{-# OPTIONS_GHC -fno-warn-orphans #-}
12
21
@@ -20,20 +29,20 @@ import Control.Concurrent
20import Control.Exception
29import Control.Exception
21import Control.Monad.Trans.Except
30import Control.Monad.Trans.Except
22import Data.Aeson
31import Data.Aeson
23−import Data.ByteString.Lazy (ByteString)
24import Data.Char
32import Data.Char
25import Data.Foldable (forM_)
33import Data.Foldable (forM_)
26−import Data.Monoid
34+import Data.Monoid hiding (getLast)
27import Data.Proxy
35import Data.Proxy
28import qualified Data.Text as T
36import qualified Data.Text as T
29import GHC.Generics
37import GHC.Generics
38+import GHC.TypeLits
30import qualified Network.HTTP.Client as C
39import qualified Network.HTTP.Client as C
31import Network.HTTP.Media
40import Network.HTTP.Media
32import Network.HTTP.Types hiding (Header)
41import Network.HTTP.Types hiding (Header)
33−import qualified Network.HTTP.Types as HTTP
34import Network.Socket
42import Network.Socket
35import Network.Wai hiding (Response)
43import Network.Wai hiding (Response)
36import Network.Wai.Handler.Warp
44import Network.Wai.Handler.Warp
45+import System.IO.Unsafe (unsafePerformIO)
37import Test.Hspec
46import Test.Hspec
38import Test.Hspec.QuickCheck
47import Test.Hspec.QuickCheck
39import Test.HUnit
48import Test.HUnit
@@ -43,6 +52,12 @@ import Servant.API
43import Servant.Client
52import Servant.Client
44import Servant.Server
53import Servant.Server
45
54
55+spec :: Spec
56+spec = describe "Servant.Client" $ do
57+ sucessSpec
58+ failSpec
59+ wrappedApiSpec
60+
46-- * test data types
61-- * test data types
47
62
48data Person = Person {
63data Person = Person {
@@ -122,8 +137,6 @@ server = serve api (
122 :<|> return ()
137 :<|> return ()
123 )
138 )
124
139
125−withServer :: (BaseUrl -> IO a) -> IO a
126−withServer action = withWaiDaemon (return server) action
127
140
128type FailApi =
141type FailApi =
129 "get" :> Raw
142 "get" :> Raw
@@ -139,93 +152,72 @@ failServer = serve failApi (
139 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
152 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
140 )
153 )
141
154
142−withFailServer :: (BaseUrl -> IO a) -> IO a
155+{-# NOINLINE manager #-}
143−withFailServer action = withWaiDaemon (return failServer) action
156+manager :: C.Manager
144−
145−spec :: IO ()
146−spec = withServer $ \ baseUrl -> do
147− manager <- C.newManager C.defaultManagerSettings
157+manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
148− let getGet :: ExceptT ServantError IO Person
158+
149− getDeleteEmpty :: ExceptT ServantError IO ()
159+sucessSpec :: Spec
150− getCapture :: String -> ExceptT ServantError IO Person
160+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
151− getBody :: Person -> ExceptT ServantError IO Person
161+
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
162+ it "Servant.API.Get" $ \(_, baseUrl) -> do
163+ let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
182 (left show <$> runExceptT getGet) `shouldReturn` Right alice
164 (left show <$> runExceptT getGet) `shouldReturn` Right alice
183
165
184 describe "Servant.API.Delete" $ do
166 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
186 (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
169 (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
187
170
188− it "allows content type" $ do
171+ it "allows content type" $ \(_, baseUrl) -> do
172+ let getDeleteContentType = getLast $ client api baseUrl manager
189 (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
173 (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
190
174
191− it "Servant.API.Capture" $ do
175+ it "Servant.API.Capture" $ \(_, baseUrl) -> do
176+ let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
192 (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
177 (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
193
178
194− it "Servant.API.ReqBody" $ do
179+ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
195 let p = Person "Clara" 42
180 let p = Person "Clara" 42
181+ getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager
196 (left show <$> runExceptT (getBody p)) `shouldReturn` Right p
182 (left show <$> runExceptT (getBody p)) `shouldReturn` Right p
197
183
198− it "Servant.API.QueryParam" $ do
184+ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
185+ let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager
199 left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
186 left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
200 Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
187 Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
201 responseStatus `shouldBe` Status 400 "bob not found"
188 responseStatus `shouldBe` Status 400 "bob not found"
202
189
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
204 (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
192 (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
205 (left show <$> runExceptT (getQueryParams ["alice", "bob"]))
193 (left show <$> runExceptT (getQueryParams ["alice", "bob"]))
206 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
194 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
207
195
208 context "Servant.API.QueryParam.QueryFlag" $
196 context "Servant.API.QueryParam.QueryFlag" $
209− forM_ [False, True] $ \ flag ->
197+ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
210− it (show flag) $ do
198+ let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager
211 (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
199 (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
212
200
213− it "Servant.API.MatrixParam" $ do
201+ it "Servant.API.MatrixParam" $ \(_, baseUrl) -> do
202+ let getMatrixParam = getNth (Proxy :: Proxy 7) $ client api baseUrl manager
214 left show <$> runExceptT (getMatrixParam (Just "alice")) `shouldReturn` Right alice
203 left show <$> runExceptT (getMatrixParam (Just "alice")) `shouldReturn` Right alice
215 Left FailureResponse{..} <- runExceptT (getMatrixParam (Just "bob"))
204 Left FailureResponse{..} <- runExceptT (getMatrixParam (Just "bob"))
216 responseStatus `shouldBe` Status 400 "bob not found"
205 responseStatus `shouldBe` Status 400 "bob not found"
217
206
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
219 left show <$> runExceptT (getMatrixParams []) `shouldReturn` Right []
209 left show <$> runExceptT (getMatrixParams []) `shouldReturn` Right []
220 left show <$> runExceptT (getMatrixParams ["alice", "bob"])
210 left show <$> runExceptT (getMatrixParams ["alice", "bob"])
221 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
211 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
222
212
223 context "Servant.API.MatrixParam.MatrixFlag" $
213 context "Servant.API.MatrixParam.MatrixFlag" $
224 forM_ [False, True] $ \ flag ->
214 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
226 left show <$> runExceptT (getMatrixFlag flag) `shouldReturn` Right flag
217 left show <$> runExceptT (getMatrixFlag flag) `shouldReturn` Right flag
227
218
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
229 res <- runExceptT (getRawSuccess methodGet)
221 res <- runExceptT (getRawSuccess methodGet)
230 case res of
222 case res of
231 Left e -> assertFailure $ show e
223 Left e -> assertFailure $ show e
@@ -234,7 +226,8 @@ spec = withServer $ \ baseUrl -> do
234 C.responseBody response `shouldBe` body
226 C.responseBody response `shouldBe` body
235 C.responseStatus response `shouldBe` ok200
227 C.responseStatus response `shouldBe` ok200
236
228
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
238 res <- runExceptT (getRawFailure methodGet)
231 res <- runExceptT (getRawFailure methodGet)
239 case res of
232 case res of
240 Left e -> assertFailure $ show e
233 Left e -> assertFailure $ show e
@@ -243,81 +236,75 @@ spec = withServer $ \ baseUrl -> do
243 C.responseBody response `shouldBe` body
236 C.responseBody response `shouldBe` body
244 C.responseStatus response `shouldBe` badRequest400
237 C.responseStatus response `shouldBe` badRequest400
245
238
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
247 res <- runExceptT getRespHeaders
241 res <- runExceptT getRespHeaders
248 case res of
242 case res of
249 Left e -> assertFailure $ show e
243 Left e -> assertFailure $ show e
250 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
244 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
251
245
252 modifyMaxSuccess (const 20) $ do
246 modifyMaxSuccess (const 20) $ do
253− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
247+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
248+ let getMultiple = getNth (Proxy :: Proxy 12) $ client api baseUrl manager
254− property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
249+ in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
255 ioProperty $ do
250 ioProperty $ do
256 result <- left show <$> runExceptT (getMultiple cap num flag body)
251 result <- left show <$> runExceptT (getMultiple cap num flag body)
257 return $
252 return $
258 result === Right (cap, num, flag, body)
253 result === Right (cap, num, flag, body)
259
254
260
255
256+wrappedApiSpec :: Spec
261− context "client correctly handles error status codes" $ do
257+wrappedApiSpec = describe "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" "" []))) $
258+ let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
266− \ host -> do
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
267− let getResponse :: ExceptT ServantError IO ()
263+ let getResponse :: ExceptT ServantError IO ()
268− getResponse = client api host manager
264+ getResponse = client api baseUrl manager
269− Left FailureResponse{..} <- runExceptT getResponse
265+ Left FailureResponse{..} <- runExceptT getResponse
270− responseStatus `shouldBe` (Status 500 "error message")
266+ responseStatus `shouldBe` (Status 500 "error message")
271− mapM_ test $
267+ in mapM_ test $
272 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
268 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
273 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
269 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
274 (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
270 (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
275 (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
271 (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
276 []
272 []
277
273
278−failSpec :: IO ()
274+failSpec :: Spec
279−failSpec = withFailServer $ \ baseUrl -> do
275+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
280− manager <- C.newManager C.defaultManagerSettings
276+
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
295 context "client returns errors appropriately" $ do
277 context "client returns errors appropriately" $ do
296− it "reports FailureResponse" $ do
278+ it "reports FailureResponse" $ \(_, baseUrl) -> do
279+ let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager
297 Left res <- runExceptT getDeleteEmpty
280 Left res <- runExceptT getDeleteEmpty
298 case res of
281 case res of
299 FailureResponse (Status 404 "Not Found") _ _ -> return ()
282 FailureResponse (Status 404 "Not Found") _ _ -> return ()
300 _ -> fail $ "expected 404 response, but got " <> show res
283 _ -> fail $ "expected 404 response, but got " <> show res
301
284
302− it "reports DecodeFailure" $ do
285+ it "reports DecodeFailure" $ \(_, baseUrl) -> do
286+ let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager
303 Left res <- runExceptT (getCapture "foo")
287 Left res <- runExceptT (getCapture "foo")
304 case res of
288 case res of
305 DecodeFailure _ ("application/json") _ -> return ()
289 DecodeFailure _ ("application/json") _ -> return ()
306 _ -> fail $ "expected DecodeFailure, but got " <> show res
290 _ -> fail $ "expected DecodeFailure, but got " <> show res
307
291
308− it "reports ConnectionError" $ do
292+ it "reports ConnectionError" $ \_ -> do
293+ let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
309 Left res <- runExceptT getGetWrongHost
294 Left res <- runExceptT getGetWrongHost
310 case res of
295 case res of
311 ConnectionError _ -> return ()
296 ConnectionError _ -> return ()
312 _ -> fail $ "expected ConnectionError, but got " <> show res
297 _ -> fail $ "expected ConnectionError, but got " <> show res
313
298
314− it "reports UnsupportedContentType" $ do
299+ it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
300+ let (getGet :<|> _ ) = client api baseUrl manager
315 Left res <- runExceptT getGet
301 Left res <- runExceptT getGet
316 case res of
302 case res of
317 UnsupportedContentType ("application/octet-stream") _ -> return ()
303 UnsupportedContentType ("application/octet-stream") _ -> return ()
318 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
304 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
319
305
320− it "reports InvalidContentTypeHeader" $ do
306+ it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
307+ let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager
321 Left res <- runExceptT (getBody alice)
308 Left res <- runExceptT (getBody alice)
322 case res of
309 case res of
323 InvalidContentTypeHeader "fooooo" _ -> return ()
310 InvalidContentTypeHeader "fooooo" _ -> return ()
@@ -331,36 +318,16 @@ data WrappedApi where
331
318
332-- * utils
319-- * utils
333
320
334−withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
321+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
335−withWaiDaemon mkApplication action = do
322+startWaiApp app = 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
323+ (port, 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
324+ let settings = setPort port $ defaultSettings
349− runSettingsSocket settings socket application)
325+ thread <- forkIO $ runSettingsSocket settings socket app
350− `finally` notifyKilled ()
351− krakenPort <- waitForStart
352− let baseUrl = (BaseUrl Http "localhost" 80 ""){baseUrlPort = krakenPort}
326+ return (thread, BaseUrl Http "localhost" port "")
353− return (thread, waitForKilled, baseUrl)
327+
354− free (thread, waitForKilled, _) = do
328+
329+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
355− killThread thread
330+endWaiApp (thread, _) = 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)
364
331
365openTestSocket :: IO (Port, Socket)
332openTestSocket :: IO (Port, Socket)
366openTestSocket = do
333openTestSocket = do
@@ -378,3 +345,37 @@ pathGen = fmap NonEmpty path
378 filter (not . (`elem` ("?%[]/#;" :: String))) $
345 filter (not . (`elem` ("?%[]/#;" :: String))) $
379 filter isPrint $
346 filter isPrint $
380 map chr [0..127]
347 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
servant-client/test/Servant/Common/BaseUrlSpec.hs+31−18
@@ -13,60 +13,73 @@ import Servant.Common.BaseUrl
13
13
14spec :: Spec
14spec :: Spec
15spec = do
15spec = do
16+ let parse = parseBaseUrl :: String -> Maybe BaseUrl
16 describe "showBaseUrl" $ do
17 describe "showBaseUrl" $ do
17 it "shows a BaseUrl" $ do
18 it "shows a BaseUrl" $ do
18− showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
19+ showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com"
19−
20 it "shows a https BaseUrl" $ do
20 it "shows a https BaseUrl" $ do
21− showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
21+ showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com"
22+ it "shows the path of a BaseUrl" $ do
23+ showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api"
24+ it "shows the path of an https BaseUrl" $ do
25+ showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api"
26+ it "handles leading slashes in path" $ do
27+ showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api"
22
28
23 describe "httpBaseUrl" $ do
29 describe "httpBaseUrl" $ do
24 it "allows to construct default http BaseUrls" $ do
30 it "allows to construct default http BaseUrls" $ do
25− BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
31+ BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 ""
26
32
27 describe "parseBaseUrl" $ do
33 describe "parseBaseUrl" $ do
28 it "is total" $ do
34 it "is total" $ do
29 property $ \ string ->
35 property $ \ string ->
30− deepseq (fmap show (parseBaseUrl string)) True
36+ deepseq (fmap show (parse string )) True
31
37
32 it "is the inverse of showBaseUrl" $ do
38 it "is the inverse of showBaseUrl" $ do
33− property $ \ baseUrl ->
34− counterexample (showBaseUrl baseUrl) $
39+ property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $
35− parseBaseUrl (showBaseUrl baseUrl) ===
40+ parse (showBaseUrl baseUrl) === Just baseUrl
36− Right baseUrl
41+
42+ context "trailing slashes" $ do
43+ it "allows trailing slashes" $ do
44+ parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")
37
45
38− it "allows trailing slashes" $ do
46+ it "allows trailing slashes in paths" $ do
39− parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
47+ parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")
40
48
41 context "urls without scheme" $ do
49 context "urls without scheme" $ do
42 it "assumes http" $ do
50 it "assumes http" $ do
43− parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
51+ parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")
44
52
45 it "allows port numbers" $ do
53 it "allows port numbers" $ do
46− parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
54+ parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "")
55+
56+ it "can parse paths" $ do
57+ parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")
47
58
48 it "rejects ftp urls" $ do
59 it "rejects ftp urls" $ do
49− parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
60+ parse "ftp://foo.com" `shouldBe` Nothing
50
61
51instance Arbitrary BaseUrl where
62instance Arbitrary BaseUrl where
52 arbitrary = BaseUrl <$>
63 arbitrary = BaseUrl <$>
53 elements [Http, Https] <*>
64 elements [Http, Https] <*>
54 hostNameGen <*>
65 hostNameGen <*>
55− portGen
66+ portGen <*>
67+ pathGen
56 where
68 where
69+ letters = ['a' .. 'z'] ++ ['A' .. 'Z']
57 -- this does not perfectly mirror the url standard, but I hope it's good
70 -- this does not perfectly mirror the url standard, but I hope it's good
58 -- enough.
71 -- enough.
59 hostNameGen = do
72 hostNameGen = do
60− let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
61 first <- elements letters
73 first <- elements letters
62 middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
74 middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
63− last <- elements letters
75+ last' <- elements letters
64− return (first : middle ++ [last])
76+ return (first : middle ++ [last'])
65 portGen = frequency $
77 portGen = frequency $
66 (1, return 80) :
78 (1, return 80) :
67 (1, return 443) :
79 (1, return 443) :
68 (1, choose (1, 20000)) :
80 (1, choose (1, 20000)) :
69 []
81 []
82+ pathGen = listOf1 . elements $ letters
70
83
71isLeft :: Either a b -> Bool
84isLeft :: Either a b -> Bool
72isLeft = either (const True) (const False)
85isLeft = either (const True) (const False)
servant-client/test/Spec.hs+1−7
@@ -1,7 +1 @@
1−import Servant.ClientSpec (failSpec, spec)
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2−
3−main :: IO ()
4−main = do
5− spec
6− failSpec
7−