From 8cf4acf2fc4dc07b77ce8f9818908b79174f3b27 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Mon, 5 Oct 2015 00:51:32 +0200 Subject: [PATCH 1/8] Fix servant-client tests to properly use hspec-discover. For some reason hspec-discover wasn't enabled for servant-client, causing test cases to be skipped and fasely reporting servant-client as test-passing whilst it was actually supposed to fail the tests. For example, we redefined BaseUrl recently to have a path field, but the tests don't reflect that yet but passed anyway. Because the test case wasn't even discovered and run. --- servant-client/test/Spec.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/servant-client/test/Spec.hs b/servant-client/test/Spec.hs index 97681f8d..038e7c8e 100644 --- a/servant-client/test/Spec.hs +++ b/servant-client/test/Spec.hs @@ -1,7 +1,2 @@ -import Servant.ClientSpec (failSpec, spec) - -main :: IO () -main = do - spec - failSpec +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From b38917959059e31785b41f194d1d606960ee9e55 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Mon, 5 Oct 2015 09:40:53 +0200 Subject: [PATCH 2/8] Modify BaseUrl tests and add some new BaseUrl tests to check if paths are correctly used --- .../test/Servant/Common/BaseUrlSpec.hs | 31 +++++++++++++------ 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs index cf615f9c..43782a90 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -15,14 +15,17 @@ spec :: Spec spec = do describe "showBaseUrl" $ do it "shows a BaseUrl" $ do - showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com" - + showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com" it "shows a https BaseUrl" $ do - showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com" + showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com" + it "shows the path of a BaseUrl" $ do + showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api" + it "shows the path of an https BaseUrl" $ do + showBaseUrl (BaseUrl Https "foo.com" 80 "api") `shouldBe` "https://foo.com/api" describe "httpBaseUrl" $ do it "allows to construct default http BaseUrls" $ do - BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80 + BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 "" describe "parseBaseUrl" $ do it "is total" $ do @@ -35,15 +38,21 @@ spec = do parseBaseUrl (showBaseUrl baseUrl) === Right baseUrl - it "allows trailing slashes" $ do - parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80) + context "trailing slashes" $ do + it "allows trailing slashes" $ do + parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80 "") + it "allows trailing slashes in paths" $ do + parseBaseUrl "foo.com/api/" `shouldBe` Right (BaseUrl Http "foo.com" 80 "api") context "urls without scheme" $ do it "assumes http" $ do - parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80) + parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do - parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080) + parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080 "") + + it "can parse paths" $ do + parseBaseUrl "http://foo.com/api" `shouldBe` Right (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft @@ -52,12 +61,13 @@ instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> elements [Http, Https] <*> hostNameGen <*> - portGen + portGen <*> + pathGen where + letters = ['a' .. 'z'] ++ ['A' .. 'Z'] -- this does not perfectly mirror the url standard, but I hope it's good -- enough. hostNameGen = do - let letters = ['a' .. 'z'] ++ ['A' .. 'Z'] first <- elements letters middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-']) last <- elements letters @@ -67,6 +77,7 @@ instance Arbitrary BaseUrl where (1, return 443) : (1, choose (1, 20000)) : [] + pathGen = listOf1 . elements $ letters isLeft :: Either a b -> Bool isLeft = either (const True) (const False) From fce1c8d2a4bf257ef2c140a7a668af6275a64364 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Tue, 6 Oct 2015 14:32:25 +0200 Subject: [PATCH 3/8] WIP: Work on fixing servant-client tests --- .../test/Servant/Common/BaseUrlSpec.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs index 43782a90..dc396f23 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -30,32 +30,33 @@ spec = do describe "parseBaseUrl" $ do it "is total" $ do property $ \ string -> - deepseq (fmap show (parseBaseUrl string)) True + deepseq (fmap show (parseBaseUrl string :: Maybe BaseUrl)) True it "is the inverse of showBaseUrl" $ do property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $ - parseBaseUrl (showBaseUrl baseUrl) === - Right baseUrl + (parseBaseUrl (showBaseUrl baseUrl) :: Maybe BaseUrl) === + Just baseUrl context "trailing slashes" $ do it "allows trailing slashes" $ do - parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80 "") + (parseBaseUrl "foo.com/" :: Maybe BaseUrl)`shouldBe` Just (BaseUrl Http "foo.com" 80 "") + it "allows trailing slashes in paths" $ do - parseBaseUrl "foo.com/api/" `shouldBe` Right (BaseUrl Http "foo.com" 80 "api") + (parseBaseUrl "foo.com/api/" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") context "urls without scheme" $ do it "assumes http" $ do - parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80 "") + (parseBaseUrl "foo.com" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do - parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080 "") + (parseBaseUrl "foo.com:8080" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") it "can parse paths" $ do - parseBaseUrl "http://foo.com/api" `shouldBe` Right (BaseUrl Http "foo.com" 80 "api") + (parseBaseUrl "http://foo.com/api" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do - parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft + (parseBaseUrl "ftp://foo.com" :: Maybe BaseUrl) `shouldBe` Nothing instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> From 59d88248881fbd914c6e12f6b09fac5f2af0df86 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Oct 2015 17:50:29 +0200 Subject: [PATCH 4/8] remove 'hspec' call in servant-client tests --- servant-client/test/Servant/ClientSpec.hs | 235 ++++++++++------------ servant-client/test/Spec.hs | 1 - 2 files changed, 106 insertions(+), 130 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 9db7c1a9..00caf9b4 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -1,12 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,20 +27,20 @@ import Control.Concurrent import Control.Exception import Control.Monad.Trans.Except import Data.Aeson -import Data.ByteString.Lazy (ByteString) import Data.Char import Data.Foldable (forM_) import Data.Monoid import Data.Proxy import qualified Data.Text as T import GHC.Generics +import GHC.TypeLits import qualified Network.HTTP.Client as C import Network.HTTP.Media import Network.HTTP.Types hiding (Header) -import qualified Network.HTTP.Types as HTTP import Network.Socket import Network.Wai hiding (Response) import Network.Wai.Handler.Warp +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit @@ -43,6 +50,12 @@ import Servant.API import Servant.Client import Servant.Server +spec :: Spec +spec = describe "Servant.Client" $ do + sucessSpec + failSpec + wrappedApiSpec + -- * test data types data Person = Person { @@ -122,8 +135,6 @@ server = serve api ( :<|> return () ) -withServer :: (BaseUrl -> IO a) -> IO a -withServer action = withWaiDaemon (return server) action type FailApi = "get" :> Raw @@ -139,93 +150,72 @@ failServer = serve failApi ( :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") ) -withFailServer :: (BaseUrl -> IO a) -> IO a -withFailServer action = withWaiDaemon (return failServer) action +{-# NOINLINE manager #-} +manager :: C.Manager +manager = unsafePerformIO $ C.newManager C.defaultManagerSettings -spec :: IO () -spec = withServer $ \ baseUrl -> do - manager <- C.newManager C.defaultManagerSettings - let getGet :: ExceptT ServantError IO Person - getDeleteEmpty :: ExceptT ServantError IO () - getCapture :: String -> ExceptT ServantError IO Person - getBody :: Person -> ExceptT ServantError IO Person - getQueryParam :: Maybe String -> ExceptT ServantError IO Person - getQueryParams :: [String] -> ExceptT ServantError IO [Person] - getQueryFlag :: Bool -> ExceptT ServantError IO Bool - getMatrixParam :: Maybe String -> ExceptT ServantError IO Person - getMatrixParams :: [String] -> ExceptT ServantError IO [Person] - getMatrixFlag :: Bool -> ExceptT ServantError IO Bool - getRawSuccess :: Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) - getRawFailure :: Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) - getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ExceptT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) - getRespHeaders :: ExceptT ServantError IO (Headers TestHeaders Bool) - getDeleteContentType :: ExceptT ServantError IO () - ( getGet - :<|> getDeleteEmpty - :<|> getCapture - :<|> getBody - :<|> getQueryParam - :<|> getQueryParams - :<|> getQueryFlag - :<|> getMatrixParam - :<|> getMatrixParams - :<|> getMatrixFlag - :<|> getRawSuccess - :<|> getRawFailure - :<|> getMultiple - :<|> getRespHeaders - :<|> getDeleteContentType) - = client api baseUrl manager +sucessSpec :: Spec +sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do - hspec $ do - it "Servant.API.Get" $ do + it "Servant.API.Get" $ \(_, baseUrl) -> do + let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager (left show <$> runExceptT getGet) `shouldReturn` Right alice describe "Servant.API.Delete" $ do - it "allows empty content type" $ do + it "allows empty content type" $ \(_, baseUrl) -> do + let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () - it "allows content type" $ do - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () + {-it "allows content type" $ \(_, baseUrl) -> do-} + {-let getDeleteContentType = getNth (Proxy :: Proxy 14) $ client api baseUrl manager-} + {-(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()-} - it "Servant.API.Capture" $ do + it "Servant.API.Capture" $ \(_, baseUrl) -> do + let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) - it "Servant.API.ReqBody" $ do + it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 + getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager (left show <$> runExceptT (getBody p)) `shouldReturn` Right p - it "Servant.API.QueryParam" $ do + it "Servant.API.QueryParam" $ \(_, baseUrl) -> do + let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) responseStatus `shouldBe` Status 400 "bob not found" - it "Servant.API.QueryParam.QueryParams" $ do + it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do + let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] (left show <$> runExceptT (getQueryParams ["alice", "bob"])) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ - forM_ [False, True] $ \ flag -> - it (show flag) $ do + forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do + let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag - it "Servant.API.MatrixParam" $ do + it "Servant.API.MatrixParam" $ \(_, baseUrl) -> do + let getMatrixParam = getNth (Proxy :: Proxy 7) $ client api baseUrl manager left show <$> runExceptT (getMatrixParam (Just "alice")) `shouldReturn` Right alice Left FailureResponse{..} <- runExceptT (getMatrixParam (Just "bob")) responseStatus `shouldBe` Status 400 "bob not found" - it "Servant.API.MatrixParam.MatrixParams" $ do + it "Servant.API.MatrixParam.MatrixParams" $ \(_, baseUrl) -> do + let getMatrixParams = getNth (Proxy :: Proxy 8) $ client api baseUrl manager left show <$> runExceptT (getMatrixParams []) `shouldReturn` Right [] left show <$> runExceptT (getMatrixParams ["alice", "bob"]) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.MatrixParam.MatrixFlag" $ forM_ [False, True] $ \ flag -> - it (show flag) $ do + it (show flag) $ \(_, baseUrl) -> do + let getMatrixFlag = getNth (Proxy :: Proxy 9) $ client api baseUrl manager left show <$> runExceptT (getMatrixFlag flag) `shouldReturn` Right flag - it "Servant.API.Raw on success" $ do + it "Servant.API.Raw on success" $ \(_, baseUrl) -> do + let getRawSuccess = getNth (Proxy :: Proxy 10) $ client api baseUrl manager res <- runExceptT (getRawSuccess methodGet) case res of Left e -> assertFailure $ show e @@ -234,7 +224,8 @@ spec = withServer $ \ baseUrl -> do C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` ok200 - it "Servant.API.Raw on failure" $ do + it "Servant.API.Raw on failure" $ \(_, baseUrl) -> do + let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager res <- runExceptT (getRawFailure methodGet) case res of Left e -> assertFailure $ show e @@ -243,81 +234,75 @@ spec = withServer $ \ baseUrl -> do C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` badRequest400 - it "Returns headers appropriately" $ withServer $ \ _ -> do + it "Returns headers appropriately" $ \(_, baseUrl) -> do + let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager res <- runExceptT getRespHeaders case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] modifyMaxSuccess (const 20) $ do - it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ - property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> + let getMultiple = getNth (Proxy :: Proxy 12) $ client api baseUrl manager + in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do result <- left show <$> runExceptT (getMultiple cap num flag body) return $ result === Right (cap, num, flag, body) - context "client correctly handles error status codes" $ do - let test :: (WrappedApi, String) -> Spec - test (WrappedApi api, desc) = - it desc $ - withWaiDaemon (return (serve api (throwE $ ServantErr 500 "error message" "" []))) $ - \ host -> do - let getResponse :: ExceptT ServantError IO () - getResponse = client api host manager - Left FailureResponse{..} <- runExceptT getResponse - responseStatus `shouldBe` (Status 500 "error message") - mapM_ test $ +wrappedApiSpec :: Spec +wrappedApiSpec = describe "error status codes" $ do + let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + context "are correctly handled by the client" $ + let test :: (WrappedApi, String) -> Spec + test (WrappedApi api, desc) = + it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do + let getResponse :: ExceptT ServantError IO () + getResponse = client api baseUrl manager + Left FailureResponse{..} <- runExceptT getResponse + responseStatus `shouldBe` (Status 500 "error message") + in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : [] -failSpec :: IO () -failSpec = withFailServer $ \ baseUrl -> do - manager <- C.newManager C.defaultManagerSettings - let getGet :: ExceptT ServantError IO Person - getDeleteEmpty :: ExceptT ServantError IO () - getCapture :: String -> ExceptT ServantError IO Person - getBody :: Person -> ExceptT ServantError IO Person - ( getGet - :<|> getDeleteEmpty - :<|> getCapture - :<|> getBody - :<|> _ ) - = client api baseUrl manager - getGetWrongHost :: ExceptT ServantError IO Person - (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager +failSpec :: Spec +failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do - hspec $ do context "client returns errors appropriately" $ do - it "reports FailureResponse" $ do + it "reports FailureResponse" $ \(_, baseUrl) -> do + let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager Left res <- runExceptT getDeleteEmpty case res of FailureResponse (Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res - it "reports DecodeFailure" $ do + it "reports DecodeFailure" $ \(_, baseUrl) -> do + let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager Left res <- runExceptT (getCapture "foo") case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res - it "reports ConnectionError" $ do + it "reports ConnectionError" $ \_ -> do + let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager Left res <- runExceptT getGetWrongHost case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res - it "reports UnsupportedContentType" $ do + it "reports UnsupportedContentType" $ \(_, baseUrl) -> do + let (getGet :<|> _ ) = client api baseUrl manager Left res <- runExceptT getGet case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res - it "reports InvalidContentTypeHeader" $ do + it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do + let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager Left res <- runExceptT (getBody alice) case res of InvalidContentTypeHeader "fooooo" _ -> return () @@ -331,36 +316,16 @@ data WrappedApi where -- * utils -withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a -withWaiDaemon mkApplication action = do - application <- mkApplication - bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl) - where - acquire application = do - (notifyStart, waitForStart) <- lvar - (notifyKilled, waitForKilled) <- lvar - thread <- forkIO $ (do - (krakenPort, socket) <- openTestSocket - let settings = - setPort krakenPort $ -- set here just for consistency, shouldn't be - -- used (it's set in the socket) - setBeforeMainLoop (notifyStart krakenPort) - defaultSettings - runSettingsSocket settings socket application) - `finally` notifyKilled () - krakenPort <- waitForStart - let baseUrl = (BaseUrl Http "localhost" 80 ""){baseUrlPort = krakenPort} - return (thread, waitForKilled, baseUrl) - free (thread, waitForKilled, _) = do - killThread thread - waitForKilled +startWaiApp :: Application -> IO (ThreadId, BaseUrl) +startWaiApp app = do + (port, socket) <- openTestSocket + let settings = setPort port $ defaultSettings + thread <- forkIO $ runSettingsSocket settings socket app + return (thread, BaseUrl Http "localhost" port "") - lvar :: IO (a -> IO (), IO a) - lvar = do - mvar <- newEmptyMVar - let put = putMVar mvar - wait = readMVar mvar - return (put, wait) + +endWaiApp :: (ThreadId, BaseUrl) -> IO () +endWaiApp (thread, _) = killThread thread openTestSocket :: IO (Port, Socket) openTestSocket = do @@ -378,3 +343,15 @@ pathGen = fmap NonEmpty path filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] + +class GetNth (n :: Nat) a b | n a -> b where + getNth :: Proxy n -> a -> b + +instance GetNth 0 (x :<|> y) x where + getNth _ (x :<|> _) = x + +{-instance GetNth 0 x x where-} + {-getNth _ = id-} + +instance (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where + getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x diff --git a/servant-client/test/Spec.hs b/servant-client/test/Spec.hs index 038e7c8e..a824f8c3 100644 --- a/servant-client/test/Spec.hs +++ b/servant-client/test/Spec.hs @@ -1,2 +1 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-} - From 47f4cec53b0c70d5c77974e55ddd67f940b6e91a Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Oct 2015 18:01:47 +0200 Subject: [PATCH 5/8] Cleanup BaseUrl tests --- .../test/Servant/Common/BaseUrlSpec.hs | 23 +++++++++---------- 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs index dc396f23..788daa02 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -13,6 +13,7 @@ import Servant.Common.BaseUrl spec :: Spec spec = do + let parse = parseBaseUrl :: String -> Maybe BaseUrl describe "showBaseUrl" $ do it "shows a BaseUrl" $ do showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com" @@ -30,33 +31,31 @@ spec = do describe "parseBaseUrl" $ do it "is total" $ do property $ \ string -> - deepseq (fmap show (parseBaseUrl string :: Maybe BaseUrl)) True + deepseq (fmap show (parse string )) True it "is the inverse of showBaseUrl" $ do property $ \ baseUrl -> - counterexample (showBaseUrl baseUrl) $ - (parseBaseUrl (showBaseUrl baseUrl) :: Maybe BaseUrl) === - Just baseUrl + counterexample (showBaseUrl baseUrl) $ parse (showBaseUrl baseUrl) === Just baseUrl context "trailing slashes" $ do it "allows trailing slashes" $ do - (parseBaseUrl "foo.com/" :: Maybe BaseUrl)`shouldBe` Just (BaseUrl Http "foo.com" 80 "") + parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows trailing slashes in paths" $ do - (parseBaseUrl "foo.com/api/" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") + parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") context "urls without scheme" $ do it "assumes http" $ do - (parseBaseUrl "foo.com" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "") + parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do - (parseBaseUrl "foo.com:8080" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") + parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") it "can parse paths" $ do - (parseBaseUrl "http://foo.com/api" :: Maybe BaseUrl) `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") + parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do - (parseBaseUrl "ftp://foo.com" :: Maybe BaseUrl) `shouldBe` Nothing + (parse "ftp://foo.com") `shouldBe` Nothing instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> @@ -71,8 +70,8 @@ instance Arbitrary BaseUrl where hostNameGen = do first <- elements letters middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-']) - last <- elements letters - return (first : middle ++ [last]) + last' <- elements letters + return (first : middle ++ [last']) portGen = frequency $ (1, return 80) : (1, return 443) : From 110196e23fbe2acb07d57cc22a2a97b0575d0c32 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Oct 2015 21:07:07 +0200 Subject: [PATCH 6/8] Fix path concatenation, Eq instance, for BaseUrl --- servant-client/src/Servant/Common/BaseUrl.hs | 11 +++++++++-- servant-client/test/Servant/Common/BaseUrlSpec.hs | 10 ++++++---- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 03ca21ed..5c3c190a 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -32,12 +32,19 @@ data BaseUrl = BaseUrl , baseUrlHost :: String -- ^ host (eg "haskell.org") , baseUrlPort :: Int -- ^ port (eg 80) , baseUrlPath :: String -- ^ path (eg "/a/b/c") - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Ord, Generic) + +instance Eq BaseUrl where + BaseUrl a b c path == BaseUrl a' b' c' path' + = a == a' && b == b' && c == c' && s path == s path' + where s ('/':x) = x + s x = x showBaseUrl :: BaseUrl -> String showBaseUrl (BaseUrl urlscheme host port path) = - schemeString ++ "//" ++ host ++ portString ++ path + schemeString ++ "//" ++ host ++ (portString path) where + a b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b schemeString = case urlscheme of Http -> "http:" Https -> "https:" diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs index 788daa02..afe541ba 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -22,7 +22,9 @@ spec = do it "shows the path of a BaseUrl" $ do showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api" it "shows the path of an https BaseUrl" $ do - showBaseUrl (BaseUrl Https "foo.com" 80 "api") `shouldBe` "https://foo.com/api" + showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api" + it "handles leading slashes in path" $ do + showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api" describe "httpBaseUrl" $ do it "allows to construct default http BaseUrls" $ do @@ -34,8 +36,8 @@ spec = do deepseq (fmap show (parse string )) True it "is the inverse of showBaseUrl" $ do - property $ \ baseUrl -> - counterexample (showBaseUrl baseUrl) $ parse (showBaseUrl baseUrl) === Just baseUrl + property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $ + parse (showBaseUrl baseUrl) === Just baseUrl context "trailing slashes" $ do it "allows trailing slashes" $ do @@ -55,7 +57,7 @@ spec = do parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do - (parse "ftp://foo.com") `shouldBe` Nothing + parse "ftp://foo.com" `shouldBe` Nothing instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> From 7529d7f77668c222444b28c27faaca2e67227e4a Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 8 Oct 2015 12:09:23 +0200 Subject: [PATCH 7/8] getLast (and last missing servant-client test) --- servant-client/test/Servant/ClientSpec.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 00caf9b4..4ea5cacf 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -29,7 +29,7 @@ import Control.Monad.Trans.Except import Data.Aeson import Data.Char import Data.Foldable (forM_) -import Data.Monoid +import Data.Monoid hiding (getLast) import Data.Proxy import qualified Data.Text as T import GHC.Generics @@ -166,9 +166,9 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () - {-it "allows content type" $ \(_, baseUrl) -> do-} - {-let getDeleteContentType = getNth (Proxy :: Proxy 14) $ client api baseUrl manager-} - {-(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()-} + it "allows content type" $ \(_, baseUrl) -> do + let getDeleteContentType = getLast $ client api baseUrl manager + (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () it "Servant.API.Capture" $ \(_, baseUrl) -> do let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager @@ -350,8 +350,14 @@ class GetNth (n :: Nat) a b | n a -> b where instance GetNth 0 (x :<|> y) x where getNth _ (x :<|> _) = x -{-instance GetNth 0 x x where-} - {-getNth _ = id-} - instance (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x + +class GetLast a b | a -> b where + getLast :: a -> b + +instance (GetLast b c) => GetLast (a :<|> b) c where + getLast (_ :<|> b) = getLast b + +instance GetLast a a where + getLast a = a From a08e64433343b1cbae46b3649025f498b167931b Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Fri, 9 Oct 2015 00:48:03 +0200 Subject: [PATCH 8/8] Add OVERLAPPING pragma to instances in ClientSpec --- servant-client/test/Servant/ClientSpec.hs | 36 +++++++++++++++++------ 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4ea5cacf..344f42ef 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -6,8 +6,10 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +#if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} +#endif +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -347,17 +349,33 @@ pathGen = fmap NonEmpty path class GetNth (n :: Nat) a b | n a -> b where getNth :: Proxy n -> a -> b -instance GetNth 0 (x :<|> y) x where - getNth _ (x :<|> _) = x +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetNth 0 (x :<|> y) x where + getNth _ (x :<|> _) = x -instance (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where - getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where + getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x class GetLast a b | a -> b where getLast :: a -> b -instance (GetLast b c) => GetLast (a :<|> b) c where - getLast (_ :<|> b) = getLast b +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (GetLast b c) => GetLast (a :<|> b) c where + getLast (_ :<|> b) = getLast b -instance GetLast a a where - getLast a = a +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetLast a a where + getLast a = a