diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index a40ca7c6..fa825e2c 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -15,11 +15,10 @@ need to have some language extensions and imports: module Client where -import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Aeson import Data.Proxy import GHC.Generics -import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client ``` @@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que ``` haskell position :: Int -- ^ value for "x" -> Int -- ^ value for "y" - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO Position + -> ClientM Position hello :: Maybe String -- ^ an optional value for "name" - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO HelloMessage + -> ClientM HelloMessage marketing :: ClientInfo -- ^ value for the request body - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO Email + -> ClientM Email ``` Each function makes available as an argument any value that the response may @@ -120,17 +113,17 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. ``` haskell -queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email) -queries manager baseurl = do - pos <- position 10 10 manager baseurl - message <- hello (Just "servant") manager baseurl - em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl +queries :: ClientM (Position, HelloMessage, Email) +queries = do + pos <- position 10 10 + message <- hello (Just "servant") + em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) return (pos, message, em) run :: IO () run = do manager <- newManager defaultManagerSettings - res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) + res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 3627608d..df037a86 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,3 +1,11 @@ +0.8.1 +----- + +* BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for + BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be + passed to each method returned by `client`. + + 0.7.1 ----- diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index edbca092..c49cfe0e 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -53,6 +53,7 @@ library , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-compat >= 0.4 && < 0.6 + , mtl hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 18581075..0b7bdeac 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -20,6 +20,8 @@ module Servant.Client , client , HasClient(..) , ClientM + , runClientM + , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl @@ -34,7 +36,7 @@ import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Manager, Response) +import Network.HTTP.Client (Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP @@ -154,17 +156,17 @@ instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a - clientWithRoute Proxy req manager baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl + type Client (Verb method status cts' a) = ClientM a + clientWithRoute Proxy req = do + snd <$> performRequestCT (Proxy :: Proxy ct) method req where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ (ReflectMethod method) => HasClient (Verb method status cts NoContent) where type Client (Verb method status cts NoContent) - = Manager -> BaseUrl -> ClientM NoContent - clientWithRoute Proxy req manager baseurl = - performRequestNoBody method req manager baseurl >> return NoContent + = ClientM NoContent + clientWithRoute Proxy req = do + performRequestNoBody method req >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ @@ -172,10 +174,10 @@ instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' (Headers ls a)) where type Client (Verb method status cts' (Headers ls a)) - = Manager -> BaseUrl -> ClientM (Headers ls a) - clientWithRoute Proxy req manager baseurl = do + = ClientM (Headers ls a) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -184,10 +186,10 @@ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = Manager -> BaseUrl -> ClientM (Headers ls NoContent) - clientWithRoute Proxy req manager baseurl = do + = ClientM (Headers ls NoContent) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req manager baseurl + hdrs <- performRequestNoBody method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -372,7 +374,7 @@ instance (KnownSymbol sym, HasClient api) -- back the full `Response`. instance HasClient Raw where type Client Raw - = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod = do diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index ea610cce..7a8d7a1e 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Servant.Common.Req where #if !MIN_VERSION_base(4,8,0) @@ -10,8 +13,18 @@ import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) -import Control.Monad.IO.Class + +#if MIN_VERSION_mtl(2,2,0) +import Control.Monad.Except (MonadError(..)) +#else +import Control.Monad.Error.Class (MonadError(..)) +#endif import Control.Monad.Trans.Except + + +import GHC.Generics +import Control.Monad.IO.Class () +import Control.Monad.Reader import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.String import Data.String.Conversions @@ -19,9 +32,9 @@ import Data.Proxy import Data.Text (Text) import Data.Text.Encoding import Data.Typeable -import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Media import Network.HTTP.Types +import Network.HTTP.Client hiding (Proxy, path) import qualified Network.HTTP.Types.Header as HTTP import Network.URI hiding (path) import Servant.API.ContentTypes @@ -149,20 +162,40 @@ parseRequest url = liftM disableStatusCheck (parseUrl url) displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -type ClientM = ExceptT ServantError IO +data ClientEnv + = ClientEnv + { manager :: Manager + , baseUrl :: BaseUrl + } -performRequest :: Method -> Req -> Manager -> BaseUrl + +-- | @ClientM@ is the monad in which client functions run. Contains the +-- 'Manager' and 'BaseUrl' used for requests in the reader environment. + +newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv + , MonadError ServantError + ) + +runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm + + +performRequest :: Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) -performRequest reqMethod req manager reqHost = do +performRequest reqMethod req = do + m <- asks manager + reqHost <- asks baseUrl partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod } - eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager + eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of Left err -> - throwE . ConnectionError $ SomeException err + throwError . ConnectionError $ SomeException err Right response -> do let status = Client.responseStatus response @@ -172,28 +205,26 @@ performRequest reqMethod req manager reqHost = do ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwE $ InvalidContentTypeHeader (cs t) body + Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwE $ FailureResponse status ct body + throwError $ FailureResponse status ct body return (status_code, body, ct, hdrs, response) -performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> Manager -> BaseUrl +performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req -> ClientM ([HTTP.Header], result) -performRequestCT ct reqMethod req manager reqHost = do +performRequestCT ct reqMethod req = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost - unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody + performRequest reqMethod (req { reqAccept = [acceptCT] }) + unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of - Left err -> throwE $ DecodeFailure err respCT respBody + Left err -> throwError $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> Manager -> BaseUrl - -> ClientM [HTTP.Header] -performRequestNoBody reqMethod req manager reqHost = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost +performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header] +performRequestNoBody reqMethod req = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index da7c763b..1f0be75b 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -32,7 +32,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (throwE, runExceptT) +import Control.Monad.Trans.Except (throwE ) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) @@ -123,22 +123,22 @@ type Api = api :: Proxy Api api = Proxy -getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person -getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent -getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person -getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] -getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person -getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person -getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] -getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool -getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl +getGet :: SCR.ClientM Person +getDeleteEmpty :: SCR.ClientM NoContent +getCapture :: String -> SCR.ClientM Person +getCaptureAll :: [String] -> SCR.ClientM [Person] +getBody :: Person -> SCR.ClientM Person +getQueryParam :: Maybe String -> SCR.ClientM Person +getQueryParams :: [String] -> SCR.ClientM [Person] +getQueryFlag :: Bool -> SCR.ClientM Bool +getRawSuccess :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl +getRawFailure :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl +getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool) -getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent +getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) +getDeleteContentType :: SCR.ClientM NoContent getGet :<|> getDeleteEmpty :<|> getCapture @@ -242,42 +242,42 @@ sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice + (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent + (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent + (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) + (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [(Person "Paula" 0), (Person "Peta" 1)] - (left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected + (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p + (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice - Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl) + left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice + Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right [] - (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl)) + (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] + (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag + (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) + res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do @@ -286,7 +286,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) + res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do @@ -294,7 +294,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- runExceptT (getRespHeaders manager baseUrl) + res <- runClientM getRespHeaders (ClientEnv manager baseUrl) case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -303,7 +303,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) + result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) return $ result === Right (cap, num, flag, body) @@ -315,9 +315,9 @@ wrappedApiSpec = describe "error status codes" $ do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM () + let getResponse :: SCR.ClientM () getResponse = client api - Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl) + Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -332,42 +332,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> getDeleteEmpty :<|> _) = client api - Left res <- runExceptT (getDeleteEmpty manager baseUrl) + Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) case res of FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> getCapture :<|> _) = client api - Left res <- runExceptT (getCapture "foo" manager baseUrl) + Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do let (getGetWrongHost :<|> _) = client api - Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 "")) + Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do let (getGet :<|> _ ) = client api - Left res <- runExceptT (getGet manager baseUrl) + Left res <- runClientM getGet (ClientEnv manager baseUrl) case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api - Left res <- runExceptT (getBody alice manager baseUrl) + Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, - HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => + HasClient api, Client api ~ SCR.ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -377,14 +377,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice + (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl) + Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec @@ -394,14 +394,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice + (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl) + Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") -- * utils diff --git a/servant-mock/.ghci b/servant-mock/.ghci deleted file mode 100644 index 0215492d..00000000 --- a/servant-mock/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude diff --git a/servant-mock/LICENSE b/servant-mock/LICENSE deleted file mode 100644 index 68d30586..00000000 --- a/servant-mock/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015-2016, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alp Mestanogullari nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-mock/Setup.hs b/servant-mock/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-mock/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs deleted file mode 100644 index a602dc88..00000000 --- a/servant-mock/example/main.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-unused-binds #-} - -import Data.Aeson -import GHC.Generics -import Network.Wai.Handler.Warp -import Servant -import Servant.Mock -import Test.QuickCheck.Arbitrary - -newtype User = User { username :: String } - deriving (Eq, Show, Arbitrary, Generic) - -instance ToJSON User - -type API = "user" :> Get '[JSON] User - -api :: Proxy API -api = Proxy - -main :: IO () -main = run 8080 (serve api $ mock api Proxy) diff --git a/servant-mock/include/overlapping-compat.h b/servant-mock/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-mock/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal deleted file mode 100644 index e7896482..00000000 --- a/servant-mock/servant-mock.cabal +++ /dev/null @@ -1,72 +0,0 @@ -name: servant-mock -version: 0.8.1 -synopsis: Derive a mock server for free from your servant API types -description: - Derive a mock server for free from your servant API types - . - See the @Servant.Mock@ module for the documentation and an example. -homepage: http://github.com/haskell-servant/servant -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2015-2016 Servant Contributors -category: Web -build-type: Simple -extra-source-files: include/*.h -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -flag example - description: Build the example too - default: True - -library - exposed-modules: - Servant.Mock - build-depends: - base >=4.7 && <5, - bytestring >= 0.10 && <0.11, - http-types >= 0.8 && <0.10, - servant == 0.8.*, - servant-server == 0.8.*, - transformers >= 0.3 && <0.6, - QuickCheck >= 2.7 && <2.10, - wai >= 3.0 && <3.3 - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include - ghc-options: -Wall - -executable mock-app - main-is: main.hs - hs-source-dirs: example - default-language: Haskell2010 - build-depends: aeson, base, servant-mock, servant-server, QuickCheck, warp - if flag(example) - buildable: True - else - buildable: False - ghc-options: -Wall - -test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs - other-modules: - Servant.MockSpec - build-depends: - base, - hspec, - hspec-wai, - QuickCheck, - servant, - servant-server, - servant-mock, - aeson, - wai diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs deleted file mode 100644 index 0d0f4a48..00000000 --- a/servant-mock/src/Servant/Mock.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#include "overlapping-compat.h" - --- | --- Module : Servant.Mock --- Copyright : 2015 Alp Mestanogullari --- License : BSD3 --- --- Maintainer : Alp Mestanogullari --- Stability : experimental --- Portability : portable --- --- Automatically derive a mock webserver that implements some API type, --- just from the said API type's definition. --- --- Using this module couldn't be simpler. Given some API type, like: --- --- > type API = "user" :> Get '[JSON] User --- --- that describes your web application, all you have to do is define --- a 'Proxy' to it: --- --- > myAPI :: Proxy API --- > myAPI = Proxy --- --- and call 'mock', which has the following type: --- --- @ --- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api --- @ --- --- What this says is, given some API type @api@ that it knows it can --- "mock", 'mock' hands you an implementation of the API type. It does so --- by having each request handler generate a random value of the --- appropriate type (@User@ in our case). All you need for this to work is --- to provide 'Arbitrary' instances for the data types returned as response --- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'. --- --- To put this all to work and run the mock server, just call 'serve' on the --- result of 'mock' to get an 'Application' that you can then run with warp. --- --- @ --- main :: IO () --- main = Network.Wai.Handler.Warp.run 8080 $ --- 'serve' myAPI ('mock' myAPI Proxy) --- @ -module Servant.Mock ( HasMock(..) ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad.IO.Class -import Data.ByteString.Lazy.Char8 (pack) -import Data.Proxy -import GHC.TypeLits -import Network.HTTP.Types.Status -import Network.Wai -import Servant -import Servant.API.ContentTypes -import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) -import Test.QuickCheck.Gen (Gen, generate) - --- | 'HasMock' defines an interpretation of API types --- than turns them into random-response-generating --- request handlers, hence providing an instance for --- all the combinators of the core /servant/ library. -class HasServer api context => HasMock api context where - -- | Calling this method creates request handlers of - -- the right type to implement the API described by - -- @api@ that just generate random response values of - -- the right type. E.g: - -- - -- @ - -- type API = "user" :> Get '[JSON] User - -- :<|> "book" :> Get '[JSON] Book - -- - -- api :: Proxy API - -- api = Proxy - -- - -- -- let's say we will start with the frontend, - -- -- and hence need a placeholder server - -- server :: Server API - -- server = mock api Proxy - -- @ - -- - -- What happens here is that @'Server' API@ - -- actually "means" 2 request handlers, of the following types: - -- - -- @ - -- getUser :: Handler User - -- getBook :: Handler Book - -- @ - -- - -- So under the hood, 'mock' uses the 'IO' bit to generate - -- random values of type 'User' and 'Book' every time these - -- endpoints are requested. - mock :: Proxy api -> Proxy context -> Server api - -instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where - mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context - -instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where - mock _ = mock (Proxy :: Proxy rest) - -instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance HasMock rest context => HasMock (RemoteHost :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance HasMock rest context => HasMock (IsSecure :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance HasMock rest context => HasMock (Vault :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance HasMock rest context => HasMock (HttpVersion :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) - => HasMock (QueryParam s a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) - => HasMock (QueryParams s a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where - mock _ context = \_ -> mock (Proxy :: Proxy rest) context - -instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes a) context where - mock _ _ = mockArbitrary - -instance OVERLAPPING_ - (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), - Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes (Headers headerTypes a)) context where - mock _ _ = mockArbitrary - -instance HasMock Raw context where - mock _ _ = \_req respond -> do - bdy <- genBody - respond $ responseLBS status200 [] bdy - - where genBody = pack <$> generate (vector 100 :: Gen [Char]) - -instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => - HasMock (WithNamedContext name subContext rest) context where - - mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) - -mockArbitrary :: (MonadIO m, Arbitrary a) => m a -mockArbitrary = liftIO (generate arbitrary) - --- utility instance -instance (Arbitrary (HList ls), Arbitrary a) - => Arbitrary (Headers ls a) where - arbitrary = Headers <$> arbitrary <*> arbitrary - -instance Arbitrary (HList '[]) where - arbitrary = pure HNil - -instance (Arbitrary a, Arbitrary (HList hs)) - => Arbitrary (HList (Header h a ': hs)) where - arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary - -instance Arbitrary NoContent where - arbitrary = pure NoContent diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs deleted file mode 100644 index 83401c73..00000000 --- a/servant-mock/test/Servant/MockSpec.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - -module Servant.MockSpec where - -import Data.Aeson as Aeson -import Data.Proxy -import GHC.Generics -import Network.Wai -import Servant.API -import Test.Hspec hiding (pending) -import Test.Hspec.Wai -import Test.QuickCheck - -import Servant -import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Mock - --- This declaration simply checks that all instances are in place. -_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) - -data Body - = Body - | ArbitraryBody - deriving (Generic) - -instance ToJSON Body - -instance Arbitrary Body where - arbitrary = return ArbitraryBody - -data TestHeader - = TestHeader - | ArbitraryHeader - deriving (Show) - -instance ToHttpApiData TestHeader where - toHeader = toHeader . show - toUrlPiece = toUrlPiece . show - toQueryParam = toQueryParam . show - - -instance Arbitrary TestHeader where - arbitrary = return ArbitraryHeader - -spec :: Spec -spec = do - describe "mock" $ do - context "Get" $ do - let api :: Proxy (Get '[JSON] Body) - api = Proxy - app = serve api (mock api Proxy) - with (return app) $ do - it "serves arbitrary response bodies" $ do - get "/" `shouldRespondWith` 200{ - matchBody = Just $ Aeson.encode ArbitraryBody - } - - context "response headers" $ do - let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body)) - withHeader = Proxy - withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) - withoutHeader = Proxy - toApp :: (HasMock api '[]) => Proxy api -> IO Application - toApp api = return $ serve api (mock api (Proxy :: Proxy '[])) - with (toApp withHeader) $ do - it "serves arbitrary response bodies" $ do - get "/" `shouldRespondWith` 200{ - matchHeaders = return $ MatchHeader $ \ h -> - if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")] - then Nothing - else Just ("headers not correct\n") - } - - with (toApp withoutHeader) $ do - it "works for no additional headers" $ do - get "/" `shouldRespondWith` 200{ - matchHeaders = return $ MatchHeader $ \ h -> - if h == [("Content-Type", "application/json")] - then Nothing - else Just ("headers not correct\n") - } diff --git a/servant-mock/test/Spec.hs b/servant-mock/test/Spec.hs deleted file mode 100644 index a824f8c3..00000000 --- a/servant-mock/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-mock/tinc.yaml b/servant-mock/tinc.yaml deleted file mode 100644 index ec6d448f..00000000 --- a/servant-mock/tinc.yaml +++ /dev/null @@ -1,5 +0,0 @@ -dependencies: - - name: servant - path: ../servant - - name: servant-server - path: ../servant-server diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 33515204..e9dd8761 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -2,6 +2,7 @@ next ---- * BACKWARDS INCOMPATIBLE replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo` * Add Servant.API.Times for parsing times with a format specified in their type. +* Added Eq, Show, Read, Generic and Ord instances to IsSecure 0.8.1 ---- diff --git a/servant/src/Servant/API/IsSecure.hs b/servant/src/Servant/API/IsSecure.hs index 031f94a7..cbf1ab79 100644 --- a/servant/src/Servant/API/IsSecure.hs +++ b/servant/src/Servant/API/IsSecure.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Servant.API.IsSecure ( -- $issecure IsSecure(..) ) where import Data.Typeable +import GHC.Generics (Generic) -- | Was this request made over an SSL connection? -- @@ -19,7 +21,7 @@ data IsSecure = Secure -- ^ the connection to the server -- is secure (HTTPS) | NotSecure -- ^ the connection to the server -- is not secure (HTTP) - deriving Typeable + deriving (Eq, Show, Read, Generic, Ord, Typeable) -- $issecure -- diff --git a/sources.txt b/sources.txt index 06ff7ed8..6c75de5e 100644 --- a/sources.txt +++ b/sources.txt @@ -4,4 +4,3 @@ servant-client servant-docs servant-foreign servant-js -servant-mock diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 0fe58482..c934dc41 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -5,7 +5,6 @@ packages: - servant-docs/ - servant-foreign/ - servant-js/ -- servant-mock/ - servant-server/ extra-deps: - base-compat-0.9.1 @@ -18,10 +17,6 @@ extra-deps: - hspec-expectations-0.7.2 - http-api-data-0.2.2 - primitive-0.6.1.0 -- servant-0.7.1 -- servant-client-0.7.1 -- servant-docs-0.7.1 -- servant-server-0.7.1 - should-not-typecheck-2.1.0 - time-locale-compat-0.1.1.1 - wai-app-static-3.1.5 diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml index 8861e1a9..c5c8fa27 100644 --- a/stack-ghc-8.0.1.yaml +++ b/stack-ghc-8.0.1.yaml @@ -5,7 +5,6 @@ packages: - servant-docs/ - servant-foreign/ - servant-js/ -- servant-mock/ - servant-server/ extra-deps: [] flags: {} diff --git a/stack.yaml b/stack.yaml index 95599455..a1e5f8c9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,6 @@ packages: - servant-docs/ - servant-foreign/ - servant-js/ -- servant-mock/ - servant-server/ - doc/tutorial extra-deps: