{-# 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 :: QueryText -> Query
queryTextToQuery = ((Text, Maybe Text) -> QueryItem) -> QueryText -> Query
forall a b. (a -> b) -> [a] -> [b]
map (((Text, Maybe Text) -> QueryItem) -> QueryText -> Query)
-> ((Text, Maybe Text) -> QueryItem) -> QueryText -> Query
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Maybe Text -> Maybe ByteString)
-> (Text, Maybe Text)
-> QueryItem
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8

-- | Convert 'QueryText' to a 'B.Builder'.
renderQueryText :: Bool -- ^ prepend a question mark?
                -> QueryText
                -> B.Builder
renderQueryText :: Bool -> QueryText -> Builder
renderQueryText Bool
b = Bool -> Query -> Builder
renderQueryBuilder Bool
b (Query -> Builder) -> (QueryText -> Query) -> QueryText -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryText -> Query
queryTextToQuery

-- | Convert 'Query' to 'QueryText' (leniently decoding the UTF-8).
queryToQueryText :: Query -> QueryText
queryToQueryText :: Query -> QueryText
queryToQueryText =
    (QueryItem -> (Text, Maybe Text)) -> Query -> QueryText
forall a b. (a -> b) -> [a] -> [b]
map ((QueryItem -> (Text, Maybe Text)) -> Query -> QueryText)
-> (QueryItem -> (Text, Maybe Text)) -> Query -> QueryText
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
go (ByteString -> Text)
-> (Maybe ByteString -> Maybe Text)
-> QueryItem
-> (Text, Maybe Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
go
  where
    go :: ByteString -> Text
go = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode

-- | Parse 'QueryText' from a 'B.ByteString'. See 'parseQuery' for details.
parseQueryText :: B.ByteString -> QueryText
parseQueryText :: ByteString -> QueryText
parseQueryText = Query -> QueryText
queryToQueryText (Query -> QueryText)
-> (ByteString -> Query) -> ByteString -> QueryText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query
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 :: SimpleQuery -> Query
simpleQueryToQuery = (SimpleQueryItem -> QueryItem) -> SimpleQuery -> Query
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> Maybe ByteString) -> SimpleQueryItem -> QueryItem
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just)

-- | Convert 'Query' to a 'Builder'.
renderQueryBuilder :: Bool -- ^ prepend a question mark?
                   -> Query
                   -> B.Builder
renderQueryBuilder :: Bool -> Query -> Builder
renderQueryBuilder Bool
_ [] = Builder
forall a. Monoid a => a
mempty
-- FIXME replace mconcat + map with foldr
renderQueryBuilder Bool
qmark' (QueryItem
p:Query
ps) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> QueryItem -> Builder
go (if Bool
qmark' then Builder
qmark else Builder
forall a. Monoid a => a
mempty) QueryItem
p
    Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (QueryItem -> Builder) -> Query -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> QueryItem -> Builder
go Builder
amp) Query
ps
  where
    qmark :: Builder
qmark = ByteString -> Builder
B.byteString ByteString
"?"
    amp :: Builder
amp = ByteString -> Builder
B.byteString ByteString
"&"
    equal :: Builder
equal = ByteString -> Builder
B.byteString ByteString
"="
    go :: Builder -> QueryItem -> Builder
go Builder
sep (ByteString
k, Maybe ByteString
mv) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
                      Builder
sep
                     , Bool -> ByteString -> Builder
urlEncodeBuilder Bool
True ByteString
k
                     , case Maybe ByteString
mv of
                         Maybe ByteString
Nothing -> Builder
forall a. Monoid a => a
mempty
                         Just ByteString
v -> Builder
equal Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Bool -> ByteString -> Builder
urlEncodeBuilder Bool
True ByteString
v
                     ]

-- | Convert 'Query' to 'ByteString'.
renderQuery :: Bool -- ^ prepend question mark?
            -> Query -> B.ByteString
renderQuery :: Bool -> Query -> ByteString
renderQuery Bool
qm = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Query -> ByteString) -> Query -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (Query -> Builder) -> Query -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Query -> Builder
renderQueryBuilder Bool
qm

-- | Convert 'SimpleQuery' to 'ByteString'.
renderSimpleQuery :: Bool -- ^ prepend question mark?
                  -> SimpleQuery -> B.ByteString
renderSimpleQuery :: Bool -> SimpleQuery -> ByteString
renderSimpleQuery Bool
useQuestionMark = Bool -> Query -> ByteString
renderQuery Bool
useQuestionMark (Query -> ByteString)
-> (SimpleQuery -> Query) -> SimpleQuery -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleQuery -> Query
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 :: ByteString -> Query
parseQuery = Bool -> ByteString -> Query
parseQueryReplacePlus Bool
True

-- | Same functionality as 'parseQuery' with the option to decode @\'+\'@ characters to @\' \'@
-- or preserve @\'+\'@
parseQueryReplacePlus :: Bool -> B.ByteString -> Query
parseQueryReplacePlus :: Bool -> ByteString -> Query
parseQueryReplacePlus Bool
replacePlus ByteString
bs = ByteString -> Query
parseQueryString' (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropQuestion ByteString
bs
  where
    dropQuestion :: ByteString -> ByteString
dropQuestion ByteString
q =
        case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
q of
            Just (Word8
63, ByteString
q') -> ByteString
q'
            Maybe (Word8, ByteString)
_ -> ByteString
q
    parseQueryString' :: ByteString -> Query
parseQueryString' ByteString
q | ByteString -> Bool
B.null ByteString
q = []
    parseQueryString' ByteString
q =
        let (ByteString
x, ByteString
xs) = ByteString -> ByteString -> SimpleQueryItem
breakDiscard ByteString
queryStringSeparators ByteString
q
         in ByteString -> QueryItem
parsePair ByteString
x QueryItem -> Query -> Query
forall a. a -> [a] -> [a]
: ByteString -> Query
parseQueryString' ByteString
xs
      where
        parsePair :: ByteString -> QueryItem
parsePair ByteString
x =
            let (ByteString
k, ByteString
v) = (Word8 -> Bool) -> ByteString -> SimpleQueryItem
B.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
61) ByteString
x -- equal sign
                v'' :: Maybe ByteString
v'' =
                    case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
v of
                        Just (Word8
_, ByteString
v') -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlDecode Bool
replacePlus ByteString
v'
                        Maybe (Word8, ByteString)
_ -> Maybe ByteString
forall a. Maybe a
Nothing
             in (Bool -> ByteString -> ByteString
urlDecode Bool
replacePlus ByteString
k, Maybe ByteString
v'')

queryStringSeparators :: B.ByteString
queryStringSeparators :: ByteString
queryStringSeparators = [Word8] -> ByteString
B.pack [Word8
38,Word8
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 :: ByteString -> ByteString -> SimpleQueryItem
breakDiscard ByteString
seps ByteString
s =
    let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> SimpleQueryItem
B.break (Word8 -> ByteString -> Bool
`B.elem` ByteString
seps) ByteString
s
     in (ByteString
x, Int -> ByteString -> ByteString
B.drop Int
1 ByteString
y)

-- | Parse 'SimpleQuery' from a 'ByteString'.
parseSimpleQuery :: B.ByteString -> SimpleQuery
parseSimpleQuery :: ByteString -> SimpleQuery
parseSimpleQuery = (QueryItem -> SimpleQueryItem) -> Query -> SimpleQuery
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe ByteString -> ByteString) -> QueryItem -> SimpleQueryItem
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Maybe ByteString -> ByteString) -> QueryItem -> SimpleQueryItem)
-> (Maybe ByteString -> ByteString) -> QueryItem -> SimpleQueryItem
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty) (Query -> SimpleQuery)
-> (ByteString -> Query) -> ByteString -> SimpleQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query
parseQuery

ord8 :: Char -> Word8
ord8 :: Char -> Word8
ord8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

unreservedQS, unreservedPI :: [Word8]
unreservedQS :: [Word8]
unreservedQS = (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
ord8 [Char]
"-_.~"
unreservedPI :: [Word8]
unreservedPI = (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
ord8 [Char]
"-_.~:@&=+$,"

-- | Percent-encoding for URLs.
urlEncodeBuilder' :: [Word8] -> B.ByteString -> B.Builder
urlEncodeBuilder' :: [Word8] -> ByteString -> Builder
urlEncodeBuilder' [Word8]
extraUnreserved = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> (ByteString -> [Builder]) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Builder) -> [Word8] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Builder
encodeChar ([Word8] -> [Builder])
-> (ByteString -> [Word8]) -> ByteString -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack
    where
      encodeChar :: Word8 -> Builder
encodeChar Word8
ch | Word8 -> Bool
unreserved Word8
ch = Word8 -> Builder
B.word8 Word8
ch
                    | Bool
otherwise     = Word8 -> Builder
h2 Word8
ch

      unreserved :: Word8 -> Bool
unreserved Word8
ch | Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90  = Bool
True -- A-Z
                    | Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122 = Bool
True -- a-z
                    | Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
ch Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57  = Bool
True -- 0-9
      unreserved Word8
c = Word8
c Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8]
extraUnreserved

      -- must be upper-case
      h2 :: Word8 -> Builder
h2 Word8
v = Word8 -> Builder
B.word8 Word8
37 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
B.word8 (Word8 -> Word8
forall a. (Ord a, Num a) => a -> a
h Word8
a) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
B.word8 (Word8 -> Word8
forall a. (Ord a, Num a) => a -> a
h Word8
b) -- 37 = %
          where (Word8
a, Word8
b) = Word8
v Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
16
      h :: a -> a
h a
i | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10    = a
48 a -> a -> a
forall a. Num a => a -> a -> a
+ a
i -- zero (0)
          | Bool
otherwise = a
65 a -> a -> a
forall a. Num a => a -> a -> a
+ a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
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 :: Bool -> ByteString -> Builder
urlEncodeBuilder Bool
True  = [Word8] -> ByteString -> Builder
urlEncodeBuilder' [Word8]
unreservedQS
urlEncodeBuilder Bool
False = [Word8] -> ByteString -> Builder
urlEncodeBuilder' [Word8]
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 :: Bool -> ByteString -> ByteString
urlEncode Bool
q = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> Builder
urlEncodeBuilder Bool
q

-- | Percent-decoding.
urlDecode :: Bool -- ^ Whether to decode @\'+\'@ to @\' \'@
          -> B.ByteString -> B.ByteString
urlDecode :: Bool -> ByteString -> ByteString
urlDecode Bool
replacePlus ByteString
z = QueryItem -> ByteString
forall a b. (a, b) -> a
fst (QueryItem -> ByteString) -> QueryItem -> ByteString
forall a b. (a -> b) -> a -> b
$ Int
-> (ByteString -> Maybe (Word8, ByteString))
-> ByteString
-> QueryItem
forall a.
Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
B.unfoldrN (ByteString -> Int
B.length ByteString
z) ByteString -> Maybe (Word8, ByteString)
go ByteString
z
  where
    go :: ByteString -> Maybe (Word8, ByteString)
go ByteString
bs =
        case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
            Maybe (Word8, ByteString)
Nothing -> Maybe (Word8, ByteString)
forall a. Maybe a
Nothing
            Just (Word8
43, ByteString
ws) | Bool
replacePlus -> (Word8, ByteString) -> Maybe (Word8, ByteString)
forall a. a -> Maybe a
Just (Word8
32, ByteString
ws) -- plus to space
            Just (Word8
37, ByteString
ws) -> (Word8, ByteString) -> Maybe (Word8, ByteString)
forall a. a -> Maybe a
Just ((Word8, ByteString) -> Maybe (Word8, ByteString))
-> (Word8, ByteString) -> Maybe (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ (Word8, ByteString)
-> Maybe (Word8, ByteString) -> (Word8, ByteString)
forall a. a -> Maybe a -> a
fromMaybe (Word8
37, ByteString
ws) (Maybe (Word8, ByteString) -> (Word8, ByteString))
-> Maybe (Word8, ByteString) -> (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ do -- percent
                (Word8
x, ByteString
xs) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
ws
                Word8
x' <- Word8 -> Maybe Word8
forall a. (Ord a, Num a) => a -> Maybe a
hexVal Word8
x
                (Word8
y, ByteString
ys) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
xs
                Word8
y' <- Word8 -> Maybe Word8
forall a. (Ord a, Num a) => a -> Maybe a
hexVal Word8
y
                (Word8, ByteString) -> Maybe (Word8, ByteString)
forall a. a -> Maybe a
Just (Word8 -> Word8 -> Word8
combine Word8
x' Word8
y', ByteString
ys)
            Just (Word8
w, ByteString
ws) -> (Word8, ByteString) -> Maybe (Word8, ByteString)
forall a. a -> Maybe a
Just (Word8
w, ByteString
ws)
    hexVal :: a -> Maybe a
hexVal a
w
        | a
48 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
w Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57  = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
48 -- 0 - 9
        | a
65 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
w Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
70  = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
55 -- A - F
        | a
97 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
w Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
102 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
87 -- a - f
        | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
    combine :: Word8 -> Word8 -> Word8
    combine :: Word8 -> Word8 -> Word8
combine Word8
a Word8
b = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL Word8
a Int
4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
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 :: [Text] -> Builder
encodePathSegments = (Text -> Builder -> Builder) -> Builder -> [Text] -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
x -> Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (ByteString -> Builder
B.byteString ByteString
"/" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
encodePathSegment Text
x)) Builder
forall a. Monoid a => a
mempty

-- | Like encodePathSegments, but without the initial slash.
encodePathSegmentsRelative :: [Text] -> B.Builder
encodePathSegmentsRelative :: [Text] -> Builder
encodePathSegmentsRelative [Text]
xs = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ByteString -> Builder
B.byteString ByteString
"/") ((Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
encodePathSegment [Text]
xs)

encodePathSegment :: Text -> B.Builder
encodePathSegment :: Text -> Builder
encodePathSegment = Bool -> ByteString -> Builder
urlEncodeBuilder Bool
False (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Parse a list of path segments from a valid URL fragment.
decodePathSegments :: B.ByteString -> [Text]
decodePathSegments :: ByteString -> [Text]
decodePathSegments ByteString
"" = []
decodePathSegments ByteString
"/" = []
decodePathSegments ByteString
a =
    ByteString -> [Text]
go (ByteString -> [Text]) -> ByteString -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
drop1Slash ByteString
a
  where
    drop1Slash :: ByteString -> ByteString
drop1Slash ByteString
bs =
        case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
            Just (Word8
47, ByteString
bs') -> ByteString
bs' -- 47 == /
            Maybe (Word8, ByteString)
_ -> ByteString
bs
    go :: ByteString -> [Text]
go ByteString
bs =
        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> SimpleQueryItem
B.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47) ByteString
bs
         in ByteString -> Text
decodePathSegment ByteString
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
            if ByteString -> Bool
B.null ByteString
y
                then []
                else ByteString -> [Text]
go (ByteString -> [Text]) -> ByteString -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
1 ByteString
y

decodePathSegment :: B.ByteString -> Text
decodePathSegment :: ByteString -> Text
decodePathSegment = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlDecode Bool
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 :: ByteString -> ByteString
extractPath = ByteString -> ByteString
forall p. (Eq p, IsString p) => p -> p
ensureNonEmpty (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
extract
  where
    extract :: ByteString -> ByteString
extract ByteString
path
      | ByteString
"http://"  ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
path = (SimpleQueryItem -> ByteString
forall a b. (a, b) -> b
snd (SimpleQueryItem -> ByteString)
-> (ByteString -> SimpleQueryItem) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SimpleQueryItem
breakOnSlash (ByteString -> SimpleQueryItem)
-> (ByteString -> ByteString) -> ByteString -> SimpleQueryItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
7) ByteString
path
      | ByteString
"https://" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
path = (SimpleQueryItem -> ByteString
forall a b. (a, b) -> b
snd (SimpleQueryItem -> ByteString)
-> (ByteString -> SimpleQueryItem) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SimpleQueryItem
breakOnSlash (ByteString -> SimpleQueryItem)
-> (ByteString -> ByteString) -> ByteString -> SimpleQueryItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
8) ByteString
path
      | Bool
otherwise                      = ByteString
path
    breakOnSlash :: ByteString -> SimpleQueryItem
breakOnSlash = (Word8 -> Bool) -> ByteString -> SimpleQueryItem
B.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47)
    ensureNonEmpty :: p -> p
ensureNonEmpty p
"" = p
"/"
    ensureNonEmpty p
p  = p
p

-- | Encode a whole path (path segments + query).
encodePath :: [Text] -> Query -> B.Builder
encodePath :: [Text] -> Query -> Builder
encodePath [Text]
x [] = [Text] -> Builder
encodePathSegments [Text]
x
encodePath [Text]
x Query
y = [Text] -> Builder
encodePathSegments [Text]
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Bool -> Query -> Builder
renderQueryBuilder Bool
True Query
y

-- | Decode a whole path (path segments + query).
decodePath :: B.ByteString -> ([Text], Query)
decodePath :: ByteString -> ([Text], Query)
decodePath ByteString
b =
    let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> SimpleQueryItem
B.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
63) ByteString
b -- question mark
    in (ByteString -> [Text]
decodePathSegments ByteString
x, ByteString -> Query
parseQuery ByteString
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 (Int -> EscapeItem -> ShowS
[EscapeItem] -> ShowS
EscapeItem -> [Char]
(Int -> EscapeItem -> ShowS)
-> (EscapeItem -> [Char])
-> ([EscapeItem] -> ShowS)
-> Show EscapeItem
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EscapeItem] -> ShowS
$cshowList :: [EscapeItem] -> ShowS
show :: EscapeItem -> [Char]
$cshow :: EscapeItem -> [Char]
showsPrec :: Int -> EscapeItem -> ShowS
$cshowsPrec :: Int -> EscapeItem -> ShowS
Show, EscapeItem -> EscapeItem -> Bool
(EscapeItem -> EscapeItem -> Bool)
-> (EscapeItem -> EscapeItem -> Bool) -> Eq EscapeItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EscapeItem -> EscapeItem -> Bool
$c/= :: EscapeItem -> EscapeItem -> Bool
== :: EscapeItem -> EscapeItem -> Bool
$c== :: EscapeItem -> EscapeItem -> Bool
Eq, Eq EscapeItem
Eq EscapeItem
-> (EscapeItem -> EscapeItem -> Ordering)
-> (EscapeItem -> EscapeItem -> Bool)
-> (EscapeItem -> EscapeItem -> Bool)
-> (EscapeItem -> EscapeItem -> Bool)
-> (EscapeItem -> EscapeItem -> Bool)
-> (EscapeItem -> EscapeItem -> EscapeItem)
-> (EscapeItem -> EscapeItem -> EscapeItem)
-> Ord EscapeItem
EscapeItem -> EscapeItem -> Bool
EscapeItem -> EscapeItem -> Ordering
EscapeItem -> EscapeItem -> EscapeItem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EscapeItem -> EscapeItem -> EscapeItem
$cmin :: EscapeItem -> EscapeItem -> EscapeItem
max :: EscapeItem -> EscapeItem -> EscapeItem
$cmax :: EscapeItem -> EscapeItem -> EscapeItem
>= :: EscapeItem -> EscapeItem -> Bool
$c>= :: EscapeItem -> EscapeItem -> Bool
> :: EscapeItem -> EscapeItem -> Bool
$c> :: EscapeItem -> EscapeItem -> Bool
<= :: EscapeItem -> EscapeItem -> Bool
$c<= :: EscapeItem -> EscapeItem -> Bool
< :: EscapeItem -> EscapeItem -> Bool
$c< :: EscapeItem -> EscapeItem -> Bool
compare :: EscapeItem -> EscapeItem -> Ordering
$ccompare :: EscapeItem -> EscapeItem -> Ordering
$cp1Ord :: Eq EscapeItem
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 :: Bool -> PartialEscapeQuery -> ByteString
renderQueryPartialEscape Bool
qm = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (PartialEscapeQuery -> ByteString)
-> PartialEscapeQuery
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (PartialEscapeQuery -> Builder)
-> PartialEscapeQuery
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PartialEscapeQuery -> Builder
renderQueryBuilderPartialEscape Bool
qm

-- | Convert 'PartialEscapeQuery' to a 'Builder'.
renderQueryBuilderPartialEscape :: Bool -- ^ prepend a question mark?
                   -> PartialEscapeQuery
                   -> B.Builder
renderQueryBuilderPartialEscape :: Bool -> PartialEscapeQuery -> Builder
renderQueryBuilderPartialEscape Bool
_ [] = Builder
forall a. Monoid a => a
mempty
-- FIXME replace mconcat + map with foldr
renderQueryBuilderPartialEscape Bool
qmark' (PartialEscapeQueryItem
p:PartialEscapeQuery
ps) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> PartialEscapeQueryItem -> Builder
go (if Bool
qmark' then Builder
qmark else Builder
forall a. Monoid a => a
mempty) PartialEscapeQueryItem
p
    Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (PartialEscapeQueryItem -> Builder)
-> PartialEscapeQuery -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> PartialEscapeQueryItem -> Builder
go Builder
amp) PartialEscapeQuery
ps
  where
    qmark :: Builder
qmark = ByteString -> Builder
B.byteString ByteString
"?"
    amp :: Builder
amp = ByteString -> Builder
B.byteString ByteString
"&"
    equal :: Builder
equal = ByteString -> Builder
B.byteString ByteString
"="
    go :: Builder -> PartialEscapeQueryItem -> Builder
go Builder
sep (ByteString
k, [EscapeItem]
mv) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
                      Builder
sep
                     , Bool -> ByteString -> Builder
urlEncodeBuilder Bool
True ByteString
k
                     , case [EscapeItem]
mv of
                         [] -> Builder
forall a. Monoid a => a
mempty
                         [EscapeItem]
vs -> Builder
equal Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((EscapeItem -> Builder) -> [EscapeItem] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map EscapeItem -> Builder
encode [EscapeItem]
vs))
                     ]
    encode :: EscapeItem -> Builder
encode (QE ByteString
v) = Bool -> ByteString -> Builder
urlEncodeBuilder Bool
True ByteString
v
    encode (QN ByteString
v) = ByteString -> Builder
B.byteString ByteString
v