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/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 9db7c1a9..344f42ef 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -1,12 +1,21 @@ -{-# 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 #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,20 +29,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.Monoid hiding (getLast) 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 +52,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 +137,6 @@ server = serve api ( :<|> return () ) -withServer :: (BaseUrl -> IO a) -> IO a -withServer action = withWaiDaemon (return server) action type FailApi = "get" :> Raw @@ -139,93 +152,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 + it "allows content type" $ \(_, baseUrl) -> do + let getDeleteContentType = getLast $ 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 +226,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 +236,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 +318,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 +345,37 @@ 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 +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetNth 0 (x :<|> y) x where + getNth _ (x :<|> _) = 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 +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + (GetLast b c) => GetLast (a :<|> b) c where + getLast (_ :<|> b) = getLast b + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + GetLast a a where + getLast a = a diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs index cf615f9c..afe541ba 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -13,60 +13,73 @@ 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" - + 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" 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 - 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 property $ \ string -> - deepseq (fmap show (parseBaseUrl string)) True + deepseq (fmap show (parse string )) True it "is the inverse of showBaseUrl" $ do - property $ \ baseUrl -> - counterexample (showBaseUrl baseUrl) $ - parseBaseUrl (showBaseUrl baseUrl) === - Right baseUrl + property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $ + parse (showBaseUrl baseUrl) === Just 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 + parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") + + it "allows trailing slashes in paths" $ do + parse "foo.com/api/" `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) + parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do - parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080) + parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") + + it "can parse paths" $ do + parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do - parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft + parse "ftp://foo.com" `shouldBe` Nothing 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 - return (first : middle ++ [last]) + last' <- elements letters + return (first : middle ++ [last']) portGen = frequency $ (1, return 80) : (1, return 443) : (1, choose (1, 20000)) : [] + pathGen = listOf1 . elements $ letters isLeft :: Either a b -> Bool isLeft = either (const True) (const False) diff --git a/servant-client/test/Spec.hs b/servant-client/test/Spec.hs index 97681f8d..a824f8c3 100644 --- a/servant-client/test/Spec.hs +++ b/servant-client/test/Spec.hs @@ -1,7 +1 @@ -import Servant.ClientSpec (failSpec, spec) - -main :: IO () -main = do - spec - failSpec - +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}