a844b7c · typeable/servant

git.iko.soy/typeable/servant

Merge pull request #519 from jml/capture-all-take-2

CaptureAll combinator - take #2

commita844b7c297871e4a24afa8d30594ae755fdd34c7 authorArian van Putten <arian.vanputten@gmail.com> dateMon 11 Jul 2016, 17:03 (10 years ago) parent8eb412f c5dcff1

16 files changed+235−18

compare with master

unifiedsplit

servant-client/src/Servant/Client.hs+32 servant-client/test/Servant/ClientSpec.hs+9−1 servant-docs/src/Servant/Docs/Internal.hs+16 servant-docs/test/Servant/DocsSpec.hs+2 servant-foreign/src/Servant/Foreign/Internal.hs+15 servant-foreign/test/Servant/ForeignSpec.hs+16−2 servant-mock/src/Servant/Mock.hs+3 servant-server/src/Servant/Server/Internal.hs+41−6 servant-server/src/Servant/Server/Internal/Router.hs+10 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3 servant-server/test/Servant/ServerSpec.hs+56−1 servant/src/Servant/API.hs+2−2 servant/src/Servant/API/Capture.hs+14−1 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+2−1 servant/src/Servant/Utils/Links.hs+10−1 servant/test/Servant/Utils/LinksSpec.hs+5

servant-client/src/Servant/Client.hs+32

@@ -118,6 +118,38 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api)

118118

119119 where p = unpack (toUrlPiece val)

120120

121+-- | If you use a 'CaptureAll' in one of your endpoints in your API,

122+-- the corresponding querying function will automatically take an

123+-- additional argument of a list of the type specified by your

124+-- 'CaptureAll'. That function will take care of inserting a textual

125+-- representation of this value at the right place in the request

126+-- path.

127+--

128+-- You can control how these values are turned into text by specifying

129+-- a 'ToHttpApiData' instance of your type.

130+--

131+-- Example:

132+--

133+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile

134+-- >

135+-- > myApi :: Proxy

136+-- > myApi = Proxy

137+--

138+-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile

139+-- > getSourceFile = client myApi

140+-- > -- then you can use "getSourceFile" to query that endpoint

141+instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)

142+ => HasClient (CaptureAll capture a :> sublayout) where

143+

144+ type Client (CaptureAll capture a :> sublayout) =

145+ [a] -> Client sublayout

146+

147+ clientWithRoute Proxy req vals =

148+ clientWithRoute (Proxy :: Proxy sublayout)

149+ (foldl' (flip appendToPath) req ps)

150+

151+ where ps = map (unpack . toUrlPiece) vals

152+

121153instance OVERLAPPABLE_

122154 -- Note [Non-Empty Content Types]

123155 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

servant-client/test/Servant/ClientSpec.hs+9−1

@@ -105,6 +105,7 @@ type Api =

105105 "get" :> Get '[JSON] Person

106106 :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

107107 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

108+ :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

108109 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

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

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

@@ -125,6 +126,7 @@ api = Proxy

125126getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person

126127getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent

127128getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person

129+getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]

128130getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person

129131getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person

130132getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]

@@ -140,6 +142,7 @@ getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent

140142getGet

141143 :<|> getDeleteEmpty

142144 :<|> getCapture

145+ :<|> getCaptureAll

143146 :<|> getBody

144147 :<|> getQueryParam

145148 :<|> getQueryParams

@@ -155,6 +158,7 @@ server = serve api (

155158 return alice

156159 :<|> return NoContent

157160 :<|> (\ name -> return $ Person name 0)

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

158162 :<|> return

159163 :<|> (\ name -> case name of

160164 Just "alice" -> return alice

@@ -250,6 +254,10 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

250254 it "Servant.API.Capture" $ \(_, baseUrl) -> do

251255 (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)

252256

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

258+ let expected = [(Person "Paula" 0), (Person "Peta" 1)]

259+ (left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected

260+

253261 it "Servant.API.ReqBody" $ \(_, baseUrl) -> do

254262 let p = Person "Clara" 42

255263 (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p

@@ -351,7 +359,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

351359 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

352360

353361 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do

354− let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

362+ let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

355363 Left res <- runExceptT (getBody alice manager baseUrl)

356364 case res of

357365 InvalidContentTypeHeader "fooooo" _ -> return ()

servant-docs/src/Servant/Docs/Internal.hs+16

@@ -702,6 +702,22 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

702702 symP = Proxy :: Proxy sym

703703

704704

705+-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

706+-- @/books/:isbn@ in the docs.

707+instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)

708+ => HasDocs (CaptureAll sym a :> sublayout) where

709+

710+ docsFor Proxy (endpoint, action) =

711+ docsFor sublayoutP (endpoint', action')

712+

713+ where sublayoutP = Proxy :: Proxy sublayout

714+ captureP = Proxy :: Proxy (CaptureAll sym a)

715+

716+ action' = over captures (|> toCapture captureP) action

717+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

718+ symP = Proxy :: Proxy sym

719+

720+

705721instance OVERLAPPABLE_

706722 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

707723 , ReflectMethod method)

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

@@ -34,6 +34,8 @@ instance ToParam (QueryFlag "foo") where

3434 toParam = error "unused"

3535instance ToCapture (Capture "foo" Int) where

3636 toCapture = error "unused"

37+instance ToCapture (CaptureAll "foo" Int) where

38+ toCapture = error "unused"

3739

3840-- * specs

3941

servant-foreign/src/Servant/Foreign/Internal.hs+15

@@ -211,6 +211,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype ap

211211 { _argName = PathSegment str

212212 , _argType = ftype }

213213

214+instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)

215+ => HasForeign lang ftype (CaptureAll sym t :> sublayout) where

216+ type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout

217+

218+ foreignFor lang Proxy Proxy req =

219+ foreignFor lang Proxy (Proxy :: Proxy sublayout) $

220+ req & reqUrl . path <>~ [Segment (Cap arg)]

221+ & reqFuncName . _FunctionName %~ (++ ["by", str])

222+ where

223+ str = pack . symbolVal $ (Proxy :: Proxy sym)

224+ ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])

225+ arg = Arg

226+ { _argName = PathSegment str

227+ , _argType = ftype }

228+

214229instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

215230 => HasForeign lang ftype (Verb method status list a) where

216231 type Foreign ftype (Verb method status list a) = Req ftype

servant-foreign/test/Servant/ForeignSpec.hs+16−2

@@ -46,6 +46,7 @@ type TestApi

4646 :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent

4747 :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent

4848 :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent

49+ :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]

4950

5051testApi :: [Req String]

5152testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)

@@ -53,9 +54,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P

5354listFromAPISpec :: Spec

5455listFromAPISpec = describe "listFromAPI" $ do

5556 it "generates 4 endpoints for TestApi" $ do

56− length testApi `shouldBe` 4

57+ length testApi `shouldBe` 5

5758

58− let [getReq, postReq, putReq, deleteReq] = testApi

59+ let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi

5960

6061 it "collects all info for get request" $ do

6162 shouldBe getReq $ defReq

@@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do

106107 , _reqReturnType = Just "voidX"

107108 , _reqFuncName = FunctionName ["delete", "test", "by", "id"]

108109 }

110+

111+ it "collects all info for capture all request" $ do

112+ shouldBe captureAllReq $ defReq

113+ { _reqUrl = Url

114+ [ Segment $ Static "test"

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

116+ []

117+ , _reqMethod = "GET"

118+ , _reqHeaders = []

119+ , _reqBody = Nothing

120+ , _reqReturnType = Just "listX of intX"

121+ , _reqFuncName = FunctionName ["get", "test", "by", "ids"]

122+ }

servant-mock/src/Servant/Mock.hs+3

@@ -115,6 +115,9 @@ instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) cont

115115instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where

116116 mock _ context = \_ -> mock (Proxy :: Proxy rest) context

117117

118+instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where

119+ mock _ context = \_ -> mock (Proxy :: Proxy rest) context

120+

118121instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where

119122 mock _ context = \_ -> mock (Proxy :: Proxy rest) context

120123

servant-server/src/Servant/Server/Internal.hs+41−6

@@ -45,13 +45,15 @@ import Prelude.Compat

4545import Web.HttpApiData (FromHttpApiData)

4646import Web.HttpApiData.Internal (parseHeaderMaybe,

4747 parseQueryParamMaybe,

48− parseUrlPieceMaybe)

48+ parseUrlPieceMaybe,

49+ parseUrlPieces)

4950

5051import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

51− Verb, ReflectMethod(reflectMethod),

52− IsSecure(..), Header,

53− QueryFlag, QueryParam, QueryParams,

54− Raw, RemoteHost, ReqBody, Vault,

52+ CaptureAll, Verb,

53+ ReflectMethod(reflectMethod),

54+ IsSecure(..), Header, QueryFlag,

55+ QueryParam, QueryParams, Raw,

56+ RemoteHost, ReqBody, Vault,

5557 WithNamedContext)

5658import Servant.API.ContentTypes (AcceptHeader (..),

5759 AllCTRender (..),

@@ -128,11 +130,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

128130 CaptureRouter $

129131 route (Proxy :: Proxy api)

130132 context

131− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of

133+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of

132134 Nothing -> delayedFail err400

133135 Just v -> return v

134136 )

135137

138+-- | If you use 'CaptureAll' in one of the endpoints for your API,

139+-- this automatically requires your server-side handler to be a

140+-- function that takes an argument of a list of the type specified by

141+-- the 'CaptureAll'. This lets servant worry about getting values from

142+-- the URL and turning them into values of the type you specify.

143+--

144+-- You can control how they'll be converted from 'Text' to your type

145+-- by simply providing an instance of 'FromHttpApiData' for your type.

146+--

147+-- Example:

148+--

149+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile

150+-- >

151+-- > server :: Server MyApi

152+-- > server = getSourceFile

153+-- > where getSourceFile :: [Text] -> Handler Book

154+-- > getSourceFile pathSegments = ...

155+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)

156+ => HasServer (CaptureAll capture a :> sublayout) context where

157+

158+ type ServerT (CaptureAll capture a :> sublayout) m =

159+ [a] -> ServerT sublayout m

160+

161+ route Proxy context d =

162+ CaptureAllRouter $

163+ route (Proxy :: Proxy sublayout)

164+ context

165+ (addCapture d $ \ txts -> case parseUrlPieces txts of

166+ Left _ -> delayedFail err400

167+ Right v -> return v

168+ )

169+

170+

136171allowedMethodHead :: Method -> Request -> Bool

137172allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

138173

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

@@ -31,6 +31,9 @@ data Router' env a =

3131 | CaptureRouter (Router' (Text, env) a)

3232 -- ^ first path component is passed to the child router in its

3333 -- environment and removed afterwards

34+ | CaptureAllRouter (Router' ([Text], env) a)

35+ -- ^ all path components are passed to the child router in its

36+ -- environment and are removed afterwards

3437 | RawRouter (env -> a)

3538 -- ^ to be used for routes we do not know anything about

3639 | Choice (Router' env a) (Router' env a)

@@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =

9093routerStructure (CaptureRouter router) =

9194 CaptureRouterStructure $

9295 routerStructure router

96+routerStructure (CaptureAllRouter router) =

97+ CaptureRouterStructure $

98+ routerStructure router

9399routerStructure (RawRouter _) =

94100 RawRouterStructure

95101routerStructure (Choice r1 r2) =

@@ -163,6 +169,10 @@ runRouterEnv router env request respond =

163169 first : rest

164170 -> let request' = request { pathInfo = rest }

165171 in runRouterEnv router' (first, env) request' respond

172+ CaptureAllRouter router' ->

173+ let segments = pathInfo request

174+ request' = request { pathInfo = [] }

175+ in runRouterEnv router' (segments, env) request' respond

166176 RawRouter app ->

167177 app env request respond

168178 Choice r1 r2 ->

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−3

@@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where

1111import Control.Monad (ap, liftM)

1212import Control.Monad.Trans (MonadIO(..))

1313import Control.Monad.Trans.Except (runExceptT)

14−import Data.Text (Text)

1514import Network.Wai (Application, Request,

1615 Response, ResponseReceived)

1716import Prelude ()

@@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)

161160

162161-- | Add a capture to the end of the capture block.

163162addCapture :: Delayed env (a -> b)

164− -> (Text -> DelayedIO a)

165− -> Delayed (Text, env) b

163+ -> (captured -> DelayedIO a)

164+ -> Delayed (captured, env) b

166165addCapture Delayed{..} new =

167166 Delayed

168167 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

servant-server/test/Servant/ServerSpec.hs+56−1

@@ -39,7 +39,7 @@ import Network.Wai.Test (defaultRequest, request,

3939 simpleHeaders, simpleStatus)

4040import Servant.API ((:<|>) (..), (:>), AuthProtect,

4141 BasicAuth, BasicAuthData(BasicAuthData),

42− Capture, Delete, Get, Header (..),

42+ Capture, CaptureAll, Delete, Get, Header (..),

4343 Headers, HttpVersion,

4444 IsSecure (..), JSON,

4545 NoContent (..), Patch, PlainText,

@@ -216,6 +216,58 @@ captureSpec = do

216216 it "strips the captured path snippet from pathInfo" $ do

217217 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

218218

219+-- }}}

220+------------------------------------------------------------------------------

221+-- * captureAllSpec {{{

222+------------------------------------------------------------------------------

223+

224+type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal

225+captureAllApi :: Proxy CaptureAllApi

226+captureAllApi = Proxy

227+captureAllServer :: [Integer] -> Handler Animal

228+captureAllServer legs = case sum legs of

229+ 4 -> return jerry

230+ 2 -> return tweety

231+ 0 -> return beholder

232+ _ -> throwE err404

233+

234+captureAllSpec :: Spec

235+captureAllSpec = do

236+ describe "Servant.API.CaptureAll" $ do

237+ with (return (serve captureAllApi captureAllServer)) $ do

238+

239+ it "can capture a single element of the 'pathInfo'" $ do

240+ response <- get "/2"

241+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety

242+

243+ it "can capture multiple elements of the 'pathInfo'" $ do

244+ response <- get "/2/2"

245+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry

246+

247+ it "can capture arbitrarily many elements of the 'pathInfo'" $ do

248+ response <- get "/1/1/0/1/0/1"

249+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry

250+

251+ it "can capture when there are no elements in 'pathInfo'" $ do

252+ response <- get "/"

253+ liftIO $ decode' (simpleBody response) `shouldBe` Just beholder

254+

255+ it "returns 400 if the decoding fails" $ do

256+ get "/notAnInt" `shouldRespondWith` 400

257+

258+ it "returns 400 if the decoding fails, regardless of which element" $ do

259+ get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400

260+

261+ it "returns 400 if the decoding fails, even when it's multiple elements" $ do

262+ get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400

263+

264+ with (return (serve

265+ (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

266+ (\ _captured request_ respond ->

267+ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

268+ it "consumes everything from pathInfo" $ do

269+ get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

270+

219271-- }}}

220272------------------------------------------------------------------------------

221273-- * queryParamSpec {{{

@@ -644,4 +696,7 @@ jerry = Animal "Mouse" 4

644696

645697tweety :: Animal

646698tweety = Animal "Bird" 2

699+

700+beholder :: Animal

701+beholder = Animal "Beholder" 0

647702-- }}}

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

@@ -8,7 +8,7 @@ module Servant.API (

99 -- * Accessing information from the request

1010 module Servant.API.Capture,

11− -- | Capturing parts of the url path as parsed values: @'Capture'@

11+ -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@

1212 module Servant.API.Header,

1313 -- | Retrieving specific headers from the request

1414 module Servant.API.HttpVersion,

@@ -60,7 +60,7 @@ module Servant.API (

6060

6161import Servant.API.Alternative ((:<|>) (..))

6262import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))

63−import Servant.API.Capture (Capture)

63+import Servant.API.Capture (Capture, CaptureAll)

6464import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

6565 FromFormUrlEncoded (..), JSON,

6666 MimeRender (..), NoContent (NoContent),

servant/src/Servant/API/Capture.hs+14−1

@@ -2,7 +2,7 @@

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE PolyKinds #-}

44{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.Capture (Capture) where

5+module Servant.API.Capture (Capture, CaptureAll) where

77import Data.Typeable (Typeable)

88import GHC.TypeLits (Symbol)

@@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol)

1515data Capture (sym :: Symbol) a

1616 deriving (Typeable)

1717

18+

19+-- | Capture all remaining values from the request path under a certain type

20+-- @a@.

21+--

22+-- Example:

23+--

24+-- >>> -- GET /src/*

25+-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile

26+data CaptureAll (sym :: Symbol) a

27+ deriving (Typeable)

28+

1829-- $setup

1930-- >>> import Servant.API

2031-- >>> import Data.Aeson

2132-- >>> import Data.Text

2233-- >>> data Book

2334-- >>> instance ToJSON Book where { toJSON = undefined }

35+-- >>> data SourceFile

36+-- >>> instance ToJSON SourceFile where { toJSON = undefined }

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+2−1

@@ -30,7 +30,8 @@ type ComprehensiveAPI =

3030 Vault :> GET :<|>

3131 Verb 'POST 204 '[JSON] NoContent :<|>

3232 Verb 'POST 204 '[JSON] Int :<|>

33− WithNamedContext "foo" '[] GET

33+ WithNamedContext "foo" '[] GET :<|>

34+ CaptureAll "foo" Int :> GET

3435

3536comprehensiveAPI :: Proxy ComprehensiveAPI

3637comprehensiveAPI = Proxy

servant/src/Servant/Utils/Links.hs+10−1

@@ -107,7 +107,7 @@ import Prelude.Compat

107107

108108import Web.HttpApiData

109109import Servant.API.BasicAuth ( BasicAuth )

110−import Servant.API.Capture ( Capture )

110+import Servant.API.Capture ( Capture, CaptureAll )

111111import Servant.API.ReqBody ( ReqBody )

112112import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )

113113import Servant.API.Header ( Header )

@@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where

163163 IsElem sa (ReqBody y x :> sb) = IsElem sa sb

164164 IsElem (Capture z y :> sa) (Capture x y :> sb)

165165 = IsElem sa sb

166+ IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)

167+ = IsElem sa sb

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

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

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

@@ -284,6 +286,13 @@ instance (ToHttpApiData v, HasLink sub)

284286 toLink (Proxy :: Proxy sub) $

285287 addSegment (escape . Text.unpack $ toUrlPiece v) l

286288

289+instance (ToHttpApiData v, HasLink sub)

290+ => HasLink (CaptureAll sym v :> sub) where

291+ type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub

292+ toLink _ l vs =

293+ toLink (Proxy :: Proxy sub) $

294+ foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs

295+

287296instance HasLink sub => HasLink (Header sym a :> sub) where

288297 type MkLink (Header sym a :> sub) = MkLink sub

289298 toLink _ = toLink (Proxy :: Proxy sub)

servant/test/Servant/Utils/LinksSpec.hs+5

@@ -13,6 +13,7 @@ import Servant.API

1313type TestApi =

1414 -- Capture and query params

1515 "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent

16+ :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent

1617

1718 -- Flags

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

@@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do

4647 :> Delete '[JSON] NoContent)

4748 apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"

4849

50+ it "generates correct links for CaptureAll" $ do

51+ apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))

52+ ["roads", "lead", "to", "rome"]

53+ `shouldBeURI` "all/roads/lead/to/rome"

4954

5055 it "generates correct links for query flags" $ do

5156 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"