diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,44 @@ +# servant-client + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +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 () +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# servant-client + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +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 () +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-http-streams.cabal b/servant-http-streams.cabal new file mode 100644 --- /dev/null +++ b/servant-http-streams.cabal @@ -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 webservice. + . + See . + . + + +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 diff --git a/src/Servant/HttpStreams.hs b/src/Servant/HttpStreams.hs new file mode 100644 --- /dev/null +++ b/src/Servant/HttpStreams.hs @@ -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 diff --git a/src/Servant/HttpStreams/Internal.hs b/src/Servant/HttpStreams/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/HttpStreams/Internal.hs @@ -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 diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ClientSpec.hs @@ -0,0 +1,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] diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/StreamSpec.hs @@ -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"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}