eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Almost compiling test

Browse source
This commit is contained in:
Julian K. Arni 2017-09-12 14:43:16 -04:00
parent 75ea91c34d
commit 5bd9d253ce
5 changed files with 59 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client-core/src/Servant/Client/Core.hs
View file

@ -26,6 +26,7 @@ module Servant.Client.Core
, EmptyClient(..) , EmptyClient(..)
, RunClient(..) , RunClient(..)
, Request(..) , Request(..)
, defaultRequest
, Response(..) , Response(..)
, RequestBody(..) , RequestBody(..)
, module Servant.Client.Core.Internal.BaseUrl , module Servant.Client.Core.Internal.BaseUrl

3
servant-client-core/src/Servant/Client/Core/Internal/Generic.hs
View file

@ -106,9 +106,6 @@ instance ClientLike client custom
=> ClientLike (a -> client) (a -> custom) where => ClientLike (a -> client) (a -> custom) where
mkClient c = mkClient . c mkClient c = mkClient . c
instance ClientLike (m a) (m a) where
mkClient = id
-- | Match client structure with client functions, regarding left-nested API clients -- | Match client structure with client functions, regarding left-nested API clients
-- as separate data structures. -- as separate data structures.
class GClientLikeP client xs where class GClientLikeP client xs where

1
servant-client/servant-client.cabal
View file

@ -73,6 +73,7 @@ test-suite spec
, aeson , aeson
, base-compat , base-compat
, bytestring , bytestring
, containers
, deepseq , deepseq
, hspec == 2.* , hspec == 2.*
, http-api-data , http-api-data

3
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

@ -76,6 +76,9 @@ instance Alt ClientM where
instance RunClient ClientM where instance RunClient ClientM where
runRequest = performRequest runRequest = performRequest
instance ClientLike (ClientM a) (ClientM a) where
mkClient = id
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm

105
servant-client/test/Servant/ClientSpec.hs
View file

@ -26,6 +26,9 @@
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.ClientSpec where module Servant.ClientSpec where
import Prelude ()
import Prelude.Compat
import Control.Arrow (left) import Control.Arrow (left)
import Control.Concurrent (ThreadId, forkIO, import Control.Concurrent (ThreadId, forkIO,
killThread) killThread)
@ -34,9 +37,12 @@ import Control.Monad.Error.Class (throwError)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint) import Data.Char (chr, isPrint)
import Data.Foldable (toList)
import Data.Foldable (forM_) import Data.Foldable (forM_)
import Data.Maybe (isJust)
import Data.Monoid hiding (getLast) import Data.Monoid hiding (getLast)
import Data.Proxy import Data.Proxy
import Data.Sequence (findIndexL)
import qualified Generics.SOP as SOP import qualified Generics.SOP as SOP
import GHC.Generics (Generic) import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
@ -45,8 +51,6 @@ import qualified Network.HTTP.Types as HTTP
import Network.Socket import Network.Socket
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Prelude ()
import Prelude.Compat
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck import Test.Hspec.QuickCheck
@ -61,19 +65,19 @@ import Servant.API ((:<|>) ((:<|>)),
Capture, Capture,
CaptureAll, Delete, CaptureAll, Delete,
DeleteNoContent, DeleteNoContent,
EmptyAPI, EmptyAPI, addHeader,
FormUrlEncoded, FormUrlEncoded,
Get, Header, Get, Header,
Headers, JSON, Headers, JSON,
NoContent, Post, NoContent (NoContent),
Put, QueryFlag, Post, Put, Raw,
QueryFlag,
QueryParam, QueryParam,
QueryParams, QueryParams,
ReqBody) ReqBody,
getHeaders)
import Servant.API.Internal.Test.ComprehensiveAPI import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Client import Servant.Client
{-import qualified Servant.Common.Req as SCR-}
{-import qualified Servant.Client.HttpClient as SCR-}
import Servant.Server import Servant.Server
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
@ -139,10 +143,8 @@ getBody :: Person -> ClientM Person
getQueryParam :: Maybe String -> ClientM Person getQueryParam :: Maybe String -> ClientM Person
getQueryParams :: [String] -> ClientM [Person] getQueryParams :: [String] -> ClientM [Person]
getQueryFlag :: Bool -> ClientM Bool getQueryFlag :: Bool -> ClientM Bool
getRawSuccess :: HTTP.Method getRawSuccess :: HTTP.Method -> ClientM Response
-> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response
getRawFailure :: HTTP.Method
-> ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: ClientM (Headers TestHeaders Bool) getRespHeaders :: ClientM (Headers TestHeaders Bool)
@ -179,7 +181,7 @@ server = serve api (
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ Servant.API.addHeader 1729 $ Servant.API.addHeader "eg2" True)
:<|> return NoContent :<|> return NoContent
:<|> emptyServer) :<|> emptyServer)
@ -233,7 +235,7 @@ type instance AuthClientData (AuthProtect "auth-tag") = ()
genAuthHandler :: AuthHandler Request () genAuthHandler :: AuthHandler Request ()
genAuthHandler = genAuthHandler =
let handler req = case lookup "AuthHeader" (requestHeaders req) of let handler req = case lookup "AuthHeader" (toList $ requestHeaders req) of
Nothing -> throwError (err401 { errBody = "Missing auth header" }) Nothing -> throwError (err401 { errBody = "Missing auth header" })
Just _ -> return () Just _ -> return ()
in mkAuthHandler handler in mkAuthHandler handler
@ -295,57 +297,58 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
manager' :: C.Manager manager' :: C.Manager
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
runClient x = runClientM x (ClientEnv manager' baseUrl) runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
sucessSpec :: Spec sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do it "Servant.API.Get" $ \(_, baseUrl) -> do
(left show <$> runClient getGet) `shouldReturn` Right alice left show <$> runClient getGet baseUrl `shouldReturn` Right alice
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
(left show <$> (runClient getDeleteEmpty)) `shouldReturn` Right NoContent left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do it "allows content type" $ \(_, baseUrl) -> do
(left show <$> (runClient getDeleteContentType)) `shouldReturn` Right NoContent left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> (runClient (getCapture "Paula"))) `shouldReturn` Right (Person "Paula" 0) left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)] let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> (runClient (getCaptureAll ["Paula", "Peta"]))) `shouldReturn` Right expected left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42 let p = Person "Clara" 42
(left show <$> runClient (getBody p)) `shouldReturn` Right p left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runClient (getQueryParam (Just "alice")) `shouldReturn` Right alice left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl
responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
(left show <$> runClient (getQueryParams [])) `shouldReturn` Right [] left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
(left show <$> runClient (getQueryParams ["alice", "bob"])) left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
(left show <$> runClient (getQueryFlag flag)) `shouldReturn` Right flag left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClient (getRawSuccess HTTP.methodGet) res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right r -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") responseStatusCode r `shouldBe` HTTP.status200
C.responseBody response `shouldBe` body responseBody r `shouldBe` "rawSuccess"
C.responseStatus response `shouldBe` HTTP.ok200 findIndexL (\x -> fst x == HTTP.hContentType) (responseHeaders r)
`shouldSatisfy` isJust
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runClient (getRawFailure HTTP.methodGet) res <- runClient (getRawFailure HTTP.methodGet) baseUrl
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" Right _ -> assertFailure "expected Left, but got Right"
Left (FailureResponse r) -> do Left (FailureResponse r) -> do
@ -354,7 +357,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runClient getRespHeaders res <- runClient getRespHeaders baseUrl
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -363,7 +366,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
result <- left show <$> runClient (getMultiple cap num flag body) result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
@ -377,7 +380,7 @@ wrappedApiSpec = describe "error status codes" $ do
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: ClientM () let getResponse :: ClientM ()
getResponse = client api getResponse = client api
Left (FailureResponse r) <- runClient getResponse Left (FailureResponse r) <- runClient getResponse baseUrl
responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $ in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@ -392,35 +395,35 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runClient getDeleteEmpty Left res <- runClient getDeleteEmpty baseUrl
case res of case res of
FailureResponse r | responseStatusCode r == 404 -> return () FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runClient (getCapture "foo") (ClientEnv manager baseUrl) Left res <- runClient (getCapture "foo") baseUrl
case res of case res of
DecodeFailure _ _ -> return () DecodeFailure _ _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res _ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api let (getGetWrongHost :<|> _) = client api
Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
case res of case res of
ConnectionError _ -> return () ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api let (getGet :<|> _ ) = client api
Left res <- runClient getGet Left res <- runClient getGet baseUrl
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClient (getBody alice) Left res <- runClient (getBody alice) baseUrl
case res of case res of
InvalidContentTypeHeader _ -> return () InvalidContentTypeHeader _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
@ -437,14 +440,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server" let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runClient (getBasic basicAuthData)) `shouldReturn` Right alice left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password" let basicAuthData = BasicAuthData "not" "password"
Left (FailureResponse r) <- runClient (getBasic basicAuthData) Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl
responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec genAuthSpec :: Spec
@ -453,15 +456,15 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> addHeader "AuthHeader" ("cool" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> Servant.Client.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runClient (getProtected authRequest) ) `shouldReturn` Right alice left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> addHeader "Wrong" ("header" :: String) req) let authRequest = mkAuthenticateReq () (\_ req -> Servant.Client.addHeader "Wrong" ("header" :: String) req)
Left (FailureResponse r) <- runClient (getProtected authRequest) Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
genericClientSpec :: Spec genericClientSpec :: Spec
@ -473,12 +476,12 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa
NestedClient2{..} = mkNestedClient2 (Just 42) NestedClient2{..} = mkNestedClient2 (Just 42)
it "works for top-level client inClientM function" $ \(_, baseUrl) -> do it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
(left show <$> (runClient (getSqr (Just 5)))) `shouldReturn` Right 25 left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
it "works for nested clients" $ \(_, baseUrl) -> do it "works for nested clients" $ \(_, baseUrl) -> do
(left show <$> (runClient (idChar (Just 'c')))) `shouldReturn` Right 'c' left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
(left show <$> (runClient (getSum 3 4))) `shouldReturn` Right 7 left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
(left show <$> (runClient doNothing )) `shouldReturn` Right () left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
-- * utils -- * utils