diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,21 +1,11 @@ name: servant-client -version: 0.4.0 +version: 0.4.1 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. . - Example below. - . - > type MyApi = "books" :> Get [Book] -- GET /books - > :<|> "books" :> ReqBody Book :> Post Book -- POST /books - > - > myApi :: Proxy MyApi - > myApi = Proxy - > - > getAllBooks :: BaseUrl -> EitherT String IO [Book] - > postNewBook :: Book -> BaseUrl -> EitherT String IO Book - > (getAllBooks :<|> postNewBook) = client myApi + See . . license: BSD3 @@ -66,6 +56,9 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs + other-modules: + Servant.ClientSpec + , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif @@ -43,15 +44,16 @@ -- | 'client' allows you to produce operations to query an API from a client. -- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: BaseUrl -> EitherT String IO [Book] --- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout client p baseurl = clientWithRoute p defReq baseurl @@ -68,15 +70,16 @@ -- one function for querying @a@ and another one for querying @b@, -- stitching them together with ':<|>', which really is just like a pair. -- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: BaseUrl -> EitherT String IO [Book] --- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b clientWithRoute Proxy req baseurl = @@ -94,13 +97,14 @@ -- -- Example: -- --- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBook :: Text -> BaseUrl -> EitherT String IO Book --- > getBook = client myApi +-- > getBook :: Text -> EitherT String IO Book +-- > getBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBook" to query that endpoint instance (KnownSymbol capture, ToText a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where @@ -123,8 +127,9 @@ #if MIN_VERSION_base(4,8,0) {-# OVERLAPPABLE #-} #endif - (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where - type Client (Delete (ct ': cts) a) = EitherT ServantError IO a + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where + type Client (Delete cts' a) = EitherT ServantError IO a clientWithRoute Proxy req baseurl = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl @@ -134,8 +139,8 @@ #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - HasClient (Delete (ct ': cts) ()) where - type Client (Delete (ct ': cts) ()) = EitherT ServantError IO () + HasClient (Delete cts ()) where + type Client (Delete cts ()) = EitherT ServantError IO () clientWithRoute Proxy req baseurl = void $ performRequestNoBody H.methodDelete req [204] baseurl @@ -145,9 +150,10 @@ #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Delete (ct ': cts) (Headers ls a)) where - type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) + ) => HasClient (Delete cts' (Headers ls a)) where + type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl = do (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl return $ Headers { getResponse = resp @@ -205,19 +211,20 @@ -- -- Example: -- --- > newtype Referer = Referer Text --- > deriving (Eq, Show, FromText, ToText) +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, FromText, ToText) -- > -- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > viewReferer :: Maybe Referer -> BaseUrl -> EitherT String IO Book --- > viewReferer = client myApi +-- > viewReferer :: Maybe Referer -> EitherT String IO Book +-- > viewReferer = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or Just "http://haskell.org/" as arguments +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (Header sym a :> sublayout) where @@ -366,13 +373,14 @@ -- -- Example: -- --- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book] --- > getBooksBy = client myApi +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov @@ -411,13 +419,14 @@ -- -- Example: -- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book] --- > getBooksBy = client myApi +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' @@ -451,13 +460,14 @@ -- -- Example: -- --- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book] --- > getBooks = client myApi +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books @@ -492,13 +502,14 @@ -- -- Example: -- --- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book] +-- > type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book] --- > getBooksBy = client myApi +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov @@ -536,13 +547,14 @@ -- -- Example: -- --- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book] +-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book] --- > getBooksBy = client myApi +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' @@ -576,13 +588,14 @@ -- -- Example: -- --- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book] +-- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book] --- > getBooks = client myApi +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books @@ -621,13 +634,14 @@ -- -- Example: -- --- > type MyApi = "books" :> ReqBody Book :> Post Book +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > addBook :: Book -> BaseUrl -> EitherT String IO Book --- > addBook = client myApi +-- > addBook :: Book -> EitherT String IO Book +-- > addBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "addBook" to query that endpoint instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ClientSpec.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fcontext-stack=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.ClientSpec where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import qualified Control.Arrow as Arrow +import Control.Concurrent +import Control.Exception +import Control.Monad.Trans.Either +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 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 Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit +import Test.QuickCheck + +import Servant.API +import Servant.Client +import Servant.Server + +-- * test data types + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +instance ToFormUrlEncoded Person where + toFormUrlEncoded Person{..} = + [("name", T.pack name), ("age", T.pack (show age))] + +lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b +lookupEither x xs = do + maybe (Left $ "could not find key " <> show x) return $ lookup x xs + +instance FromFormUrlEncoded Person where + fromFormUrlEncoded xs = do + n <- lookupEither "name" xs + a <- lookupEither "age" xs + return $ Person (T.unpack n) (read $ T.unpack a) + +deriving instance Eq ServantError + +instance Eq C.HttpException where + a == b = show a == show b + +alice :: Person +alice = Person "Alice" 42 + +type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] + +type Api = + "get" :> Get '[JSON] Person + :<|> "deleteEmpty" :> Delete '[] () + :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] 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 + :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person + :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person] + :<|> "matrixflag" :> MatrixFlag "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" :> Delete '[JSON] () +api :: Proxy Api +api = Proxy + +server :: Application +server = serve api ( + return alice + :<|> return () + :<|> (\ name -> return $ Person name 0) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 400 "missing parameter" "" []) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 400 "missing parameter" "" []) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> (\ a b c d -> return (a, b, c, d)) + :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> return () + ) + +withServer :: (BaseUrl -> IO a) -> IO a +withServer action = withWaiDaemon (return server) action + +type FailApi = + "get" :> Raw + :<|> "capture" :> Capture "name" String :> Raw + :<|> "body" :> Raw +failApi :: Proxy FailApi +failApi = Proxy + +failServer :: Application +failServer = serve failApi ( + (\ _request respond -> respond $ responseLBS ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") + :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + ) + +withFailServer :: (BaseUrl -> IO a) -> IO a +withFailServer action = withWaiDaemon (return failServer) action + +spec :: IO () +spec = withServer $ \ baseUrl -> do + let getGet :: EitherT ServantError IO Person + getDeleteEmpty :: EitherT ServantError IO () + getCapture :: String -> EitherT ServantError IO Person + getBody :: Person -> EitherT ServantError IO Person + getQueryParam :: Maybe String -> EitherT ServantError IO Person + getQueryParams :: [String] -> EitherT ServantError IO [Person] + getQueryFlag :: Bool -> EitherT ServantError IO Bool + getMatrixParam :: Maybe String -> EitherT ServantError IO Person + getMatrixParams :: [String] -> EitherT ServantError IO [Person] + getMatrixFlag :: Bool -> EitherT ServantError IO Bool + getRawSuccess :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) + getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) + getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) + getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool) + getDeleteContentType :: EitherT ServantError IO () + ( getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getMatrixParam + :<|> getMatrixParams + :<|> getMatrixFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType) + = client api baseUrl + + hspec $ do + it "Servant.API.Get" $ do + (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice + + describe "Servant.API.Delete" $ do + it "allows empty content type" $ do + (Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right () + + it "allows content type" $ do + (Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right () + + it "Servant.API.Capture" $ do + (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) + + it "Servant.API.ReqBody" $ do + let p = Person "Clara" 42 + (Arrow.left show <$> runEitherT (getBody p)) `shouldReturn` Right p + + it "Servant.API.QueryParam" $ do + Arrow.left show <$> runEitherT (getQueryParam (Just "alice")) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob")) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.QueryParam.QueryParams" $ do + (Arrow.left show <$> runEitherT (getQueryParams [])) `shouldReturn` Right [] + (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"])) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.QueryParam.QueryFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ do + (Arrow.left show <$> runEitherT (getQueryFlag flag)) `shouldReturn` Right flag + + it "Servant.API.MatrixParam" $ do + Arrow.left show <$> runEitherT (getMatrixParam (Just "alice")) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob")) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.MatrixParam.MatrixParams" $ do + Arrow.left show <$> runEitherT (getMatrixParams []) `shouldReturn` Right [] + Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"]) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.MatrixParam.MatrixFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ do + Arrow.left show <$> runEitherT (getMatrixFlag flag) `shouldReturn` Right flag + + it "Servant.API.Raw on success" $ do + res <- runEitherT (getRawSuccess methodGet) + case res of + Left e -> assertFailure $ show e + Right (code, body, ct, _, response) -> do + (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") + C.responseBody response `shouldBe` body + C.responseStatus response `shouldBe` ok200 + + it "Servant.API.Raw on failure" $ do + res <- runEitherT (getRawFailure methodGet) + case res of + Left e -> assertFailure $ show e + Right (code, body, ct, _, response) -> do + (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") + C.responseBody response `shouldBe` body + C.responseStatus response `shouldBe` badRequest400 + + it "Returns headers appropriately" $ withServer $ \ _ -> do + res <- runEitherT 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 -> + ioProperty $ do + result <- Arrow.left show <$> runEitherT (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 (left $ ServantErr 500 "error message" "" []))) $ + \ host -> do + let getResponse :: EitherT ServantError IO () + getResponse = client api host + Left FailureResponse{..} <- runEitherT getResponse + responseStatus `shouldBe` (Status 500 "error message") + 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 + let getGet :: EitherT ServantError IO Person + getDeleteEmpty :: EitherT ServantError IO () + getCapture :: String -> EitherT ServantError IO Person + getBody :: Person -> EitherT ServantError IO Person + ( getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> _ ) + = client api baseUrl + getGetWrongHost :: EitherT ServantError IO Person + (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872) + + hspec $ do + context "client returns errors appropriately" $ do + it "reports FailureResponse" $ do + Left res <- runEitherT getDeleteEmpty + case res of + FailureResponse (Status 404 "Not Found") _ _ -> return () + _ -> fail $ "expected 404 response, but got " <> show res + + it "reports DecodeFailure" $ do + Left res <- runEitherT (getCapture "foo") + case res of + DecodeFailure _ ("application/json") _ -> return () + _ -> fail $ "expected DecodeFailure, but got " <> show res + + it "reports ConnectionError" $ do + Left res <- runEitherT getGetWrongHost + case res of + ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return () + _ -> fail $ "expected ConnectionError, but got " <> show res + + it "reports UnsupportedContentType" $ do + Left res <- runEitherT getGet + case res of + UnsupportedContentType ("application/octet-stream") _ -> return () + _ -> fail $ "expected UnsupportedContentType, but got " <> show res + + it "reports InvalidContentTypeHeader" $ do + Left res <- runEitherT (getBody alice) + case res of + InvalidContentTypeHeader "fooooo" _ -> return () + _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res + +data WrappedApi where + WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a, + HasClient api, Client api ~ EitherT ServantError IO ()) => + Proxy api -> WrappedApi + + +-- * 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 + + lvar :: IO (a -> IO (), IO a) + lvar = do + mvar <- newEmptyMVar + let put = putMVar mvar + wait = readMVar mvar + return (put, wait) + +openTestSocket :: IO (Port, Socket) +openTestSocket = do + s <- socket AF_INET Stream defaultProtocol + localhost <- inet_addr "127.0.0.1" + bind s (SockAddrInet aNY_PORT 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/test/Servant/Common/BaseUrlSpec.hs b/test/Servant/Common/BaseUrlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Common/BaseUrlSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Common.BaseUrlSpec where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.DeepSeq +import Test.Hspec +import Test.QuickCheck + +import Servant.Common.BaseUrl + +spec :: Spec +spec = do + describe "showBaseUrl" $ do + it "shows a BaseUrl" $ do + 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" + + describe "httpBaseUrl" $ do + it "allows to construct default http BaseUrls" $ do + BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80 + + describe "parseBaseUrl" $ do + it "is total" $ do + property $ \ string -> + deepseq (fmap show (parseBaseUrl string)) True + + it "is the inverse of showBaseUrl" $ do + property $ \ baseUrl -> + counterexample (showBaseUrl baseUrl) $ + parseBaseUrl (showBaseUrl baseUrl) === + Right baseUrl + + it "allows trailing slashes" $ do + parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80) + + context "urls without scheme" $ do + it "assumes http" $ do + 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) + + it "rejects ftp urls" $ do + parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft + +instance Arbitrary BaseUrl where + arbitrary = BaseUrl <$> + elements [Http, Https] <*> + hostNameGen <*> + portGen + where + -- 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]) + portGen = frequency $ + (1, return 80) : + (1, return 443) : + (1, choose (1, 20000)) : + [] + +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False)