diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index fd3ab24b..18581075 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -118,6 +118,38 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api) where p = unpack (toUrlPiece val) +-- | If you use a 'CaptureAll' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional argument of a list of the type specified by your +-- 'CaptureAll'. That function will take care of inserting a textual +-- representation of this value at the right place in the request +-- path. +-- +-- You can control how these values are turned into text by specifying +-- a 'ToHttpApiData' instance of your type. +-- +-- Example: +-- +-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile +-- > +-- > myApi :: Proxy +-- > myApi = Proxy +-- +-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile +-- > getSourceFile = client myApi +-- > -- then you can use "getSourceFile" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) + => HasClient (CaptureAll capture a :> sublayout) where + + type Client (CaptureAll capture a :> sublayout) = + [a] -> Client sublayout + + clientWithRoute Proxy req vals = + clientWithRoute (Proxy :: Proxy sublayout) + (foldl' (flip appendToPath) req ps) + + where ps = map (unpack . toUrlPiece) vals + instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4c21e201..da7c763b 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -105,6 +105,7 @@ type Api = "get" :> Get '[JSON] Person :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person + :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] @@ -125,6 +126,7 @@ api = Proxy getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getCaptureAll :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] @@ -140,6 +142,7 @@ getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent getGet :<|> getDeleteEmpty :<|> getCapture + :<|> getCaptureAll :<|> getBody :<|> getQueryParam :<|> getQueryParams @@ -155,6 +158,7 @@ server = serve api ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) + :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice @@ -250,6 +254,10 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Capture" $ \(_, baseUrl) -> do (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) + it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do + let expected = [(Person "Paula" 0), (Person "Peta" 1)] + (left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected + it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p @@ -351,7 +359,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api Left res <- runExceptT (getBody alice manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index fad8717c..7b181822 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -702,6 +702,22 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) symP = Proxy :: Proxy sym +-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as +-- @/books/:isbn@ in the docs. +instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout) + => HasDocs (CaptureAll sym a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint', action') + + where sublayoutP = Proxy :: Proxy sublayout + captureP = Proxy :: Proxy (CaptureAll sym a) + + action' = over captures (|> toCapture captureP) action + endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint + symP = Proxy :: Proxy sym + + instance OVERLAPPABLE_ (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status , ReflectMethod method) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 018fd46b..054ea00a 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -34,6 +34,8 @@ instance ToParam (QueryFlag "foo") where toParam = error "unused" instance ToCapture (Capture "foo" Int) where toCapture = error "unused" +instance ToCapture (CaptureAll "foo" Int) where + toCapture = error "unused" -- * specs diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 0e68cc6c..59d09436 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -211,6 +211,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype ap { _argName = PathSegment str , _argType = ftype } +instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout) + => HasForeign lang ftype (CaptureAll sym t :> sublayout) where + type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout + + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy (Proxy :: Proxy sublayout) $ + req & reqUrl . path <>~ [Segment (Cap arg)] + & reqFuncName . _FunctionName %~ (++ ["by", str]) + where + str = pack . symbolVal $ (Proxy :: Proxy sym) + ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t]) + arg = Arg + { _argName = PathSegment str + , _argType = ftype } + instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method) => HasForeign lang ftype (Verb method status list a) where type Foreign ftype (Verb method status list a) = Req ftype diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 2df0c1ba..966861d5 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -46,6 +46,7 @@ type TestApi :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent + :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int] testApi :: [Req String] testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) @@ -53,9 +54,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do it "generates 4 endpoints for TestApi" $ do - length testApi `shouldBe` 4 + length testApi `shouldBe` 5 - let [getReq, postReq, putReq, deleteReq] = testApi + let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi it "collects all info for get request" $ do shouldBe getReq $ defReq @@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["delete", "test", "by", "id"] } + + it "collects all info for capture all request" $ do + shouldBe captureAllReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap (Arg "ids" "listX of intX") ] + [] + , _reqMethod = "GET" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = Just "listX of intX" + , _reqFuncName = FunctionName ["get", "test", "by", "ids"] + } diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 8aa57f0f..0d0f4a48 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -115,6 +115,9 @@ instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) cont instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context + instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where mock _ context = \_ -> mock (Proxy :: Proxy rest) context diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 21374dbe..de4a237a 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -45,13 +45,15 @@ import Prelude.Compat import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, - parseUrlPieceMaybe) + parseUrlPieceMaybe, + parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, - Verb, ReflectMethod(reflectMethod), - IsSecure(..), Header, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault, + CaptureAll, Verb, + ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, + QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, Vault, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), @@ -128,11 +130,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) CaptureRouter $ route (Proxy :: Proxy api) context - (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of + (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v ) +-- | If you use 'CaptureAll' in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a +-- function that takes an argument of a list of the type specified by +-- the 'CaptureAll'. This lets servant worry about getting values from +-- the URL and turning them into values of the type you specify. +-- +-- You can control how they'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromHttpApiData' for your type. +-- +-- Example: +-- +-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile +-- > +-- > server :: Server MyApi +-- > server = getSourceFile +-- > where getSourceFile :: [Text] -> Handler Book +-- > getSourceFile pathSegments = ... +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) + => HasServer (CaptureAll capture a :> sublayout) context where + + type ServerT (CaptureAll capture a :> sublayout) m = + [a] -> ServerT sublayout m + + route Proxy context d = + CaptureAllRouter $ + route (Proxy :: Proxy sublayout) + context + (addCapture d $ \ txts -> case parseUrlPieces txts of + Left _ -> delayedFail err400 + Right v -> return v + ) + + allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 3b69c04c..d01cc67a 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -31,6 +31,9 @@ data Router' env a = | CaptureRouter (Router' (Text, env) a) -- ^ first path component is passed to the child router in its -- environment and removed afterwards + | CaptureAllRouter (Router' ([Text], env) a) + -- ^ all path components are passed to the child router in its + -- environment and are removed afterwards | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a) @@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) = routerStructure (CaptureRouter router) = CaptureRouterStructure $ routerStructure router +routerStructure (CaptureAllRouter router) = + CaptureRouterStructure $ + routerStructure router routerStructure (RawRouter _) = RawRouterStructure routerStructure (Choice r1 r2) = @@ -163,6 +169,10 @@ runRouterEnv router env request respond = first : rest -> let request' = request { pathInfo = rest } in runRouterEnv router' (first, env) request' respond + CaptureAllRouter router' -> + let segments = pathInfo request + request' = request { pathInfo = [] } + in runRouterEnv router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 10bdc461..5f78d0bb 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where import Control.Monad (ap, liftM) import Control.Monad.Trans (MonadIO(..)) import Control.Monad.Trans.Except (runExceptT) -import Data.Text (Text) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () @@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req) -- | Add a capture to the end of the capture block. addCapture :: Delayed env (a -> b) - -> (Text -> DelayedIO a) - -> Delayed (Text, env) b + -> (captured -> DelayedIO a) + -> Delayed (captured, env) b addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 4e1adade..2337c258 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -39,7 +39,7 @@ import Network.Wai.Test (defaultRequest, request, simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData(BasicAuthData), - Capture, Delete, Get, Header (..), + Capture, CaptureAll, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, @@ -216,6 +216,58 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) +-- }}} +------------------------------------------------------------------------------ +-- * captureAllSpec {{{ +------------------------------------------------------------------------------ + +type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal +captureAllApi :: Proxy CaptureAllApi +captureAllApi = Proxy +captureAllServer :: [Integer] -> Handler Animal +captureAllServer legs = case sum legs of + 4 -> return jerry + 2 -> return tweety + 0 -> return beholder + _ -> throwE err404 + +captureAllSpec :: Spec +captureAllSpec = do + describe "Servant.API.CaptureAll" $ do + with (return (serve captureAllApi captureAllServer)) $ do + + it "can capture a single element of the 'pathInfo'" $ do + response <- get "/2" + liftIO $ decode' (simpleBody response) `shouldBe` Just tweety + + it "can capture multiple elements of the 'pathInfo'" $ do + response <- get "/2/2" + liftIO $ decode' (simpleBody response) `shouldBe` Just jerry + + it "can capture arbitrarily many elements of the 'pathInfo'" $ do + response <- get "/1/1/0/1/0/1" + liftIO $ decode' (simpleBody response) `shouldBe` Just jerry + + it "can capture when there are no elements in 'pathInfo'" $ do + response <- get "/" + liftIO $ decode' (simpleBody response) `shouldBe` Just beholder + + it "returns 400 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 400 + + it "returns 400 if the decoding fails, regardless of which element" $ do + get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400 + + it "returns 400 if the decoding fails, even when it's multiple elements" $ do + get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + + with (return (serve + (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) + (\ _captured request_ respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + it "consumes everything from pathInfo" $ do + get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) + -- }}} ------------------------------------------------------------------------------ -- * queryParamSpec {{{ @@ -644,4 +696,7 @@ jerry = Animal "Mouse" 4 tweety :: Animal tweety = Animal "Bird" 2 + +beholder :: Animal +beholder = Animal "Beholder" 0 -- }}} diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 5ea7b480..cbb0db09 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -8,7 +8,7 @@ module Servant.API ( -- * Accessing information from the request module Servant.API.Capture, - -- | Capturing parts of the url path as parsed values: @'Capture'@ + -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@ module Servant.API.Header, -- | Retrieving specific headers from the request module Servant.API.HttpVersion, @@ -60,7 +60,7 @@ module Servant.API ( import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) -import Servant.API.Capture (Capture) +import Servant.API.Capture (Capture, CaptureAll) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, MimeRender (..), NoContent (NoContent), diff --git a/servant/src/Servant/API/Capture.hs b/servant/src/Servant/API/Capture.hs index 9a2e1b61..7ee7972a 100644 --- a/servant/src/Servant/API/Capture.hs +++ b/servant/src/Servant/API/Capture.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Capture (Capture) where +module Servant.API.Capture (Capture, CaptureAll) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) @@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol) data Capture (sym :: Symbol) a deriving (Typeable) + +-- | Capture all remaining values from the request path under a certain type +-- @a@. +-- +-- Example: +-- +-- >>> -- GET /src/* +-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile +data CaptureAll (sym :: Symbol) a + deriving (Typeable) + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } +-- >>> data SourceFile +-- >>> instance ToJSON SourceFile where { toJSON = undefined } diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 5666ba0c..f568e56f 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -30,7 +30,8 @@ type ComprehensiveAPI = Vault :> GET :<|> Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] Int :<|> - WithNamedContext "foo" '[] GET + WithNamedContext "foo" '[] GET :<|> + CaptureAll "foo" Int :> GET comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index c312997c..d6b218be 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -107,7 +107,7 @@ import Prelude.Compat import Web.HttpApiData import Servant.API.BasicAuth ( BasicAuth ) -import Servant.API.Capture ( Capture ) +import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) @@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (Capture z y :> sa) (Capture x y :> sb) = IsElem sa sb + IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) + = IsElem sa sb IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb @@ -284,6 +286,13 @@ instance (ToHttpApiData v, HasLink sub) toLink (Proxy :: Proxy sub) $ addSegment (escape . Text.unpack $ toUrlPiece v) l +instance (ToHttpApiData v, HasLink sub) + => HasLink (CaptureAll sym v :> sub) where + type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub + toLink _ l vs = + toLink (Proxy :: Proxy sub) $ + foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs + instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 5a7ea4c4..2040fc55 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -13,6 +13,7 @@ import Servant.API type TestApi = -- Capture and query params "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent + :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent -- Flags :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent @@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do :> Delete '[JSON] NoContent) apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" + it "generates correct links for CaptureAll" $ do + apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) + ["roads", "lead", "to", "rome"] + `shouldBeURI` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"