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 #-} -