{-# 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 :: forall a. ByteString -> Parser a -> Either String a
fullyParse = forall a.
(Parser a -> ByteString -> Result a)
-> (Result a -> ByteString -> Result a)
-> ByteString
-> Parser a
-> Either String a
fullyParse' forall a. Parser a -> ByteString -> Result a
parse forall i r. Monoid i => IResult i r -> i -> IResult i r
feed

{-# INLINE (<?>) #-}
(<?>) :: Parser a -> String -> Parser a
<?> :: forall a. Parser a -> String -> Parser a
(<?>) Parser a
a !String
b = 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' :: forall a.
(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) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Parsing "
                                          , forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
context
                                          , String
": "
                                          , String
e
                                          , String
"."
                                          ]
      (Partial ByteString -> Result a
_)  -> forall a b. a -> Either a b
Left String
"parse failed"  -- expected to be impossible
      (Done ByteString
_ a
x)   -> 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 = forall a. Integral a => Parser a
decimal


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


------------------------------------------------------------------------------
crlf :: Parser ByteString
crlf :: Parser ByteString
crlf = ByteString -> Parser ByteString
string ByteString
"\r\n" 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 forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char -> Bool
f Char
c
    !l1 :: String
l1 = forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
g forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ String
l1
{-# INLINE toTableList #-}


------------------------------------------------------------------------------
toTable :: (Char -> Bool) -> (Char -> Bool)
toTable :: (Char -> Bool) -> Char -> Bool
toTable = String -> Char -> Bool
inClass 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 forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'


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

    --------------------------------------------------------------------------
    header :: Parser ByteString (ByteString, ByteString)
header            = {-# SCC "pHeaders/header" #-}
                        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
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
contents)

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

    --------------------------------------------------------------------------
    contents :: Parser ByteString
contents          = {-# SCC "pHeaders/contents" #-}
                        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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
crlf)
                            (Parser ByteString
continuation forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
S.empty)

    --------------------------------------------------------------------------
    isLeadingWS :: Char -> Bool
isLeadingWS Char
w     = {-# SCC "pHeaders/isLeadingWS" #-}
                        Char
w forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
w 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" #-}
                        forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Char -> ByteString -> ByteString
S.cons
                               (Parser ()
leadingWhiteSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ByteString
takeWhile (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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
quotedText forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
q
  where
    quotedText :: Parser ByteString
quotedText = ([ByteString] -> ByteString
S.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder -> Parser ByteString Builder
f 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 forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
t
        -- RFC says that backslash only escapes for <">
        forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ ByteString -> Parser ByteString
string ByteString
"\\\"" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Parser ByteString Builder
f (Builder
soFar' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'"')
               , 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, (forall a. Eq a => a -> a -> Bool
/= Char
'"'), (forall a. Eq a => a -> a -> Bool
/= Char
'\\') ]


------------------------------------------------------------------------------
{-# INLINE isRFCText #-}
isRFCText :: Char -> Bool
isRFCText :: Char -> Bool
isRFCText = Bool -> Bool
not 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (ByteString, ByteString)
pAvPair)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString, ByteString)
aforall 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    ByteString
val <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option ByteString
"" forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
pWord)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Parser a -> String -> Parser a
<?> String
"pParameter'"
  where
    parser :: Parser ByteString (ByteString, ByteString)
parser = do
        ByteString
key <- Parser ByteString
pToken forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
        ByteString
val <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Char -> Parser Char
char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
pWord' Char -> Bool
valueCharPred)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString -> ByteString
trim ByteString
key, ByteString
val)


------------------------------------------------------------------------------
{-# INLINE trim #-}
trim :: ByteString -> ByteString
trim :: ByteString -> ByteString
trim = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.span Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst 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 forall a. Parser a -> String -> Parser a
<?> String
"pValueWithParameters'"
  where
    parser :: Parser (ByteString, [(CI ByteString, ByteString)])
parser = do
        ByteString
value  <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';'))
        [(ByteString, ByteString)]
params <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString (ByteString, ByteString)
pParam
        forall t. Chunk t => Parser t ()
endOfInput
        forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
value, forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall s. FoldCase s => s -> CI s
CI.mk) [(ByteString, ByteString)]
params)
    pParam :: Parser ByteString (ByteString, ByteString)
pParam = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace 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 forall a. Parser a -> String -> Parser a
<?> String
"pContentTypeWithParameters"
  where
    parser :: Parser (ByteString, [(CI ByteString, ByteString)])
parser = do
        ByteString
value  <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> ByteString
trim (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSep))
        [(ByteString, ByteString)]
params <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isSep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (ByteString, ByteString)
pParameter)
        forall t. Chunk t => Parser t ()
endOfInput
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString
value, forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall s. FoldCase s => s -> CI s
CI.mk) [(ByteString, ByteString)]
params)

    isSep :: Char -> Bool
isSep Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
';' Bool -> Bool -> Bool
|| Char
c 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl
                 , Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
                 , Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
pToken forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace) 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 :: forall a. Parser a -> ByteString -> Maybe a
parseToCompletion Parser a
p ByteString
s = forall {i} {a}. IResult i a -> Maybe a
toResult forall a b. (a -> b) -> a -> b
$ forall a. Result a -> Result a
finish Result a
r
  where
    r :: Result a
r = forall a. Parser a -> ByteString -> Result a
parse Parser a
p ByteString
s

    toResult :: IResult i a -> Maybe a
toResult (Done i
_ a
c) = forall a. a -> Maybe a
Just a
c
    toResult IResult i 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 forall a. a -> a
id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat 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 = (forall t. Chunk t => Parser t ()
endOfInput forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DList ByteString
s) 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
hx forall a. Eq a => a -> a -> Bool
/= Int
2 Bool -> Bool -> Bool
|| (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> Bool
S.all Char -> Bool
isHexDigit ByteString
hx)) forall a b. (a -> b) -> a -> b
$
             forall (m :: * -> *) a. MonadPlus m => m a
mzero

        let code :: Char
code = Word8 -> Char
w2c ((forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromHex ByteString
hx) :: Word8)
        DList ByteString -> Parser (DList ByteString)
nextChunk forall a b. (a -> b) -> a -> b
$ DList ByteString
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
code) 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' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
c) forall a. a -> [a] -> [a]
:)
        ByteString
bs   <- (Char -> Bool) -> Parser ByteString
takeTill (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a b. (a -> b) -> a -> b
$ DList ByteString
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> ByteString
S.singleton Char
' ') 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString 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 forall a. Monoid a => a
mempty
  where
    go :: Builder -> ByteString -> Builder
go !Builder
b !ByteString
s = 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 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 forall a. Eq a => a -> a -> Bool
== Char
' '
                                then Builder
b' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'+'
                                else Builder
b' 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ Char
c) [\Char
c' -> Char -> Bool
isAscii Char
c' Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c'
                    , forall a b c. (a -> b -> c) -> b -> a -> c
flip 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
'%' forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8 Word8
hi 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit
    !low :: Word8
low      = Int -> Word8
toDigit forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf
    !hi :: Word8
hi       = Int -> Word8
toDigit forall a b. (a -> b) -> a -> b
$ (Word8
c forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Int
`shiftr` Int
4

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


------------------------------------------------------------------------------
finish :: Result a -> Result a
finish :: forall a. Result a -> Result a
finish (Partial ByteString -> IResult ByteString a
f) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall i r. Monoid i => IResult i r -> i -> IResult i r
feed ByteString
"" forall a b. (a -> b) -> a -> b
$ ByteString -> IResult ByteString a
f ByteString
""
finish IResult ByteString a
x           = IResult ByteString 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k} {a}. Ord k => (k, a) -> Map k [a] -> Map k [a]
ins 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 = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. [a] -> [a] -> [a]
(++) k
k [a
v] Map k [a]
m

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

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

    --------------------------------------------------------------------------
    urldecode :: ByteString -> Maybe ByteString
urldecode = 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (ByteString
a',ByteString
b')

    --------------------------------------------------------------------------
    decoded :: [(ByteString, ByteString)]
decoded = forall {t}.
([(ByteString, ByteString)] -> t)
-> [(ByteString, ByteString)] -> t
go forall a. a -> a
id [(ByteString, ByteString)]
parts
      where
        go :: ([(ByteString, ByteString)] -> t)
-> [(ByteString, ByteString)] -> t
go ![(ByteString, ByteString)] -> t
dl []     = [(ByteString, ByteString)] -> t
dl []
        go ![(ByteString, ByteString)] -> t
dl ((ByteString, ByteString)
x:[(ByteString, ByteString)]
xs) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([(ByteString, ByteString)] -> t)
-> [(ByteString, ByteString)] -> t
go [(ByteString, ByteString)] -> t
dl [(ByteString, ByteString)]
xs)
                              (\(ByteString, ByteString)
p -> ([(ByteString, ByteString)] -> t)
-> [(ByteString, ByteString)] -> t
go ([(ByteString, ByteString)] -> t
dl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
pforall 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 = forall a. Monoid a => [a] -> a
mconcat [Builder]
builders
  where
    builders :: [Builder]
builders        = forall a. a -> [a] -> [a]
intersperse (Char -> Builder
char8 Char
'&') forall a b. (a -> b) -> a -> b
$
                      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ByteString, [ByteString]) -> [Builder]
encodeVS forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map ByteString [ByteString]
m

    encodeVS :: (ByteString, [ByteString]) -> [Builder]
encodeVS (ByteString
k,[ByteString]
vs) = 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   = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> Cookie
toCookie forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
S.isPrefixOf ByteString
"$" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing Bool
False Bool
False


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


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

------------------------------------------------------------------------------
unsafeFromHex :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromHex :: forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromHex = 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 = 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 forall a. Bits a => a -> a -> a
.|. forall {b}. Enum b => Char -> b
nybble Char
i

    nybble :: Char -> b
nybble Char
c | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$! forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'0'
             | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'f' = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$! Int
10 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'a'
             | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'F' = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$! Int
10 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'A'
             | Bool
otherwise            = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"bad hex digit: " forall a. [a] -> [a] -> [a]
++ 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 :: forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat = forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' 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 forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a. Enum a => Int -> a
toEnum (Char -> Int
digitToInt Char
i)

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