module Network.HTTP.Types.URI
(
QueryItem
, Query
, SimpleQueryItem
, SimpleQuery
, simpleQueryToQuery
, renderQuery
, renderQueryBuilder
, renderSimpleQuery
, parseQuery
, parseSimpleQuery
, renderQueryPartialEscape
, renderQueryBuilderPartialEscape
, EscapeItem(..)
, PartialEscapeQueryItem
, PartialEscapeQuery
, QueryText
, queryTextToQuery
, queryToQueryText
, renderQueryText
, parseQueryText
, encodePathSegments
, decodePathSegments
, encodePathSegmentsRelative
, extractPath
, encodePath
, decodePath
, 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 ()
type QueryItem = (B.ByteString, Maybe B.ByteString)
type Query = [QueryItem]
type QueryText = [(Text, Maybe Text)]
queryTextToQuery :: QueryText -> Query
queryTextToQuery = map $ encodeUtf8 *** fmap encodeUtf8
renderQueryText :: Bool
-> QueryText
-> B.Builder
renderQueryText b = renderQueryBuilder b . queryTextToQuery
queryToQueryText :: Query -> QueryText
queryToQueryText =
map $ go *** fmap go
where
go = decodeUtf8With lenientDecode
parseQueryText :: B.ByteString -> QueryText
parseQueryText = queryToQueryText . parseQuery
type SimpleQueryItem = (B.ByteString, B.ByteString)
type SimpleQuery = [SimpleQueryItem]
simpleQueryToQuery :: SimpleQuery -> Query
simpleQueryToQuery = map (second Just)
renderQueryBuilder :: Bool
-> Query
-> B.Builder
renderQueryBuilder _ [] = mempty
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
]
renderQuery :: Bool
-> Query -> B.ByteString
renderQuery qm = BL.toStrict . B.toLazyByteString . renderQueryBuilder qm
renderSimpleQuery :: Bool
-> SimpleQuery -> B.ByteString
renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . simpleQueryToQuery
parseQuery :: B.ByteString -> Query
parseQuery = parseQueryString' . dropQuestion
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
v'' =
case B.uncons v of
Just (_, v') -> Just $ urlDecode True v'
_ -> Nothing
in (urlDecode True k, v'')
queryStringSeparators :: B.ByteString
queryStringSeparators = B.pack [38,59]
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)
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 "-_.~:@&=+$,"
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
| ch >= 97 && ch <= 122 = True
| ch >= 48 && ch <= 57 = True
unreserved c = c `elem` extraUnreserved
h2 v = B.word8 37 `mappend` B.word8 (h a) `mappend` B.word8 (h b)
where (a, b) = v `divMod` 16
h i | i < 10 = 48 + i
| otherwise = 65 + i 10
urlEncodeBuilder
:: Bool
-> B.ByteString
-> B.Builder
urlEncodeBuilder True = urlEncodeBuilder' unreservedQS
urlEncodeBuilder False = urlEncodeBuilder' unreservedPI
urlEncode :: Bool
-> B.ByteString
-> B.ByteString
urlEncode q = BL.toStrict . B.toLazyByteString . urlEncodeBuilder q
urlDecode :: Bool
-> 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)
Just (37, ws) -> Just $ fromMaybe (37, ws) $ do
(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
| 65 <= w && w <= 70 = Just $ w 55
| 97 <= w && w <= 102 = Just $ w 87
| otherwise = Nothing
combine :: Word8 -> Word8 -> Word8
combine a b = shiftL a 4 .|. b
encodePathSegments :: [Text] -> B.Builder
encodePathSegments = foldr (\x -> mappend (B.byteString "/" `mappend` encodePathSegment x)) mempty
encodePathSegmentsRelative :: [Text] -> B.Builder
encodePathSegmentsRelative xs = mconcat $ intersperse (B.byteString "/") (map encodePathSegment xs)
encodePathSegment :: Text -> B.Builder
encodePathSegment = urlEncodeBuilder False . encodeUtf8
decodePathSegments :: B.ByteString -> [Text]
decodePathSegments "" = []
decodePathSegments "/" = []
decodePathSegments a =
go $ drop1Slash a
where
drop1Slash bs =
case B.uncons bs of
Just (47, bs') -> bs'
_ -> 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
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
encodePath :: [Text] -> Query -> B.Builder
encodePath x [] = encodePathSegments x
encodePath x y = encodePathSegments x `mappend` renderQueryBuilder True y
decodePath :: B.ByteString -> ([Text], Query)
decodePath b =
let (x, y) = B.break (== 63) b
in (decodePathSegments x, parseQuery y)
data EscapeItem = QE B.ByteString
| QN B.ByteString
deriving (Show, Eq, Ord)
type PartialEscapeQueryItem = (B.ByteString, [EscapeItem])
type PartialEscapeQuery = [PartialEscapeQueryItem]
renderQueryPartialEscape :: Bool
-> PartialEscapeQuery -> B.ByteString
renderQueryPartialEscape qm = BL.toStrict . B.toLazyByteString . renderQueryBuilderPartialEscape qm
renderQueryBuilderPartialEscape :: Bool
-> PartialEscapeQuery
-> B.Builder
renderQueryBuilderPartialEscape _ [] = mempty
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