Skip to content

Commit da0c83d

Browse files
swamp-agrswamp-agr
authored
Add URI fragment as a separate combinator (#1324)
1 parent 339eec6 commit da0c83d

File tree

19 files changed

+418
-120
lines changed

19 files changed

+418
-120
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

Lines changed: 41 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE CPP #-}
23
{-# LANGUAGE DataKinds #-}
34
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE FlexibleInstances #-}
@@ -13,6 +14,10 @@
1314
{-# LANGUAGE TypeOperators #-}
1415
{-# LANGUAGE UndecidableInstances #-}
1516

17+
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18+
#define HAS_TYPE_ERROR
19+
#endif
20+
1621
module Servant.Client.Core.HasClient (
1722
clientIn,
1823
HasClient (..),
@@ -63,17 +68,18 @@ import qualified Network.HTTP.Types as H
6368
import Servant.API
6469
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
6570
BuildHeadersTo (..), Capture', CaptureAll, Description,
66-
EmptyAPI, FramingRender (..), FramingUnrender (..),
71+
EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
6772
FromSourceIO (..), Header', Headers (..), HttpVersion,
6873
IsSecure, MimeRender (mimeRender),
69-
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
70-
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
71-
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
72-
ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
73-
contentType, getHeadersHList, getResponse, toQueryParam,
74-
toUrlPiece)
74+
MimeUnrender (mimeUnrender), NoContent (NoContent),
75+
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
76+
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
77+
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
78+
Verb, WithNamedContext, contentType, getHeadersHList,
79+
getResponse, toQueryParam, toUrlPiece)
7580
import Servant.API.ContentTypes
7681
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
82+
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
7783
import Servant.API.Modifiers
7884
(FoldRequired, RequiredArgument, foldRequiredArgument)
7985
import Servant.API.UVerb
@@ -745,6 +751,34 @@ instance ( HasClient m api
745751
hoistClientMonad pm _ f cl = \authreq ->
746752
hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
747753

754+
-- | Ignore @'Fragment'@ in client functions.
755+
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
756+
--
757+
-- Example:
758+
--
759+
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
760+
-- >
761+
-- > myApi :: Proxy MyApi
762+
-- > myApi = Proxy
763+
-- >
764+
-- > getBooksBy :: Maybe Text -> ClientM [Book]
765+
-- > getBooksBy = client myApi
766+
-- > -- then you can just use "getBooksBy" to query that endpoint.
767+
-- > -- 'getBooksBy Nothing' for all books
768+
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
769+
#ifdef HAS_TYPE_ERROR
770+
instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
771+
#else
772+
instance ( HasClient m api
773+
#endif
774+
) => HasClient m (Fragment a :> api) where
775+
776+
type Client m (Fragment a :> api) = Client m api
777+
778+
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
779+
780+
hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
781+
748782
-- * Basic Authentication
749783

750784
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

‎servant-client/test/Servant/ClientTestUtils.hs

Lines changed: 35 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,18 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE ConstraintKinds #-}
3-
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE DeriveGeneric #-}
5-
{-# LANGUAGE FlexibleContexts #-}
6-
{-# LANGUAGE FlexibleInstances #-}
7-
{-# LANGUAGE GADTs #-}
8-
{-# LANGUAGE MultiParamTypeClasses #-}
9-
{-# LANGUAGE OverloadedStrings #-}
10-
{-# LANGUAGE PolyKinds #-}
11-
{-# LANGUAGE ScopedTypeVariables #-}
12-
{-# LANGUAGE TypeApplications #-}
13-
{-# LANGUAGE TypeFamilies #-}
14-
{-# LANGUAGE TypeOperators #-}
15-
{-# LANGUAGE UndecidableInstances #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE ConstraintKinds #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE FlexibleContexts #-}
6+
{-# LANGUAGE FlexibleInstances #-}
7+
{-# LANGUAGE GADTs #-}
8+
{-# LANGUAGE MultiParamTypeClasses #-}
9+
{-# LANGUAGE OverloadedStrings #-}
10+
{-# LANGUAGE PolyKinds #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
12+
{-# LANGUAGE TypeApplications #-}
13+
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE TypeOperators #-}
15+
{-# LANGUAGE UndecidableInstances #-}
1616
{-# OPTIONS_GHC -freduction-depth=100 #-}
1717
{-# OPTIONS_GHC -fno-warn-orphans #-}
1818
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -27,20 +27,22 @@ import Control.Concurrent
2727
import Control.Monad.Error.Class
2828
(throwError)
2929
import Data.Aeson
30-
import qualified Data.ByteString.Lazy as LazyByteString
30+
import qualified Data.ByteString.Lazy as LazyByteString
3131
import Data.Char
3232
(chr, isPrint)
3333
import Data.Monoid ()
3434
import Data.Proxy
35-
import Data.Text (Text)
36-
import qualified Data.Text as Text
37-
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
35+
import Data.Text
36+
(Text)
37+
import qualified Data.Text as Text
38+
import Data.Text.Encoding
39+
(decodeUtf8, encodeUtf8)
3840
import GHC.Generics
3941
(Generic)
40-
import qualified Network.HTTP.Client as C
41-
import qualified Network.HTTP.Types as HTTP
42+
import qualified Network.HTTP.Client as C
43+
import qualified Network.HTTP.Types as HTTP
4244
import Network.Socket
43-
import qualified Network.Wai as Wai
45+
import qualified Network.Wai as Wai
4446
import Network.Wai.Handler.Warp
4547
import System.IO.Unsafe
4648
(unsafePerformIO)
@@ -50,15 +52,14 @@ import Web.FormUrlEncoded
5052

5153
import Servant.API
5254
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
53-
BasicAuthData (..), Capture, CaptureAll,
54-
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
55-
Headers, JSON, MimeRender(mimeRender),
56-
MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
57-
Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
58-
StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
59-
addHeader)
55+
BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
56+
EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,
57+
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
58+
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
59+
QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,
60+
WithStatus (WithStatus), addHeader)
6061
import Servant.Client
61-
import qualified Servant.Client.Core.Auth as Auth
62+
import qualified Servant.Client.Core.Auth as Auth
6263
import Servant.Server
6364
import Servant.Server.Experimental.Auth
6465
import Servant.Test.ComprehensiveAPI
@@ -109,6 +110,7 @@ type Api =
109110
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
110111
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
111112
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
113+
:<|> "fragment" :> Fragment String :> Get '[JSON] Person
112114
:<|> "rawSuccess" :> Raw
113115
:<|> "rawSuccessPassHeaders" :> Raw
114116
:<|> "rawFailure" :> Raw
@@ -141,6 +143,7 @@ getBody :: Person -> ClientM Person
141143
getQueryParam :: Maybe String -> ClientM Person
142144
getQueryParams :: [String] -> ClientM [Person]
143145
getQueryFlag :: Bool -> ClientM Bool
146+
getFragment :: ClientM Person
144147
getRawSuccess :: HTTP.Method -> ClientM Response
145148
getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
146149
getRawFailure :: HTTP.Method -> ClientM Response
@@ -163,6 +166,7 @@ getRoot
163166
:<|> getQueryParam
164167
:<|> getQueryParams
165168
:<|> getQueryFlag
169+
:<|> getFragment
166170
:<|> getRawSuccess
167171
:<|> getRawSuccessPassHeaders
168172
:<|> getRawFailure
@@ -188,6 +192,7 @@ server = serve api (
188192
Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
189193
:<|> (\ names -> return (zipWith Person names [0..]))
190194
:<|> return
195+
:<|> return alice
191196
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
192197
:<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
193198
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

‎servant-client/test/Servant/SuccessSpec.hs

Lines changed: 23 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,17 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE ConstraintKinds #-}
3-
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE FlexibleContexts #-}
5-
{-# LANGUAGE FlexibleInstances #-}
6-
{-# LANGUAGE GADTs #-}
7-
{-# LANGUAGE MultiParamTypeClasses #-}
8-
{-# LANGUAGE OverloadedStrings #-}
9-
{-# LANGUAGE PolyKinds #-}
10-
{-# LANGUAGE ScopedTypeVariables #-}
11-
{-# LANGUAGE TypeApplications #-}
12-
{-# LANGUAGE TypeFamilies #-}
13-
{-# LANGUAGE TypeOperators #-}
14-
{-# LANGUAGE UndecidableInstances #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE ConstraintKinds #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE PolyKinds #-}
10+
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE TypeApplications #-}
12+
{-# LANGUAGE TypeFamilies #-}
13+
{-# LANGUAGE TypeOperators #-}
14+
{-# LANGUAGE UndecidableInstances #-}
1515
{-# OPTIONS_GHC -freduction-depth=100 #-}
1616
{-# OPTIONS_GHC -fno-warn-orphans #-}
1717
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -34,20 +34,21 @@ import Data.Maybe
3434
import Data.Monoid ()
3535
import Data.Text
3636
(Text)
37-
import qualified Network.HTTP.Client as C
38-
import qualified Network.HTTP.Types as HTTP
37+
import qualified Network.HTTP.Client as C
38+
import qualified Network.HTTP.Types as HTTP
3939
import Test.Hspec
4040
import Test.Hspec.QuickCheck
4141
import Test.HUnit
4242
import Test.QuickCheck
4343

4444
import Servant.API
45-
(NoContent (NoContent), WithStatus(WithStatus), getHeaders)
45+
(NoContent (NoContent), WithStatus (WithStatus), getHeaders)
4646
import Servant.Client
47-
import qualified Servant.Client.Core.Request as Req
48-
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
49-
import Servant.Test.ComprehensiveAPI
47+
import qualified Servant.Client.Core.Request as Req
48+
import Servant.Client.Internal.HttpClient
49+
(defaultMakeClientRequest)
5050
import Servant.ClientTestUtils
51+
import Servant.Test.ComprehensiveAPI
5152

5253
-- This declaration simply checks that all instances are in place.
5354
_ = client comprehensiveAPIWithoutStreaming
@@ -103,6 +104,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
103104
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
104105
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
105106

107+
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
108+
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
106109
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
107110
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
108111
case res of

‎servant-docs/golden/comprehensive.md

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -182,6 +182,28 @@
182182

183183
```
184184

185+
## GET /fragment
186+
187+
### Fragment:
188+
189+
- *foo*: Fragment Int
190+
191+
### Response:
192+
193+
- Status code 200
194+
- Headers: []
195+
196+
- Supported content types are:
197+
198+
- `application/json;charset=utf-8`
199+
- `application/json`
200+
201+
- Example (`application/json;charset=utf-8`, `application/json`):
202+
203+
```javascript
204+
205+
```
206+
185207
## GET /get-int
186208

187209
### Response:

0 commit comments

Comments
 (0)