From ce0fb4d3032caef73d4cbaaa0b099fa9d96b3ded Mon Sep 17 00:00:00 2001
From: Robert Hensing <robert@roberthensing.nl>
Date: Mon, 6 Nov 2017 14:42:41 +0100
Subject: [PATCH] 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,