diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,29 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20.3.0 +-------- + +- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811) + + Implement Server-sent events (SSE) for the Servant client using a new + combinator "ServerSentEvents". The raw event messages, accumulated events and + JSON-processed events can be exposed. + +- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804) + + Expose MultiVerb, a more ergonomic way of defining endpoints that return + many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html + +- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706) +- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778) +- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805) +- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784) [#1814](https://github.com/haskell-servant/servant/pull/1814) +- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800) + + Adding a Host combinator allows servant users to select APIs according + to the Host header provided by clients. + 0.20.2 ------ diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} import Data.Proxy -import Data.Text +import Data.Text (Text) import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} import Data.Proxy -import Data.Text +import Data.Text (Text) import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: servant-client -version: 0.20.2 +version: 0.20.3.0 synopsis: Automatic derivation of querying functions for servant category: Servant, Web description: @@ -21,8 +21,7 @@ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1 +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 extra-source-files: CHANGELOG.md @@ -94,13 +93,13 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: - , base >=4.14 && <4.21 - , bytestring >=0.10.8.1 && <0.13 - , containers >=0.5.7.1 && <0.8 + , base >= 4.16.4.0 && < 4.22 + , bytestring >=0.11 && <0.13 + , containers >=0.6.5.1 && <0.9 , deepseq >=1.4.2.0 && <1.6 , mtl ^>=2.2.2 || ^>=2.3.1 , stm >=2.4.5.1 && <2.6 - , time >=1.6.0.1 && <1.13 + , time >=1.6.0.1 && <1.15 , transformers >=0.5.2.0 && <0.7 -- Servant dependencies. @@ -162,6 +161,7 @@ , servant-client , servant-client-core , sop-core + , generics-sop , stm , text , transformers diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs --- a/src/Servant/Client/Internal/HttpClient.hs +++ b/src/Servant/Client/Internal/HttpClient.hs @@ -232,8 +232,15 @@ -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' -- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl' -- otherwise the body, headers and query string are derived from the @servant@ 'Request' -defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request -defaultMakeClientRequest burl r = return Client.defaultRequest +-- +-- Note that @Applicative@ dependency is not really needed for this function +-- implementation. But in the past the return type was wrapped into @IO@ +-- without a necessity breaking the API backward-compatibility. In order to not +-- break the API again it was changed to @Applicative@ so that you can just use +-- something like @Data.Functor.Identity@ without a need to involve @IO@ but +-- still keeping it compatible with the code written when it was typed as @IO@. +defaultMakeClientRequest :: Applicative f => BaseUrl -> Request -> f Client.Request +defaultMakeClientRequest burl r = pure Client.defaultRequest { Client.method = requestMethod r , Client.host = fromString $ baseUrlHost burl , Client.port = baseUrlPort burl diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -22,54 +22,49 @@ import Prelude () import Prelude.Compat -import Control.Concurrent - (ThreadId, forkIO, killThread) -import Control.Monad - (join) -import Control.Monad.Error.Class - (throwError) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad (join) +import Control.Monad.Error.Class (throwError) import Data.Aeson -import Data.ByteString - (ByteString) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Builder - (byteString) import qualified Data.ByteString.Lazy as LazyByteString -import Data.Char - (chr, isPrint) -import Data.Maybe (fromMaybe) +import Data.Char (chr, isPrint) +import Data.Maybe (fromMaybe) import Data.Monoid () import Data.Proxy import Data.SOP -import Data.Text - (Text) +import Data.Text (Text) import qualified Data.Text as Text -import Data.Text.Encoding - (decodeUtf8, encodeUtf8) -import GHC.Generics - (Generic) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Generics.SOP as GSOP +import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Network.Socket import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import System.IO.Unsafe - (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck -import Text.Read (readMaybe) -import Web.FormUrlEncoded - (FromForm, ToForm) +import Text.Read (readMaybe) +import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, DeepQuery, DeleteNoContent, - EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, - JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), + (AuthProtect, BasicAuth, BasicAuthData (..), Capture, + CaptureAll, DeepQuery, DeleteNoContent, EmptyAPI, + FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, + Headers, Host, JSON, MimeRender (mimeRender), + MimeUnrender (mimeUnrender), NamedRoutes, NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, - QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), - UVerb, Union, Verb, WithStatus (WithStatus), NamedRoutes, addHeader) -import Servant.API.Generic ((:-)) -import Servant.API.QueryString (FromDeepQuery(..), ToDeepQuery(..)) + QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), + ToHttpApiData (..), UVerb, Union, Verb, + WithStatus (WithStatus), addHeader, (:<|>) ((:<|>)), (:>)) +import Servant.API.Generic ((:-)) +import Servant.API.MultiVerb +import Servant.API.QueryString + (FromDeepQuery (..), ToDeepQuery (..)) +import Servant.API.Range import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -119,7 +114,7 @@ , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes } deriving Generic -data OtherRoutes mode = OtherRoutes +newtype OtherRoutes mode = OtherRoutes { something :: mode :- "something" :> Get '[JSON] [String] } deriving Generic @@ -145,6 +140,36 @@ , (["name"], Just (Text.pack name')) ] +----------------------------- +-- MultiVerb test endpoint -- +----------------------------- + +-- This is the list of all possible responses +type MultipleChoicesIntResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +data MultipleChoicesIntResult + = NegativeNumber + | Even Bool + | Odd Int + deriving stock (Generic) + deriving (AsUnion MultipleChoicesIntResponses) + via GenericAsUnion MultipleChoicesIntResponses MultipleChoicesIntResult + +instance GSOP.Generic MultipleChoicesIntResult + +-- This is our endpoint description +type MultipleChoicesInt = + Capture "int" Int + :> MultiVerb + 'GET + '[JSON] + MultipleChoicesIntResponses + MultipleChoicesIntResult + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person @@ -187,7 +212,10 @@ WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> NamedRoutes RecordRoutes + :<|> "multiple-choices-int" :> MultipleChoicesInt :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text + :<|> "host-test" :> Host "servant.example" :> Get '[JSON] Bool + :<|> PaginatedAPI api :: Proxy Api api = Proxy @@ -221,6 +249,10 @@ WithStatus 301 Text]) uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) recordRoutes :: RecordRoutes (AsClientT ClientM) +multiChoicesInt :: Int -> ClientM MultipleChoicesIntResult +captureVerbatim :: Verbatim -> ClientM Text +getHost :: ClientM Bool +getPaginatedPerson :: Maybe (Range 1 100) -> ClientM [Person] getRoot :<|> getGet @@ -249,7 +281,10 @@ :<|> uverbGetSuccessOrRedirect :<|> uverbGetCreated :<|> recordRoutes - :<|> captureVerbatim = client api + :<|> multiChoicesInt + :<|> captureVerbatim + :<|> getHost + :<|> getPaginatedPerson = client api server :: Application server = serve api ( @@ -260,10 +295,10 @@ :<|> (\ 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" "" []) + :<|> (\case + Just "alice" -> return alice + Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServerError 400 "missing parameter" "" []) :<|> const (Tagged $ \request respond -> respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload") (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict) @@ -282,15 +317,15 @@ } ) :<|> return alice - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> Tagged (\ request respond -> respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders request) "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 (addHeader 1729 $ addHeader "eg2" True) :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True) - :<|> (return $ addHeader "cookie1" $ addHeader "cookie2" True) + :<|> return (addHeader "cookie1" $ addHeader "cookie2" True) :<|> return NoContent - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") :<|> emptyServer :<|> (\shouldRedirect -> if shouldRedirect then respond (WithStatus @301 ("redirecting" :: Text)) @@ -299,11 +334,22 @@ :<|> RecordRoutes { version = pure 42 , echo = pure - , otherRoutes = \_ -> OtherRoutes + , otherRoutes = const OtherRoutes { something = pure ["foo", "bar", "pweet"] } } + :<|> (\param -> + if param < 0 + then pure NegativeNumber + else + if even param + then pure $ Odd 3 + else pure $ Even True + ) + :<|> pure . decodeUtf8 . unVerbatim + :<|> pure True + :<|> usersServer ) -- * api for testing failures @@ -318,10 +364,10 @@ failServer :: Application failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + 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")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") ) -- * basic auth stuff @@ -424,3 +470,14 @@ instance FromHttpApiData Verbatim where parseUrlPiece = pure . Verbatim . encodeUtf8 + +-- * range type example + +type PaginatedAPI = + "users" :> QueryParam "page" (Range 1 100) :> Get '[JSON] [Person] + +usersServer :: Maybe (Range 1 100) -> Handler [Person] +usersServer mpage = do + let pageNum = maybe 1 unRange mpage + -- pageNum is guaranteed to be between 1 and 100 + return [Person "Example" $ fromIntegral pageNum] diff --git a/test/Servant/MiddlewareSpec.hs b/test/Servant/MiddlewareSpec.hs --- a/test/Servant/MiddlewareSpec.hs +++ b/test/Servant/MiddlewareSpec.hs @@ -16,9 +16,7 @@ module Servant.MiddlewareSpec (spec) where -import Control.Arrow - ( left, - ) +import Control.Arrow (left) import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) import Control.Exception (Exception, throwIO, try) import Control.Monad.IO.Class