servant-http-streams (empty) → 0.16
raw patch · 11 files changed
+1150/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, base, base-compat, bifunctors, bytestring, case-insensitive, containers, deepseq, entropy, exceptions, hspec, http-api-data, http-common, http-media, http-streams, http-types, io-streams, kan-extensions, markdown-unlit, monad-control, mtl, network, semigroupoids, servant, servant-client-core, servant-http-streams, servant-server, stm, tdigest, text, time, transformers, transformers-base, transformers-compat, wai, warp
Files
- CHANGELOG.md +7/−0
- LICENSE +30/−0
- README.lhs +44/−0
- README.md +44/−0
- Setup.hs +2/−0
- servant-http-streams.cabal +136/−0
- src/Servant/HttpStreams.hs +19/−0
- src/Servant/HttpStreams/Internal.hs +251/−0
- test/Servant/ClientSpec.hs +506/−0
- test/Servant/StreamSpec.hs +110/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.16+----++- Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 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 Zalora South East Asia Pte Ltd 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.
+ README.lhs view
@@ -0,0 +1,44 @@+# servant-client++++This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.++## Example++``` haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++import Data.Proxy+import Data.Text+import Servant.API+import Servant.HttpStreams+++type Book = Text++type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+ :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books++myApi :: Proxy MyApi+myApi = Proxy++-- 'client' allows you to produce operations to query an API from a client.+postNewBook :: Book -> ClientM Book+getAllBooks :: ClientM [Book]+(getAllBooks :<|> postNewBook) = client myApi++-- the IOException happens already in withClientEnvIO+main' :: IO ()+main' = do+ let burl = BaseUrl Http "localhost" 8081 ""+ withClientEnvIO burl $ \env -> do+ res <- runClientM getAllBooks env+ case res of+ Left err -> putStrLn $ "Error: " ++ show err+ Right books -> print books++main :: IO ()+main = return ()+```
+ README.md view
@@ -0,0 +1,44 @@+# servant-client++++This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.++## Example++``` haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++import Data.Proxy+import Data.Text+import Servant.API+import Servant.HttpStreams+++type Book = Text++type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+ :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books++myApi :: Proxy MyApi+myApi = Proxy++-- 'client' allows you to produce operations to query an API from a client.+postNewBook :: Book -> ClientM Book+getAllBooks :: ClientM [Book]+(getAllBooks :<|> postNewBook) = client myApi++-- the IOException happens already in withClientEnvIO+main' :: IO ()+main' = do+ let burl = BaseUrl Http "localhost" 8081 ""+ withClientEnvIO burl $ \env -> do+ res <- runClientM getAllBooks env+ case res of+ Left err -> putStrLn $ "Error: " ++ show err+ Right books -> print books++main :: IO ()+main = return ()+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-http-streams.cabal view
@@ -0,0 +1,136 @@+cabal-version: >=1.10+name: servant-http-streams+version: 0.16++synopsis: Automatic derivation of querying functions for servant+category: Servant, Web+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.+ .+ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.+ .+ <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>++homepage: http://haskell-servant.readthedocs.org/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD3+license-file: LICENSE+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright: 2019 Servant Contributors+build-type: Simple+tested-with:+ GHC ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.3++extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: http://github.com/haskell-servant/servant.git++library+ exposed-modules:+ Servant.HttpStreams+ Servant.HttpStreams.Internal++ -- Bundled with GHC: Lower bound to not force re-installs+ -- text and mtl are bundled starting with GHC-8.4+ build-depends:+ base >= 4.9 && < 4.13+ , bytestring >= 0.10.8.1 && < 0.11+ , containers >= 0.5.7.1 && < 0.7+ , deepseq >= 1.4.2.0 && < 1.5+ , mtl >= 2.2.2 && < 2.3+ , text >= 1.2.3.0 && < 1.3+ , time >= 1.6.0.1 && < 1.9+ , transformers >= 0.5.2.0 && < 0.6++ if !impl(ghc >= 8.2)+ build-depends:+ bifunctors >= 5.5.3 && < 5.6++ -- Servant dependencies.+ -- Strict dependency on `servant-client-core` as we re-export things.+ build-depends:+ servant == 0.16.*+ , servant-client-core >= 0.16 && <0.16.1++ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+ -- Here can be exceptions if we really need features from the newer versions.+ build-depends:+ base-compat >= 0.10.5 && < 0.11+ , case-insensitive+ , http-streams >= 0.8.6.1 && < 0.9+ , http-media >= 0.7.1.3 && < 0.8+ , io-streams >= 1.5.0.1 && < 1.6+ , http-types >= 0.12.2 && < 0.13+ , http-common >= 0.8.2.0 && < 0.9+ , exceptions >= 0.10.0 && < 0.11+ , kan-extensions >= 5.2 && < 5.3+ , monad-control >= 1.0.2.3 && < 1.1+ , semigroupoids >= 5.3.1 && < 5.4+ , transformers-base >= 0.4.5.2 && < 0.5+ , transformers-compat >= 0.6.2 && < 0.7++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wno-redundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Servant.ClientSpec+ Servant.StreamSpec++ -- Dependencies inherited from the library. No need to specify bounds.+ build-depends:+ base+ , aeson+ , base-compat+ , bytestring+ , http-api-data+ , http-streams+ , deepseq+ , http-types+ , mtl+ , kan-extensions+ , servant-http-streams+ , servant-client-core+ , stm+ , text+ , transformers+ , transformers-compat+ , wai+ , warp++ -- Additonal dependencies+ build-depends:+ entropy >= 0.4.1.3 && < 0.5+ , hspec >= 2.6.0 && < 2.8+ , HUnit >= 1.6.0.0 && < 1.7+ , network >= 2.8.0.0 && < 3.1+ , QuickCheck >= 2.12.6.1 && < 2.13+ , servant == 0.16.*+ , servant-server == 0.16.*+ , tdigest >= 0.2 && < 0.3++ build-tool-depends:+ hspec-discover:hspec-discover >= 2.6.0 && < 2.8++test-suite readme+ type: exitcode-stdio-1.0+ main-is: README.lhs+ build-depends: base, servant, http-streams, text, servant-http-streams, markdown-unlit+ build-tool-depends: markdown-unlit:markdown-unlit+ ghc-options: -pgmL markdown-unlit+ default-language: Haskell2010
+ src/Servant/HttpStreams.hs view
@@ -0,0 +1,19 @@+++-- | This module provides 'client' which can automatically generate+-- querying functions for each endpoint just from the type representing your+-- API.+module Servant.HttpStreams+ ( client+ , ClientM+ , withClientM+ , runClientM+ , ClientEnv(..)+ , mkClientEnv+ , withClientEnvIO+ , hoistClient+ , module Servant.Client.Core.Reexport+ ) where++import Servant.Client.Core.Reexport+import Servant.HttpStreams.Internal
+ src/Servant/HttpStreams/Internal.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Servant.HttpStreams.Internal where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq+ (NFData, force)+import Control.Exception+ (IOException, SomeException (..), catch, evaluate, throwIO)+import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Codensity+ (Codensity (..))+import Control.Monad.Error.Class+ (MonadError (..))+import Control.Monad.IO.Class+ (liftIO)+import Control.Monad.Reader+import Control.Monad.Trans.Except+import Data.Bifunctor+ (bimap, first)+import Data.ByteString.Builder+ (toLazyByteString)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import Data.Foldable+ (for_, toList)+import Data.Functor.Alt+ (Alt (..))+import Data.Maybe+ (maybeToList)+import Data.Proxy+ (Proxy (..))+import Data.Semigroup+ ((<>))+import Data.Sequence+ (fromList)+import Data.String+ (fromString)+import GHC.Generics+import Network.HTTP.Media+ (renderHeader)+import Network.HTTP.Types+ (Status (..), hContentType, http11, renderQuery)+import Servant.Client.Core++import qualified Network.Http.Client as Client+import qualified Network.Http.Types as Client+import qualified Servant.Types.SourceT as S+import qualified System.IO.Streams as Streams++-- | The environment in which a request is run.+--+-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.+--+data ClientEnv+ = ClientEnv+ { baseUrl :: BaseUrl+ , connection :: Client.Connection+ }++-- | 'ClientEnv' smart constructor.+mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv+mkClientEnv = ClientEnv++-- | Open a connection to 'BaseUrl'.+withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r+withClientEnvIO burl k = Client.withConnection open $ \conn ->+ k (mkClientEnv burl conn)+ where+ open = Client.openConnection (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)++-- | Generates a set of client functions for an API.+--+-- Example:+--+-- > type API = Capture "no" Int :> Get '[JSON] Int+-- > :<|> Get '[JSON] [Bool]+-- >+-- > api :: Proxy API+-- > api = Proxy+-- >+-- > getInt :: Int -> ClientM Int+-- > getBools :: ClientM [Bool]+-- > getInt :<|> getBools = client api+client :: HasClient ClientM api => Proxy api -> Client ClientM api+client api = api `clientIn` (Proxy :: Proxy ClientM)++-- | Change the monad the client functions live in, by+-- supplying a conversion function+-- (a natural transformation to be precise).+--+-- For example, assuming you have some @manager :: 'Manager'@ and+-- @baseurl :: 'BaseUrl'@ around:+--+-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int+-- > api :: Proxy API+-- > api = Proxy+-- > getInt :: IO Int+-- > postInt :: Int -> IO Int+-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)+-- > where cenv = mkClientEnv manager baseurl+hoistClient+ :: HasClient ClientM api+ => Proxy api+ -> (forall a. m a -> n a)+ -> Client m api+ -> Client n api+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)++-- | @ClientM@ is the monad in which client functions run. Contains the+-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.+newtype ClientM a = ClientM+ { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }+ deriving ( Functor, Applicative, Monad, MonadIO, Generic+ , MonadReader ClientEnv, MonadError ClientError)++instance MonadBase IO ClientM where+ liftBase = ClientM . liftIO++-- | Try clients in order, last error is preserved.+instance Alt ClientM where+ a <!> b = a `catchError` \_ -> b++instance RunClient ClientM where+ runRequest = performRequest+ throwClientError = throwError++instance RunStreamingClient ClientM where+ withStreamingRequest = performWithStreamingRequest++runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)+runClientM cm env = withClientM cm env (evaluate . force)++withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b+withClientM cm env k =+ let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm+ in f k++performRequest :: Request -> ClientM Response+performRequest req = do+ ClientEnv burl conn <- ask+ let (req', body) = requestToClientRequest burl req+ x <- ClientM $ lift $ lift $ Codensity $ \k -> do+ Client.sendRequest conn req' body+ Client.receiveResponse conn $ \res' body' -> do+ let sc = Client.getStatusCode res'+ lbs <- BSL.fromChunks <$> Streams.toList body'+ let res'' = clientResponseToResponse res' lbs+ if sc >= 200 && sc < 300+ then k (Right res'')+ else k (Left (mkFailureResponse burl req res''))++ either throwError pure x++performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a+performWithStreamingRequest req k = do+ ClientEnv burl conn <- ask+ let (req', body) = requestToClientRequest burl req+ ClientM $ lift $ lift $ Codensity $ \k1 -> do+ Client.sendRequest conn req' body+ Client.receiveResponseRaw conn $ \res' body' -> do+ -- check status code+ let sc = Client.getStatusCode res'+ unless (sc >= 200 && sc < 300) $ do+ lbs <- BSL.fromChunks <$> Streams.toList body'+ throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)++ x <- k (clientResponseToResponse res' (fromInputStream body'))+ k1 x++mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError+mkFailureResponse burl request =+ FailureResponse (bimap (const ()) f request)+ where+ f b = (burl, BSL.toStrict $ toLazyByteString b)++clientResponseToResponse :: Client.Response -> body -> ResponseF body+clientResponseToResponse r body = Response+ { responseStatusCode = Status (Client.getStatusCode r) (Client.getStatusMessage r)+ , responseBody = body+ , responseHeaders = fromList $ map (first CI.mk) $ Client.retrieveHeaders $ Client.getHeaders r+ , responseHttpVersion = http11 -- guess+ }++requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())+requestToClientRequest burl r = (request, body)+ where+ request = Client.buildRequest1 $ do+ Client.http (Client.Method $ requestMethod r)+ $ fromString (baseUrlPath burl)+ <> BSL.toStrict (toLazyByteString (requestPath r))+ <> renderQuery True (toList (requestQueryString r))+ -- We are connected, but we still need to know what we try to query+ Client.setHostname (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)+ for_ (maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers) $ \(hn, hv) ->+ Client.setHeader (CI.original hn) hv++ -- body is always chunked+ Client.setTransferEncoding++ -- Content-Type and Accept are specified by requestBody and requestAccept+ headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $+ toList $ requestHeaders r++ acceptHdr+ | null hs = Nothing+ | otherwise = Just ("Accept", renderHeader hs)+ where+ hs = toList $ requestAccept r++ convertBody bd os = case bd of+ RequestBodyLBS body' ->+ Streams.writeTo os (Just (B.lazyByteString body'))+ RequestBodyBS body' ->+ Streams.writeTo os (Just (B.byteString body'))+ RequestBodySource sourceIO ->+ toOutputStream sourceIO os++ (body, contentTypeHdr) = case requestBody r of+ Nothing -> (Client.emptyBody, Nothing)+ Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))++catchConnectionError :: IO a -> IO (Either ClientError a)+catchConnectionError action =+ catch (Right <$> action) $ \e ->+ pure . Left . ConnectionError $ SomeException (e :: IOException)++fromInputStream :: Streams.InputStream b -> S.SourceT IO b+fromInputStream is = S.SourceT $ \k -> k loop where+ loop = S.Effect $ maybe S.Stop (flip S.Yield loop) <$> Streams.read is++toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()+toOutputStream (S.SourceT k) os = k loop where+ loop S.Stop = return ()+ loop (S.Error err) = fail err+ loop (S.Skip s) = loop s+ loop (S.Effect mx) = mx >>= loop+ loop (S.Yield x s) = Streams.write (Just (B.lazyByteString x)) os >> loop s
+ test/Servant/ClientSpec.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where++import Prelude ()+import Prelude.Compat++import Control.Arrow+ (left)+import Control.Concurrent+ (ThreadId, forkIO, killThread)+import Control.DeepSeq+ (NFData (..))+import Control.Exception+ (bracket, fromException, IOException)+import Control.Monad.Error.Class+ (throwError)+import Data.Aeson+import Data.Char+ (chr, isPrint)+import Data.Foldable+ (forM_, toList)+import Data.Maybe+ (isJust)+import Data.Monoid ()+import Data.Proxy+import Data.Semigroup+ ((<>))+import GHC.Generics+ (Generic)+import qualified Network.HTTP.Types as HTTP+import Network.Socket+import qualified Network.Wai as Wai+import Network.Wai.Handler.Warp+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.HUnit+import Test.QuickCheck+import Web.FormUrlEncoded+ (FromForm, ToForm)++import Servant.API+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,+ BasicAuthData (..), Capture, CaptureAll, Delete,+ DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,+ Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,+ QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)+import qualified Servant.Client.Core.Auth as Auth+import qualified Servant.Client.Core.Request as Req+import Servant.HttpStreams+import Servant.Server+import Servant.Server.Experimental.Auth+import Servant.Test.ComprehensiveAPI++-- This declaration simply checks that all instances are in place.+_ = client comprehensiveAPIWithoutStreaming++spec :: Spec+spec = describe "Servant.HttpStreams" $ do+ sucessSpec+ failSpec+ wrappedApiSpec+ basicAuthSpec+ genAuthSpec+ hoistClientSpec+ connectionErrorSpec++-- * test data types++data Person = Person+ { _name :: String+ , _age :: Integer+ } deriving (Eq, Show, Generic)++instance NFData Person where+ rnf (Person n a) = rnf n `seq` rnf a++instance ToJSON Person+instance FromJSON Person++instance ToForm Person+instance FromForm Person++instance Arbitrary Person where+ arbitrary = Person <$> arbitrary <*> arbitrary++alice :: Person+alice = Person "Alice" 42++carol :: Person+carol = Person "Carol" 17++type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]++type Api =+ Get '[JSON] Person+ :<|> "get" :> Get '[JSON] Person+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent+ :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person+ :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [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+ :<|> "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" :> DeleteNoContent '[JSON] NoContent+ :<|> "redirectWithCookie" :> Raw+ :<|> "empty" :> EmptyAPI++api :: Proxy Api+api = Proxy++getRoot :: ClientM Person+getGet :: ClientM Person+getDeleteEmpty :: ClientM NoContent+getCapture :: String -> ClientM Person+getCaptureAll :: [String] -> ClientM [Person]+getBody :: Person -> ClientM Person+getQueryParam :: Maybe String -> ClientM Person+getQueryParams :: [String] -> ClientM [Person]+getQueryFlag :: Bool -> ClientM Bool+getRawSuccess :: HTTP.Method -> ClientM Response+getRawFailure :: HTTP.Method -> ClientM Response+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]+ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])+getRespHeaders :: ClientM (Headers TestHeaders Bool)+getDeleteContentType :: ClientM NoContent+_getRedirectWithCookie :: HTTP.Method -> ClientM Response++getRoot+ :<|> getGet+ :<|> getDeleteEmpty+ :<|> getCapture+ :<|> getCaptureAll+ :<|> getBody+ :<|> getQueryParam+ :<|> getQueryParams+ :<|> getQueryFlag+ :<|> getRawSuccess+ :<|> getRawFailure+ :<|> getMultiple+ :<|> getRespHeaders+ :<|> getDeleteContentType+ :<|> _getRedirectWithCookie+ :<|> EmptyClient = client api++server :: Application+server = serve api (+ return carol+ :<|> return alice+ :<|> return NoContent+ :<|> (\ name -> return $ Person name 0)+ :<|> (\ names -> return (zipWith Person names [0..]))+ :<|> return+ :<|> (\ name -> case name of+ Just "alice" -> return alice+ Just n -> throwError $ ServerError 400 (n ++ " not found") "" []+ Nothing -> throwError $ ServerError 400 "missing parameter" "" [])+ :<|> (\ names -> return (zipWith Person names [0..]))+ :<|> return+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")+ :<|> (\ a b c d -> return (a, b, c, d))+ :<|> (return $ addHeader 1729 $ addHeader "eg2" True)+ :<|> return NoContent+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")+ :<|> emptyServer)++type FailApi =+ "get" :> Raw+ :<|> "capture" :> Capture "name" String :> Raw+ :<|> "body" :> Raw+failApi :: Proxy FailApi+failApi = Proxy++failServer :: Application+failServer = serve failApi (+ (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")+ :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")+ :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")+ )++-- * basic auth stuff++type BasicAuthAPI =+ BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person++basicAuthAPI :: Proxy BasicAuthAPI+basicAuthAPI = Proxy++basicAuthHandler :: BasicAuthCheck ()+basicAuthHandler =+ let check (BasicAuthData username password) =+ if username == "servant" && password == "server"+ then return (Authorized ())+ else return Unauthorized+ in BasicAuthCheck check++basicServerContext :: Context '[ BasicAuthCheck () ]+basicServerContext = basicAuthHandler :. EmptyContext++basicAuthServer :: Application+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))++-- * general auth stuff++type GenAuthAPI =+ AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person++genAuthAPI :: Proxy GenAuthAPI+genAuthAPI = Proxy++type instance AuthServerData (AuthProtect "auth-tag") = ()+type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()++genAuthHandler :: AuthHandler Wai.Request ()+genAuthHandler =+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of+ Nothing -> throwError (err401 { errBody = "Missing auth header" })+ Just _ -> return ()+ in mkAuthHandler handler++genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]+genAuthServerContext = genAuthHandler :. EmptyContext++genAuthServer :: Application+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))++runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)+runClient x burl = withClientEnvIO burl (runClientM x)++runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)+runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)+ where+ runClientMUnsafe x env = withClientM x env return++sucessSpec :: Spec+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do+ it "Servant.API.Get root" $ \(_, baseUrl) -> do+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol++ it "Servant.API.Get" $ \(_, baseUrl) -> do+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice++ describe "Servant.API.Delete" $ do+ it "allows empty content type" $ \(_, baseUrl) -> do+ left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent++ it "allows content type" $ \(_, baseUrl) -> do+ left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent++ it "Servant.API.Capture" $ \(_, baseUrl) -> do+ left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)++ it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do+ let expected = [(Person "Paula" 0), (Person "Peta" 1)]+ left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected++ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do+ let p = Person "Clara" 42+ left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p++ it "Servant.API FailureResponse" $ \(_, baseUrl) -> do+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice+ Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl+ Req.requestPath req `shouldBe` (baseUrl, "/param")+ toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]+ Req.requestMethod req `shouldBe` HTTP.methodGet++ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice+ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl+ responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"++ it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do+ left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []+ left show <$> runClient (getQueryParams ["alice", "bob"]) 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 <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag++ it "Servant.API.Raw on success" $ \(_, baseUrl) -> do+ res <- runClient (getRawSuccess HTTP.methodGet) baseUrl+ case res of+ Left e -> assertFailure $ show e+ Right r -> do+ responseStatusCode r `shouldBe` HTTP.status200+ responseBody r `shouldBe` "rawSuccess"++ it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do+ res <- runClient (getRawFailure HTTP.methodGet) baseUrl+ case res of+ Right _ -> assertFailure "expected Left, but got Right"+ Left (FailureResponse _ r) -> do+ responseStatusCode r `shouldBe` HTTP.status400+ responseBody r `shouldBe` "rawFailure"+ Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e++ it "Returns headers appropriately" $ \(_, baseUrl) -> do+ res <- runClient getRespHeaders baseUrl+ 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" $ \(_, baseUrl) ->+ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->+ ioProperty $ do+ result <- left show <$> runClient (getMultiple cap num flag body) baseUrl+ return $+ result === Right (cap, num, flag, body)+++wrappedApiSpec :: Spec+wrappedApiSpec = describe "error status codes" $ do+ let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []+ context "are correctly handled by the client" $+ let test :: (WrappedApi, String) -> Spec+ test (WrappedApi api, desc) =+ it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do+ let getResponse :: ClientM ()+ getResponse = client api+ Left (FailureResponse _ r) <- runClient getResponse baseUrl+ responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")+ in mapM_ test $+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :+ []++failSpec :: Spec+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do++ context "client returns errors appropriately" $ do+ it "reports FailureResponse" $ \(_, baseUrl) -> do+ let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api+ Left res <- runClient getDeleteEmpty baseUrl+ case res of+ FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()+ _ -> fail $ "expected 404 response, but got " <> show res++ it "reports DecodeFailure" $ \(_, baseUrl) -> do+ let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api+ Left res <- runClient (getCapture "foo") baseUrl+ case res of+ DecodeFailure _ _ -> return ()+ _ -> fail $ "expected DecodeFailure, but got " <> show res++ -- we don't catch IOException's+ xit "reports ConnectionError" $ \_ -> do+ let (getGetWrongHost :<|> _) = client api+ Left res <- runClient getGetWrongHost (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 <- runClient getGet 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 <- runClient (getBody alice) baseUrl+ case res of+ InvalidContentTypeHeader _ -> return ()+ _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res++data WrappedApi where+ WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,+ HasClient ClientM api, Client ClientM api ~ ClientM ()) =>+ Proxy api -> WrappedApi++basicAuthSpec :: Spec+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do+ context "Authentication works when requests are properly authenticated" $ do++ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do+ let getBasic = client basicAuthAPI+ let basicAuthData = BasicAuthData "servant" "server"+ left show <$> runClient (getBasic basicAuthData) 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 _ r) <- runClient (getBasic basicAuthData) baseUrl+ responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"++genAuthSpec :: Spec+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do+ context "Authentication works when requests are properly authenticated" $ do++ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do+ let getProtected = client genAuthAPI+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)+ left show <$> runClient (getProtected authRequest) 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 = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)+ Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl+ responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")++-- * hoistClient++type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int++hoistClientAPI :: Proxy HoistClientAPI+hoistClientAPI = Proxy++hoistClientServer :: Application -- implements HoistClientAPI+hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)++hoistClientSpec :: Spec+hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do+ describe "Servant.Client.hoistClient" $ do+ it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do+ let (getInt :<|> postInt)+ = hoistClient hoistClientAPI+ (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)+ (client hoistClientAPI)++ getInt `shouldReturn` 5+ postInt 5 `shouldReturn` 5++-- * ConnectionError+type ConnectionErrorAPI = Get '[JSON] Int++connectionErrorAPI :: Proxy ConnectionErrorAPI+connectionErrorAPI = Proxy++connectionErrorSpec :: Spec+connectionErrorSpec = describe "Servant.Client.ClientError" $+ xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do+ let getInt = client connectionErrorAPI+ let baseUrl' = BaseUrl Http "example.invalid" 80 ""+ let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e+ isHttpError _ = False+ (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True++-- * utils++startWaiApp :: Application -> IO (ThreadId, BaseUrl)+startWaiApp app = do+ (port, socket) <- openTestSocket+ let settings = setPort port $ defaultSettings+ thread <- forkIO $ runSettingsSocket settings socket app+ return (thread, BaseUrl Http "localhost" port "")+++endWaiApp :: (ThreadId, BaseUrl) -> IO ()+endWaiApp (thread, _) = killThread thread++openTestSocket :: IO (Port, Socket)+openTestSocket = do+ s <- socket AF_INET Stream defaultProtocol+ let localhost = tupleToHostAddress (127, 0, 0, 1)+ bind s (SockAddrInet defaultPort 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/StreamSpec.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Servant.StreamSpec (spec) where++import Control.Monad.Trans.Except+import qualified Data.ByteString as BS+import Data.Proxy+import Prelude ()+import Prelude.Compat+import Servant.API+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,+ NewlineFraming, NoFraming, OctetStream, SourceIO, StreamBody,+ StreamGet)+import Servant.ClientSpec+ (Person (..))+import qualified Servant.ClientSpec as CS+import Servant.HttpStreams+import Servant.Server+import Servant.Types.SourceT+import System.Entropy+ (getEntropy, getHardwareEntropy)+import Test.Hspec+++spec :: Spec+spec = describe "Servant.HttpStreams streaming" $ do+ streamSpec++type StreamApi =+ "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)+ :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)+ :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)++api :: Proxy StreamApi+api = Proxy++getGetNL, getGetNS :: ClientM (SourceIO Person)+_getGetALot :: ClientM (SourceIO BS.ByteString)+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)+getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api++alice :: Person+alice = Person "Alice" 42++bob :: Person+bob = Person "Bob" 25++server :: Application+server = serve api+ $ return (source [alice, bob, alice])+ :<|> return (source [alice, bob, alice])+ -- 2 ^ (18 + 10) = 256M+ :<|> return (SourceT ($ lots (powerOfTwo 18)))+ :<|> return+ where+ lots n+ | n < 0 = Stop+ | otherwise = Effect $ do+ let size = powerOfTwo 10+ mbs <- getHardwareEntropy size+ bs <- maybe (getEntropy size) pure mbs+ return (Yield bs (lots (n - 1)))++powerOfTwo :: Int -> Int+powerOfTwo = (2 ^)++withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r+withClient x burl k = do+ withClientEnvIO burl $ \env -> withClientM x env k++testRunSourceIO :: SourceIO a+ -> IO (Either String [a])+testRunSourceIO = runExceptT . runSourceT++streamSpec :: Spec+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do+ it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do+ withClient getGetNL baseUrl $ \(Right res) ->+ testRunSourceIO res `shouldReturn` Right [alice, bob, alice]++ it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do+ withClient getGetNS baseUrl $ \(Right res) ->+ testRunSourceIO res `shouldReturn` Right [alice, bob, alice]++ it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do+ withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->+ testRunSourceIO res `shouldReturn` Right output+ where+ input = ["foo", "", "bar"]+ output = ["foo", "bar"]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}