Fix #835. Use Escaped to prevent double-escaping
This commit is contained in:
parent
7edd35c9f0
commit
71425ab23c
1 changed files with 27 additions and 7 deletions
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue