From a616a8d6898363e16b8ef658c68ac9481054c0d4 Mon Sep 17 00:00:00 2001
From: Jonathan Lange <jml@mumak.net>
Date: Thu, 26 May 2016 16:49:04 +0100
Subject: [PATCH] Add CaptureAll to the API definitions

---
 servant/src/Servant/API.hs              |  4 ++--
 servant/src/Servant/API/Capture.hs      | 15 ++++++++++++++-
 servant/src/Servant/Utils/Links.hs      | 11 ++++++++++-
 servant/test/Servant/Utils/LinksSpec.hs |  5 +++++
 4 files changed, 31 insertions(+), 4 deletions(-)

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/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"