da0c83d · typeable/servant

servant-client-core/src/Servant/Client/Core/HasClient.hs+41−7

compare with master

unifiedsplit

@@ -1,4 +1,5 @@

1{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -13,6 +14,10 @@

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

15

16

17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18+#define HAS_TYPE_ERROR

19+#endif

20+

16module Servant.Client.Core.HasClient (

21module Servant.Client.Core.HasClient (

17 clientIn,

22 clientIn,

18 HasClient (..),

23 HasClient (..),

@@ -63,17 +68,18 @@ import qualified Network.HTTP.Types as H

63import Servant.API

68import Servant.API

64 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

69 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

65 BuildHeadersTo (..), Capture', CaptureAll, Description,

70 BuildHeadersTo (..), Capture', CaptureAll, Description,

66− EmptyAPI, FramingRender (..), FramingUnrender (..),

71+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),

67 FromSourceIO (..), Header', Headers (..), HttpVersion,

72 FromSourceIO (..), Header', Headers (..), HttpVersion,

68 IsSecure, MimeRender (mimeRender),

73 IsSecure, MimeRender (mimeRender),

69− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,

74+ MimeUnrender (mimeUnrender), NoContent (NoContent),

70− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,

75+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

76+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

71− ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,

77+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

72− ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,

78+ Verb, WithNamedContext, contentType, getHeadersHList,

73− contentType, getHeadersHList, getResponse, toQueryParam,

79+ getResponse, toQueryParam, toUrlPiece)

74− toUrlPiece)

75import Servant.API.ContentTypes

80import Servant.API.ContentTypes

76 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

81 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

82+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

77import Servant.API.Modifiers

83import Servant.API.Modifiers

78 (FoldRequired, RequiredArgument, foldRequiredArgument)

84 (FoldRequired, RequiredArgument, foldRequiredArgument)

79import Servant.API.UVerb

85import Servant.API.UVerb

@@ -745,6 +751,34 @@ instance ( HasClient m api

745 hoistClientMonad pm _ f cl = \authreq ->

751 hoistClientMonad pm _ f cl = \authreq ->

746 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

752 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

747

753

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+

748-- * Basic Authentication

782-- * Basic Authentication

749

783

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

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

servant-client/test/Servant/ClientTestUtils.hs+35−30

@@ -1,18 +1,18 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

15+{-# LANGUAGE UndecidableInstances #-}

16{-# OPTIONS_GHC -freduction-depth=100 #-}

17{-# OPTIONS_GHC -fno-warn-orphans #-}

18{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

@@ -27,20 +27,22 @@ import Control.Concurrent

27import Control.Monad.Error.Class

28 (throwError)

29import Data.Aeson

30−import qualified Data.ByteString.Lazy as LazyByteString

30+import qualified Data.ByteString.Lazy as LazyByteString

31import Data.Char

32 (chr, isPrint)

33import Data.Monoid ()

34import Data.Proxy

35−import Data.Text (Text)

35+import Data.Text

36+ (Text)

36−import qualified Data.Text as Text

37+import qualified Data.Text as Text

37−import Data.Text.Encoding (encodeUtf8, decodeUtf8)

38+import Data.Text.Encoding

39+ (decodeUtf8, encodeUtf8)

38import GHC.Generics

40import GHC.Generics

39 (Generic)

41 (Generic)

40−import qualified Network.HTTP.Client as C

42+import qualified Network.HTTP.Client as C

41−import qualified Network.HTTP.Types as HTTP

43+import qualified Network.HTTP.Types as HTTP

42import Network.Socket

44import Network.Socket

43−import qualified Network.Wai as Wai

45+import qualified Network.Wai as Wai

44import Network.Wai.Handler.Warp

46import Network.Wai.Handler.Warp

45import System.IO.Unsafe

47import System.IO.Unsafe

46 (unsafePerformIO)

48 (unsafePerformIO)

@@ -50,15 +52,14 @@ import Web.FormUrlEncoded

50

52

51import Servant.API

53import Servant.API

52 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

54 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

53− BasicAuthData (..), Capture, CaptureAll,

55+ BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,

54− DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

56+ EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,

55− Headers, JSON, MimeRender(mimeRender),

57+ JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

56− MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,

58+ NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

57− Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,

59+ QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,

58− StdMethod(GET), Union, UVerb, WithStatus(WithStatus),

60+ WithStatus (WithStatus), addHeader)

59− addHeader)

60import Servant.Client

61import Servant.Client

61−import qualified Servant.Client.Core.Auth as Auth

62+import qualified Servant.Client.Core.Auth as Auth

62import Servant.Server

63import Servant.Server

63import Servant.Server.Experimental.Auth

64import Servant.Server.Experimental.Auth

64import Servant.Test.ComprehensiveAPI

65import Servant.Test.ComprehensiveAPI

@@ -109,6 +110,7 @@ type Api =

109 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

110 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

110 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

111 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

111 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

112 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

113+ :<|> "fragment" :> Fragment String :> Get '[JSON] Person

112 :<|> "rawSuccess" :> Raw

114 :<|> "rawSuccess" :> Raw

113 :<|> "rawSuccessPassHeaders" :> Raw

115 :<|> "rawSuccessPassHeaders" :> Raw

114 :<|> "rawFailure" :> Raw

116 :<|> "rawFailure" :> Raw

@@ -141,6 +143,7 @@ getBody :: Person -> ClientM Person

141getQueryParam :: Maybe String -> ClientM Person

143getQueryParam :: Maybe String -> ClientM Person

142getQueryParams :: [String] -> ClientM [Person]

144getQueryParams :: [String] -> ClientM [Person]

143getQueryFlag :: Bool -> ClientM Bool

145getQueryFlag :: Bool -> ClientM Bool

146+getFragment :: ClientM Person

144getRawSuccess :: HTTP.Method -> ClientM Response

147getRawSuccess :: HTTP.Method -> ClientM Response

145getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response

148getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response

146getRawFailure :: HTTP.Method -> ClientM Response

149getRawFailure :: HTTP.Method -> ClientM Response

@@ -163,6 +166,7 @@ getRoot

163 :<|> getQueryParam

166 :<|> getQueryParam

164 :<|> getQueryParams

167 :<|> getQueryParams

165 :<|> getQueryFlag

168 :<|> getQueryFlag

169+ :<|> getFragment

166 :<|> getRawSuccess

170 :<|> getRawSuccess

167 :<|> getRawSuccessPassHeaders

171 :<|> getRawSuccessPassHeaders

168 :<|> getRawFailure

172 :<|> getRawFailure

@@ -188,6 +192,7 @@ server = serve api (

188 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

192 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

189 :<|> (\ names -> return (zipWith Person names [0..]))

193 :<|> (\ names -> return (zipWith Person names [0..]))

190 :<|> return

194 :<|> return

195+ :<|> return alice

191 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

196 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

192 :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))

197 :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))

193 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

198 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

servant-client/test/Servant/SuccessSpec.hs+23−20

@@ -1,17 +1,17 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE UndecidableInstances #-}

15{-# OPTIONS_GHC -freduction-depth=100 #-}

16{-# OPTIONS_GHC -fno-warn-orphans #-}

17{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

@@ -34,20 +34,21 @@ import Data.Maybe

34import Data.Monoid ()

35import Data.Text

36 (Text)

37−import qualified Network.HTTP.Client as C

37+import qualified Network.HTTP.Client as C

38−import qualified Network.HTTP.Types as HTTP

38+import qualified Network.HTTP.Types as HTTP

39import Test.Hspec

40import Test.Hspec.QuickCheck

41import Test.HUnit

42import Test.QuickCheck

43

44import Servant.API

45− (NoContent (NoContent), WithStatus(WithStatus), getHeaders)

45+ (NoContent (NoContent), WithStatus (WithStatus), getHeaders)

46import Servant.Client

47−import qualified Servant.Client.Core.Request as Req

47+import qualified Servant.Client.Core.Request as Req

48−import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)

48+import Servant.Client.Internal.HttpClient

49−import Servant.Test.ComprehensiveAPI

49+ (defaultMakeClientRequest)

50import Servant.ClientTestUtils

51+import Servant.Test.ComprehensiveAPI

51

52

52-- This declaration simply checks that all instances are in place.

53-- This declaration simply checks that all instances are in place.

53_ = client comprehensiveAPIWithoutStreaming

54_ = client comprehensiveAPIWithoutStreaming

@@ -103,6 +104,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

103 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do

104 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do

104 left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag

105 left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag

105

106

107+ it "Servant.API.Fragment" $ \(_, baseUrl) -> do

108+ left id <$> runClient getFragment baseUrl `shouldReturn` Right alice

106 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

109 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

107 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

110 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

108 case res of

111 case res of

servant-docs/golden/comprehensive.md+22

@@ -182,6 +182,28 @@

182

183```

184

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+

185## GET /get-int

207## GET /get-int

186

208

187### Response:

209### Response:

servant-docs/src/Servant/Docs/Internal.hs+52−7

@@ -25,8 +25,8 @@ import Control.Applicative

25import Control.Arrow

26 (second)

27import Control.Lens

28− (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),

28+ (makeLenses, mapped, over, set, traversed, view, (%~), (&),

29− (<>~), (^.), (|>))

29+ (.~), (<>~), (^.), (|>))

30import qualified Data.ByteString.Char8 as BSC

31import Data.ByteString.Lazy.Char8

32 (ByteString)

@@ -64,7 +64,7 @@ import Servant.API

64import Servant.API.ContentTypes

65import Servant.API.TypeLevel

66

67−import qualified Data.Universe.Helpers as U

67+import qualified Data.Universe.Helpers as U

68

69import qualified Data.HashMap.Strict as HM

70import qualified Data.Text as T

@@ -161,6 +161,20 @@ data DocQueryParam = DocQueryParam

161 , _paramKind :: ParamKind

162 } deriving (Eq, Ord, Show)

163

164+-- | A type to represent fragment. Holds the name of the fragment and its description.

165+--

166+-- Write a 'ToFragment' instance for your fragment types.

167+data DocFragment = DocFragment

168+ { _fragSymbol :: String -- type supplied

169+ , _fragDesc :: String -- user supplied

170+ } deriving (Eq, Ord, Show)

171+

172+-- | There should be at most one 'Fragment' per API endpoint.

173+-- So here we are keeping the first occurrence.

174+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment

175+Nothing `combineFragment` mdocFragment = mdocFragment

176+Just docFragment `combineFragment` _ = Just docFragment

177+

164-- | An introductory paragraph for your documentation. You can pass these to

178-- | An introductory paragraph for your documentation. You can pass these to

165-- 'docsWithIntros'.

179-- 'docsWithIntros'.

166data DocIntro = DocIntro

180data DocIntro = DocIntro

@@ -283,6 +297,7 @@ data Action = Action

283 , _captures :: [DocCapture] -- type collected + user supplied info

297 , _captures :: [DocCapture] -- type collected + user supplied info

284 , _headers :: [Text] -- type collected

298 , _headers :: [Text] -- type collected

285 , _params :: [DocQueryParam] -- type collected + user supplied info

299 , _params :: [DocQueryParam] -- type collected + user supplied info

300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info

286 , _notes :: [DocNote] -- user supplied

301 , _notes :: [DocNote] -- user supplied

287 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

288 , _rqtypes :: [M.MediaType] -- type collected

303 , _rqtypes :: [M.MediaType] -- type collected

@@ -296,8 +311,9 @@ data Action = Action

296-- As such, we invent a non-commutative, left associative operation

311-- As such, we invent a non-commutative, left associative operation

297-- 'combineAction' to mush two together taking the response from the very left.

312-- 'combineAction' to mush two together taking the response from the very left.

298combineAction :: Action -> Action -> Action

313combineAction :: Action -> Action -> Action

314+Action a c h p f n m ts body resp

299−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =

315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =

300− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')

316+ Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')

301

317

302-- | Default 'Action'. Has no 'captures', no query 'params', expects

318-- | Default 'Action'. Has no 'captures', no query 'params', expects

303-- no request body ('rqbody') and the typical response is 'defResponse'.

319-- no request body ('rqbody') and the typical response is 'defResponse'.

@@ -305,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod

305-- Tweakable with lenses.

321-- Tweakable with lenses.

306--

322--

307-- >>> defAction

323-- >>> defAction

308−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}

324+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}

309--

325--

310-- >>> defAction & response.respStatus .~ 201

326-- >>> defAction & response.respStatus .~ 201

311−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}

327+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}

312--

328--

313defAction :: Action

329defAction :: Action

314defAction =

330defAction =

@@ -316,6 +332,7 @@ defAction =

316 []

332 []

317 []

333 []

318 []

334 []

335+ Nothing

319 []

336 []

320 []

337 []

321 []

338 []

@@ -368,6 +385,7 @@ makeLenses ''API

368makeLenses ''Endpoint

385makeLenses ''Endpoint

369makeLenses ''DocCapture

386makeLenses ''DocCapture

370makeLenses ''DocQueryParam

387makeLenses ''DocQueryParam

388+makeLenses ''DocFragment

371makeLenses ''DocIntro

389makeLenses ''DocIntro

372makeLenses ''DocNote

390makeLenses ''DocNote

373makeLenses ''Response

391makeLenses ''Response

@@ -587,6 +605,15 @@ class ToCapture c where

587class ToAuthInfo a where

605class ToAuthInfo a where

588 toAuthInfo :: Proxy a -> DocAuthentication

606 toAuthInfo :: Proxy a -> DocAuthentication

589

607

608+-- | The class that helps us get documentation for URL fragments.

609+--

610+-- Example of an instance:

611+--

612+-- > instance ToFragment (Fragment a) where

613+-- > toFragment _ = DocFragment "fragment" "fragment description"

614+class ToFragment t where

615+ toFragment :: Proxy t -> DocFragment

616+

590-- | Generate documentation in Markdown format for

617-- | Generate documentation in Markdown format for

591-- the given 'API'.

618-- the given 'API'.

592--

619--

@@ -629,6 +656,7 @@ markdownWith RenderingOptions{..} api = unlines $

629 capturesStr (action ^. captures) ++

656 capturesStr (action ^. captures) ++

630 headersStr (action ^. headers) ++

657 headersStr (action ^. headers) ++

631 paramsStr meth (action ^. params) ++

658 paramsStr meth (action ^. params) ++

659+ fragmentStr (action ^. fragment) ++

632 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

660 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

633 responseStr (action ^. response) ++

661 responseStr (action ^. response) ++

634 []

662 []

@@ -730,6 +758,14 @@ markdownWith RenderingOptions{..} api = unlines $

730

758

731 where values = param ^. paramValues

759 where values = param ^. paramValues

732

760

761+ fragmentStr :: Maybe DocFragment -> [String]

762+ fragmentStr Nothing = []

763+ fragmentStr (Just frag) =

764+ [ "### Fragment:", ""

765+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)

766+ , ""

767+ ]

768+

733 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]

769 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]

734 rqbodyStr [] [] = []

770 rqbodyStr [] [] = []

735 rqbodyStr types s =

771 rqbodyStr types s =

@@ -959,6 +995,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)

959 paramP = Proxy :: Proxy (QueryFlag sym)

995 paramP = Proxy :: Proxy (QueryFlag sym)

960 action' = over params (|> toParam paramP) action

996 action' = over params (|> toParam paramP) action

961

997

998+instance (ToFragment (Fragment a), HasDocs api)

999+ => HasDocs (Fragment a :> api) where

1000+

1001+ docsFor Proxy (endpoint, action) =

1002+ docsFor subApiP (endpoint, action')

1003+

1004+ where subApiP = Proxy :: Proxy api

1005+ fragmentP = Proxy :: Proxy (Fragment a)

1006+ action' = set fragment (Just (toFragment fragmentP)) action

962

1007

963instance HasDocs Raw where

1008instance HasDocs Raw where

964 docsFor _proxy (endpoint, action) _ =

1009 docsFor _proxy (endpoint, action) _ =

servant-docs/test/Servant/DocsSpec.hs+2

@@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where

58 toCapture _ = DocCapture "foo" "Capture foo Int"

59instance ToCapture (CaptureAll "foo" Int) where

60 toCapture _ = DocCapture "foo" "Capture all foo Int"

61+instance ToFragment (Fragment Int) where

62+ toFragment _ = DocFragment "foo" "Fragment Int"

61

63

62-- * specs

64-- * specs

63

65

servant-foreign/src/Servant/Foreign/Internal.hs+17−1

@@ -84,6 +84,11 @@ captureArg _ = error "captureArg called on non capture"

84

85type Path f = [Segment f]

86

87+newtype Frag f = Frag { unFragment :: Arg f }

88+ deriving (Data, Eq, Show, Typeable)

89+

90+makePrisms ''Frag

91+

87data ArgType

92data ArgType

88 = Normal

93 = Normal

89 | Flag

94 | Flag

@@ -115,11 +120,12 @@ makePrisms ''HeaderArg

115data Url f = Url

120data Url f = Url

116 { _path :: Path f

121 { _path :: Path f

117 , _queryStr :: [QueryArg f]

122 , _queryStr :: [QueryArg f]

123+ , _frag :: Maybe f

118 }

124 }

119 deriving (Data, Eq, Show, Typeable)

125 deriving (Data, Eq, Show, Typeable)

120

126

121defUrl :: Url f

127defUrl :: Url f

122−defUrl = Url [] []

128+defUrl = Url [] [] Nothing

123

129

124makeLenses ''Url

130makeLenses ''Url

125

131

@@ -324,6 +330,16 @@ instance

324 { _argName = PathSegment str

330 { _argName = PathSegment str

325 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

331 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

326

332

333+instance

334+ (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)

335+ => HasForeign lang ftype (Fragment a :> api) where

336+ type Foreign ftype (Fragment a :> api) = Foreign ftype api

337+ foreignFor lang Proxy Proxy req =

338+ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $

339+ req & reqUrl . frag .~ Just argT

340+ where

341+ argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))

342+

327instance HasForeign lang ftype Raw where

343instance HasForeign lang ftype Raw where

328 type Foreign ftype Raw = HTTP.Method -> Req ftype

344 type Foreign ftype Raw = HTTP.Method -> Req ftype

329

345

servant-foreign/test/Servant/ForeignSpec.hs+6−1

@@ -14,8 +14,8 @@ module Servant.ForeignSpec where

14import Data.Monoid

15 ((<>))

16import Data.Proxy

17−import Servant.Test.ComprehensiveAPI

18import Servant.Foreign

17import Servant.Foreign

18+import Servant.Test.ComprehensiveAPI

19import Servant.Types.SourceT

20 (SourceT)

21

@@ -91,6 +91,7 @@ listFromAPISpec = describe "listFromAPI" $ do

91 { _reqUrl = Url

92 [ Segment $ Static "test" ]

93 [ QueryArg (Arg "flag" "boolX") Flag ]

94+ Nothing

94 , _reqMethod = "GET"

95 , _reqMethod = "GET"

95 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

96 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

96 , _reqBody = Nothing

97 , _reqBody = Nothing

@@ -103,6 +104,7 @@ listFromAPISpec = describe "listFromAPI" $ do

103 { _reqUrl = Url

104 { _reqUrl = Url

104 [ Segment $ Static "test" ]

105 [ Segment $ Static "test" ]

105 [ QueryArg (Arg "param" "maybe intX") Normal ]

106 [ QueryArg (Arg "param" "maybe intX") Normal ]

107+ Nothing

106 , _reqMethod = "POST"

108 , _reqMethod = "POST"

107 , _reqHeaders = []

109 , _reqHeaders = []

108 , _reqBody = Just "listX of stringX"

110 , _reqBody = Just "listX of stringX"

@@ -116,6 +118,7 @@ listFromAPISpec = describe "listFromAPI" $ do

116 [ Segment $ Static "test" ]

118 [ Segment $ Static "test" ]

117 -- Should this be |intX| or |listX of intX| ?

119 -- Should this be |intX| or |listX of intX| ?

118 [ QueryArg (Arg "params" "listX of intX") List ]

120 [ QueryArg (Arg "params" "listX of intX") List ]

121+ Nothing

119 , _reqMethod = "PUT"

122 , _reqMethod = "PUT"

120 , _reqHeaders = []

123 , _reqHeaders = []

121 , _reqBody = Just "stringX"

124 , _reqBody = Just "stringX"

@@ -129,6 +132,7 @@ listFromAPISpec = describe "listFromAPI" $ do

129 [ Segment $ Static "test"

132 [ Segment $ Static "test"

130 , Segment $ Cap (Arg "id" "intX") ]

133 , Segment $ Cap (Arg "id" "intX") ]

131 []

134 []

135+ Nothing

132 , _reqMethod = "DELETE"

136 , _reqMethod = "DELETE"

133 , _reqHeaders = []

137 , _reqHeaders = []

134 , _reqBody = Nothing

138 , _reqBody = Nothing

@@ -142,6 +146,7 @@ listFromAPISpec = describe "listFromAPI" $ do

142 [ Segment $ Static "test"

146 [ Segment $ Static "test"

143 , Segment $ Cap (Arg "ids" "listX of intX") ]

147 , Segment $ Cap (Arg "ids" "listX of intX") ]

144 []

148 []

149+ Nothing

145 , _reqMethod = "GET"

150 , _reqMethod = "GET"

146 , _reqHeaders = []

151 , _reqHeaders = []

147 , _reqBody = Nothing

152 , _reqBody = Nothing

servant-server/src/Servant/Server/Internal.hs+35−10

@@ -71,17 +71,17 @@ import Prelude ()

71import Prelude.Compat

72import Servant.API

73 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',

74− CaptureAll, Description, EmptyAPI, FramingRender (..),

74+ CaptureAll, Description, EmptyAPI, Fragment,

75− FramingUnrender (..), FromSourceIO (..), Header', If,

75+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),

76− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,

76+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,

77− ReflectMethod (reflectMethod), RemoteHost, ReqBody',

77+ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

78− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',

78+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

79− Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,

79+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

80 WithNamedContext)

81import Servant.API.ContentTypes

82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

83− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,

83+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,

84− NoContent)

84+ canHandleAcceptH)

85import Servant.API.Modifiers

86 (FoldLenient, FoldRequired, RequestArgument,

87 unfoldRequestArgument)

@@ -89,8 +89,8 @@ import Servant.API.ResponseHeaders

89 (GetHeaders, Headers, getHeaders, getResponse)

90import qualified Servant.Types.SourceT as S

91import Web.HttpApiData

92− (FromHttpApiData, parseHeader, parseQueryParam,

92+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

93− parseUrlPieces, parseUrlPiece)

93+ parseUrlPieces)

94

95import Servant.Server.Internal.BasicAuth

96import Servant.Server.Internal.Context

@@ -106,6 +106,8 @@ import Servant.Server.Internal.ServerError

106#ifdef HAS_TYPE_ERROR

107import GHC.TypeLits

108 (ErrorMessage (..), TypeError)

109+import Servant.API.TypeLevel

110+ (AtLeastOneFragment, FragmentUnique)

109#endif

111#endif

110

112

111class HasServer api context where

113class HasServer api context where

@@ -880,5 +882,28 @@ type HasServerArrowTypeError a b =

880 ':$$: 'ShowType b

882 ':$$: 'ShowType b

881#endif

883#endif

882

884

885+-- | Ignore @'Fragment'@ in server handlers.

886+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

887+--

888+-- Example:

889+--

890+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

891+-- >

892+-- > server :: Server MyApi

893+-- > server = getBooksBy

894+-- > where getBooksBy :: Handler [Book]

895+-- > getBooksBy = ...return all books...

896+#ifdef HAS_TYPE_ERROR

897+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)

898+#else

899+instance (HasServer api context)

900+#endif

901+ => HasServer (Fragment a1 :> api) context where

902+ type ServerT (Fragment a1 :> api) m = ServerT api m

903+

904+ route _ = route (Proxy :: Proxy api)

905+

906+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)

907+

883-- $setup

908-- $setup

884-- >>> import Servant

909-- >>> import Servant

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−2

@@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where

11import Prelude ()

12import Prelude.Compat

13

14−import Control.Exception hiding

14+import Control.Exception hiding

15 (Handler)

16import Control.Monad.IO.Class

17import Control.Monad.Trans.Resource

@@ -28,7 +28,7 @@ import Test.Hspec

28import Test.Hspec.Wai

29 (request, shouldRespondWith, with)

30

31−import qualified Data.Text as T

31+import qualified Data.Text as T

32

33import System.IO.Unsafe

34 (unsafePerformIO)

servant-server/test/Servant/ServerSpec.hs+47−15

@@ -1,12 +1,12 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TypeOperators #-}

10{-# OPTIONS_GHC -freduction-depth=100 #-}

11

12module Servant.ServerSpec where

@@ -48,12 +48,12 @@ import Network.Wai.Test

48import Servant.API

49 ((:<|>) (..), (:>), AuthProtect, BasicAuth,

50 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

51− Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,

51+ Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

52− HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),

52+ Headers, HttpVersion, IsSecure (..), JSON, Lenient,

53− NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,

53+ NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

54− Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,

54+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

55− ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,

55+ RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

56− UVerb, Verb, addHeader)

56+ UVerb, Union, Verb, addHeader)

57import Servant.Server

58 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

59 emptyServer, err401, err403, err404, respond, serve,

@@ -92,6 +92,7 @@ spec = do

92 captureSpec

93 captureAllSpec

94 queryParamSpec

95+ fragmentSpec

95 reqBodySpec

96 reqBodySpec

96 headerSpec

97 headerSpec

97 rawSpec

98 rawSpec

@@ -461,6 +462,37 @@ queryParamSpec = do

461 { name = "Alice"

462 { name = "Alice"

462 }

463 }

463

464

465+-- }}}

466+------------------------------------------------------------------------------

467+-- * fragmentSpec {{{

468+------------------------------------------------------------------------------

469+

470+type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person

471+ :<|> "age" :> Fragment Integer :> Get '[JSON] Person

472+

473+fragmentApi :: Proxy FragmentApi

474+fragmentApi = Proxy

475+

476+fragServer :: Server FragmentApi

477+fragServer = fragmentServer :<|> fragAge

478+ where

479+ fragmentServer = return alice

480+ fragAge = return alice

481+

482+fragmentSpec :: Spec

483+fragmentSpec = do

484+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest

485+ { rawQueryString = params

486+ , queryString = parseQuery params

487+ , pathInfo = pinfo

488+ }

489+

490+ describe "Servant.API.Fragment" $ do

491+ it "ignores fragment even if it is present in query" $ do

492+ flip runSession (serve fragmentApi fragServer) $ do

493+ response1 <- mkRequest "#Alice" ["name"]

494+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice

495+

464-- }}}

496-- }}}

465------------------------------------------------------------------------------

497------------------------------------------------------------------------------

466-- * reqBodySpec {{{

498-- * reqBodySpec {{{

servant/servant.cabal+1

@@ -40,6 +40,7 @@ library

40 Servant.API.Description

41 Servant.API.Empty

42 Servant.API.Experimental.Auth

43+ Servant.API.Fragment

43 Servant.API.Generic

44 Servant.API.Generic

44 Servant.API.Header

45 Servant.API.Header

45 Servant.API.HttpVersion

46 Servant.API.HttpVersion

servant/src/Servant/API.hs+12−9

@@ -19,6 +19,8 @@ module Servant.API (

19 -- | Retrieving the HTTP version of the request

20 module Servant.API.QueryParam,

21 -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@

22+ module Servant.API.Fragment,

23+ -- | Documenting the fragment of the 'URI': @'Fragment'@

22 module Servant.API.ReqBody,

24 module Servant.API.ReqBody,

23 -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@

25 -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@

24 module Servant.API.RemoteHost,

26 module Servant.API.RemoteHost,

@@ -93,6 +95,8 @@ import Servant.API.Empty

93 (EmptyAPI (..))

95 (EmptyAPI (..))

94import Servant.API.Experimental.Auth

96import Servant.API.Experimental.Auth

95 (AuthProtect)

97 (AuthProtect)

98+import Servant.API.Fragment

99+ (Fragment)

96import Servant.API.Header

100import Servant.API.Header

97 (Header, Header')

101 (Header, Header')

98import Servant.API.HttpVersion

102import Servant.API.HttpVersion

@@ -121,21 +125,20 @@ import Servant.API.Stream

121 ToSourceIO (..))

125 ToSourceIO (..))

122import Servant.API.Sub

126import Servant.API.Sub

123 ((:>))

127 ((:>))

128+import Servant.API.UVerb

129+ (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,

130+ Unique, WithStatus (..), inject, statusOf)

124import Servant.API.Vault

131import Servant.API.Vault

125 (Vault)

132 (Vault)

126import Servant.API.Verbs

133import Servant.API.Verbs

127 (Delete, DeleteAccepted, DeleteNoContent,

134 (Delete, DeleteAccepted, DeleteNoContent,

128 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

135 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

129 GetNonAuthoritative, GetPartialContent, GetResetContent,

136 GetNonAuthoritative, GetPartialContent, GetResetContent,

130− Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,

137+ NoContentVerb, Patch, PatchAccepted, PatchNoContent,

131− Post, PostAccepted, PostCreated, PostNoContent,

138+ PatchNonAuthoritative, Post, PostAccepted, PostCreated,

132− PostNonAuthoritative, PostResetContent, Put, PutAccepted,

139+ PostNoContent, PostNonAuthoritative, PostResetContent, Put,

133− PutCreated, PutNoContent, PutNonAuthoritative,

140+ PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,

134− ReflectMethod (reflectMethod), StdMethod (..),

141+ ReflectMethod (reflectMethod), StdMethod (..), Verb)

135− Verb, NoContentVerb)

136−import Servant.API.UVerb

137− (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,

138− WithStatus (..), IsMember, Unique, inject)

139import Servant.API.WithNamedContext

142import Servant.API.WithNamedContext

140 (WithNamedContext)

143 (WithNamedContext)

141import Servant.Links

144import Servant.Links

servant/src/Servant/API/Fragment.hsnew file+25

@@ -0,0 +1,25 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# OPTIONS_HADDOCK not-home #-}

6+module Servant.API.Fragment (Fragment) where

7+

8+import Data.Typeable

9+ (Typeable)

10+

11+-- | Document the URI fragment in API. Useful in combination with 'Link'.

12+--

13+-- Example:

14+--

15+-- >>> -- /post#TRACKING

16+-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking

17+data Fragment (a :: *)

18+ deriving Typeable

19+

20+-- $setup

21+-- >>> import Servant.API

22+-- >>> import Data.Aeson

23+-- >>> import Data.Text

24+-- >>> data Tracking

25+-- >>> instance ToJSON Tracking where { toJSON = undefined }

servant/src/Servant/API/Modifiers.hs−2

@@ -131,8 +131,6 @@ type RequestArgument mods a =

131 (If (FoldLenient mods) (Either Text a) a)

132 (Maybe (If (FoldLenient mods) (Either Text a) a))

133

134−

135−

136-- | Unfold a value into a 'RequestArgument'.

134-- | Unfold a value into a 'RequestArgument'.

137unfoldRequestArgument

135unfoldRequestArgument

138 :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

136 :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

servant/src/Servant/API/TypeLevel.hs+59−9

@@ -1,12 +1,16 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableSuperClasses #-}

10

14

11{-|

15{-|

12This module collects utilities for manipulating @servant@ API types. The

16This module collects utilities for manipulating @servant@ API types. The

@@ -41,6 +45,9 @@ module Servant.API.TypeLevel (

41 -- ** Logic

45 -- ** Logic

42 Or,

46 Or,

43 And,

47 And,

48+ -- ** Fragment

49+ FragmentUnique,

50+ AtLeastOneFragment

44 ) where

51 ) where

45

52

46

53

@@ -50,6 +57,7 @@ import Servant.API.Alternative

50 (type (:<|>))

57 (type (:<|>))

51import Servant.API.Capture

58import Servant.API.Capture

52 (Capture, CaptureAll)

59 (Capture, CaptureAll)

60+import Servant.API.Fragment

53import Servant.API.Header

61import Servant.API.Header

54 (Header)

62 (Header)

55import Servant.API.QueryParam

63import Servant.API.QueryParam

@@ -60,6 +68,8 @@ import Servant.API.Sub

60 (type (:>))

68 (type (:>))

61import Servant.API.Verbs

69import Servant.API.Verbs

62 (Verb)

70 (Verb)

71+import Servant.API.UVerb

72+ (UVerb)

63import GHC.TypeLits

73import GHC.TypeLits

64 (ErrorMessage (..), TypeError)

74 (ErrorMessage (..), TypeError)

65

75

@@ -128,6 +138,7 @@ type family IsElem endpoint api :: Constraint where

128 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

138 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

129 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

139 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

130 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

140 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

141+ IsElem sa (Fragment x :> sb) = IsElem sa sb

131 IsElem (Verb m s ct typ) (Verb m s ct' typ)

142 IsElem (Verb m s ct typ) (Verb m s ct' typ)

132 = IsSubList ct ct'

143 = IsSubList ct ct'

133 IsElem e e = ()

144 IsElem e e = ()

@@ -241,6 +252,43 @@ We might try to factor these our more cleanly, but the type synonyms and type

241families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).

252families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).

242-}

253-}

243

254

255+-- ** Fragment

256+

257+class FragmentUnique api => AtLeastOneFragment api

258+

259+-- | If fragment appeared in API endpoint twice, compile-time error would be raised.

260+--

261+-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent

262+-- >>> instance AtLeastOneFragment FailAPI

263+-- ...

264+-- ...Only one Fragment allowed per endpoint in api...

265+-- ...

266+-- ...In the instance declaration for...

267+instance AtLeastOneFragment (Verb m s ct typ)

268+

269+instance AtLeastOneFragment (UVerb m cts as)

270+

271+instance AtLeastOneFragment (Fragment a)

272+

273+type family FragmentUnique api :: Constraint where

274+ FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb)

275+ FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa)

276+ FragmentUnique (x :> sa) = FragmentUnique sa

277+ FragmentUnique (Fragment a) = ()

278+ FragmentUnique x = ()

279+

280+type family FragmentNotIn api orig :: Constraint where

281+ FragmentNotIn (sa :<|> sb) orig =

282+ And (FragmentNotIn sa orig) (FragmentNotIn sb orig)

283+ FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig)

284+ FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig

285+ FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig)

286+ FragmentNotIn x orig = ()

287+

288+type NotUniqueFragmentInApi api =

289+ 'Text "Only one Fragment allowed per endpoint in api ‘"

290+ ':<>: 'ShowType api

291+ ':<>: 'Text "’."

244

292

245-- $setup

293-- $setup

246--

294--

@@ -248,6 +296,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).

248--

296--

249-- >>> :set -XPolyKinds

297-- >>> :set -XPolyKinds

250-- >>> :set -XGADTs

298-- >>> :set -XGADTs

299+-- >>> :set -XTypeSynonymInstances -XFlexibleInstances

251-- >>> import Data.Proxy

300-- >>> import Data.Proxy

252-- >>> import Data.Type.Equality

301-- >>> import Data.Type.Equality

253-- >>> import Servant.API

302-- >>> import Servant.API

@@ -255,4 +304,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).

255-- >>> instance Show (OK ctx) where show _ = "OK"

304-- >>> instance Show (OK ctx) where show _ = "OK"

256-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK

305-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK

257-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool

306-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool

307+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent

258-- >>> let sampleAPI = Proxy :: Proxy SampleAPI

308-- >>> let sampleAPI = Proxy :: Proxy SampleAPI

servant/src/Servant/Links.hs+30−6

@@ -120,6 +120,7 @@ module Servant.Links (

120 , Param (..)

121 , linkSegments

122 , linkQueryParams

123+ , linkFragment

123) where

124) where

124

125

125import Data.List

126import Data.List

@@ -152,6 +153,8 @@ import Servant.API.Empty

152 (EmptyAPI (..))

153 (EmptyAPI (..))

153import Servant.API.Experimental.Auth

154import Servant.API.Experimental.Auth

154 (AuthProtect)

155 (AuthProtect)

156+import Servant.API.Fragment

157+ (Fragment)

155import Servant.API.Generic

158import Servant.API.Generic

156import Servant.API.Header

159import Servant.API.Header

157 (Header')

160 (Header')

@@ -188,10 +191,13 @@ import Web.HttpApiData

188data Link = Link

191data Link = Link

189 { _segments :: [Escaped]

192 { _segments :: [Escaped]

190 , _queryParams :: [Param]

193 , _queryParams :: [Param]

194+ , _fragment :: Fragment'

191 } deriving Show

195 } deriving Show

192

196

193newtype Escaped = Escaped String

197newtype Escaped = Escaped String

194

198

199+type Fragment' = Maybe String

200+

195escaped :: String -> Escaped

201escaped :: String -> Escaped

196escaped = Escaped . escapeURIString isUnreserved

202escaped = Escaped . escapeURIString isUnreserved

197

203

@@ -208,11 +214,14 @@ linkSegments = map getEscaped . _segments

208linkQueryParams :: Link -> [Param]

214linkQueryParams :: Link -> [Param]

209linkQueryParams = _queryParams

215linkQueryParams = _queryParams

210

216

217+linkFragment :: Link -> Fragment'

218+linkFragment = _fragment

219+

211instance ToHttpApiData Link where

220instance ToHttpApiData Link where

212 toHeader = TE.encodeUtf8 . toUrlPiece

221 toHeader = TE.encodeUtf8 . toUrlPiece

213 toUrlPiece l =

222 toUrlPiece l =

214 let uri = linkURI l

223 let uri = linkURI l

215− in Text.pack $ uriPath uri ++ uriQuery uri

224+ in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri

216

225

217-- | Query parameter.

226-- | Query parameter.

218data Param

227data Param

@@ -228,6 +237,9 @@ addQueryParam :: Param -> Link -> Link

228addQueryParam qp l =

237addQueryParam qp l =

229 l { _queryParams = _queryParams l <> [qp] }

238 l { _queryParams = _queryParams l <> [qp] }

230

239

240+addFragment :: Fragment' -> Link -> Link

241+addFragment fr l = l { _fragment = fr }

242+

231-- | Transform 'Link' into 'URI'.

243-- | Transform 'Link' into 'URI'.

232--

244--

233-- >>> type API = "something" :> Get '[JSON] Int

245-- >>> type API = "something" :> Get '[JSON] Int

@@ -245,7 +257,7 @@ addQueryParam qp l =

245-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()

257-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()

246-- >>> let someRoute = Proxy :: Proxy SomeRoute

258-- >>> let someRoute = Proxy :: Proxy SomeRoute

247-- >>> safeLink someRoute someRoute "test@example.com"

259-- >>> safeLink someRoute someRoute "test@example.com"

248−-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}

260+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}

249--

261--

250-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"

262-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"

251-- abc/test%40example.com

263-- abc/test%40example.com

@@ -269,11 +281,12 @@ data LinkArrayElementStyle

269-- sum?x=1&x=2&x=3

281-- sum?x=1&x=2&x=3

270--

282--

271linkURI' :: LinkArrayElementStyle -> Link -> URI

283linkURI' :: LinkArrayElementStyle -> Link -> URI

272−linkURI' addBrackets (Link segments q_params) =

284+linkURI' addBrackets (Link segments q_params mfragment) =

273 URI mempty -- No scheme (relative)

285 URI mempty -- No scheme (relative)

274 Nothing -- Or authority (relative)

286 Nothing -- Or authority (relative)

275 (intercalate "/" $ map getEscaped segments)

287 (intercalate "/" $ map getEscaped segments)

276− (makeQueries q_params) mempty

288+ (makeQueries q_params)

289+ (makeFragment mfragment)

277 where

290 where

278 makeQueries :: [Param] -> String

291 makeQueries :: [Param] -> String

279 makeQueries [] = ""

292 makeQueries [] = ""

@@ -285,6 +298,10 @@ linkURI' addBrackets (Link segments q_params) =

285 makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)

298 makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)

286 makeQuery (FlagParam k) = escape k

299 makeQuery (FlagParam k) = escape k

287

300

301+ makeFragment :: Fragment' -> String

302+ makeFragment Nothing = ""

303+ makeFragment (Just fr) = "#" <> escape fr

304+

288 style = case addBrackets of

305 style = case addBrackets of

289 LinkArrayElementBracket -> "[]="

306 LinkArrayElementBracket -> "[]="

290 LinkArrayElementPlain -> "="

307 LinkArrayElementPlain -> "="

@@ -310,7 +327,7 @@ safeLink'

310 -> Proxy api -- ^ The whole API that this endpoint is a part of

327 -> Proxy api -- ^ The whole API that this endpoint is a part of

311 -> Proxy endpoint -- ^ The API endpoint you would like to point to

328 -> Proxy endpoint -- ^ The API endpoint you would like to point to

312 -> MkLink endpoint a

329 -> MkLink endpoint a

313−safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)

330+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)

314

331

315-- | Create all links in an API.

332-- | Create all links in an API.

316--

333--

@@ -341,7 +358,7 @@ allLinks'

341 => (Link -> a)

358 => (Link -> a)

342 -> Proxy api

359 -> Proxy api

343 -> MkLink api a

360 -> MkLink api a

344−allLinks' toA api = toLink toA api (Link mempty mempty)

361+allLinks' toA api = toLink toA api (Link mempty mempty mempty)

345

362

346-------------------------------------------------------------------------------

363-------------------------------------------------------------------------------

347-- Generics

364-- Generics

@@ -563,6 +580,13 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where

563 type MkLink (AuthProtect tag :> sub) a = MkLink sub a

580 type MkLink (AuthProtect tag :> sub) a = MkLink sub a

564 toLink = simpleToLink (Proxy :: Proxy sub)

581 toLink = simpleToLink (Proxy :: Proxy sub)

565

582

583+instance (HasLink sub, ToHttpApiData v)

584+ => HasLink (Fragment v :> sub) where

585+ type MkLink (Fragment v :> sub) a = v -> MkLink sub a

586+ toLink toA _ l mv =

587+ toLink toA (Proxy :: Proxy sub) $

588+ addFragment ((Just . Text.unpack . toQueryParam) mv) l

589+

566-- | Helper for implementing 'toLink' for combinators not affecting link

590-- | Helper for implementing 'toLink' for combinators not affecting link

567-- structure.

591-- structure.

568simpleToLink

592simpleToLink

servant/src/Servant/Test/ComprehensiveAPI.hs+1

@@ -71,6 +71,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

71 :<|> "summary" :> Summary "foo" :> GET

72 :<|> "description" :> Description "foo" :> GET

73 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)

74+ :<|> "fragment" :> Fragment Int :> GET

74 :<|> endpoint

75 :<|> endpoint

75

76

76type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

77type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

servant/test/Servant/LinksSpec.hs+8−1

@@ -13,9 +13,9 @@ import Test.Hspec

13 (Expectation, Spec, describe, it, shouldBe)

14

15import Servant.API

16+import Servant.Links

16import Servant.Test.ComprehensiveAPI

17import Servant.Test.ComprehensiveAPI

17 (comprehensiveAPIWithoutRaw)

18 (comprehensiveAPIWithoutRaw)

18−import Servant.Links

19

20type TestApi =

21 -- Capture and query params

@@ -26,6 +26,9 @@ type TestApi =

26 -- Flags

27 :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent

28

29+ -- Fragment

30+ :<|> "say" :> Fragment String :> Get '[JSON] NoContent

31+

29 -- All of the verbs

32 -- All of the verbs

30 :<|> "get" :> Get '[JSON] NoContent

33 :<|> "get" :> Get '[JSON] NoContent

31 :<|> "put" :> Put '[JSON] NoContent

34 :<|> "put" :> Put '[JSON] NoContent

@@ -76,6 +79,10 @@ spec = describe "Servant.Links" $ do

76 apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"

79 apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"

77 apiLink l1 False True `shouldBeLink` "balls?fast"

80 apiLink l1 False True `shouldBeLink` "balls?fast"

78

81

82+ it "generates correct link for fragment" $ do

83+ let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent)

84+ apiLink l1 "something" `shouldBeLink` "say#something"

85+

79 it "generates correct links for all of the verbs" $ do

86 it "generates correct links for all of the verbs" $ do

80 apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"

87 apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"

81 apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"

88 apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"