Merge pull request #854 from phadej/pull-851

Pull 851

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

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,30 @@ 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.
+--
+-- >>> 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
+    -> MkLink api
+allLinks api = toLink api (Link mempty mempty)
+
 -- | Construct a toLink for an endpoint.
 class HasLink endpoint where
     type MkLink endpoint
@@ -266,6 +292,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
@@ -313,3 +344,4 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where
 
 -- $setup
 -- >>> import Servant.API
+-- >>> import Data.Text (Text)

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,