diff --git a/.travis.yml b/.travis.yml index fa534767..eb12059a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -69,12 +69,12 @@ install: - rm -fv cabal.project cabal.project.local - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi" - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"servant-machines\" \"servant-conduit\" \"servant-pipes\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/basic-streaming\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/hoist-server-with-context\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project" + - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-http-streams\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"servant-machines\" \"servant-conduit\" \"servant-pipes\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/basic-streaming\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/hoist-server-with-context\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project" - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project" - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" + - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-http-streams | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "servant/configure.ac" ]; then @@ -86,6 +86,9 @@ install: - if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi + - if [ -f "servant-http-streams/configure.ac" ]; then + (cd "servant-http-streams" && autoreconf -i); + fi - if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi @@ -150,7 +153,7 @@ install: (cd "doc/cookbook/using-free-client" && autoreconf -i); fi - rm -f cabal.project.freeze - - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "servant-machines"/dist "servant-conduit"/dist "servant-pipes"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/basic-streaming"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/hoist-server-with-context"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist + - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-http-streams"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "servant-machines"/dist "servant-conduit"/dist "servant-pipes"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/basic-streaming"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/hoist-server-with-context"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Here starts the actual work to be performed for the package under test; @@ -164,12 +167,12 @@ script: - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal servant-machines-*/*.cabal servant-conduit-*/*.cabal servant-pipes-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-basic-streaming-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-hoist-server-with-context-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project" + - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-http-streams-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal servant-machines-*/*.cabal servant-conduit-*/*.cabal servant-pipes-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-basic-streaming-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-hoist-server-with-context-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project" - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project" - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" + - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-http-streams | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true - cat cabal.project.local || true - echo -en 'travis_fold:end:unpack\\r' diff --git a/cabal.project b/cabal.project index a059a9f4..6052321d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,8 @@ -packages: servant/ +packages: + servant/ servant-client/ servant-client-core/ + servant-http-streams/ servant-docs/ servant-foreign/ servant-server/ diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index 5eb9cd2d..ca2811be 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -137,7 +137,7 @@ And we continue by turning http-client's `Response` into servant's `Response`, and calling the continuation. We should get a `Pure` value. ```haskell - let res = I.clientResponseToResponse res' + let res = I.clientResponseToResponse id res' case k res of Pure n -> diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 08c79e85..d1e444ba 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -39,10 +39,12 @@ library Servant.Client.Core.Internal.Auth Servant.Client.Core.Internal.BaseUrl Servant.Client.Core.Internal.BasicAuth + Servant.Client.Core.Internal.ClientError Servant.Client.Core.Internal.ClientF Servant.Client.Core.Internal.Generic Servant.Client.Core.Internal.HasClient Servant.Client.Core.Internal.Request + Servant.Client.Core.Internal.Response Servant.Client.Core.Internal.RunClient -- Bundled with GHC: Lower bound to not force re-installs diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 09527eaa..635df2ed 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -41,7 +41,7 @@ module Servant.Client.Core -- * Response , Response - , GenResponse (..) + , ResponseF (..) , RunClient(..) , module Servant.Client.Core.Internal.BaseUrl -- ** Streaming @@ -64,4 +64,6 @@ import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.Generic import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Response +import Servant.Client.Core.Internal.ClientError import Servant.Client.Core.Internal.RunClient diff --git a/servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs b/servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs new file mode 100644 index 00000000..25715f87 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Core.Internal.ClientError where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import Control.Exception + (SomeException (..)) +import Control.Monad.Catch + (Exception) +import qualified Data.ByteString as BS +import Data.Text + (Text) +import Data.Typeable + (Typeable, typeOf) +import GHC.Generics + (Generic) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types () + +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Response + + + +-- | A type representing possible errors in a request +-- +-- Note that this type substantially changed in 0.12. +data ServantError = + -- | The server returned an error response including the + -- failing request. 'requestPath' includes the 'BaseUrl' and the + -- path of the request. + FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response + -- | The body could not be decoded at the expected type + | DecodeFailure Text Response + -- | The content-type of the response is not supported + | UnsupportedContentType MediaType Response + -- | The content-type header is invalid + | InvalidContentTypeHeader Response + -- | There was a connection error, and no response was received + | ConnectionError SomeException + deriving (Show, Generic, Typeable) + +instance Eq ServantError where + FailureResponse req res == FailureResponse req' res' = req == req' && res == res' + DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r' + UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r' + InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r' + ConnectionError exc == ConnectionError exc' = eqSomeException exc exc' + where + -- returns true, if type of exception is the same + eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b + + -- prevent wild card blindness + FailureResponse {} == _ = False + DecodeFailure {} == _ = False + UnsupportedContentType {} == _ = False + InvalidContentTypeHeader {} == _ = False + ConnectionError {} == _ = False + +instance Exception ServantError + +-- | Note: an exception in 'ConnectionError' might not be evaluated fully, +-- We only 'rnf' its 'show'ed value. +instance NFData ServantError where + rnf (FailureResponse req res) = rnf req `seq` rnf res + rnf (DecodeFailure err res) = rnf err `seq` rnf res + rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res + rnf (InvalidContentTypeHeader res) = rnf res + rnf (ConnectionError err) = err `seq` rnf (show err) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs b/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs index 20035c0b..7b2a0deb 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs @@ -2,6 +2,8 @@ module Servant.Client.Core.Internal.ClientF where import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Response +import Servant.Client.Core.Internal.ClientError data ClientF a = RunRequest Request (Response -> a) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 6be92ec6..f480e655 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -16,10 +16,7 @@ module Servant.Client.Core.Internal.HasClient where import Prelude () import Prelude.Compat -import Control.Concurrent.MVar - (modifyMVar, newMVar) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BL import Data.Foldable (toList) import Data.List @@ -34,7 +31,7 @@ import Data.Text (Text, pack) import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, BuildHeadersTo (..), Capture', CaptureAll, Description, @@ -50,11 +47,12 @@ import Servant.API.ContentTypes (contentTypes) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) -import qualified Servant.Types.SourceT as S import Servant.Client.Core.Internal.Auth import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.ClientError import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Response import Servant.Client.Core.Internal.RunClient -- * Accessing APIs as a Client @@ -283,7 +281,7 @@ instance {-# OVERLAPPABLE #-} clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres) + return $ fromSourceIO $ framingUnrender' $ responseBody gres where req' = req { requestAccept = fromList [contentType (Proxy :: Proxy ct)] @@ -552,7 +550,7 @@ instance clientWithRoute pm Proxy req body = clientWithRoute pm (Proxy :: Proxy api) - $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req + $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req where ctypeP = Proxy :: Proxy ctype framingP = Proxy :: Proxy framing @@ -562,28 +560,6 @@ instance (mimeRender ctypeP :: chunk -> BL.ByteString) (toSourceIO body) - -- not pretty. - givesPopper :: (IO BS.ByteString -> IO ()) -> IO () - givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do - ref <- newMVar step0 - - -- Note sure we need locking, but it's feels safer. - let popper :: IO BS.ByteString - popper = modifyMVar ref nextBs - - needsPopper popper - - nextBs S.Stop = return (S.Stop, BS.empty) - nextBs (S.Error err) = fail err - nextBs (S.Skip s) = nextBs s - nextBs (S.Effect ms) = ms >>= nextBs - nextBs (S.Yield lbs s) = case BL.toChunks lbs of - [] -> nextBs s - (x:xs) | BS.null x -> nextBs step' - | otherwise -> return (step', x) - where - step' = S.Yield (BL.fromChunks xs) s - -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where type Client m (path :> api) = Client m api diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index ffa1c674..08e06f25 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -17,10 +16,6 @@ import Prelude.Compat import Control.DeepSeq (NFData (..)) -import Control.Exception - (SomeException (..)) -import Control.Monad.Catch - (Exception) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor @@ -30,8 +25,6 @@ import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS -import Data.Int - (Int64) import Data.Semigroup ((<>)) import qualified Data.Sequence as Seq @@ -40,64 +33,16 @@ import Data.Text import Data.Text.Encoding (encodeUtf8) import Data.Typeable - (Typeable, typeOf) + (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media (MediaType, mainType, parameters, subType) import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, - Status (..), http11, methodGet) + http11, methodGet) import Servant.API - (ToHttpApiData, toEncodedUrlPiece, toHeader) -import Servant.Client.Core.Internal.BaseUrl - (BaseUrl) - --- | A type representing possible errors in a request --- --- Note that this type substantially changed in 0.12. -data ServantError = - -- | The server returned an error response including the - -- failing request. 'requestPath' includes the 'BaseUrl' and the - -- path of the request. - FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response - -- | The body could not be decoded at the expected type - | DecodeFailure Text Response - -- | The content-type of the response is not supported - | UnsupportedContentType MediaType Response - -- | The content-type header is invalid - | InvalidContentTypeHeader Response - -- | There was a connection error, and no response was received - | ConnectionError SomeException - deriving (Show, Generic, Typeable) - -instance Eq ServantError where - FailureResponse req res == FailureResponse req' res' = req == req' && res == res' - DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r' - UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r' - InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r' - ConnectionError exc == ConnectionError exc' = eqSomeException exc exc' - where - -- returns true, if type of exception is the same - eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b - - -- prevent wild card blindness - FailureResponse {} == _ = False - DecodeFailure {} == _ = False - UnsupportedContentType {} == _ = False - InvalidContentTypeHeader {} == _ = False - ConnectionError {} == _ = False - -instance Exception ServantError - --- | Note: an exception in 'ConnectionError' might not be evaluated fully, --- We only 'rnf' its 'show'ed value. -instance NFData ServantError where - rnf (FailureResponse req res) = rnf req `seq` rnf res - rnf (DecodeFailure err res) = rnf err `seq` rnf res - rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res - rnf (InvalidContentTypeHeader res) = rnf res - rnf (ConnectionError err) = err `seq` rnf (show err) + (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) mediaTypeRnf :: MediaType -> () mediaTypeRnf mt = @@ -143,31 +88,13 @@ type Request = RequestF RequestBody Builder.Builder data RequestBody = RequestBodyLBS LBS.ByteString | RequestBodyBS BS.ByteString - | RequestBodyBuilder Int64 Builder.Builder - | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ()) - | RequestBodyIO (IO RequestBody) + | RequestBodySource (SourceIO LBS.ByteString) deriving (Generic, Typeable) -data GenResponse a = Response - { responseStatusCode :: Status - , responseHeaders :: Seq.Seq Header - , responseHttpVersion :: HttpVersion - , responseBody :: a - } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) - -instance NFData a => NFData (GenResponse a) where - rnf (Response sc hs hv body) = - rnfStatus sc `seq` - rnf hs `seq` - rnfHttpVersion hv `seq` - rnf body - where - rnfStatus (Status code msg) = rnf code `seq` rnf msg - rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict - -type Response = GenResponse LBS.ByteString -type StreamingResponse = GenResponse (IO BS.ByteString) +instance Show RequestBody where + showsPrec d (RequestBodyLBS lbs) = showParen (d > 10) + $ showString "RequestBodyLBS " + . showsPrec 11 lbs -- A GET request to the top-level path defaultRequest :: Request diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Response.hs b/servant-client-core/src/Servant/Client/Core/Internal/Response.hs new file mode 100644 index 00000000..0186be26 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Response.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Client.Core.Internal.Response where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Sequence as Seq +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Types + (Header, HttpVersion (..), Status (..)) + +import Servant.API.Stream + (SourceIO) + +data ResponseF a = Response + { responseStatusCode :: Status + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + , responseBody :: a + } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) + +instance NFData a => NFData (ResponseF a) where + rnf (Response sc hs hv body) = + rnfStatus sc `seq` + rnf hs `seq` + rnfHttpVersion hv `seq` + rnf body + where + rnfStatus (Status code msg) = rnf code `seq` rnf msg + rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict + +type Response = ResponseF LBS.ByteString +type StreamingResponse = ResponseF (SourceIO BS.ByteString) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index 9ef71e86..197e570e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -25,8 +25,8 @@ import Servant.API import Servant.Client.Core.Internal.ClientF import Servant.Client.Core.Internal.Request - (GenResponse (..), Request, Response, ServantError (..), - StreamingResponse) +import Servant.Client.Core.Internal.Response +import Servant.Client.Core.Internal.ClientError class Monad m => RunClient m where -- | How to make a request. diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 401b1e8f..b13b72bf 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -9,7 +9,7 @@ module Servant.Client.Core.Reexport -- * Response (for @Raw@) , Response , StreamingResponse - , GenResponse(..) + , ResponseF(..) -- * Generic Client , ClientLike(..) @@ -30,4 +30,5 @@ module Servant.Client.Core.Reexport import Servant.Client.Core.Internal.BaseUrl import Servant.Client.Core.Internal.Generic import Servant.Client.Core.Internal.HasClient -import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Response +import Servant.Client.Core.Internal.ClientError diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 9edc6dbf..8340e245 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -14,6 +14,9 @@ module Servant.Client.Internal.HttpClient where import Prelude () import Prelude.Compat +import Control.Concurrent.MVar + (modifyMVar, newMVar) +import qualified Data.ByteString as BS import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad @@ -52,7 +55,6 @@ import Data.Sequence (fromList) import Data.String (fromString) -import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import GHC.Generics @@ -62,6 +64,7 @@ import Network.HTTP.Types (hContentType, renderQuery, statusCode) import Servant.Client.Core +import qualified Servant.Types.SourceT as S import qualified Network.HTTP.Client as Client -- | The environment in which a request is run. @@ -167,7 +170,7 @@ performRequest req = do response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' let status = Client.responseStatus response status_code = statusCode status - ourResponse = clientResponseToResponse response + ourResponse = clientResponseToResponse id response unless (status_code >= 200 && status_code < 300) $ throwError $ mkFailureResponse burl req ourResponse return ourResponse @@ -197,34 +200,34 @@ performRequest req = do fReq = Client.hrFinalRequest responses fRes = Client.hrFinalResponse responses -mkFailureResponse :: BaseUrl -> Request -> GenResponse BSL.ByteString -> ServantError +mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ServantError mkFailureResponse burl request = FailureResponse (bimap (const ()) f request) where f b = (burl, BSL.toStrict $ toLazyByteString b) -clientResponseToResponse :: Client.Response a -> GenResponse a -clientResponseToResponse r = Response - { responseStatusCode = Client.responseStatus r - , responseBody = Client.responseBody r - , responseHeaders = fromList $ Client.responseHeaders r - , responseHttpVersion = Client.responseVersion r - } +clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b +clientResponseToResponse f r = Response + { responseStatusCode = Client.responseStatus r + , responseBody = f (Client.responseBody r) + , responseHeaders = fromList $ Client.responseHeaders r + , responseHttpVersion = Client.responseVersion r + } requestToClientRequest :: BaseUrl -> Request -> Client.Request requestToClientRequest burl r = Client.defaultRequest - { Client.method = requestMethod r - , Client.host = fromString $ baseUrlHost burl - , Client.port = baseUrlPort burl - , Client.path = BSL.toStrict - $ fromString (baseUrlPath burl) - <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r - , Client.requestHeaders = - maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers - , Client.requestBody = body - , Client.secure = isSecure - } + { Client.method = requestMethod r + , Client.host = fromString $ baseUrlHost burl + , Client.port = baseUrlPort burl + , Client.path = BSL.toStrict + $ fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r) + , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.requestHeaders = + maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers + , Client.requestBody = body + , Client.secure = isSecure + } where -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ @@ -237,21 +240,38 @@ requestToClientRequest burl r = Client.defaultRequest hs = toList $ requestAccept r convertBody bd = case bd of - RequestBodyLBS body' -> Client.RequestBodyLBS body' - RequestBodyBS body' -> Client.RequestBodyBS body' - RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body' - RequestBodyStream size body' -> Client.RequestBodyStream size body' - RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body' - RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body') + RequestBodyLBS body' -> Client.RequestBodyLBS body' + RequestBodyBS body' -> Client.RequestBodyBS body' + RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper + where + givesPopper :: (IO BS.ByteString -> IO ()) -> IO () + givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do + ref <- newMVar step0 + + -- Note sure we need locking, but it's feels safer. + let popper :: IO BS.ByteString + popper = modifyMVar ref nextBs + + needsPopper popper + + nextBs S.Stop = return (S.Stop, BS.empty) + nextBs (S.Error err) = fail err + nextBs (S.Skip s) = nextBs s + nextBs (S.Effect ms) = ms >>= nextBs + nextBs (S.Yield lbs s) = case BSL.toChunks lbs of + [] -> nextBs s + (x:xs) | BS.null x -> nextBs step' + | otherwise -> return (step', x) + where + step' = S.Yield (BSL.fromChunks xs) s (body, contentTypeHdr) = case requestBody r of - Nothing -> (Client.RequestBodyLBS "", Nothing) - Just (body', typ) - -> (convertBody body', Just (hContentType, renderHeader typ)) + Nothing -> (Client.RequestBodyBS "", Nothing) + Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of - Http -> False - Https -> True + Http -> False + Https -> True catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 429c079d..fbf82c2d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -35,6 +35,7 @@ import Control.Monad.Reader import Control.Monad.STM (atomically) import Control.Monad.Trans.Except +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Foldable (for_) @@ -53,8 +54,9 @@ import qualified Network.HTTP.Client as Client import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, - clientResponseToResponse, mkClientEnv, requestToClientRequest, - mkFailureResponse) + clientResponseToResponse, mkClientEnv, mkFailureResponse, + requestToClientRequest) +import qualified Servant.Types.SourceT as S -- | Generates a set of client functions for an API. @@ -165,7 +167,7 @@ performRequest req = do atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response status_code = statusCode status - ourResponse = clientResponseToResponse response + ourResponse = clientResponseToResponse id response unless (status_code >= 200 && status_code < 300) $ throwError $ mkFailureResponse burl req ourResponse return ourResponse @@ -183,7 +185,7 @@ performWithStreamingRequest req k = do -- we throw FailureResponse in IO :( unless (status_code >= 200 && status_code < 300) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) - throwIO $ mkFailureResponse burl req (clientResponseToResponse res { Client.responseBody = b }) + throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) - x <- k (clientResponseToResponse res) + x <- k (clientResponseToResponse (S.fromAction BS.null) res) k1 x diff --git a/servant-http-streams/CHANGELOG.md b/servant-http-streams/CHANGELOG.md new file mode 100644 index 00000000..59eafb93 --- /dev/null +++ b/servant-http-streams/CHANGELOG.md @@ -0,0 +1,2 @@ + [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) diff --git a/servant-http-streams/LICENSE b/servant-http-streams/LICENSE new file mode 100644 index 00000000..c6a28c24 --- /dev/null +++ b/servant-http-streams/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/servant-http-streams/README.lhs b/servant-http-streams/README.lhs new file mode 120000 index 00000000..42061c01 --- /dev/null +++ b/servant-http-streams/README.lhs @@ -0,0 +1 @@ +README.md \ No newline at end of file diff --git a/servant-http-streams/README.md b/servant-http-streams/README.md new file mode 100644 index 00000000..96620f84 --- /dev/null +++ b/servant-http-streams/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/servant-http-streams/Setup.hs b/servant-http-streams/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-http-streams/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-http-streams/servant-http-streams.cabal b/servant-http-streams/servant-http-streams.cabal new file mode 100644 index 00000000..4cd5e6e3 --- /dev/null +++ b/servant-http-streams/servant-http-streams.cabal @@ -0,0 +1,137 @@ +cabal-version: >=1.10 +name: servant-http-streams +version: 0.15 + +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: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors +build-type: Simple +tested-with: + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.2 + +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.15.* + , servant-client-core >= 0.15 && <0.15.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 + , generics-sop >= 0.4.0.1 && < 0.5 + , hspec >= 2.6.0 && < 2.7 + , HUnit >= 1.6.0.0 && < 1.7 + , network >= 2.8.0.0 && < 3.1 + , QuickCheck >= 2.12.6.1 && < 2.13 + , servant == 0.15.* + , servant-server == 0.15.* + , tdigest >= 0.2 && < 0.3 + + build-tool-depends: + hspec-discover:hspec-discover >= 2.6.0 && < 2.7 + +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/servant-http-streams/src/Servant/HttpStreams.hs b/servant-http-streams/src/Servant/HttpStreams.hs new file mode 100644 index 00000000..99959f9e --- /dev/null +++ b/servant-http-streams/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/servant-http-streams/src/Servant/HttpStreams/Internal.hs b/servant-http-streams/src/Servant/HttpStreams/Internal.hs new file mode 100644 index 00000000..b2914f78 --- /dev/null +++ b/servant-http-streams/src/Servant/HttpStreams/Internal.hs @@ -0,0 +1,254 @@ +{-# 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 ServantError (Codensity IO)) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv, MonadError ServantError) + +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 + throwServantError = throwError + +instance RunStreamingClient ClientM where + withStreamingRequest = performWithStreamingRequest + +instance ClientLike (ClientM a) (ClientM a) where + mkClient = id + +runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = withClientM cm env (evaluate . force) + +withClientM :: ClientM a -> ClientEnv -> (Either ServantError 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 -> ServantError +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 ServantError 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/servant-http-streams/test/Servant/ClientSpec.hs b/servant-http-streams/test/Servant/ClientSpec.hs new file mode 100644 index 00000000..df1d175a --- /dev/null +++ b/servant-http-streams/test/Servant/ClientSpec.hs @@ -0,0 +1,571 @@ +{-# 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 qualified Generics.SOP as SOP +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.Internal.Auth as Auth +import qualified Servant.Client.Core.Internal.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 + genericClientSpec + 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 $ ServantErr 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServantErr 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)) + +-- * generic client stuff + +type GenericClientAPI + = QueryParam "sqr" Int :> Get '[JSON] Int + :<|> Capture "foo" String :> NestedAPI1 + +data GenericClient = GenericClient + { getSqr :: Maybe Int -> ClientM Int + , mkNestedClient1 :: String -> NestedClient1 + } deriving Generic +instance SOP.Generic GenericClient +instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient + +type NestedAPI1 + = QueryParam "int" Int :> NestedAPI2 + :<|> QueryParam "id" Char :> Get '[JSON] Char + +data NestedClient1 = NestedClient1 + { mkNestedClient2 :: Maybe Int -> NestedClient2 + , idChar :: Maybe Char -> ClientM Char + } deriving Generic +instance SOP.Generic NestedClient1 +instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 + +type NestedAPI2 + = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int + :<|> "void" :> Post '[JSON] () + +data NestedClient2 = NestedClient2 + { getSum :: Int -> Int -> ClientM Int + , doNothing :: ClientM () + } deriving Generic +instance SOP.Generic NestedClient2 +instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 + +genericClientServer :: Application +genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( + (\ mx -> case mx of + Just x -> return (x*x) + Nothing -> throwError $ ServantErr 400 "missing parameter" "" [] + ) + :<|> nestedServer1 + ) + where + nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) + nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () + +runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a) +runClient x burl = withClientEnvIO burl (runClientM x) + +runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ServantError 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 $ ServantErr 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") + +genericClientSpec :: Spec +genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.Generic" $ do + + let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) + NestedClient1{..} = mkNestedClient1 "example" + NestedClient2{..} = mkNestedClient2 (Just 42) + + it "works for top-level client inClientM function" $ \(_, baseUrl) -> do + left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25 + + it "works for nested clients" $ \(_, baseUrl) -> do + left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c' + left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 + left show <$> runClient doNothing baseUrl `shouldReturn` Right () + +-- * 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.ServantError" $ + 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/servant-http-streams/test/Servant/StreamSpec.hs b/servant-http-streams/test/Servant/StreamSpec.hs new file mode 100644 index 00000000..f13b6dd8 --- /dev/null +++ b/servant-http-streams/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 ServantError 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/servant-http-streams/test/Spec.hs b/servant-http-streams/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-http-streams/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index e5ff1ed9..6ca42b6f 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -35,6 +35,8 @@ module Servant.API.ResponseHeaders , HList(..) ) where +import Control.DeepSeq + (NFData (..)) import Data.ByteString.Char8 as BS (ByteString, init, pack, unlines) import qualified Data.CaseInsensitive as CI @@ -60,16 +62,32 @@ data Headers ls a = Headers { getResponse :: a -- ^ HList of headers. } deriving (Functor) +instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where + rnf (Headers x hdrs) = rnf x `seq` rnf hdrs + data ResponseHeader (sym :: Symbol) a = Header a | MissingHeader | UndecodableHeader ByteString deriving (Typeable, Eq, Show, Functor) +instance NFData a => NFData (ResponseHeader sym a) where + rnf MissingHeader = () + rnf (UndecodableHeader bs) = rnf bs + rnf (Header x) = rnf x + data HList a where HNil :: HList '[] HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs) +class NFDataHList xs where rnfHList :: HList xs -> () +instance NFDataHList '[] where rnfHList HNil = () +instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where + rnfHList (HCons h xs) = rnf h `seq` rnfHList xs + +instance NFDataHList xs => NFData (HList xs) where + rnf = rnfHList + type family HeaderValMap (f :: * -> *) (xs :: [*]) where HeaderValMap f '[] = '[] HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs