From a91cde109f9b846600a5ddb3009b58e2006f236b Mon Sep 17 00:00:00 2001 From: Mateusz Curylo Date: Sat, 16 Mar 2019 07:35:32 +0000 Subject: [PATCH] ClientSpec split into multiple modules --- servant-client/servant-client.cabal | 9 +- servant-client/test/Servant/BasicAuthSpec.hs | 53 ++ servant-client/test/Servant/ClientSpec.hs | 514 ------------------ .../test/Servant/ClientTestUtils.hs | 262 +++++++++ .../test/Servant/ConnectionErrorSpec.hs | 55 ++ servant-client/test/Servant/FailSpec.hs | 75 +++ servant-client/test/Servant/GenAuthSpec.hs | 54 ++ .../test/Servant/HoistClientSpec.hs | 58 ++ servant-client/test/Servant/StreamSpec.hs | 7 +- servant-client/test/Servant/SuccessSpec.hs | 140 +++++ servant-client/test/Servant/WrappedApiSpec.hs | 63 +++ 11 files changed, 771 insertions(+), 519 deletions(-) create mode 100644 servant-client/test/Servant/BasicAuthSpec.hs delete mode 100644 servant-client/test/Servant/ClientSpec.hs create mode 100644 servant-client/test/Servant/ClientTestUtils.hs create mode 100644 servant-client/test/Servant/ConnectionErrorSpec.hs create mode 100644 servant-client/test/Servant/FailSpec.hs create mode 100644 servant-client/test/Servant/GenAuthSpec.hs create mode 100644 servant-client/test/Servant/HoistClientSpec.hs create mode 100644 servant-client/test/Servant/SuccessSpec.hs create mode 100644 servant-client/test/Servant/WrappedApiSpec.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 73ee378b..84cfb2b1 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -89,8 +89,15 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: - Servant.ClientSpec + Servant.BasicAuthSpec + Servant.ClientTestUtils + Servant.ConnectionErrorSpec + Servant.FailSpec + Servant.GenAuthSpec + Servant.HoistClientSpec Servant.StreamSpec + Servant.SuccessSpec + Servant.WrappedApiSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: diff --git a/servant-client/test/Servant/BasicAuthSpec.hs b/servant-client/test/Servant/BasicAuthSpec.hs new file mode 100644 index 00000000..902c4da1 --- /dev/null +++ b/servant-client/test/Servant/BasicAuthSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.BasicAuthSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Arrow + (left) +import Data.Monoid () +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.API + (BasicAuthData (..)) +import Servant.Client +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.BasicAuthSpec" $ do + basicAuthSpec + +basicAuthSpec :: Spec +basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do + let getBasic = client basicAuthAPI + let basicAuthData = BasicAuthData "servant" "server" + left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do + let getBasic = client basicAuthAPI + let basicAuthData = BasicAuthData "not" "password" + Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl + responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs deleted file mode 100644 index f40fa3bc..00000000 --- a/servant-client/test/Servant/ClientSpec.hs +++ /dev/null @@ -1,514 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -freduction-depth=100 #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where - -import Prelude () -import Prelude.Compat - -import Control.Arrow - (left) -import Control.Concurrent - (ThreadId, forkIO, killThread) -import Control.Concurrent.STM - (atomically) -import Control.Concurrent.STM.TVar - (newTVar, readTVar) -import Control.Exception - (bracket, fromException) -import Control.Monad.Error.Class - (throwError) -import Data.Aeson -import Data.Char - (chr, isPrint) -import Data.Foldable - (forM_, toList) -import Data.Maybe - (isJust, listToMaybe) -import Data.Monoid () -import Data.Proxy -import Data.Semigroup - ((<>)) -import GHC.Generics - (Generic) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP -import Network.Socket -import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp -import System.IO.Unsafe - (unsafePerformIO) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.HUnit -import Test.QuickCheck -import Web.FormUrlEncoded - (FromForm, ToForm) - -import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, Delete, - DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag, - QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders) -import Servant.Client -import qualified Servant.Client.Core.Auth as Auth -import qualified Servant.Client.Core.Request as Req -import Servant.Server -import Servant.Server.Experimental.Auth -import Servant.Test.ComprehensiveAPI - --- This declaration simply checks that all instances are in place. -_ = client comprehensiveAPIWithoutStreaming - -spec :: Spec -spec = describe "Servant.Client" $ do - sucessSpec - failSpec - wrappedApiSpec - basicAuthSpec - genAuthSpec - hoistClientSpec - connectionErrorSpec - --- * test data types - -data Person = Person - { _name :: String - , _age :: Integer - } deriving (Eq, Show, Generic) - -instance ToJSON Person -instance FromJSON Person - -instance ToForm Person -instance FromForm Person - -instance Arbitrary Person where - arbitrary = Person <$> arbitrary <*> arbitrary - -alice :: Person -alice = Person "Alice" 42 - -carol :: Person -carol = Person "Carol" 17 - -type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] - -type Api = - Get '[JSON] Person - :<|> "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent - :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person - :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] - :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person - :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person - :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] - :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool - :<|> "rawSuccess" :> Raw - :<|> "rawFailure" :> Raw - :<|> "multiple" :> - Capture "first" String :> - QueryParam "second" Int :> - QueryFlag "third" :> - ReqBody '[JSON] [(String, [Rational])] :> - Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) - :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent - :<|> "redirectWithCookie" :> Raw - :<|> "empty" :> EmptyAPI - -api :: Proxy Api -api = Proxy - -getRoot :: ClientM Person -getGet :: ClientM Person -getDeleteEmpty :: ClientM NoContent -getCapture :: String -> ClientM Person -getCaptureAll :: [String] -> ClientM [Person] -getBody :: Person -> ClientM Person -getQueryParam :: Maybe String -> ClientM Person -getQueryParams :: [String] -> ClientM [Person] -getQueryFlag :: Bool -> ClientM Bool -getRawSuccess :: HTTP.Method -> ClientM Response -getRawFailure :: HTTP.Method -> ClientM Response -getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] - -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -getRespHeaders :: ClientM (Headers TestHeaders Bool) -getDeleteContentType :: ClientM NoContent -getRedirectWithCookie :: HTTP.Method -> ClientM Response - -getRoot - :<|> getGet - :<|> getDeleteEmpty - :<|> getCapture - :<|> getCaptureAll - :<|> getBody - :<|> getQueryParam - :<|> getQueryParams - :<|> getQueryFlag - :<|> getRawSuccess - :<|> getRawFailure - :<|> getMultiple - :<|> getRespHeaders - :<|> getDeleteContentType - :<|> getRedirectWithCookie - :<|> EmptyClient = client api - -server :: Application -server = serve api ( - return carol - :<|> return alice - :<|> return NoContent - :<|> (\ name -> return $ Person name 0) - :<|> (\ names -> return (zipWith Person names [0..])) - :<|> return - :<|> (\ name -> case name of - Just "alice" -> return alice - Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] - Nothing -> throwError $ ServerError 400 "missing parameter" "" []) - :<|> (\ names -> return (zipWith Person names [0..])) - :<|> return - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") - :<|> (\ a b c d -> return (a, b, c, d)) - :<|> (return $ addHeader 1729 $ addHeader "eg2" True) - :<|> return NoContent - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") - :<|> emptyServer) - -type FailApi = - "get" :> Raw - :<|> "capture" :> Capture "name" String :> Raw - :<|> "body" :> Raw -failApi :: Proxy FailApi -failApi = Proxy - -failServer :: Application -failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") - :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") - ) - --- * basic auth stuff - -type BasicAuthAPI = - BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person - -basicAuthAPI :: Proxy BasicAuthAPI -basicAuthAPI = Proxy - -basicAuthHandler :: BasicAuthCheck () -basicAuthHandler = - let check (BasicAuthData username password) = - if username == "servant" && password == "server" - then return (Authorized ()) - else return Unauthorized - in BasicAuthCheck check - -basicServerContext :: Context '[ BasicAuthCheck () ] -basicServerContext = basicAuthHandler :. EmptyContext - -basicAuthServer :: Application -basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) - --- * general auth stuff - -type GenAuthAPI = - AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person - -genAuthAPI :: Proxy GenAuthAPI -genAuthAPI = Proxy - -type instance AuthServerData (AuthProtect "auth-tag") = () -type instance Auth.AuthClientData (AuthProtect "auth-tag") = () - -genAuthHandler :: AuthHandler Wai.Request () -genAuthHandler = - let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of - Nothing -> throwError (err401 { errBody = "Missing auth header" }) - Just _ -> return () - in mkAuthHandler handler - -genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] -genAuthServerContext = genAuthHandler :. EmptyContext - -genAuthServer :: Application -genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) - -{-# NOINLINE manager' #-} -manager' :: C.Manager -manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings - -runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a) -runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') - -sucessSpec :: Spec -sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do - it "Servant.API.Get root" $ \(_, baseUrl) -> do - left show <$> runClient getRoot baseUrl `shouldReturn` Right carol - - it "Servant.API.Get" $ \(_, baseUrl) -> do - left show <$> runClient getGet baseUrl `shouldReturn` Right alice - - describe "Servant.API.Delete" $ do - it "allows empty content type" $ \(_, baseUrl) -> do - left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent - - it "allows content type" $ \(_, baseUrl) -> do - left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent - - it "Servant.API.Capture" $ \(_, baseUrl) -> do - left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) - - it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do - let expected = [(Person "Paula" 0), (Person "Peta" 1)] - left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected - - it "Servant.API.ReqBody" $ \(_, baseUrl) -> do - let p = Person "Clara" 42 - left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p - - it "Servant.API FailureResponse" $ \(_, baseUrl) -> do - left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice - Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl - Req.requestPath req `shouldBe` (baseUrl, "/param") - toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")] - Req.requestMethod req `shouldBe` HTTP.methodGet - - it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice - Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl - responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" - - it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] - left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl - `shouldReturn` Right [Person "alice" 0, Person "bob" 1] - - context "Servant.API.QueryParam.QueryFlag" $ - forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag - - it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runClient (getRawSuccess HTTP.methodGet) baseUrl - case res of - Left e -> assertFailure $ show e - Right r -> do - responseStatusCode r `shouldBe` HTTP.status200 - responseBody r `shouldBe` "rawSuccess" - - it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - res <- runClient (getRawFailure HTTP.methodGet) baseUrl - case res of - Right _ -> assertFailure "expected Left, but got Right" - Left (FailureResponse _ r) -> do - responseStatusCode r `shouldBe` HTTP.status400 - responseBody r `shouldBe` "rawFailure" - Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e - - it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- runClient getRespHeaders baseUrl - case res of - Left e -> assertFailure $ show e - Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] - - it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do - mgr <- C.newManager C.defaultManagerSettings - cj <- atomically . newTVar $ C.createCookieJar [] - _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj)) - cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) - C.cookie_name <$> cookie `shouldBe` Just "testcookie" - C.cookie_value <$> cookie `shouldBe` Just "test" - - modifyMaxSuccess (const 20) $ do - it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> - property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> - ioProperty $ do - result <- left show <$> runClient (getMultiple cap num flag body) baseUrl - return $ - result === Right (cap, num, flag, body) - - -wrappedApiSpec :: Spec -wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwError $ ServerError 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 :: ClientM () - getResponse = client api - Left (FailureResponse _ r) <- runClient getResponse baseUrl - responseStatusCode r `shouldBe` (HTTP.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 :: Spec -failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do - - context "client returns errors appropriately" $ do - it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api - Left res <- runClient getDeleteEmpty baseUrl - case res of - FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () - _ -> fail $ "expected 404 response, but got " <> show res - - it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api - Left res <- runClient (getCapture "foo") baseUrl - case res of - DecodeFailure _ _ -> return () - _ -> fail $ "expected DecodeFailure, but got " <> show res - - it "reports ConnectionError" $ \_ -> do - let (getGetWrongHost :<|> _) = client api - Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") - case res of - ConnectionError _ -> return () - _ -> fail $ "expected ConnectionError, but got " <> show res - - it "reports UnsupportedContentType" $ \(_, baseUrl) -> do - let (_ :<|> getGet :<|> _ ) = client api - Left res <- runClient getGet baseUrl - case res of - UnsupportedContentType ("application/octet-stream") _ -> return () - _ -> fail $ "expected UnsupportedContentType, but got " <> show res - - it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api - Left res <- runClient (getBody alice) baseUrl - case res of - InvalidContentTypeHeader _ -> return () - _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res - -data WrappedApi where - WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, - HasClient ClientM api, Client ClientM api ~ ClientM ()) => - Proxy api -> WrappedApi - -basicAuthSpec :: Spec -basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do - context "Authentication works when requests are properly authenticated" $ do - - it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI - let basicAuthData = BasicAuthData "servant" "server" - left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice - - context "Authentication is rejected when requests are not authenticated properly" $ do - - it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI - let basicAuthData = BasicAuthData "not" "password" - Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl - responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" - -genAuthSpec :: Spec -genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do - context "Authentication works when requests are properly authenticated" $ do - - it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do - let getProtected = client genAuthAPI - let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req) - left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice - - context "Authentication is rejected when requests are not authenticated properly" $ do - - it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do - let getProtected = client genAuthAPI - let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) - Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl - responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") - --- * hoistClient - -type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int - -hoistClientAPI :: Proxy HoistClientAPI -hoistClientAPI = Proxy - -hoistClientServer :: Application -- implements HoistClientAPI -hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n) - -hoistClientSpec :: Spec -hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do - describe "Servant.Client.hoistClient" $ do - it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do - let (getInt :<|> postInt) - = hoistClient hoistClientAPI - (fmap (either (error . show) id) . flip runClient baseUrl) - (client hoistClientAPI) - - getInt `shouldReturn` 5 - postInt 5 `shouldReturn` 5 - --- * ConnectionError -type ConnectionErrorAPI = Get '[JSON] Int - -connectionErrorAPI :: Proxy ConnectionErrorAPI -connectionErrorAPI = Proxy - -connectionErrorSpec :: Spec -connectionErrorSpec = describe "Servant.Client.ClientError" $ - it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do - let getInt = client connectionErrorAPI - let baseUrl' = BaseUrl Http "example.invalid" 80 "" - let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e - isHttpError _ = False - (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True - --- * utils - -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 "") - - -endWaiApp :: (ThreadId, BaseUrl) -> IO () -endWaiApp (thread, _) = killThread thread - -openTestSocket :: IO (Port, Socket) -openTestSocket = do - s <- socket AF_INET Stream defaultProtocol - let localhost = tupleToHostAddress (127, 0, 0, 1) - bind s (SockAddrInet defaultPort localhost) - listen s 1 - port <- socketPort s - return (fromIntegral port, s) - -pathGen :: Gen (NonEmptyList Char) -pathGen = fmap NonEmpty path - where - path = listOf1 $ elements $ - filter (not . (`elem` ("?%[]/#;" :: String))) $ - filter isPrint $ - map chr [0..127] diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs new file mode 100644 index 00000000..a483a405 --- /dev/null +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.ClientTestUtils where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent + (ThreadId, forkIO, killThread) +import Control.Monad.Error.Class + (throwError) +import Data.Aeson +import Data.Char + (chr, isPrint) +import Data.Monoid () +import Data.Proxy +import GHC.Generics + (Generic) +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP +import Network.Socket +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp +import System.IO.Unsafe + (unsafePerformIO) +import Test.QuickCheck +import Web.FormUrlEncoded + (FromForm, ToForm) + +import Servant.API + ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, + BasicAuthData (..), Capture, CaptureAll, + DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, + Headers, JSON, NoContent (NoContent), Post, QueryFlag, + QueryParam, QueryParams, Raw, ReqBody, addHeader) +import Servant.Client +import qualified Servant.Client.Core.Auth as Auth +import Servant.Server +import Servant.Server.Experimental.Auth +import Servant.Test.ComprehensiveAPI + +-- This declaration simply checks that all instances are in place. +_ = client comprehensiveAPIWithoutStreaming + +-- * test data types + +data Person = Person + { _name :: String + , _age :: Integer + } deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +instance ToForm Person +instance FromForm Person + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary + +alice :: Person +alice = Person "Alice" 42 + +carol :: Person +carol = Person "Carol" 17 + +type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] + +type Api = + Get '[JSON] Person + :<|> "get" :> Get '[JSON] Person + :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent + :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person + :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] + :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person + :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person + :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] + :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "rawSuccess" :> Raw + :<|> "rawFailure" :> Raw + :<|> "multiple" :> + Capture "first" String :> + QueryParam "second" Int :> + QueryFlag "third" :> + ReqBody '[JSON] [(String, [Rational])] :> + Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) + :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) + :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent + :<|> "redirectWithCookie" :> Raw + :<|> "empty" :> EmptyAPI + +api :: Proxy Api +api = Proxy + +getRoot :: ClientM Person +getGet :: ClientM Person +getDeleteEmpty :: ClientM NoContent +getCapture :: String -> ClientM Person +getCaptureAll :: [String] -> ClientM [Person] +getBody :: Person -> ClientM Person +getQueryParam :: Maybe String -> ClientM Person +getQueryParams :: [String] -> ClientM [Person] +getQueryFlag :: Bool -> ClientM Bool +getRawSuccess :: HTTP.Method -> ClientM Response +getRawFailure :: HTTP.Method -> ClientM Response +getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] + -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: ClientM (Headers TestHeaders Bool) +getDeleteContentType :: ClientM NoContent +getRedirectWithCookie :: HTTP.Method -> ClientM Response + +getRoot + :<|> getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getCaptureAll + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType + :<|> getRedirectWithCookie + :<|> EmptyClient = client api + +server :: Application +server = serve api ( + return carol + :<|> return alice + :<|> return NoContent + :<|> (\ name -> return $ Person name 0) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServerError 400 "missing parameter" "" []) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (\ a b c d -> return (a, b, c, d)) + :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> return NoContent + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") + :<|> emptyServer) + +type FailApi = + "get" :> Raw + :<|> "capture" :> Capture "name" String :> Raw + :<|> "body" :> Raw +failApi :: Proxy FailApi +failApi = Proxy + +failServer :: Application +failServer = serve failApi ( + (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + ) + +-- * basic auth stuff + +type BasicAuthAPI = + BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person + +basicAuthAPI :: Proxy BasicAuthAPI +basicAuthAPI = Proxy + +basicAuthHandler :: BasicAuthCheck () +basicAuthHandler = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized ()) + else return Unauthorized + in BasicAuthCheck check + +basicServerContext :: Context '[ BasicAuthCheck () ] +basicServerContext = basicAuthHandler :. EmptyContext + +basicAuthServer :: Application +basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) + +-- * general auth stuff + +type GenAuthAPI = + AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person + +genAuthAPI :: Proxy GenAuthAPI +genAuthAPI = Proxy + +type instance AuthServerData (AuthProtect "auth-tag") = () +type instance Auth.AuthClientData (AuthProtect "auth-tag") = () + +genAuthHandler :: AuthHandler Wai.Request () +genAuthHandler = + let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of + Nothing -> throwError (err401 { errBody = "Missing auth header" }) + Just _ -> return () + in mkAuthHandler handler + +genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] +genAuthServerContext = genAuthHandler :. EmptyContext + +genAuthServer :: Application +genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) + +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a) +runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') + +-- * utils + +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 "") + + +endWaiApp :: (ThreadId, BaseUrl) -> IO () +endWaiApp (thread, _) = killThread thread + +openTestSocket :: IO (Port, Socket) +openTestSocket = do + s <- socket AF_INET Stream defaultProtocol + let localhost = tupleToHostAddress (127, 0, 0, 1) + bind s (SockAddrInet defaultPort localhost) + listen s 1 + port <- socketPort s + return (fromIntegral port, s) + +pathGen :: Gen (NonEmptyList Char) +pathGen = fmap NonEmpty path + where + path = listOf1 $ elements $ + filter (not . (`elem` ("?%[]/#;" :: String))) $ + filter isPrint $ + map chr [0..127] diff --git a/servant-client/test/Servant/ConnectionErrorSpec.hs b/servant-client/test/Servant/ConnectionErrorSpec.hs new file mode 100644 index 00000000..0458f775 --- /dev/null +++ b/servant-client/test/Servant/ConnectionErrorSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.ConnectionErrorSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Exception + (fromException) +import Data.Maybe + (isJust) +import Data.Monoid () +import Data.Proxy +import qualified Network.HTTP.Client as C +import Test.Hspec + +import Servant.API + (Get, JSON) +import Servant.Client +import Servant.ClientTestUtils + + +spec :: Spec +spec = describe "Servant.ConnectionErrorSpec" $ do + connectionErrorSpec + +type ConnectionErrorAPI = Get '[JSON] Int + +connectionErrorAPI :: Proxy ConnectionErrorAPI +connectionErrorAPI = Proxy + +connectionErrorSpec :: Spec +connectionErrorSpec = describe "Servant.Client.ClientError" $ + it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do + let getInt = client connectionErrorAPI + let baseUrl' = BaseUrl Http "example.invalid" 80 "" + let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e + isHttpError _ = False + (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True diff --git a/servant-client/test/Servant/FailSpec.hs b/servant-client/test/Servant/FailSpec.hs new file mode 100644 index 00000000..c5938e40 --- /dev/null +++ b/servant-client/test/Servant/FailSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.FailSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid () +import Data.Semigroup + ((<>)) +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.API + ((:<|>) ((:<|>))) +import Servant.Client +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.FailSpec" $ do + failSpec + +failSpec :: Spec +failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do + + context "client returns errors appropriately" $ do + it "reports FailureResponse" $ \(_, baseUrl) -> do + let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api + Left res <- runClient getDeleteEmpty baseUrl + case res of + FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () + _ -> fail $ "expected 404 response, but got " <> show res + + it "reports DecodeFailure" $ \(_, baseUrl) -> do + let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api + Left res <- runClient (getCapture "foo") baseUrl + case res of + DecodeFailure _ _ -> return () + _ -> fail $ "expected DecodeFailure, but got " <> show res + + it "reports ConnectionError" $ \_ -> do + let (getGetWrongHost :<|> _) = client api + Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") + case res of + ConnectionError _ -> return () + _ -> fail $ "expected ConnectionError, but got " <> show res + + it "reports UnsupportedContentType" $ \(_, baseUrl) -> do + let (_ :<|> getGet :<|> _ ) = client api + Left res <- runClient getGet baseUrl + case res of + UnsupportedContentType "application/octet-stream" _ -> return () + _ -> fail $ "expected UnsupportedContentType, but got " <> show res + + it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do + let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + Left res <- runClient (getBody alice) baseUrl + case res of + InvalidContentTypeHeader _ -> return () + _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res diff --git a/servant-client/test/Servant/GenAuthSpec.hs b/servant-client/test/Servant/GenAuthSpec.hs new file mode 100644 index 00000000..13bd8461 --- /dev/null +++ b/servant-client/test/Servant/GenAuthSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.GenAuthSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Arrow + (left) +import Data.Monoid () +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.Client +import qualified Servant.Client.Core.Auth as Auth +import qualified Servant.Client.Core.Request as Req +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.GenAuthSpec" $ do + genAuthSpec + +genAuthSpec :: Spec +genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do + let getProtected = client genAuthAPI + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req) + left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do + let getProtected = client genAuthAPI + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) + Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl + responseStatusCode r `shouldBe` HTTP.Status 401 "Unauthorized" + diff --git a/servant-client/test/Servant/HoistClientSpec.hs b/servant-client/test/Servant/HoistClientSpec.hs new file mode 100644 index 00000000..704329f0 --- /dev/null +++ b/servant-client/test/Servant/HoistClientSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.HoistClientSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid () +import Data.Proxy +import Test.Hspec + +import Servant.API + ((:<|>) ((:<|>)), (:>), Capture, + Get, JSON, Post) +import Servant.Client +import Servant.Server +import Servant.ClientTestUtils + + +spec :: Spec +spec = describe "Servant.HoistClientSpec" $ do + hoistClientSpec + +type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int + +hoistClientAPI :: Proxy HoistClientAPI +hoistClientAPI = Proxy + +hoistClientServer :: Application -- implements HoistClientAPI +hoistClientServer = serve hoistClientAPI $ return 5 :<|> return + +hoistClientSpec :: Spec +hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.hoistClient" $ do + it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do + let (getInt :<|> postInt) + = hoistClient hoistClientAPI + (fmap (either (error . show) id) . flip runClient baseUrl) + (client hoistClientAPI) + + getInt `shouldReturn` 5 + postInt 5 `shouldReturn` 5 diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index d0fc2a64..85018576 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/servant-client/test/Servant/StreamSpec.hs @@ -39,9 +39,6 @@ import Servant.API NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet, ) import Servant.Client.Streaming -import Servant.ClientSpec - (Person (..)) -import qualified Servant.ClientSpec as CS import Servant.Server import Servant.Test.ComprehensiveAPI import Servant.Types.SourceT @@ -52,6 +49,8 @@ import System.IO.Unsafe import System.Mem (performGC) import Test.Hspec +import Servant.ClientTestUtils (Person(..)) +import qualified Servant.ClientTestUtils as CT #if MIN_VERSION_base(4,10,0) import GHC.Stats @@ -120,7 +119,7 @@ testRunSourceIO :: SourceIO a testRunSourceIO = runExceptT . runSourceT streamSpec :: Spec -streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do +streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do withClient getGetNL baseUrl $ \(Right res) -> testRunSourceIO res `shouldReturn` Right [alice, bob, alice] diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs new file mode 100644 index 00000000..d16cfd79 --- /dev/null +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.SuccessSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Arrow + (left) +import Control.Concurrent.STM + (atomically) +import Control.Concurrent.STM.TVar + (newTVar, readTVar) +import Data.Foldable + (forM_, toList) +import Data.Maybe + (listToMaybe) +import Data.Monoid () +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit +import Test.QuickCheck + +import Servant.API + (NoContent (NoContent), getHeaders) +import Servant.Client +import qualified Servant.Client.Core.Request as Req +import Servant.Test.ComprehensiveAPI +import Servant.ClientTestUtils + +-- This declaration simply checks that all instances are in place. +_ = client comprehensiveAPIWithoutStreaming + +spec :: Spec +spec = describe "Servant.SuccessSpec" $ do + successSpec + +successSpec :: Spec +successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + it "Servant.API.Get root" $ \(_, baseUrl) -> do + left show <$> runClient getRoot baseUrl `shouldReturn` Right carol + + it "Servant.API.Get" $ \(_, baseUrl) -> do + left show <$> runClient getGet baseUrl `shouldReturn` Right alice + + describe "Servant.API.Delete" $ do + it "allows empty content type" $ \(_, baseUrl) -> do + left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent + + it "allows content type" $ \(_, baseUrl) -> do + left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent + + it "Servant.API.Capture" $ \(_, baseUrl) -> do + left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) + + it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do + let expected = [Person "Paula" 0, Person "Peta" 1] + left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected + + it "Servant.API.ReqBody" $ \(_, baseUrl) -> do + let p = Person "Clara" 42 + left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p + + it "Servant.API FailureResponse" $ \(_, baseUrl) -> do + left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice + Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl + Req.requestPath req `shouldBe` (baseUrl, "/param") + toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")] + Req.requestMethod req `shouldBe` HTTP.methodGet + + it "Servant.API.QueryParam" $ \(_, baseUrl) -> do + left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice + Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl + responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" + + it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do + left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] + left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.QueryParam.QueryFlag" $ + forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do + left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + + it "Servant.API.Raw on success" $ \(_, baseUrl) -> do + res <- runClient (getRawSuccess HTTP.methodGet) baseUrl + case res of + Left e -> assertFailure $ show e + Right r -> do + responseStatusCode r `shouldBe` HTTP.status200 + responseBody r `shouldBe` "rawSuccess" + + it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do + res <- runClient (getRawFailure HTTP.methodGet) baseUrl + case res of + Right _ -> assertFailure "expected Left, but got Right" + Left (FailureResponse _ r) -> do + responseStatusCode r `shouldBe` HTTP.status400 + responseBody r `shouldBe` "rawFailure" + Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e + + it "Returns headers appropriately" $ \(_, baseUrl) -> do + res <- runClient getRespHeaders baseUrl + case res of + Left e -> assertFailure $ show e + Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + + it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do + mgr <- C.newManager C.defaultManagerSettings + cj <- atomically . newTVar $ C.createCookieJar [] + _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj)) + cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) + C.cookie_name <$> cookie `shouldBe` Just "testcookie" + C.cookie_value <$> cookie `shouldBe` Just "test" + + modifyMaxSuccess (const 20) $ do + it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + ioProperty $ do + result <- left show <$> runClient (getMultiple cap num flag body) baseUrl + return $ + result === Right (cap, num, flag, body) + diff --git a/servant-client/test/Servant/WrappedApiSpec.hs b/servant-client/test/Servant/WrappedApiSpec.hs new file mode 100644 index 00000000..5172ad56 --- /dev/null +++ b/servant-client/test/Servant/WrappedApiSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.WrappedApiSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Exception + (bracket) +import Control.Monad.Error.Class + (throwError) +import Data.Monoid () +import Data.Proxy +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.API + (Delete, Get, JSON, Post, Put) +import Servant.Client +import Servant.Server +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.WrappedApiSpec" $ do + wrappedApiSpec + +data WrappedApi where + WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, + HasClient ClientM api, Client ClientM api ~ ClientM ()) => + Proxy api -> WrappedApi + +wrappedApiSpec :: Spec +wrappedApiSpec = describe "error status codes" $ do + let serveW api = serve api $ throwError $ ServerError 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 :: ClientM () + getResponse = client api + Left (FailureResponse _ r) <- runClient getResponse baseUrl + responseStatusCode r `shouldBe` HTTP.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") : + []