From 71425ab23c050301db72cbb8c10216bc19246130 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Mon, 18 Dec 2017 18:47:32 +0200
Subject: [PATCH] Fix #835. Use Escaped to prevent double-escaping

---
 servant/src/Servant/Utils/Links.hs | 34 ++++++++++++++++++++++++------
 1 file changed, 27 insertions(+), 7 deletions(-)

diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs
index 25eb2ad1..a7d8a6ea 100644
--- a/servant/src/Servant/Utils/Links.hs
+++ b/servant/src/Servant/Utils/Links.hs
@@ -127,12 +127,24 @@ import Servant.API.Experimental.Auth ( AuthProtect )
 -- The only way of constructing a 'Link' is using 'safeLink', which means any
 -- 'Link' is guaranteed to be part of the mentioned API.
 data Link = Link
-  { _segments :: [String]   -- ^ Segments of "foo/bar" would be ["foo", "bar"]
+  { _segments    :: [Escaped]
   , _queryParams :: [Param]
   } deriving Show
 
+newtype Escaped = Escaped String
+
+escaped :: String -> Escaped
+escaped = Escaped . escapeURIString isUnreserved
+
+getEscaped :: Escaped -> String
+getEscaped (Escaped s) = s
+
+instance Show Escaped where
+    showsPrec d (Escaped s) = showsPrec d s
+    show (Escaped s)        = show s
+
 linkSegments :: Link -> [String]
-linkSegments = _segments
+linkSegments = map getEscaped . _segments
 
 linkQueryParams :: Link -> [Param]
 linkQueryParams = _queryParams
@@ -150,7 +162,7 @@ data Param
     | FlagParam      String
   deriving Show
 
-addSegment :: String -> Link -> Link
+addSegment :: Escaped -> Link -> Link
 addSegment seg l = l { _segments = _segments l <> [seg] }
 
 addQueryParam :: Param -> Link -> Link
@@ -171,6 +183,14 @@ addQueryParam qp l =
 -- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
 -- foo%2Fbar
 --
+-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
+-- >>> let someRoute = Proxy :: Proxy SomeRoute
+-- >>> safeLink someRoute someRoute "test@example.com"
+-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
+--
+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
+-- abc/test%40example.com
+--
 linkURI :: Link -> URI
 linkURI = linkURI' LinkArrayElementBracket
 
@@ -193,7 +213,7 @@ linkURI' :: LinkArrayElementStyle -> Link -> URI
 linkURI' addBrackets (Link segments q_params) =
     URI mempty  -- No scheme (relative)
         Nothing -- Or authority (relative)
-        (intercalate "/" $ map escape segments)
+        (intercalate "/" $ map getEscaped segments)
         (makeQueries q_params) mempty
   where
     makeQueries :: [Param] -> String
@@ -258,7 +278,7 @@ class HasLink endpoint where
 instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
     type MkLink (sym :> sub) = MkLink sub
     toLink _ =
-        toLink (Proxy :: Proxy sub) . addSegment seg
+        toLink (Proxy :: Proxy sub) . addSegment (escaped seg)
       where
         seg = symbolVal (Proxy :: Proxy sym)
 
@@ -308,14 +328,14 @@ instance (ToHttpApiData v, HasLink sub)
     type MkLink (Capture sym v :> sub) = v -> MkLink sub
     toLink _ l v =
         toLink (Proxy :: Proxy sub) $
-            addSegment (escape . Text.unpack $ toUrlPiece v) l
+            addSegment (escaped . 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
+            foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
 
 instance HasLink sub => HasLink (Header sym a :> sub) where
     type MkLink (Header sym a :> sub) = MkLink sub