From a3408fde51c3c562cf7c77e2db7322487a2dad8d Mon Sep 17 00:00:00 2001
From: Nickolay Kudasov <nickolay.kudasov@gmail.com>
Date: Wed, 20 Jan 2016 19:22:51 +0300
Subject: [PATCH] Add CaptureAll combinator

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

diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs
index 03051533..6768d119 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,
@@ -49,7 +49,7 @@ module Servant.API (
   ) where
 
 import           Servant.API.Alternative     ((:<|>) (..))
-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..8ea344cd 100644
--- a/servant/src/Servant/API/Capture.hs
+++ b/servant/src/Servant/API/Capture.hs
@@ -2,10 +2,11 @@
 {-# 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)
+
 -- | Capture a value from the request path under a certain type @a@.
 --
 -- Example:
@@ -15,9 +16,20 @@ import           GHC.TypeLits  (Symbol)
 data Capture (sym :: Symbol) a
     deriving (Typeable)
 
+-- | Capture all values from the request path under a certain type @a@.
+--
+-- Example:
+--
+-- >>>            -- GET /src/*
+-- >>> type MyApi = "src" :> CaptureAll Text :> Get '[JSON] SourceFile
+data CaptureAll 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 d83ffc7e..ce3fc433 100644
--- a/servant/src/Servant/Utils/Links.hs
+++ b/servant/src/Servant/Utils/Links.hs
@@ -115,7 +115,7 @@ import GHC.TypeLits ( KnownSymbol, symbolVal )
 import GHC.Exts(Constraint)
 
 import Web.HttpApiData
-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 )
@@ -291,6 +291,13 @@ instance (ToHttpApiData v, HasLink sub)
         toLink (Proxy :: Proxy sub) $
             addSegment (escape . Text.unpack $ toUrlPiece v) l
 
+instance (ToHttpApiData v, HasLink sub)
+    => HasLink (CaptureAll v :> sub) where
+    type MkLink (CaptureAll 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 07e0b068..2e36ee26 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] ()
+  :<|> "all" :> CaptureAll String :> Get '[JSON] ()
 
   -- Flags
   :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()
@@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do
                                          :> Delete '[JSON] ())
         apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
 
+    it "generates correct links for CaptureAll" $ do
+        apiLink (Proxy :: Proxy ("all" :> CaptureAll String :> Get '[JSON] ()))
+          ["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"