{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE OverloadedStrings #-}

------------------------------------------------------------------------------
module Snap.Internal.Parsing where
------------------------------------------------------------------------------
import           Control.Applicative              (Alternative ((<|>)), Applicative (pure, (*>), (<*)), liftA2, (<$>))
import           Control.Arrow                    (first, second)
import           Control.Monad                    (Monad (return), MonadPlus (mzero), liftM, when)
import           Data.Attoparsec.ByteString.Char8 (IResult (Done, Fail, Partial), Parser, Result, anyChar, char, choice, decimal, endOfInput, feed, inClass, isDigit, isSpace, letter_ascii, many', match, option, parse, satisfy, skipSpace, skipWhile, string, take, takeTill, takeWhile, sepBy')
import qualified Data.Attoparsec.ByteString.Char8 as AP
import           Data.Bits                        (Bits (unsafeShiftL, (.&.), (.|.)))
import           Data.ByteString.Builder          (Builder, byteString, char8, toLazyByteString, word8)
import           Data.ByteString.Char8            (ByteString)
import qualified Data.ByteString.Char8            as S
import           Data.ByteString.Internal         (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8       as L
import           Data.CaseInsensitive             (CI)
import qualified Data.CaseInsensitive             as CI (mk)
import           Data.Char                        (Char, intToDigit, isAlpha, isAlphaNum, isAscii, isControl, isHexDigit, ord)
import           Data.Int                         (Int64)
import           Data.List                        (concat, intercalate, intersperse)
import           Data.Map                         (Map)
import qualified Data.Map                         as Map (empty, insertWith, toList)
import           Data.Maybe                       (Maybe (..), maybe)
import           Data.Monoid                      (Monoid (mconcat, mempty), (<>))
import           Data.Word                        (Word8)
import           GHC.Exts                         ( Int (I#)
                                                  , word2Int#
#if MIN_VERSION_base(4,16,0)
                                                  , uncheckedShiftRLWord8#
                                                  , word8ToWord#
#else
                                                  , uncheckedShiftRL#
#endif
                                                  )
import           GHC.Word                         (Word8 (..))
import           Prelude                          (Bool (..), Either (..), Enum (fromEnum, toEnum), Eq (..), Num (..), Ord (..), String, and, any, concatMap, elem, error, filter, flip, foldr, fst, id, map, not, otherwise, show, snd, ($), ($!), (&&), (++), (.), (||))
import           Snap.Internal.Http.Types         (Cookie (Cookie))
------------------------------------------------------------------------------


------------------------------------------------------------------------------
{-# INLINE fullyParse #-}
fullyParse :: ByteString -> Parser a -> Either String a
fullyParse :: ByteString -> Parser a -> Either String a
fullyParse = (Parser a -> ByteString -> Result a)
-> (Result a -> ByteString -> Result a)
-> ByteString
-> Parser a
-> Either String a
forall a.
(Parser a -> ByteString -> Result a)
-> (Result a -> ByteString -> Result a)
-> ByteString
-> Parser a
-> Either String a
fullyParse' Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
parse Result a -> ByteString -> Result a
forall i r. Monoid i => IResult i r -> i -> IResult i r
feed

{-# INLINE (<?>) #-}
(<?>) :: Parser a -> String -> Parser a
<?> :: Parser a -> String -> Parser a
(<?>) Parser a
a !String
b = Parser a -> String -> Parser a
forall i a. Parser i a -> String -> Parser i a
(AP.<?>) Parser a
a String
b
infix 0 <?>

------------------------------------------------------------------------------
{-# INLINE fullyParse' #-}
fullyParse' :: (Parser a -> ByteString -> Result a)
            -> (Result a -> ByteString -> Result a)
            -> ByteString
            -> Parser a
            -> Either String a
fullyParse' :: (Parser a -> ByteString -> Result a)
-> (Result a -> ByteString -> Result a)
-> ByteString
-> Parser a
-> Either String a
fullyParse' Parser a -> ByteString -> Result a
parseFunc Result a -> ByteString -> Result a
feedFunc ByteString
s Parser a
p =
    case Result a
r' of
      (Fail ByteString
_ [String]
context String
e) -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Parsing "
                                          , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
context
                                          , String
": "
                                          , String
e
                                          , String
"."
                                          ]
      (Partial ByteString -> Result a
_)  -> String -> Either String a
forall a b. a -> Either a b
Left String
"parse failed"  -- expected to be impossible
      (Done ByteString
_ a
x)   -> a -> Either String a
forall a b. b -> Either a b
Right a
x
  where
    r :: Result a
r  = Parser a -> ByteString -> Result a
parseFunc Parser a
p ByteString
s
    r' :: Result a
r' = Result a -> ByteString -> Result a
feedFunc Result a
r ByteString
""

------------------------------------------------------------------------------
-- Parsers for different tokens in an HTTP request.

------------------------------------------------------------------------------
parseNum :: Parser Int64
parseNum :: Parser Int64
parseNum = Parser Int64
forall a. Integral a => Parser a
decimal


------------------------------------------------------------------------------
untilEOL :: Parser ByteString
untilEOL :: Parser ByteString
untilEOL = (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
notend Parser ByteString -> String -> Parser ByteString
forall a. Parser a -> String -> Parser a
<?> String
"untilEOL"
  where
    notend :: Char -> Bool
notend Char
c = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'


------------------------------------------------------------------------------
crlf :: Parser ByteString
crlf :: Parser ByteString
crlf = ByteString -> Parser ByteString
string ByteString
"\r\n" Parser ByteString -> String -> Parser ByteString
forall a. Parser a -> String -> Parser a
<?> String
"crlf"


------------------------------------------------------------------------------
toTableList :: (Char -> Bool) -> [Char]
toTableList :: (Char -> Bool) -> String
toTableList Char -> Bool
f = String
l
  where
    g :: Char -> Bool
g Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char -> Bool
f Char
c
    !l1 :: String
l1 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
g (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c [Word8
0..Word8
255]
    !l0 :: String
l0 = if Char -> Bool
f Char
'-' then [Char
'-'] else []
    !l :: String
l  = String
l0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l1
{-# INLINE toTableList #-}


------------------------------------------------------------------------------
toTable :: (Char -> Bool) -> (Char -> Bool)
toTable :: (Char -> Bool) -> Char -> Bool
toTable = String -> Char -> Bool
inClass (String -> Char -> Bool)
-> ((Char -> Bool) -> String) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String
toTableList
{-# INLINE toTable #-}


------------------------------------------------------------------------------
skipFieldChars :: Parser ()
skipFieldChars :: Parser ()
skipFieldChars = (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isFieldChar


------------------------------------------------------------------------------
isFieldChar :: Char -> Bool
isFieldChar :: Char -> Bool
isFieldChar = (Char -> Bool) -> Char -> Bool
toTable Char -> Bool
f
  where
    f :: Char -> Bool
f Char
c = (Char -> Bool
isDigit Char
c) Bool -> Bool -> Bool
|| (Char -> Bool
isAlpha Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'


------------------------------------------------------------------------------
-- | Parser for request headers.
pHeaders :: Parser [(ByteString, ByteString)]
pHeaders :: Parser [(ByteString, ByteString)]
pHeaders = Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString (ByteString, ByteString)
header Parser [(ByteString, ByteString)]
-> String -> Parser [(ByteString, ByteString)]
forall a. Parser a -> String -> Parser a
<?> String
"headers"
  where
    --------------------------------------------------------------------------
    slurp :: Parser b -> Parser ByteString
slurp Parser b
p = (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, b) -> ByteString)
-> Parser ByteString (ByteString, b) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b -> Parser ByteString (ByteString, b)
forall a. Parser a -> Parser (ByteString, a)
match Parser b
p

    --------------------------------------------------------------------------
    header :: Parser ByteString (ByteString, ByteString)
header            = {-# SCC "pHeaders/header" #-}
                        (ByteString -> ByteString -> (ByteString, ByteString))
-> Parser ByteString
-> Parser ByteString
-> Parser ByteString (ByteString, ByteString)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
                            Parser ByteString
fieldName
                            (Char -> Parser Char
char Char
':' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
contents)

    --------------------------------------------------------------------------
    fieldName :: Parser ByteString
fieldName         = {-# SCC "pHeaders/fieldName" #-}
                        Parser () -> Parser ByteString
forall b. Parser b -> Parser ByteString
slurp (Parser Char
letter_ascii Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipFieldChars)

    --------------------------------------------------------------------------
    contents :: Parser ByteString
contents          = {-# SCC "pHeaders/contents" #-}
                        (ByteString -> ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ByteString -> ByteString -> ByteString
S.append
                            (Parser ByteString
untilEOL Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
crlf)
                            (Parser ByteString
continuation Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
S.empty)

    --------------------------------------------------------------------------
    isLeadingWS :: Char -> Bool
isLeadingWS Char
w     = {-# SCC "pHeaders/isLeadingWS" #-}
                        Char
w Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
w Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'

    --------------------------------------------------------------------------
    leadingWhiteSpace :: Parser ()
leadingWhiteSpace = {-# SCC "pHeaders/leadingWhiteSpace" #-}
                        (Char -> Bool) -> Parser ()
skipWhile1 Char -> Bool
isLeadingWS

    --------------------------------------------------------------------------
    continuation :: Parser ByteString
continuation      = {-# SCC "pHeaders/continuation" #-}
                        (Char -> ByteString -> ByteString)
-> Parser Char -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Char -> ByteString -> ByteString
S.cons
                               (Parser ()
leadingWhiteSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
' ')
                               Parser ByteString
contents

    --------------------------------------------------------------------------
    skipWhile1 :: (Char -> Bool) -> Parser ()
skipWhile1 Char -> Bool
f = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
f Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
f


------------------------------------------------------------------------------
-- unhelpfully, the spec mentions "old-style" cookies that don't have quotes
-- around the value. wonderful.
pWord :: Parser ByteString
pWord :: Parser ByteString
pWord = (Char -> Bool) -> Parser ByteString
pWord' Char -> Bool
isRFCText


------------------------------------------------------------------------------
pWord' :: (Char -> Bool) -> Parser ByteString
pWord' :: (Char -> Bool) -> Parser ByteString
pWord' Char -> Bool
charPred = (Char -> Bool) -> Parser ByteString
pQuotedString' Char -> Bool
charPred Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ByteString
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';'))


------------------------------------------------------------------------------
pQuotedString :: Parser ByteString
pQuotedString :: Parser ByteString
pQuotedString = (Char -> Bool) -> Parser ByteString
pQuotedString' Char -> Bool
isRFCText


------------------------------------------------------------------------------
pQuotedString' :: (Char -> Bool) -> Parser ByteString
pQuotedString' :: (Char -> Bool) -> Parser ByteString
pQuotedString' Char -> Bool
charPred = Parser Char
q Parser Char -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
quotedText Parser ByteString -> Parser Char -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
q
  where
    quotedText :: Parser ByteString
quotedText = ([ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (Builder -> [ByteString]) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Builder -> ByteString) -> Builder -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString) (Builder -> ByteString)
-> Parser ByteString Builder -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder -> Parser ByteString Builder
f Builder
forall a. Monoid a => a
mempty

    f :: Builder -> Parser ByteString Builder
f Builder
soFar = do
        ByteString
t <- (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
qdtext
        let soFar' :: Builder
soFar' = Builder
soFar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
t
        -- RFC says that backslash only escapes for <">
        [Parser ByteString Builder] -> Parser ByteString Builder
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ ByteString -> Parser ByteString
string ByteString
"\\\"" Parser ByteString
-> Parser ByteString Builder -> Parser ByteString Builder
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Parser ByteString Builder
f (Builder
soFar' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'"')
               , Builder -> Parser ByteString Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
soFar' ]

    q :: Parser Char
q      = Char -> Parser Char
char Char
'"'
    qdtext :: Char -> Bool
qdtext = [Char -> Bool] -> Char -> Bool
matchAll [ Char -> Bool
charPred, (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'), (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\') ]


------------------------------------------------------------------------------
{-# INLINE isRFCText #-}
isRFCText :: Char -> Bool
isRFCText :: Char -> Bool
isRFCText = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl


------------------------------------------------------------------------------
{-# INLINE matchAll #-}
matchAll :: [ Char -> Bool ] -> Char -> Bool
matchAll :: [Char -> Bool] -> Char -> Bool
matchAll [Char -> Bool]
x Char
c = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((Char -> Bool) -> Bool) -> [Char -> Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
c) [Char -> Bool]
x


------------------------------------------------------------------------------
pAvPairs :: Parser [(ByteString, ByteString)]
pAvPairs :: Parser [(ByteString, ByteString)]
pAvPairs = do
    (ByteString, ByteString)
a <- Parser ByteString (ByteString, ByteString)
pAvPair
    [(ByteString, ByteString)]
b <- Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
';' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser ()
-> Parser ByteString (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (ByteString, ByteString)
pAvPair)
    [(ByteString, ByteString)] -> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ByteString, ByteString)] -> Parser [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> Parser [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$! (ByteString, ByteString)
a(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
b


------------------------------------------------------------------------------
{-# INLINE pAvPair #-}
pAvPair :: Parser (ByteString, ByteString)
pAvPair :: Parser ByteString (ByteString, ByteString)
pAvPair = do
    ByteString
key <- Parser ByteString
pToken Parser ByteString -> Parser () -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    ByteString
val <- (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option ByteString
"" (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'=' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
pWord)
    (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
 -> Parser ByteString (ByteString, ByteString))
-> (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$! (ByteString
key, ByteString
val)


------------------------------------------------------------------------------
pParameter :: Parser (ByteString, ByteString)
pParameter :: Parser ByteString (ByteString, ByteString)
pParameter = (Char -> Bool) -> Parser ByteString (ByteString, ByteString)
pParameter' Char -> Bool
isRFCText


------------------------------------------------------------------------------
pParameter' :: (Char -> Bool) -> Parser (ByteString, ByteString)
pParameter' :: (Char -> Bool) -> Parser ByteString (ByteString, ByteString)
pParameter' Char -> Bool
valueCharPred = Parser ByteString (ByteString, ByteString)
parser Parser ByteString (ByteString, ByteString)
-> String -> Parser ByteString (ByteString, ByteString)
forall a. Parser a -> String -> Parser a
<?> String
"pParameter'"
  where
    parser :: Parser ByteString (ByteString, ByteString)
parser = do
        ByteString
key <- Parser ByteString
pToken Parser ByteString -> Parser () -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
        ByteString
val <- (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Char -> Parser Char
char Char
'=' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
pWord' Char -> Bool
valueCharPred)
        (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
 -> Parser ByteString (ByteString, ByteString))
-> (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$! (ByteString -> ByteString
trim ByteString
key, ByteString
val)


------------------------------------------------------------------------------
{-# INLINE trim #-}
trim :: ByteString -> ByteString
trim :: ByteString -> ByteString
trim = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.span Char -> Bool
isSpace (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd Char -> Bool
isSpace


------------------------------------------------------------------------------
pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters =  (Char -> Bool)
-> Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters' Char -> Bool
isRFCText


------------------------------------------------------------------------------
pValueWithParameters' :: (Char -> Bool) -> Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters' :: (Char -> Bool)
-> Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters' Char -> Bool
valueCharPred = Parser (ByteString, [(CI ByteString, ByteString)])
parser Parser (ByteString, [(CI ByteString, ByteString)])
-> String -> Parser (ByteString, [(CI ByteString, ByteString)])
forall a. Parser a -> String -> Parser a
<?> String
"pValueWithParameters'"
  where
    parser :: Parser (ByteString, [(CI ByteString, ByteString)])
parser = do
        ByteString
value  <- (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';'))
        [(ByteString, ByteString)]
params <- Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString (ByteString, ByteString)
pParam
        Parser ()
forall t. Chunk t => Parser t ()
endOfInput
        (ByteString, [(CI ByteString, ByteString)])
-> Parser (ByteString, [(CI ByteString, ByteString)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
value, ((ByteString, ByteString) -> (CI ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString)
-> (ByteString, ByteString) -> (CI ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk) [(ByteString, ByteString)]
params)
    pParam :: Parser ByteString (ByteString, ByteString)
pParam = Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
';' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser ()
-> Parser ByteString (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString (ByteString, ByteString)
pParameter' Char -> Bool
valueCharPred


------------------------------------------------------------------------------
pContentTypeWithParameters :: Parser ( ByteString
                                     , [(CI ByteString, ByteString)] )
pContentTypeWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])
pContentTypeWithParameters = Parser (ByteString, [(CI ByteString, ByteString)])
parser Parser (ByteString, [(CI ByteString, ByteString)])
-> String -> Parser (ByteString, [(CI ByteString, ByteString)])
forall a. Parser a -> String -> Parser a
<?> String
"pContentTypeWithParameters"
  where
    parser :: Parser (ByteString, [(CI ByteString, ByteString)])
parser = do
        ByteString
value  <- (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSep))
        [(ByteString, ByteString)]
params <- Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isSep Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser ()
-> Parser ByteString (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (ByteString, ByteString)
pParameter)
        Parser ()
forall t. Chunk t => Parser t ()
endOfInput
        (ByteString, [(CI ByteString, ByteString)])
-> Parser (ByteString, [(CI ByteString, ByteString)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, [(CI ByteString, ByteString)])
 -> Parser (ByteString, [(CI ByteString, ByteString)]))
-> (ByteString, [(CI ByteString, ByteString)])
-> Parser (ByteString, [(CI ByteString, ByteString)])
forall a b. (a -> b) -> a -> b
$! (ByteString
value, ((ByteString, ByteString) -> (CI ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString)
-> (ByteString, ByteString) -> (CI ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk) [(ByteString, ByteString)]
params)

    isSep :: Char -> Bool
isSep Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
','


------------------------------------------------------------------------------
{-# INLINE pToken #-}
pToken :: Parser ByteString
pToken :: Parser ByteString
pToken = (Char -> Bool) -> Parser ByteString
takeWhile Char -> Bool
isToken


------------------------------------------------------------------------------
{-# INLINE isToken #-}
isToken :: Char -> Bool
isToken :: Char -> Bool
isToken = (Char -> Bool) -> Char -> Bool
toTable Char -> Bool
f
  where
    f :: Char -> Bool
f = [Char -> Bool] -> Char -> Bool
matchAll [ Char -> Bool
isAscii
                 , Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl
                 , Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
                 , Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [ Char
'(', Char
')', Char
'<', Char
'>', Char
'@', Char
',', Char
';'
                                   , Char
':', Char
'\\', Char
'\"', Char
'/', Char
'[', Char
']'
                                   , Char
'?', Char
'=', Char
'{', Char
'}' ]
                 ]


------------------------------------------------------------------------------
{-# INLINE pTokens #-}
-- | Used for "#field-name", and field-name = token, so "#token":
-- comma-separated tokens/field-names, like a header field list.
pTokens :: Parser [ByteString]
pTokens :: Parser [ByteString]
pTokens = (Parser ()
skipSpace Parser () -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
pToken Parser ByteString -> Parser () -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace) Parser ByteString -> Parser Char -> Parser [ByteString]
forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
`sepBy'` Char -> Parser Char
char Char
','


                              ------------------
                              -- Url encoding --
                              ------------------

------------------------------------------------------------------------------
{-# INLINE parseToCompletion #-}
parseToCompletion :: Parser a -> ByteString -> Maybe a
parseToCompletion :: Parser a -> ByteString -> Maybe a
parseToCompletion Parser a
p ByteString
s = IResult ByteString a -> Maybe a
forall i a. IResult i a -> Maybe a
toResult (IResult ByteString a -> Maybe a)
-> IResult ByteString a -> Maybe a
forall a b. (a -> b) -> a -> b
$ IResult ByteString a -> IResult ByteString a
forall a. Result a -> Result a
finish IResult ByteString a
r
  where
    r :: IResult ByteString a
r = Parser a -> ByteString -> IResult ByteString a
forall a. Parser a -> ByteString -> Result a
parse Parser a
p ByteString
s

    toResult :: IResult i a -> Maybe a
toResult (Done i
_ a
c) = a -> Maybe a
forall a. a -> Maybe a
Just a
c
    toResult IResult i a
_          = Maybe a
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
type DList a = [a] -> [a]

pUrlEscaped :: Parser ByteString
pUrlEscaped :: Parser ByteString
pUrlEscaped = do
    DList ByteString
sq <- DList ByteString -> Parser (DList ByteString)
nextChunk DList ByteString
forall a. a -> a
id
    ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Parser ByteString)
-> ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ DList ByteString
sq []

  where
    --------------------------------------------------------------------------
    nextChunk :: DList ByteString -> Parser (DList ByteString)
    nextChunk :: DList ByteString -> Parser (DList ByteString)
nextChunk !DList ByteString
s = (Parser ()
forall t. Chunk t => Parser t ()
endOfInput Parser () -> Parser (DList ByteString) -> Parser (DList ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> DList ByteString -> Parser (DList ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DList ByteString
s) Parser (DList ByteString)
-> Parser (DList ByteString) -> Parser (DList ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
        Char
c <- Parser Char
anyChar
        case Char
c of
          Char
'+' -> DList ByteString -> Parser (DList ByteString)
plusSpace DList ByteString
s
          Char
'%' -> DList ByteString -> Parser (DList ByteString)
percentEncoded DList ByteString
s
          Char
_   -> Char -> DList ByteString -> Parser (DList ByteString)
unEncoded Char
c DList ByteString
s

    --------------------------------------------------------------------------
    percentEncoded :: DList ByteString -> Parser (DList ByteString)
    percentEncoded :: DList ByteString -> Parser (DList ByteString)
percentEncoded !DList ByteString
l = do
        ByteString
hx <- Int -> Parser ByteString
take Int
2
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
hx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
2 Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> Bool
S.all Char -> Bool
isHexDigit ByteString
hx)) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
             Parser ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero

        let code :: Char
code = Word8 -> Char
w2c ((ByteString -> Word8
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromHex ByteString
hx) :: Word8)
        DList ByteString -> Parser (DList ByteString)
nextChunk (DList ByteString -> Parser (DList ByteString))
-> DList ByteString -> Parser (DList ByteString)
forall a b. (a -> b) -> a -> b
$ DList ByteString
l DList ByteString -> DList ByteString -> DList ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
code) ByteString -> DList ByteString
forall a. a -> [a] -> [a]
:)

    --------------------------------------------------------------------------
    unEncoded :: Char -> DList ByteString -> Parser (DList ByteString)
    unEncoded :: Char -> DList ByteString -> Parser (DList ByteString)
unEncoded !Char
c !DList ByteString
l' = do
        let l :: DList ByteString
l = DList ByteString
l' DList ByteString -> DList ByteString -> DList ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
c) ByteString -> DList ByteString
forall a. a -> [a] -> [a]
:)
        ByteString
bs   <- (Char -> Bool) -> Parser ByteString
takeTill ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'%', Char
'+'])
        if ByteString -> Bool
S.null ByteString
bs
          then DList ByteString -> Parser (DList ByteString)
nextChunk DList ByteString
l
          else DList ByteString -> Parser (DList ByteString)
nextChunk (DList ByteString -> Parser (DList ByteString))
-> DList ByteString -> Parser (DList ByteString)
forall a b. (a -> b) -> a -> b
$ DList ByteString
l DList ByteString -> DList ByteString -> DList ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> DList ByteString
forall a. a -> [a] -> [a]
:)

    --------------------------------------------------------------------------
    plusSpace :: DList ByteString -> Parser (DList ByteString)
    plusSpace :: DList ByteString -> Parser (DList ByteString)
plusSpace DList ByteString
l = DList ByteString -> Parser (DList ByteString)
nextChunk (DList ByteString
l DList ByteString -> DList ByteString -> DList ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
' ') ByteString -> DList ByteString
forall a. a -> [a] -> [a]
:))


------------------------------------------------------------------------------
-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"
-- [not including the quotes - ed], and reserved characters used for their
-- reserved purposes may be used unencoded within a URL."




------------------------------------------------------------------------------
-- | Decode an URL-escaped string (see
-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)
--
-- Example:
--
-- @
-- ghci> 'urlDecode' "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"
-- Just "1 attoparsec ~= 3 * 10^-2 meters"
-- @
urlDecode :: ByteString -> Maybe ByteString
urlDecode :: ByteString -> Maybe ByteString
urlDecode = Parser ByteString -> ByteString -> Maybe ByteString
forall a. Parser a -> ByteString -> Maybe a
parseToCompletion Parser ByteString
pUrlEscaped
{-# INLINE urlDecode #-}


------------------------------------------------------------------------------
-- | URL-escape a string (see
-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)
--
-- Example:
--
-- @
-- ghci> 'urlEncode' "1 attoparsec ~= 3 * 10^-2 meters"
-- "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"
-- @
urlEncode :: ByteString -> ByteString
urlEncode :: ByteString -> ByteString
urlEncode = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
urlEncodeBuilder
{-# INLINE urlEncode #-}


------------------------------------------------------------------------------
-- | URL-escape a string (see
-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.
--
-- Example:
--
-- @
-- ghci> import "Data.ByteString.Builder"
-- ghci> 'toLazyByteString' . 'urlEncodeBuilder' $ "1 attoparsec ~= 3 * 10^-2 meters"
-- "1+attoparsec+%7e%3d+3+*+10%5e-2+meters"
-- @
urlEncodeBuilder :: ByteString -> Builder
urlEncodeBuilder :: ByteString -> Builder
urlEncodeBuilder = Builder -> ByteString -> Builder
go Builder
forall a. Monoid a => a
mempty
  where
    go :: Builder -> ByteString -> Builder
go !Builder
b !ByteString
s = Builder
-> ((Char, ByteString) -> Builder)
-> Maybe (Char, ByteString)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
b' (Char, ByteString) -> Builder
esc (ByteString -> Maybe (Char, ByteString)
S.uncons ByteString
y)
      where
        (ByteString
x,ByteString
y)     = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.span Char -> Bool
urlEncodeClean ByteString
s
        b' :: Builder
b'        = Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
x
        esc :: (Char, ByteString) -> Builder
esc (Char
c,ByteString
r) = let b'' :: Builder
b'' = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
                                then Builder
b' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'+'
                                else Builder
b' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
hexd Char
c
                    in Builder -> ByteString -> Builder
go Builder
b'' ByteString
r


------------------------------------------------------------------------------
urlEncodeClean :: Char -> Bool
urlEncodeClean :: Char -> Bool
urlEncodeClean = (Char -> Bool) -> Char -> Bool
toTable Char -> Bool
f
  where
    f :: Char -> Bool
f Char
c = ((Char -> Bool) -> Bool) -> [Char -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
c) [\Char
c' -> Char -> Bool
isAscii Char
c' Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c'
                    , (Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [ Char
'$', Char
'_', Char
'-', Char
'.', Char
'!'
                                , Char
'*' , Char
'\'', Char
'(', Char
')', Char
',' ]]


------------------------------------------------------------------------------
hexd :: Char -> Builder
hexd :: Char -> Builder
hexd Char
c0 = Char -> Builder
char8 Char
'%' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 Word8
hi Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 Word8
low
  where
    !c :: Word8
c        = Char -> Word8
c2w Char
c0
    toDigit :: Int -> Word8
toDigit   = Char -> Word8
c2w (Char -> Word8) -> (Int -> Char) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit
    !low :: Word8
low      = Int -> Word8
toDigit (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf
    !hi :: Word8
hi       = Int -> Word8
toDigit (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Int
`shiftr` Int
4

    shiftr :: Word8 -> Int -> Int
shiftr (W8# Word#
a#) (I# Int#
b#) = Int# -> Int
I# (Word# -> Int#
word2Int# (Word# -> Int# -> Word#
uncheckedShiftRL# Word#
a# Int#
b#))
#if MIN_VERSION_base(4,16,0)
    uncheckedShiftRL# a# b# = word8ToWord# (uncheckedShiftRLWord8# a# b#)
#endif


------------------------------------------------------------------------------
finish :: Result a -> Result a
finish :: Result a -> Result a
finish (Partial ByteString -> Result a
f) = (Result a -> ByteString -> Result a)
-> ByteString -> Result a -> Result a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Result a -> ByteString -> Result a
forall i r. Monoid i => IResult i r -> i -> IResult i r
feed ByteString
"" (Result a -> Result a) -> Result a -> Result a
forall a b. (a -> b) -> a -> b
$ ByteString -> Result a
f ByteString
""
finish Result a
x           = Result a
x


                    ---------------------------------------
                    -- application/x-www-form-urlencoded --
                    ---------------------------------------

------------------------------------------------------------------------------
-- | Parse a string encoded in @application/x-www-form-urlencoded@ < http://en.wikipedia.org/wiki/POST_%28HTTP%29#Use_for_submitting_web_forms format>.
--
-- Example:
--
-- @
-- ghci> 'parseUrlEncoded' "Name=John+Doe&Name=Jane+Doe&Age=23&Formula=a+%2B+b+%3D%3D+13%25%21"
-- 'Data.Map.fromList' [("Age",["23"]),("Formula",["a + b == 13%!"]),("Name",["John Doe","Jane Doe"])]
-- @
parseUrlEncoded :: ByteString -> Map ByteString [ByteString]
parseUrlEncoded :: ByteString -> Map ByteString [ByteString]
parseUrlEncoded ByteString
s = ((ByteString, ByteString)
 -> Map ByteString [ByteString] -> Map ByteString [ByteString])
-> Map ByteString [ByteString]
-> [(ByteString, ByteString)]
-> Map ByteString [ByteString]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ByteString, ByteString)
-> Map ByteString [ByteString] -> Map ByteString [ByteString]
forall k a. Ord k => (k, a) -> Map k [a] -> Map k [a]
ins Map ByteString [ByteString]
forall k a. Map k a
Map.empty [(ByteString, ByteString)]
decoded

  where
    --------------------------------------------------------------------------
    ins :: (k, a) -> Map k [a] -> Map k [a]
ins (!k
k,a
v) !Map k [a]
m = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) k
k [a
v] Map k [a]
m

    --------------------------------------------------------------------------
    parts :: [(ByteString,ByteString)]
    parts :: [(ByteString, ByteString)]
parts = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, ByteString)
breakApart ([ByteString] -> [(ByteString, ByteString)])
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
            (Char -> Bool) -> ByteString -> [ByteString]
S.splitWith (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'&' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') ByteString
s

    --------------------------------------------------------------------------
    breakApart :: ByteString -> (ByteString, ByteString)
breakApart = ((ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
S.drop Int
1)) ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')

    --------------------------------------------------------------------------
    urldecode :: ByteString -> Maybe ByteString
urldecode = Parser ByteString -> ByteString -> Maybe ByteString
forall a. Parser a -> ByteString -> Maybe a
parseToCompletion Parser ByteString
pUrlEscaped

    --------------------------------------------------------------------------
    decodeOne :: (ByteString, ByteString) -> Maybe (ByteString, ByteString)
decodeOne (ByteString
a,ByteString
b) = do
        !ByteString
a' <- ByteString -> Maybe ByteString
urldecode ByteString
a
        !ByteString
b' <- ByteString -> Maybe ByteString
urldecode ByteString
b
        (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$! (ByteString
a',ByteString
b')

    --------------------------------------------------------------------------
    decoded :: [(ByteString, ByteString)]
decoded = ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall c.
([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id [(ByteString, ByteString)]
parts
      where
        go :: ([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go ![(ByteString, ByteString)] -> c
dl []     = [(ByteString, ByteString)] -> c
dl []
        go ![(ByteString, ByteString)] -> c
dl ((ByteString, ByteString)
x:[(ByteString, ByteString)]
xs) = c
-> ((ByteString, ByteString) -> c)
-> Maybe (ByteString, ByteString)
-> c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go [(ByteString, ByteString)] -> c
dl [(ByteString, ByteString)]
xs)
                              (\(ByteString, ByteString)
p -> ([(ByteString, ByteString)] -> c)
-> [(ByteString, ByteString)] -> c
go ([(ByteString, ByteString)] -> c
dl ([(ByteString, ByteString)] -> c)
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
p(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:)) [(ByteString, ByteString)]
xs)
                              ((ByteString, ByteString) -> Maybe (ByteString, ByteString)
decodeOne (ByteString, ByteString)
x)


------------------------------------------------------------------------------
-- | Like 'printUrlEncoded', but produces a 'Builder' instead of a
-- 'ByteString'. Useful for constructing a large string efficiently in
-- a single step.
--
-- Example:
--
-- @
-- ghci> import "Data.Map"
-- ghci> import "Data.Monoid"
-- ghci> import "Data.ByteString.Builder"
-- ghci> let bldr = 'buildUrlEncoded' ('Data.Map.fromList' [("Name", ["John Doe"]), ("Age", ["23"])])
-- ghci> 'toLazyByteString' $ 'byteString' "http://example.com/script?" <> bldr
-- "http://example.com/script?Age=23&Name=John+Doe"
-- @
buildUrlEncoded :: Map ByteString [ByteString] -> Builder
buildUrlEncoded :: Map ByteString [ByteString] -> Builder
buildUrlEncoded Map ByteString [ByteString]
m = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
builders
  where
    builders :: [Builder]
builders        = Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
char8 Char
'&') ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
                      ((ByteString, [ByteString]) -> [Builder])
-> [(ByteString, [ByteString])] -> [Builder]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ByteString, [ByteString]) -> [Builder]
encodeVS ([(ByteString, [ByteString])] -> [Builder])
-> [(ByteString, [ByteString])] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Map ByteString [ByteString] -> [(ByteString, [ByteString])]
forall k a. Map k a -> [(k, a)]
Map.toList Map ByteString [ByteString]
m

    encodeVS :: (ByteString, [ByteString]) -> [Builder]
encodeVS (ByteString
k,[ByteString]
vs) = (ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> Builder
encodeOne ByteString
k) [ByteString]
vs

    encodeOne :: ByteString -> ByteString -> Builder
encodeOne ByteString
k ByteString
v   = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
urlEncodeBuilder ByteString
k
                              , Char -> Builder
char8 Char
'='
                              , ByteString -> Builder
urlEncodeBuilder ByteString
v ]


------------------------------------------------------------------------------
-- | Given a collection of key-value pairs with possibly duplicate
-- keys (represented as a 'Data.Map.Map'), construct a string in
-- @application/x-www-form-urlencoded@ format.
--
-- Example:
--
-- @
-- ghci> 'printUrlEncoded' ('Data.Map.fromList' [("Name", ["John Doe"]), ("Age", ["23"])])
-- "Age=23&Name=John+Doe"
-- @
printUrlEncoded :: Map ByteString [ByteString] -> ByteString
printUrlEncoded :: Map ByteString [ByteString] -> ByteString
printUrlEncoded = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (Map ByteString [ByteString] -> [ByteString])
-> Map ByteString [ByteString]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Map ByteString [ByteString] -> ByteString)
-> Map ByteString [ByteString]
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (Map ByteString [ByteString] -> Builder)
-> Map ByteString [ByteString]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString [ByteString] -> Builder
buildUrlEncoded


                             --------------------
                             -- Cookie parsing --
                             --------------------

------------------------------------------------------------------------------
-- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109
-- (cookie spec): please point out any errors!
------------------------------------------------------------------------------
pCookies :: Parser [Cookie]
pCookies :: Parser [Cookie]
pCookies = do
    -- grab kvps and turn to strict bytestrings
    [(ByteString, ByteString)]
kvps <- Parser [(ByteString, ByteString)]
pAvPairs
    [Cookie] -> Parser [Cookie]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Cookie] -> Parser [Cookie]) -> [Cookie] -> Parser [Cookie]
forall a b. (a -> b) -> a -> b
$! ((ByteString, ByteString) -> Cookie)
-> [(ByteString, ByteString)] -> [Cookie]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> Cookie
toCookie ([(ByteString, ByteString)] -> [Cookie])
-> [(ByteString, ByteString)] -> [Cookie]
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((ByteString, ByteString) -> Bool)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
S.isPrefixOf ByteString
"$" (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
kvps

  where
    toCookie :: (ByteString, ByteString) -> Cookie
toCookie (ByteString
nm,ByteString
val) = ByteString
-> ByteString
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Bool
-> Bool
-> Cookie
Cookie ByteString
nm ByteString
val Maybe UTCTime
forall a. Maybe a
Nothing Maybe ByteString
forall a. Maybe a
Nothing Maybe ByteString
forall a. Maybe a
Nothing Bool
False Bool
False


------------------------------------------------------------------------------
parseCookie :: ByteString -> Maybe [Cookie]
parseCookie :: ByteString -> Maybe [Cookie]
parseCookie = Parser [Cookie] -> ByteString -> Maybe [Cookie]
forall a. Parser a -> ByteString -> Maybe a
parseToCompletion Parser [Cookie]
pCookies


                            -----------------------
                            -- utility functions --
                            -----------------------

------------------------------------------------------------------------------
unsafeFromHex :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromHex :: ByteString -> a
unsafeFromHex = (a -> Char -> a) -> a -> ByteString -> a
forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' a -> Char -> a
f a
0
  where
#if MIN_VERSION_base(4,5,0)
    sl :: a -> Int -> a
sl = a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL
#else
    sl = shiftL
#endif

    f :: a -> Char -> a
f !a
cnt !Char
i = a -> Int -> a
sl a
cnt Int
4 a -> a -> a
forall a. Bits a => a -> a -> a
.|. Char -> a
forall p. Enum p => Char -> p
nybble Char
i

    nybble :: Char -> p
nybble Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Int -> p
forall a. Enum a => Int -> a
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$! Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0'
             | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int -> p
forall a. Enum a => Int -> a
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$! Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a'
             | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' = Int -> p
forall a. Enum a => Int -> a
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$! Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A'
             | Bool
otherwise            = String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"bad hex digit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c
{-# INLINE unsafeFromHex #-}


------------------------------------------------------------------------------
-- Note: only works for nonnegative naturals
unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat :: ByteString -> a
unsafeFromNat = (a -> Char -> a) -> a -> ByteString -> a
forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' a -> Char -> a
forall a. (Num a, Enum a) => a -> Char -> a
f a
0
  where
    zero :: Int
zero = Char -> Int
ord Char
'0'
    f :: a -> Char -> a
f !a
cnt !Char
i = a
cnt a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a. Enum a => Int -> a
toEnum (Char -> Int
digitToInt Char
i)

    digitToInt :: Char -> Int
digitToInt Char
c = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9
                     then Int
d
                     else String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"bad digit: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
      where
        !d :: Int
d = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
zero
{-# INLINE unsafeFromNat #-}