packages feed

servant-client 0.4.0 → 0.4.1

raw patch · 4 files changed

+521/−59 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Servant.Client: instance [overlap ok] (MimeUnrender ct a, BuildHeadersTo ls) => HasClient (Delete (ct : cts) (Headers ls a))
- Servant.Client: instance [overlap ok] HasClient (Delete (ct : cts) ())
- Servant.Client: instance [overlap ok] MimeUnrender ct a => HasClient (Delete (ct : cts) a)
+ Servant.Client: instance [overlap ok] (MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct : cts)) => HasClient (Delete cts' (Headers ls a))
+ Servant.Client: instance [overlap ok] (MimeUnrender ct a, cts' ~ (ct : cts)) => HasClient (Delete cts' a)
+ Servant.Client: instance [overlap ok] HasClient (Delete cts ())

Files

servant-client.cabal view
@@ -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 <http://hackage.haskell.org/package/servant servant> 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 <http://haskell-servant.github.io/tutorial/client.html the client section of the tutorial>.   .   <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG> 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
src/Servant/Client.hs view
@@ -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
+ test/Servant/ClientSpec.hs view
@@ -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]
+ test/Servant/Common/BaseUrlSpec.hs view
@@ -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)