http-types-0.12.2: Network/HTTP/Types/URI.hs
{-# LANGUAGE OverloadedStrings, CPP #-}
module Network.HTTP.Types.URI
(
-- * Query string
QueryItem
, Query
, SimpleQueryItem
, SimpleQuery
, simpleQueryToQuery
, renderQuery
, renderQueryBuilder
, renderSimpleQuery
, parseQuery
, parseQueryReplacePlus
, parseSimpleQuery
-- **Escape only parts
, renderQueryPartialEscape
, renderQueryBuilderPartialEscape
, EscapeItem(..)
, PartialEscapeQueryItem
, PartialEscapeQuery
-- ** Text query string (UTF8 encoded)
, QueryText
, queryTextToQuery
, queryToQueryText
, renderQueryText
, parseQueryText
-- * Path segments
, encodePathSegments
, decodePathSegments
, encodePathSegmentsRelative
-- * Path (segments + query string)
, extractPath
, encodePath
, decodePath
-- * URL encoding / decoding
, urlEncodeBuilder
, urlEncode
, urlDecode
)
where
import Control.Arrow
import Data.Bits
import Data.Char
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Word
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Char8 () {-IsString-}
-- | Query item
type QueryItem = (B.ByteString, Maybe B.ByteString)
-- | Query.
--
-- General form: @a=b&c=d@, but if the value is Nothing, it becomes
-- @a&c=d@.
type Query = [QueryItem]
-- | Like Query, but with 'Text' instead of 'B.ByteString' (UTF8-encoded).
type QueryText = [(Text, Maybe Text)]
-- | Convert 'QueryText' to 'Query'.
queryTextToQuery :: QueryText -> Query
queryTextToQuery = map $ encodeUtf8 *** fmap encodeUtf8
-- | Convert 'QueryText' to a 'B.Builder'.
renderQueryText :: Bool -- ^ prepend a question mark?
-> QueryText
-> B.Builder
renderQueryText b = renderQueryBuilder b . queryTextToQuery
-- | Convert 'Query' to 'QueryText' (leniently decoding the UTF-8).
queryToQueryText :: Query -> QueryText
queryToQueryText =
map $ go *** fmap go
where
go = decodeUtf8With lenientDecode
-- | Parse 'QueryText' from a 'B.ByteString'. See 'parseQuery' for details.
parseQueryText :: B.ByteString -> QueryText
parseQueryText = queryToQueryText . parseQuery
-- | Simplified Query item type without support for parameter-less items.
type SimpleQueryItem = (B.ByteString, B.ByteString)
-- | Simplified Query type without support for parameter-less items.
type SimpleQuery = [SimpleQueryItem]
-- | Convert 'SimpleQuery' to 'Query'.
simpleQueryToQuery :: SimpleQuery -> Query
simpleQueryToQuery = map (second Just)
-- | Convert 'Query' to a 'Builder'.
renderQueryBuilder :: Bool -- ^ prepend a question mark?
-> Query
-> B.Builder
renderQueryBuilder _ [] = mempty
-- FIXME replace mconcat + map with foldr
renderQueryBuilder qmark' (p:ps) = mconcat
$ go (if qmark' then qmark else mempty) p
: map (go amp) ps
where
qmark = B.byteString "?"
amp = B.byteString "&"
equal = B.byteString "="
go sep (k, mv) = mconcat [
sep
, urlEncodeBuilder True k
, case mv of
Nothing -> mempty
Just v -> equal `mappend` urlEncodeBuilder True v
]
-- | Convert 'Query' to 'ByteString'.
renderQuery :: Bool -- ^ prepend question mark?
-> Query -> B.ByteString
renderQuery qm = BL.toStrict . B.toLazyByteString . renderQueryBuilder qm
-- | Convert 'SimpleQuery' to 'ByteString'.
renderSimpleQuery :: Bool -- ^ prepend question mark?
-> SimpleQuery -> B.ByteString
renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . simpleQueryToQuery
-- | Split out the query string into a list of keys and values. A few
-- importants points:
--
-- * The result returned is still bytestrings, since we perform no character
-- decoding here. Most likely, you will want to use UTF-8 decoding, but this is
-- left to the user of the library.
--
-- * Percent decoding errors are ignored. In particular, @"%Q"@ will be output as
-- @"%Q"@.
--
-- * It decodes @\'+\'@ characters to @\' \'@
parseQuery :: B.ByteString -> Query
parseQuery = parseQueryReplacePlus True
-- | Same functionality as 'parseQuery' with the option to decode @\'+\'@ characters to @\' \'@
-- or preserve @\'+\'@
parseQueryReplacePlus :: Bool -> B.ByteString -> Query
parseQueryReplacePlus replacePlus bs = parseQueryString' $ dropQuestion bs
where
dropQuestion q =
case B.uncons q of
Just (63, q') -> q'
_ -> q
parseQueryString' q | B.null q = []
parseQueryString' q =
let (x, xs) = breakDiscard queryStringSeparators q
in parsePair x : parseQueryString' xs
where
parsePair x =
let (k, v) = B.break (== 61) x -- equal sign
v'' =
case B.uncons v of
Just (_, v') -> Just $ urlDecode replacePlus v'
_ -> Nothing
in (urlDecode replacePlus k, v'')
queryStringSeparators :: B.ByteString
queryStringSeparators = B.pack [38,59] -- ampersand, semicolon
-- | Break the second bytestring at the first occurrence of any bytes from
-- the first bytestring, discarding that byte.
breakDiscard :: B.ByteString -> B.ByteString -> (B.ByteString, B.ByteString)
breakDiscard seps s =
let (x, y) = B.break (`B.elem` seps) s
in (x, B.drop 1 y)
-- | Parse 'SimpleQuery' from a 'ByteString'.
parseSimpleQuery :: B.ByteString -> SimpleQuery
parseSimpleQuery = map (second $ fromMaybe B.empty) . parseQuery
ord8 :: Char -> Word8
ord8 = fromIntegral . ord
unreservedQS, unreservedPI :: [Word8]
unreservedQS = map ord8 "-_.~"
unreservedPI = map ord8 "-_.~:@&=+$,"
-- | Percent-encoding for URLs.
urlEncodeBuilder' :: [Word8] -> B.ByteString -> B.Builder
urlEncodeBuilder' extraUnreserved = mconcat . map encodeChar . B.unpack
where
encodeChar ch | unreserved ch = B.word8 ch
| otherwise = h2 ch
unreserved ch | ch >= 65 && ch <= 90 = True -- A-Z
| ch >= 97 && ch <= 122 = True -- a-z
| ch >= 48 && ch <= 57 = True -- 0-9
unreserved c = c `elem` extraUnreserved
-- must be upper-case
h2 v = B.word8 37 `mappend` B.word8 (h a) `mappend` B.word8 (h b) -- 37 = %
where (a, b) = v `divMod` 16
h i | i < 10 = 48 + i -- zero (0)
| otherwise = 65 + i - 10 -- 65: A
-- | Percent-encoding for URLs (using 'B.Builder').
urlEncodeBuilder
:: Bool -- ^ Whether input is in query string. True: Query string, False: Path element
-> B.ByteString
-> B.Builder
urlEncodeBuilder True = urlEncodeBuilder' unreservedQS
urlEncodeBuilder False = urlEncodeBuilder' unreservedPI
-- | Percent-encoding for URLs.
urlEncode :: Bool -- ^ Whether to decode @\'+\'@ to @\' \'@
-> B.ByteString -- ^ The ByteString to encode as URL
-> B.ByteString -- ^ The encoded URL
urlEncode q = BL.toStrict . B.toLazyByteString . urlEncodeBuilder q
-- | Percent-decoding.
urlDecode :: Bool -- ^ Whether to decode @\'+\'@ to @\' \'@
-> B.ByteString -> B.ByteString
urlDecode replacePlus z = fst $ B.unfoldrN (B.length z) go z
where
go bs =
case B.uncons bs of
Nothing -> Nothing
Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space
Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent
(x, xs) <- B.uncons ws
x' <- hexVal x
(y, ys) <- B.uncons xs
y' <- hexVal y
Just (combine x' y', ys)
Just (w, ws) -> Just (w, ws)
hexVal w
| 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9
| 65 <= w && w <= 70 = Just $ w - 55 -- A - F
| 97 <= w && w <= 102 = Just $ w - 87 -- a - f
| otherwise = Nothing
combine :: Word8 -> Word8 -> Word8
combine a b = shiftL a 4 .|. b
-- | Encodes a list of path segments into a valid URL fragment.
--
-- This function takes the following three steps:
--
-- * UTF-8 encodes the characters.
--
-- * Performs percent encoding on all unreserved characters, as well as @\:\@\=\+\$@,
--
-- * Prepends each segment with a slash.
--
-- For example:
--
-- > encodePathSegments [\"foo\", \"bar\", \"baz\"]
-- \"\/foo\/bar\/baz\"
--
-- > encodePathSegments [\"foo bar\", \"baz\/bin\"]
-- \"\/foo\%20bar\/baz\%2Fbin\"
--
-- > encodePathSegments [\"שלום\"]
-- \"\/%D7%A9%D7%9C%D7%95%D7%9D\"
--
-- Huge thanks to Jeremy Shaw who created the original implementation of this
-- function in web-routes and did such thorough research to determine all
-- correct escaping procedures.
encodePathSegments :: [Text] -> B.Builder
encodePathSegments = foldr (\x -> mappend (B.byteString "/" `mappend` encodePathSegment x)) mempty
-- | Like encodePathSegments, but without the initial slash.
encodePathSegmentsRelative :: [Text] -> B.Builder
encodePathSegmentsRelative xs = mconcat $ intersperse (B.byteString "/") (map encodePathSegment xs)
encodePathSegment :: Text -> B.Builder
encodePathSegment = urlEncodeBuilder False . encodeUtf8
-- | Parse a list of path segments from a valid URL fragment.
decodePathSegments :: B.ByteString -> [Text]
decodePathSegments "" = []
decodePathSegments "/" = []
decodePathSegments a =
go $ drop1Slash a
where
drop1Slash bs =
case B.uncons bs of
Just (47, bs') -> bs' -- 47 == /
_ -> bs
go bs =
let (x, y) = B.break (== 47) bs
in decodePathSegment x :
if B.null y
then []
else go $ B.drop 1 y
decodePathSegment :: B.ByteString -> Text
decodePathSegment = decodeUtf8With lenientDecode . urlDecode False
-- | Extract whole path (path segments + query) from a
-- <http://tools.ietf.org/html/rfc2616#section-5.1.2 RFC 2616 Request-URI>.
--
-- >>> extractPath "/path"
-- "/path"
--
-- >>> extractPath "http://example.com:8080/path"
-- "/path"
--
-- >>> extractPath "http://example.com"
-- "/"
--
-- >>> extractPath ""
-- "/"
extractPath :: B.ByteString -> B.ByteString
extractPath = ensureNonEmpty . extract
where
extract path
| "http://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 7) path
| "https://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 8) path
| otherwise = path
breakOnSlash = B.break (== 47)
ensureNonEmpty "" = "/"
ensureNonEmpty p = p
-- | Encode a whole path (path segments + query).
encodePath :: [Text] -> Query -> B.Builder
encodePath x [] = encodePathSegments x
encodePath x y = encodePathSegments x `mappend` renderQueryBuilder True y
-- | Decode a whole path (path segments + query).
decodePath :: B.ByteString -> ([Text], Query)
decodePath b =
let (x, y) = B.break (== 63) b -- question mark
in (decodePathSegments x, parseQuery y)
-----------------------------------------------------------------------------------------
-- | For some URIs characters must not be URI encoded,
-- e.g. @\'+\'@ or @\':\'@ in @q=a+language:haskell+created:2009-01-01..2009-02-01&sort=stars@
-- The character list unreservedPI instead of unreservedQS would solve this.
-- But we explicitly decide what part to encode.
-- This is mandatory when searching for @\'+\'@: @q=%2B+language:haskell@.
data EscapeItem = QE B.ByteString -- will be URL encoded
| QN B.ByteString -- will not be url encoded, e.g. @\'+\'@ or @\':\'@
deriving (Show, Eq, Ord)
-- | Query item
type PartialEscapeQueryItem = (B.ByteString, [EscapeItem])
-- | Query with some chars that should not be escaped.
--
-- General form: @a=b&c=d:e+f&g=h@
type PartialEscapeQuery = [PartialEscapeQueryItem]
-- | Convert 'PartialEscapeQuery' to 'ByteString'.
renderQueryPartialEscape :: Bool -- ^ prepend question mark?
-> PartialEscapeQuery -> B.ByteString
renderQueryPartialEscape qm = BL.toStrict . B.toLazyByteString . renderQueryBuilderPartialEscape qm
-- | Convert 'PartialEscapeQuery' to a 'Builder'.
renderQueryBuilderPartialEscape :: Bool -- ^ prepend a question mark?
-> PartialEscapeQuery
-> B.Builder
renderQueryBuilderPartialEscape _ [] = mempty
-- FIXME replace mconcat + map with foldr
renderQueryBuilderPartialEscape qmark' (p:ps) = mconcat
$ go (if qmark' then qmark else mempty) p
: map (go amp) ps
where
qmark = B.byteString "?"
amp = B.byteString "&"
equal = B.byteString "="
go sep (k, mv) = mconcat [
sep
, urlEncodeBuilder True k
, case mv of
[] -> mempty
vs -> equal `mappend` (mconcat (map encode vs))
]
encode (QE v) = urlEncodeBuilder True v
encode (QN v) = B.byteString v