module PercentEncoding.Parsers where

import qualified Control.Exception as Exception
import qualified Data.ByteString as ByteString
import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Text.Encoding.Error as Text.Encoding
import qualified PercentEncoding.MonadPlus as MonadPlus
import Platform.Prelude hiding (try)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified TextBuilder as TextBuilder

type Parser = Parsec Void Text

{-# INLINEABLE urlEncodedComponentText #-}
urlEncodedComponentText :: (Char -> Bool) -> Parser Text
urlEncodedComponentText :: (Char -> Bool) -> Parser Text
urlEncodedComponentText Char -> Bool
stopCharPredicate =
  String -> Parser Text -> Parser Text
forall a. String -> Parser a -> Parser a
labeled String
"URL-encoded component"
    (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ (TextBuilder -> Text)
-> ParsecT Void Text Identity TextBuilder -> Parser Text
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextBuilder -> Text
TextBuilder.toText
    (ParsecT Void Text Identity TextBuilder -> Parser Text)
-> ParsecT Void Text Identity TextBuilder -> Parser Text
forall a b. (a -> b) -> a -> b
$ (TextBuilder -> TextBuilder -> TextBuilder)
-> ParsecT Void Text Identity TextBuilder
-> ParsecT Void Text Identity TextBuilder
forall (m :: * -> *) a. MonadPlus m => (a -> a -> a) -> m a -> m a
MonadPlus.scanl1 TextBuilder -> TextBuilder -> TextBuilder
forall a. Monoid a => a -> a -> a
mappend
    (ParsecT Void Text Identity TextBuilder
 -> ParsecT Void Text Identity TextBuilder)
-> ParsecT Void Text Identity TextBuilder
-> ParsecT Void Text Identity TextBuilder
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity TextBuilder
parser
  where
    parser :: ParsecT Void Text Identity TextBuilder
parser =
      [ParsecT Void Text Identity TextBuilder]
-> ParsecT Void Text Identity TextBuilder
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Text -> TextBuilder
TextBuilder.text (Text -> TextBuilder)
-> Parser Text -> ParsecT Void Text Identity TextBuilder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"Unencoded char") Char -> Bool
Token Text -> Bool
unencodedCharPredicate),
          ParsecT Void Text Identity TextBuilder
urlEncodedSequenceTextBuilder
        ]
      where
        unencodedCharPredicate :: Char -> Bool
unencodedCharPredicate Char
c =
          Bool -> Bool
not (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' Bool -> Bool -> Bool
|| Char -> Bool
stopCharPredicate Char
c)

{-# INLINEABLE urlEncodedSequenceTextBuilder #-}
urlEncodedSequenceTextBuilder :: Parser TextBuilder.TextBuilder
urlEncodedSequenceTextBuilder :: ParsecT Void Text Identity TextBuilder
urlEncodedSequenceTextBuilder =
  String
-> ParsecT Void Text Identity TextBuilder
-> ParsecT Void Text Identity TextBuilder
forall a. String -> Parser a -> Parser a
labeled String
"URL-encoded sequence" (ParsecT Void Text Identity TextBuilder
 -> ParsecT Void Text Identity TextBuilder)
-> ParsecT Void Text Identity TextBuilder
-> ParsecT Void Text Identity TextBuilder
forall a b. (a -> b) -> a -> b
$ do
    (TextBuilder, ByteString, ByteString -> Decoding)
start <- (TextBuilder, ByteString, ByteString -> Decoding)
-> Word8
-> ParsecT
     Void
     Text
     Identity
     (TextBuilder, ByteString, ByteString -> Decoding)
forall {m :: * -> *}.
MonadFail m =>
(TextBuilder, ByteString, ByteString -> Decoding)
-> Word8 -> m (TextBuilder, ByteString, ByteString -> Decoding)
progress (TextBuilder
forall a. Monoid a => a
mempty, ByteString
forall a. Monoid a => a
mempty, ByteString -> Decoding
Text.Encoding.streamDecodeUtf8) (Word8
 -> ParsecT
      Void
      Text
      Identity
      (TextBuilder, ByteString, ByteString -> Decoding))
-> ParsecT Void Text Identity Word8
-> ParsecT
     Void
     Text
     Identity
     (TextBuilder, ByteString, ByteString -> Decoding)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT Void Text Identity Word8
urlEncodedByte
    ((TextBuilder, ByteString, ByteString -> Decoding)
 -> Word8
 -> ParsecT
      Void
      Text
      Identity
      (TextBuilder, ByteString, ByteString -> Decoding))
-> (TextBuilder, ByteString, ByteString -> Decoding)
-> ParsecT Void Text Identity Word8
-> ParsecT
     Void
     Text
     Identity
     (TextBuilder, ByteString, ByteString -> Decoding)
forall (m :: * -> *) a b.
MonadPlus m =>
(a -> b -> m a) -> a -> m b -> m a
MonadPlus.scanlM (TextBuilder, ByteString, ByteString -> Decoding)
-> Word8
-> ParsecT
     Void
     Text
     Identity
     (TextBuilder, ByteString, ByteString -> Decoding)
forall {m :: * -> *}.
MonadFail m =>
(TextBuilder, ByteString, ByteString -> Decoding)
-> Word8 -> m (TextBuilder, ByteString, ByteString -> Decoding)
progress (TextBuilder, ByteString, ByteString -> Decoding)
start ParsecT Void Text Identity Word8
urlEncodedByte ParsecT
  Void
  Text
  Identity
  (TextBuilder, ByteString, ByteString -> Decoding)
-> ((TextBuilder, ByteString, ByteString -> Decoding)
    -> ParsecT Void Text Identity TextBuilder)
-> ParsecT Void Text Identity TextBuilder
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TextBuilder, ByteString, ByteString -> Decoding)
-> ParsecT Void Text Identity TextBuilder
forall {m :: * -> *} {a} {c}.
MonadFail m =>
(a, ByteString, c) -> m a
finish
  where
    progress :: (TextBuilder, ByteString, ByteString -> Decoding)
-> Word8 -> m (TextBuilder, ByteString, ByteString -> Decoding)
progress (!TextBuilder
builder, ByteString
_ :: ByteString, ByteString -> Decoding
decode) Word8
byte =
      case IO (Either UnicodeException Decoding)
-> Either UnicodeException Decoding
forall a. IO a -> a
unsafeDupablePerformIO (IO Decoding -> IO (Either UnicodeException Decoding)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (Decoding -> IO Decoding
forall a. a -> IO a
evaluate (ByteString -> Decoding
decode (Word8 -> ByteString
ByteString.singleton Word8
byte)))) of
        Right (Text.Encoding.Some Text
decodedChunk ByteString
undecodedBytes ByteString -> Decoding
newDecode) ->
          (TextBuilder, ByteString, ByteString -> Decoding)
-> m (TextBuilder, ByteString, ByteString -> Decoding)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TextBuilder
builder TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text Text
decodedChunk, ByteString
undecodedBytes, ByteString -> Decoding
newDecode)
        Left (Text.Encoding.DecodeError String
error Maybe Word8
_) ->
          String -> m (TextBuilder, ByteString, ByteString -> Decoding)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
showString String
"UTF8 decoding: " String
error)
        Left UnicodeException
_ ->
          String -> m (TextBuilder, ByteString, ByteString -> Decoding)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected decoding error"
    finish :: (a, ByteString, c) -> m a
finish (a
builder, ByteString
undecodedBytes, c
_) =
      if ByteString -> Bool
ByteString.null ByteString
undecodedBytes
        then a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
builder
        else String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
showString String
"UTF8 decoding: Bytes remaining: " (ByteString -> String
forall a. Show a => a -> String
show ByteString
undecodedBytes))

{-# INLINE urlEncodedByte #-}
urlEncodedByte :: Parser Word8
urlEncodedByte :: ParsecT Void Text Identity Word8
urlEncodedByte = do
  Char
_ <- ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'%')
  Word8
digit1 <- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8)
-> ParsecT Void Text Identity Int
-> ParsecT Void Text Identity Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int
hexadecimalDigit
  Word8
digit2 <- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8)
-> ParsecT Void Text Identity Int
-> ParsecT Void Text Identity Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int
hexadecimalDigit
  return (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL Word8
digit1 Int
4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
digit2)

{-# INLINE hexadecimalDigit #-}
hexadecimalDigit :: Parser Int
hexadecimalDigit :: ParsecT Void Text Identity Int
hexadecimalDigit = String
-> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"Hex digit" do
  Char
c <- ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
  let x :: Int
x = Char -> Int
ord Char
c
  if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
48 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
58
    then Int -> ParsecT Void Text Identity Int
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48)
    else
      if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
65 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
71
        then Int -> ParsecT Void Text Identity Int
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
55)
        else
          if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
97 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
103
            then Int -> ParsecT Void Text Identity Int
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
87)
            else String -> ParsecT Void Text Identity Int
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not a hexadecimal digit: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c)

{-# INLINE labeled #-}
labeled :: String -> Parser a -> Parser a
labeled :: forall a. String -> Parser a -> Parser a
labeled String
label Parser a
parser =
  Parser a
parser Parser a -> String -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
label