da0c83d · servant · git.iko.soy

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

@@ -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+

1621module Servant.Client.Core.HasClient (

1722 clientIn,

1823 HasClient (..),

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

6368import 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)

7580import Servant.API.ContentTypes

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

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

7783import Servant.API.Modifiers

7884 (FoldRequired, RequiredArgument, foldRequiredArgument)

7985import 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

750784instance 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 #-}

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

2727import Control.Monad.Error.Class

2828 (throwError)

2929import Data.Aeson

30−import qualified Data.ByteString.Lazy as LazyByteString

30+import qualified Data.ByteString.Lazy as LazyByteString

3131import Data.Char

3232 (chr, isPrint)

3333import Data.Monoid ()

3434import 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)

3840import 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

4244import Network.Socket

43−import qualified Network.Wai as Wai

45+import qualified Network.Wai as Wai

4446import Network.Wai.Handler.Warp

4547import System.IO.Unsafe

4648 (unsafePerformIO)

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

5052

5153import 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)

6061import Servant.Client

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

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

6263import Servant.Server

6364import Servant.Server.Experimental.Auth

6465import 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

141143getQueryParam :: Maybe String -> ClientM Person

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

143145getQueryFlag :: Bool -> ClientM Bool

146+getFragment :: ClientM Person

144147getRawSuccess :: HTTP.Method -> ClientM Response

145148getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response

146149getRawFailure :: 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+23−20

@@ -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

3434import Data.Monoid ()

3535import 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

3939import Test.Hspec

4040import Test.Hspec.QuickCheck

4141import Test.HUnit

4242import Test.QuickCheck

4343

4444import Servant.API

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

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

4646import 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)

5050import 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+22

@@ -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:

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

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

2525import Control.Arrow

2626 (second)

2727import Control.Lens

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

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

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

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

3030import qualified Data.ByteString.Char8 as BSC

3131import Data.ByteString.Lazy.Char8

3232 (ByteString)

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

6464import Servant.API.ContentTypes

6565import Servant.API.TypeLevel

6666

67−import qualified Data.Universe.Helpers as U

67+import qualified Data.Universe.Helpers as U

6868

6969import qualified Data.HashMap.Strict as HM

7070import qualified Data.Text as T

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

161161 , _paramKind :: ParamKind

162162 } deriving (Eq, Ord, Show)

163163

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+

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

165179-- 'docsWithIntros'.

166180data DocIntro = DocIntro

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

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

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

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

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

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

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

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

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

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

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

298313combineAction :: Action -> Action -> Action

299−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' 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')

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

315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' 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')

301317

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

303319-- 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

305321-- Tweakable with lenses.

306322--

307323-- >>> 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 = []}}

309325--

310326-- >>> 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 = []}}

312328--

313329defAction :: Action

314330defAction =

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

316332 []

317333 []

318334 []

335+ Nothing

319336 []

320337 []

321338 []

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

368385makeLenses ''Endpoint

369386makeLenses ''DocCapture

370387makeLenses ''DocQueryParam

388+makeLenses ''DocFragment

371389makeLenses ''DocIntro

372390makeLenses ''DocNote

373391makeLenses ''Response

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

587605class ToAuthInfo a where

588606 toAuthInfo :: Proxy a -> DocAuthentication

589607

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+

590617-- | Generate documentation in Markdown format for

591618-- the given 'API'.

592619--

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

629656 capturesStr (action ^. captures) ++

630657 headersStr (action ^. headers) ++

631658 paramsStr meth (action ^. params) ++

659+ fragmentStr (action ^. fragment) ++

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

633661 responseStr (action ^. response) ++

634662 []

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

730758

731759 where values = param ^. paramValues

732760

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

762+ fragmentStr Nothing = []

763+ fragmentStr (Just frag) =

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

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

766+ , ""

767+ ]

768+

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

734770 rqbodyStr [] [] = []

735771 rqbodyStr types s =

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

959995 paramP = Proxy :: Proxy (QueryFlag sym)

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

961997

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

9621007

9631008instance HasDocs Raw where

9641009 docsFor _proxy (endpoint, action) _ =

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

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

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

5959instance ToCapture (CaptureAll "foo" Int) where

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

61+instance ToFragment (Fragment Int) where

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

6163

6264-- * specs

6365

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

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

8484

8585type Path f = [Segment f]

8686

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

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

89+

90+makePrisms ''Frag

91+

8792data ArgType

8893 = Normal

8994 | Flag

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

115120data Url f = Url

116121 { _path :: Path f

117122 , _queryStr :: [QueryArg f]

123+ , _frag :: Maybe f

118124 }

119125 deriving (Data, Eq, Show, Typeable)

120126

121127defUrl :: Url f

122−defUrl = Url [] []

128+defUrl = Url [] [] Nothing

123129

124130makeLenses ''Url

125131

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

324330 { _argName = PathSegment str

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

326332

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+

327343instance HasForeign lang ftype Raw where

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

329345

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

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

1414import Data.Monoid

1515 ((<>))

1616import Data.Proxy

17−import Servant.Test.ComprehensiveAPI

1817import Servant.Foreign

18+import Servant.Test.ComprehensiveAPI

1919import Servant.Types.SourceT

2020 (SourceT)

2121

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

9191 { _reqUrl = Url

9292 [ Segment $ Static "test" ]

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

94+ Nothing

9495 , _reqMethod = "GET"

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

9697 , _reqBody = Nothing

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

103104 { _reqUrl = Url

104105 [ Segment $ Static "test" ]

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

107+ Nothing

106108 , _reqMethod = "POST"

107109 , _reqHeaders = []

108110 , _reqBody = Just "listX of stringX"

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

116118 [ Segment $ Static "test" ]

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

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

121+ Nothing

119122 , _reqMethod = "PUT"

120123 , _reqHeaders = []

121124 , _reqBody = Just "stringX"

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

129132 [ Segment $ Static "test"

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

131134 []

135+ Nothing

132136 , _reqMethod = "DELETE"

133137 , _reqHeaders = []

134138 , _reqBody = Nothing

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

142146 [ Segment $ Static "test"

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

144148 []

149+ Nothing

145150 , _reqMethod = "GET"

146151 , _reqHeaders = []

147152 , _reqBody = Nothing

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

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

7171import Prelude.Compat

7272import Servant.API

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

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

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

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

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

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

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

74+ CaptureAll, Description, EmptyAPI, Fragment,

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

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

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

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

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

8080 WithNamedContext)

8181import Servant.API.ContentTypes

8282 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

84− NoContent)

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

84+ canHandleAcceptH)

8585import Servant.API.Modifiers

8686 (FoldLenient, FoldRequired, RequestArgument,

8787 unfoldRequestArgument)

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

8989 (GetHeaders, Headers, getHeaders, getResponse)

9090import qualified Servant.Types.SourceT as S

9191import Web.HttpApiData

92− (FromHttpApiData, parseHeader, parseQueryParam,

93− parseUrlPieces, parseUrlPiece)

92+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

93+ parseUrlPieces)

9494

9595import Servant.Server.Internal.BasicAuth

9696import Servant.Server.Internal.Context

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

106106#ifdef HAS_TYPE_ERROR

107107import GHC.TypeLits

108108 (ErrorMessage (..), TypeError)

109+import Servant.API.TypeLevel

110+ (AtLeastOneFragment, FragmentUnique)

109111#endif

110112

111113class HasServer api context where

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

880882 ':$$: 'ShowType b

881883#endif

882884

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+

883908-- $setup

884909-- >>> import Servant

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

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

1111import Prelude ()

1212import Prelude.Compat

1313

14−import Control.Exception hiding

14+import Control.Exception hiding

1515 (Handler)

1616import Control.Monad.IO.Class

1717import Control.Monad.Trans.Resource

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

2828import Test.Hspec.Wai

2929 (request, shouldRespondWith, with)

3030

31−import qualified Data.Text as T

31+import qualified Data.Text as T

3232

3333import System.IO.Unsafe

3434 (unsafePerformIO)

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

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

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

1111

1212module Servant.ServerSpec where

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

4848import Servant.API

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

5050 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

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

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

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

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

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

56− UVerb, Verb, addHeader)

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

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

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

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

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

56+ UVerb, Union, Verb, addHeader)

5757import Servant.Server

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

5959 emptyServer, err401, err403, err404, respond, serve,

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

9292 captureSpec

9393 captureAllSpec

9494 queryParamSpec

95+ fragmentSpec

9596 reqBodySpec

9697 headerSpec

9798 rawSpec

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

461462 { name = "Alice"

462463 }

463464

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+

464496-- }}}

465497------------------------------------------------------------------------------

466498-- * reqBodySpec {{{

servant/servant.cabal+1

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

4040 Servant.API.Description

4141 Servant.API.Empty

4242 Servant.API.Experimental.Auth

43+ Servant.API.Fragment

4344 Servant.API.Generic

4445 Servant.API.Header

4546 Servant.API.HttpVersion

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

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

1919 -- | Retrieving the HTTP version of the request

2020 module Servant.API.QueryParam,

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

22+ module Servant.API.Fragment,

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

2224 module Servant.API.ReqBody,

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

2426 module Servant.API.RemoteHost,

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

9395 (EmptyAPI (..))

9496import Servant.API.Experimental.Auth

9597 (AuthProtect)

98+import Servant.API.Fragment

99+ (Fragment)

96100import Servant.API.Header

97101 (Header, Header')

98102import Servant.API.HttpVersion

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

121125 ToSourceIO (..))

122126import Servant.API.Sub

123127 ((:>))

128+import Servant.API.UVerb

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

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

124131import Servant.API.Vault

125132 (Vault)

126133import Servant.API.Verbs

127134 (Delete, DeleteAccepted, DeleteNoContent,

128135 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,

129136 GetNonAuthoritative, GetPartialContent, GetResetContent,

130− Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,

131− Post, PostAccepted, PostCreated, PostNoContent,

132− PostNonAuthoritative, PostResetContent, Put, PutAccepted,

133− PutCreated, PutNoContent, PutNonAuthoritative,

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

135− Verb, NoContentVerb)

136−import Servant.API.UVerb

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

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

137+ NoContentVerb, Patch, PatchAccepted, PatchNoContent,

138+ PatchNonAuthoritative, Post, PostAccepted, PostCreated,

139+ PostNoContent, PostNonAuthoritative, PostResetContent, Put,

140+ PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,

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

139142import Servant.API.WithNamedContext

140143 (WithNamedContext)

141144import 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 =

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

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

133133

134−

135−

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

137135unfoldRequestArgument

138136 :: 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 #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableSuperClasses #-}

1014

1115{-|

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

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

4145 -- ** Logic

4246 Or,

4347 And,

48+ -- ** Fragment

49+ FragmentUnique,

50+ AtLeastOneFragment

4451 ) where

4552

4653

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

5057 (type (:<|>))

5158import Servant.API.Capture

5259 (Capture, CaptureAll)

60+import Servant.API.Fragment

5361import Servant.API.Header

5462 (Header)

5563import Servant.API.QueryParam

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

6068 (type (:>))

6169import Servant.API.Verbs

6270 (Verb)

71+import Servant.API.UVerb

72+ (UVerb)

6373import GHC.TypeLits

6474 (ErrorMessage (..), TypeError)

6575

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

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

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

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

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

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

132143 = IsSubList ct ct'

133144 IsElem e e = ()

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

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

242253-}

243254

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 "’."

244292

245293-- $setup

246294--

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

248296--

249297-- >>> :set -XPolyKinds

250298-- >>> :set -XGADTs

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

251300-- >>> import Data.Proxy

252301-- >>> import Data.Type.Equality

253302-- >>> import Servant.API

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

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

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

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

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

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

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

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

120120 , Param (..)

121121 , linkSegments

122122 , linkQueryParams

123+ , linkFragment

123124) where

124125

125126import Data.List

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

152153 (EmptyAPI (..))

153154import Servant.API.Experimental.Auth

154155 (AuthProtect)

156+import Servant.API.Fragment

157+ (Fragment)

155158import Servant.API.Generic

156159import Servant.API.Header

157160 (Header')

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

188191data Link = Link

189192 { _segments :: [Escaped]

190193 , _queryParams :: [Param]

194+ , _fragment :: Fragment'

191195 } deriving Show

192196

193197newtype Escaped = Escaped String

194198

199+type Fragment' = Maybe String

200+

195201escaped :: String -> Escaped

196202escaped = Escaped . escapeURIString isUnreserved

197203

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

208214linkQueryParams :: Link -> [Param]

209215linkQueryParams = _queryParams

210216

217+linkFragment :: Link -> Fragment'

218+linkFragment = _fragment

219+

211220instance ToHttpApiData Link where

212221 toHeader = TE.encodeUtf8 . toUrlPiece

213222 toUrlPiece l =

214223 let uri = linkURI l

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

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

216225

217226-- | Query parameter.

218227data Param

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

228237addQueryParam qp l =

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

230239

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

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

242+

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

232244--

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

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

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

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

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

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

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

249261--

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

251263-- abc/test%40example.com

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

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

270282--

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

272−linkURI' addBrackets (Link segments q_params) =

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

273285 URI mempty -- No scheme (relative)

274286 Nothing -- Or authority (relative)

275287 (intercalate "/" $ map getEscaped segments)

276− (makeQueries q_params) mempty

288+ (makeQueries q_params)

289+ (makeFragment mfragment)

277290 where

278291 makeQueries :: [Param] -> String

279292 makeQueries [] = ""

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

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

286299 makeQuery (FlagParam k) = escape k

287300

301+ makeFragment :: Fragment' -> String

302+ makeFragment Nothing = ""

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

304+

288305 style = case addBrackets of

289306 LinkArrayElementBracket -> "[]="

290307 LinkArrayElementPlain -> "="

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

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

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

312329 -> MkLink endpoint a

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

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

314331

315332-- | Create all links in an API.

316333--

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

341358 => (Link -> a)

342359 -> Proxy api

343360 -> MkLink api a

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

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

345362

346363-------------------------------------------------------------------------------

347364-- Generics

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

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

564581 toLink = simpleToLink (Proxy :: Proxy sub)

565582

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+

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

567591-- structure.

568592simpleToLink

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

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

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

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

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

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

7475 :<|> endpoint

7576

7677type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

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

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

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

1414

1515import Servant.API

16+import Servant.Links

1617import Servant.Test.ComprehensiveAPI

1718 (comprehensiveAPIWithoutRaw)

18−import Servant.Links

1919

2020type TestApi =

2121 -- Capture and query params

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

2626 -- Flags

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

2828

29+ -- Fragment

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

31+

2932 -- All of the verbs

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

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

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

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

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

7881

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+

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

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

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