Fix #835. Use Escaped to prevent double-escaping

This commit is contained in:
Oleg Grenrus 2017-12-18 18:47:32 +02:00
parent 7edd35c9f0
commit 71425ab23c

View file

@ -127,12 +127,24 @@ import Servant.API.Experimental.Auth ( AuthProtect )
-- The only way of constructing a 'Link' is using 'safeLink', which means any -- The only way of constructing a 'Link' is using 'safeLink', which means any
-- 'Link' is guaranteed to be part of the mentioned API. -- 'Link' is guaranteed to be part of the mentioned API.
data Link = Link data Link = Link
{ _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] { _segments :: [Escaped]
, _queryParams :: [Param] , _queryParams :: [Param]
} deriving Show } 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 :: Link -> [String]
linkSegments = _segments linkSegments = map getEscaped . _segments
linkQueryParams :: Link -> [Param] linkQueryParams :: Link -> [Param]
linkQueryParams = _queryParams linkQueryParams = _queryParams
@ -150,7 +162,7 @@ data Param
| FlagParam String | FlagParam String
deriving Show deriving Show
addSegment :: String -> Link -> Link addSegment :: Escaped -> Link -> Link
addSegment seg l = l { _segments = _segments l <> [seg] } addSegment seg l = l { _segments = _segments l <> [seg] }
addQueryParam :: Param -> Link -> Link addQueryParam :: Param -> Link -> Link
@ -171,6 +183,14 @@ addQueryParam qp l =
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) -- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
-- foo%2Fbar -- 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 :: Link -> URI
linkURI = linkURI' LinkArrayElementBracket linkURI = linkURI' LinkArrayElementBracket
@ -193,7 +213,7 @@ linkURI' :: LinkArrayElementStyle -> Link -> URI
linkURI' addBrackets (Link segments q_params) = linkURI' addBrackets (Link segments q_params) =
URI mempty -- No scheme (relative) URI mempty -- No scheme (relative)
Nothing -- Or authority (relative) Nothing -- Or authority (relative)
(intercalate "/" $ map escape segments) (intercalate "/" $ map getEscaped segments)
(makeQueries q_params) mempty (makeQueries q_params) mempty
where where
makeQueries :: [Param] -> String makeQueries :: [Param] -> String
@ -258,7 +278,7 @@ class HasLink endpoint where
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
type MkLink (sym :> sub) = MkLink sub type MkLink (sym :> sub) = MkLink sub
toLink _ = toLink _ =
toLink (Proxy :: Proxy sub) . addSegment seg toLink (Proxy :: Proxy sub) . addSegment (escaped seg)
where where
seg = symbolVal (Proxy :: Proxy sym) seg = symbolVal (Proxy :: Proxy sym)
@ -308,14 +328,14 @@ instance (ToHttpApiData v, HasLink sub)
type MkLink (Capture sym v :> sub) = v -> MkLink sub type MkLink (Capture sym v :> sub) = v -> MkLink sub
toLink _ l v = toLink _ l v =
toLink (Proxy :: Proxy sub) $ toLink (Proxy :: Proxy sub) $
addSegment (escape . Text.unpack $ toUrlPiece v) l addSegment (escaped . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where => HasLink (CaptureAll sym v :> sub) where
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub
toLink _ l vs = toLink _ l vs =
toLink (Proxy :: Proxy sub) $ 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 instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub type MkLink (Header sym a :> sub) = MkLink sub