From 7410b4faa8120c440ac66b2c7b993dc22258536c Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 6 Nov 2017 14:42:41 +0100 Subject: [PATCH 1/2] Links: add allLinks function and MkLink instance for (:<|>) This lets you generate all links at once, which is useful in conjunction with servant-generic. --- servant/src/Servant/Utils/Links.hs | 17 +++++++++++++++++ servant/test/Servant/Utils/LinksSpec.hs | 13 +++++++++++++ 2 files changed, 30 insertions(+) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 0318f96c..80f895c8 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -84,6 +84,7 @@ module Servant.Utils.Links ( -- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink + , allLinks , URI(..) -- * Adding custom types , HasLink(..) @@ -108,6 +109,7 @@ import Prelude () import Prelude.Compat import Web.HttpApiData +import Servant.API.Alternative ( (:<|>)((:<|>)) ) import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.ReqBody ( ReqBody ) @@ -220,6 +222,16 @@ safeLink -> MkLink endpoint safeLink _ endpoint = toLink endpoint (Link mempty mempty) +-- | Create all links in an API. +-- +-- Note that the @api@ type must be restricted to the endpoints that have +-- valid links to them. +allLinks + :: forall api. HasLink api + => Proxy api + -> MkLink api +allLinks api = toLink api (Link mempty mempty) + -- | Construct a toLink for an endpoint. class HasLink endpoint where type MkLink endpoint @@ -266,6 +278,11 @@ instance (KnownSymbol sym, HasLink sub) where k = symbolVal (Proxy :: Proxy sym) +-- :<|> instance - Generate all links at once +instance (HasLink a, HasLink b) => HasLink (a :<|> b) where + type MkLink (a :<|> b) = MkLink a :<|> MkLink b + toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l + -- Misc instances instance HasLink sub => HasLink (ReqBody ct a :> sub) where type MkLink (ReqBody ct a :> sub) = MkLink sub diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index b8dbcee7..29f3c1df 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.Utils.LinksSpec where import Data.Proxy (Proxy (..)) @@ -10,6 +11,7 @@ import Test.Hspec (Expectation, Spec, describe, it, import Data.String (fromString) import Servant.API +import Servant.Utils.Links (allLinks) type TestApi = -- Capture and query params @@ -27,6 +29,10 @@ type TestApi = :<|> "raw" :> Raw :<|> NoEndpoint +type LinkableApi = + "all" :> CaptureAll "names" String :> Get '[JSON] NoContent + :<|> "get" :> Get '[JSON] NoContent + apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint @@ -67,6 +73,13 @@ spec = describe "Servant.Utils.Links" $ do apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" + it "can generate all links for an API that has only linkable endpoints" $ do + let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi) + simple + `shouldBeLink` "get" + allNames ["Seneca", "Aurelius"] + `shouldBeLink` "all/Seneca/Aurelius" + -- | -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, From 2779f523caa1155429ab04f99630bfc385512022 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 7 Nov 2017 18:49:30 +0200 Subject: [PATCH 2/2] Add doctests (and changelog) --- servant/CHANGELOG.md | 2 ++ servant/src/Servant/Utils/Links.hs | 15 +++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 1fe4c8c9..a5603540 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -30,6 +30,8 @@ [#767](https://github.com/haskell-servant/servant/pull/767) [#790](https://github.com/haskell-servant/servant/pull/790) [#788](https://github.com/haskell-servant/servant/pull/788)) +- Add `addLinks` to generate all links for unnested APIs. + ([#851](https://github.com/haskell-servant/servant/pull/851)) - Allow newest dependencies ([#772](https://github.com/haskell-servant/servant/pull/772) [#842](https://github.com/haskell-servant/servant/pull/842)) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 80f895c8..d39e4a61 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -226,6 +226,20 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty) -- -- Note that the @api@ type must be restricted to the endpoints that have -- valid links to them. +-- +-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double +-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API) +-- >>> :t fooLink +-- fooLink :: Text -> Link +-- >>> :t barLink +-- barLink :: Int -> Link +-- +-- Note: nested APIs don't work well with this approach +-- +-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) +-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: * +-- = Char -> (Int -> Link) :<|> (Double -> Link) +-- allLinks :: forall api. HasLink api => Proxy api @@ -330,3 +344,4 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where -- $setup -- >>> import Servant.API +-- >>> import Data.Text (Text)