{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Iri.Parsing.Attoparsec.Text
  ( iri,
    httpIri,
    hierarchy,
    scheme,
    host,
    regName,
    domainLabel,
    port,
    path,
    pathSegment,
    query,
    fragment,
  )
where

import Data.Attoparsec.Text hiding (try)
import Data.ByteString qualified as K
import Data.Text.Encoding qualified as B
import Data.Text.Encoding.Error qualified as L
import Data.Vector qualified as S
import Iri.CodePointPredicates.Rfc3987 qualified as C
import Iri.Data
import Iri.MonadPlus qualified as R
import Iri.Prelude
import Net.IPv4 qualified as M
import Net.IPv6 qualified as N
import Ptr.ByteString qualified as ByteString
import Ptr.Poking qualified as Poking
import Text.Builder qualified as J
import VectorBuilder.MonadPlus qualified as E

{-# 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 i a. Parser i a -> String -> Parser i a
<?> String
label

-- |
-- Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'.
-- Performs URL-decoding.
{-# INLINEABLE iri #-}
iri :: Parser Iri
iri :: Parser Iri
iri =
  String -> Parser Iri -> Parser Iri
forall a. String -> Parser a -> Parser a
labeled String
"IRI" (Parser Iri -> Parser Iri) -> Parser Iri -> Parser Iri
forall a b. (a -> b) -> a -> b
$ do
    Scheme
parsedScheme <- Parser Scheme
scheme
    Char -> Parser Char
char Char
':'
    Hierarchy
parsedHierarchy <- Parser Hierarchy
hierarchy
    Query
parsedQuery <- Parser Query
query
    Fragment
parsedFragment <- Parser Fragment
fragment
    Iri -> Parser Iri
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> Hierarchy -> Query -> Fragment -> Iri
Iri Scheme
parsedScheme Hierarchy
parsedHierarchy Query
parsedQuery Fragment
parsedFragment)

-- |
-- Same as 'iri', but optimized specifially for the case of HTTP IRIs.
{-# INLINEABLE httpIri #-}
httpIri :: Parser HttpIri
httpIri :: Parser HttpIri
httpIri =
  String -> Parser HttpIri -> Parser HttpIri
forall a. String -> Parser a -> Parser a
labeled String
"HTTP IRI" (Parser HttpIri -> Parser HttpIri)
-> Parser HttpIri -> Parser HttpIri
forall a b. (a -> b) -> a -> b
$ do
    Text -> Parser Text
asciiCI Text
"http"
    Bool
secure <- (Char -> Bool) -> Parser Char
satisfy (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
's' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'S') Parser Char -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Text -> Parser Text
string Text
"://"
    Host
parsedHost <- Parser Host
host
    Port
parsedPort <- Word16 -> Port
PresentPort (Word16 -> Port) -> Parser Text Word16 -> Parser Text Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
':' Parser Char -> Parser Text Word16 -> Parser Text Word16
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Word16
port) Parser Text Port -> Parser Text Port -> Parser Text Port
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Port -> Parser Text Port
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Port
MissingPort
    Path
parsedPath <- ((Char -> Parser Char
char Char
'/') Parser Char -> Parser Text Path -> Parser Text Path
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Path
path) Parser Text Path -> Parser Text Path -> Parser Text Path
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Path -> Parser Text Path
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector PathSegment -> Path
Path Vector PathSegment
forall a. Monoid a => a
mempty)
    Query
parsedQuery <- Parser Query
query
    Fragment
parsedFragment <- Parser Fragment
fragment
    HttpIri -> Parser HttpIri
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Security -> Host -> Port -> Path -> Query -> Fragment -> HttpIri
HttpIri (Bool -> Security
Security Bool
secure) Host
parsedHost Port
parsedPort Path
parsedPath Query
parsedQuery Fragment
parsedFragment)

{-# INLINE hierarchy #-}
hierarchy :: Parser Hierarchy
hierarchy :: Parser Hierarchy
hierarchy =
  do
    Bool
slashPresent <- (Char -> Parser Char
char Char
'/') Parser Char -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    if Bool
slashPresent
      then do
        Bool
slashPresent <- (Char -> Parser Char
char Char
'/') Parser Char -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        if Bool
slashPresent
          then (Authority -> Path -> Hierarchy) -> Parser Hierarchy
forall body. (Authority -> Path -> body) -> Parser body
authorisedHierarchyBody Authority -> Path -> Hierarchy
AuthorisedHierarchy
          else Path -> Hierarchy
AbsoluteHierarchy (Path -> Hierarchy) -> Parser Text Path -> Parser Hierarchy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Path
path
      else Path -> Hierarchy
RelativeHierarchy (Path -> Hierarchy) -> Parser Text Path -> Parser Hierarchy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Path
path

{-# INLINE authorisedHierarchyBody #-}
authorisedHierarchyBody :: (Authority -> Path -> body) -> Parser body
authorisedHierarchyBody :: forall body. (Authority -> Path -> body) -> Parser body
authorisedHierarchyBody Authority -> Path -> body
body =
  do
    UserInfo
parsedUserInfo <- ((User -> Password -> UserInfo) -> Parser UserInfo
forall a. (User -> Password -> a) -> Parser a
presentUserInfo User -> Password -> UserInfo
PresentUserInfo Parser UserInfo -> Parser Char -> Parser UserInfo
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'@') Parser UserInfo -> Parser UserInfo -> Parser UserInfo
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UserInfo -> Parser UserInfo
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserInfo
MissingUserInfo
    Host
parsedHost <- Parser Host
host
    Port
parsedPort <- Word16 -> Port
PresentPort (Word16 -> Port) -> Parser Text Word16 -> Parser Text Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
':' Parser Char -> Parser Text Word16 -> Parser Text Word16
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Word16
port) Parser Text Port -> Parser Text Port -> Parser Text Port
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Port -> Parser Text Port
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Port
MissingPort
    Path
parsedPath <- ((Char -> Parser Char
char Char
'/') Parser Char -> Parser Text Path -> Parser Text Path
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Path
path) Parser Text Path -> Parser Text Path -> Parser Text Path
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Path -> Parser Text Path
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector PathSegment -> Path
Path Vector PathSegment
forall a. Monoid a => a
mempty)
    body -> Parser body
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Authority -> Path -> body
body (UserInfo -> Host -> Port -> Authority
Authority UserInfo
parsedUserInfo Host
parsedHost Port
parsedPort) Path
parsedPath)

{-# INLINE scheme #-}
scheme :: Parser Scheme
scheme :: Parser Scheme
scheme =
  String -> Parser Scheme -> Parser Scheme
forall a. String -> Parser a -> Parser a
labeled String
"Scheme"
    (Parser Scheme -> Parser Scheme) -> Parser Scheme -> Parser Scheme
forall a b. (a -> b) -> a -> b
$ (Text -> Scheme) -> Parser Text -> Parser Scheme
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Scheme
Scheme (ByteString -> Scheme) -> (Text -> ByteString) -> Text -> Scheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
B.encodeUtf8) ((Char -> Bool) -> Parser Text
takeWhile1 (Predicate
C.scheme Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord))

{-# INLINEABLE presentUserInfo #-}
presentUserInfo :: (User -> Password -> a) -> Parser a
presentUserInfo :: forall a. (User -> Password -> a) -> Parser a
presentUserInfo User -> Password -> a
result =
  String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
labeled String
"User info"
    (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ do
      User
user <- ByteString -> User
User (ByteString -> User) -> Parser Text ByteString -> Parser Text User
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text ByteString
urlEncodedComponent (Predicate
C.unencodedUserInfoComponent Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord)
      Bool
passwordFollows <- Bool
True Bool -> Parser Char -> Parser Text Bool
forall a b. a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
':' Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      if Bool
passwordFollows
        then do
          Password
password <- ByteString -> Password
PresentPassword (ByteString -> Password)
-> Parser Text ByteString -> Parser Text Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text ByteString
urlEncodedComponent (Predicate
C.unencodedUserInfoComponent Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord)
          a -> Parser a
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> Password -> a
result User
user Password
password)
        else a -> Parser a
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> Password -> a
result User
user Password
MissingPassword)

{-# INLINE host #-}
host :: Parser Host
host :: Parser Host
host =
  String -> Parser Host -> Parser Host
forall a. String -> Parser a -> Parser a
labeled String
"Host"
    (Parser Host -> Parser Host) -> Parser Host -> Parser Host
forall a b. (a -> b) -> a -> b
$ IPv6 -> Host
IpV6Host
    (IPv6 -> Host) -> Parser Text IPv6 -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text IPv6
N.parser
    Parser Host -> Parser Host -> Parser Host
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IPv4 -> Host
IpV4Host
    (IPv4 -> Host) -> Parser Text IPv4 -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text IPv4
M.parser
    Parser Host -> Parser Host -> Parser Host
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RegName -> Host
NamedHost
    (RegName -> Host) -> Parser Text RegName -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text RegName
regName

{-# INLINE regName #-}
regName :: Parser RegName
regName :: Parser Text RegName
regName =
  (Vector DomainLabel -> RegName)
-> Parser Text (Vector DomainLabel) -> Parser Text RegName
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector DomainLabel -> RegName
RegName (Parser Text DomainLabel
-> Parser Char -> Parser Text (Vector DomainLabel)
forall (m :: * -> *) (vector :: * -> *) element separator.
(MonadPlus m, Vector vector element) =>
m element -> m separator -> m (vector element)
E.sepBy1 Parser Text DomainLabel
domainLabel (Char -> Parser Char
char Char
'.'))

-- |
-- Domain label with Punycode decoding applied.
{-# INLINE domainLabel #-}
domainLabel :: Parser DomainLabel
domainLabel :: Parser Text DomainLabel
domainLabel =
  String -> Parser Text DomainLabel -> Parser Text DomainLabel
forall a. String -> Parser a -> Parser a
labeled String
"Domain label"
    (Parser Text DomainLabel -> Parser Text DomainLabel)
-> Parser Text DomainLabel -> Parser Text DomainLabel
forall a b. (a -> b) -> a -> b
$ Text -> DomainLabel
DomainLabel
    (Text -> DomainLabel) -> Parser Text -> Parser Text DomainLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (Predicate
C.unencodedRegName Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord)

{-# INLINE port #-}
port :: Parser Word16
port :: Parser Text Word16
port =
  Parser Text Word16
forall a. Integral a => Parser a
decimal

{-# INLINE path #-}
path :: Parser Path
path :: Parser Text Path
path =
  do
    Vector PathSegment
segments <- Parser Text PathSegment
-> Parser Char -> Parser Text (Vector PathSegment)
forall (m :: * -> *) (vector :: * -> *) element separator.
(MonadPlus m, Vector vector element) =>
m element -> m separator -> m (vector element)
E.sepBy Parser Text PathSegment
pathSegment (Char -> Parser Char
char Char
'/')
    if Vector PathSegment -> Bool
segmentsAreEmpty Vector PathSegment
segments
      then Path -> Parser Text Path
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector PathSegment -> Path
Path Vector PathSegment
forall a. Monoid a => a
mempty)
      else Path -> Parser Text Path
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector PathSegment -> Path
Path Vector PathSegment
segments)
  where
    segmentsAreEmpty :: Vector PathSegment -> Bool
segmentsAreEmpty Vector PathSegment
segments =
      Vector PathSegment -> Int
forall a. Vector a -> Int
S.length Vector PathSegment
segments
        Int -> Predicate
forall a. Eq a => a -> a -> Bool
== Int
1
        Bool -> Bool -> Bool
&& (case Vector PathSegment -> PathSegment
forall a. Vector a -> a
S.unsafeHead Vector PathSegment
segments of PathSegment ByteString
headSegment -> ByteString -> Bool
K.null ByteString
headSegment)

{-# INLINE pathSegment #-}
pathSegment :: Parser PathSegment
pathSegment :: Parser Text PathSegment
pathSegment =
  (ByteString -> PathSegment)
-> Parser Text ByteString -> Parser Text PathSegment
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> PathSegment
PathSegment ((Char -> Bool) -> Parser Text ByteString
urlEncodedComponent (Predicate
C.unencodedPathSegment Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord))

{-# INLINEABLE urlEncodedComponent #-}
urlEncodedComponent :: (Char -> Bool) -> Parser ByteString
urlEncodedComponent :: (Char -> Bool) -> Parser Text ByteString
urlEncodedComponent Char -> Bool
unencodedCharPredicate =
  String -> Parser Text ByteString -> Parser Text ByteString
forall a. String -> Parser a -> Parser a
labeled String
"URL-encoded component"
    (Parser Text ByteString -> Parser Text ByteString)
-> Parser Text ByteString -> Parser Text ByteString
forall a b. (a -> b) -> a -> b
$ (Poking -> ByteString)
-> Parser Text Poking -> Parser Text ByteString
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Poking -> ByteString
ByteString.poking
    (Parser Text Poking -> Parser Text ByteString)
-> Parser Text Poking -> Parser Text ByteString
forall a b. (a -> b) -> a -> b
$ Parser Text Poking -> Parser Text Poking
forall (m :: * -> *) a. (MonadPlus m, Monoid a) => m a -> m a
R.fold
    (Parser Text Poking -> Parser Text Poking)
-> Parser Text Poking -> Parser Text Poking
forall a b. (a -> b) -> a -> b
$ (ByteString -> Poking
Poking.bytes (ByteString -> Poking) -> (Text -> ByteString) -> Text -> Poking
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
B.encodeUtf8 (Text -> Poking) -> Parser Text -> Parser Text Poking
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
unencodedCharPredicate)
    Parser Text Poking -> Parser Text Poking -> Parser Text Poking
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Word8 -> Poking
Poking.word8 (Word8 -> Poking) -> Parser Text Word8 -> Parser Text Poking
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Word8
urlEncodedByte)

{-# INLINEABLE urlEncodedComponentText #-}
urlEncodedComponentText :: (Char -> Bool) -> Parser Text
urlEncodedComponentText :: (Char -> Bool) -> Parser Text
urlEncodedComponentText Char -> Bool
unencodedCharPredicate =
  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
$ (Builder -> Text) -> Parser Text Builder -> Parser Text
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Text
J.run
    (Parser Text Builder -> Parser Text)
-> Parser Text Builder -> Parser Text
forall a b. (a -> b) -> a -> b
$ (Builder -> Builder -> Builder)
-> Builder -> Parser Text Builder -> Parser Text Builder
forall (m :: * -> *) a b.
MonadPlus m =>
(a -> b -> a) -> a -> m b -> m a
R.foldl Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend Builder
forall a. Monoid a => a
mempty
    (Parser Text Builder -> Parser Text Builder)
-> Parser Text Builder -> Parser Text Builder
forall a b. (a -> b) -> a -> b
$ (Text -> Builder
J.text (Text -> Builder) -> Parser Text -> Parser Text Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
unencodedCharPredicate)
    Parser Text Builder -> Parser Text Builder -> Parser Text Builder
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Builder
urlEncodedSequenceTextBuilder

{-# INLINEABLE urlEncodedSequenceTextBuilder #-}
urlEncodedSequenceTextBuilder :: Parser J.Builder
urlEncodedSequenceTextBuilder :: Parser Text Builder
urlEncodedSequenceTextBuilder =
  String -> Parser Text Builder -> Parser Text Builder
forall a. String -> Parser a -> Parser a
labeled String
"URL-encoded sequence" (Parser Text Builder -> Parser Text Builder)
-> Parser Text Builder -> Parser Text Builder
forall a b. (a -> b) -> a -> b
$ do
    (Builder, ByteString, ByteString -> Decoding)
start <- (Builder, ByteString, ByteString -> Decoding)
-> Word8
-> Parser Text (Builder, ByteString, ByteString -> Decoding)
forall {m :: * -> *}.
MonadFail m =>
(Builder, ByteString, ByteString -> Decoding)
-> Word8 -> m (Builder, ByteString, ByteString -> Decoding)
progress (Builder
forall a. Monoid a => a
mempty, ByteString
forall a. Monoid a => a
mempty, ByteString -> Decoding
B.streamDecodeUtf8) (Word8
 -> Parser Text (Builder, ByteString, ByteString -> Decoding))
-> Parser Text Word8
-> Parser Text (Builder, ByteString, ByteString -> Decoding)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text Word8
urlEncodedByte
    ((Builder, ByteString, ByteString -> Decoding)
 -> Word8
 -> Parser Text (Builder, ByteString, ByteString -> Decoding))
-> (Builder, ByteString, ByteString -> Decoding)
-> Parser Text Word8
-> Parser Text (Builder, ByteString, ByteString -> Decoding)
forall (m :: * -> *) a b.
MonadPlus m =>
(a -> b -> m a) -> a -> m b -> m a
R.foldlM (Builder, ByteString, ByteString -> Decoding)
-> Word8
-> Parser Text (Builder, ByteString, ByteString -> Decoding)
forall {m :: * -> *}.
MonadFail m =>
(Builder, ByteString, ByteString -> Decoding)
-> Word8 -> m (Builder, ByteString, ByteString -> Decoding)
progress ((Builder, ByteString, ByteString -> Decoding)
start) Parser Text Word8
urlEncodedByte Parser Text (Builder, ByteString, ByteString -> Decoding)
-> ((Builder, ByteString, ByteString -> Decoding)
    -> Parser Text Builder)
-> Parser Text Builder
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Builder, ByteString, ByteString -> Decoding)
-> Parser Text Builder
forall {m :: * -> *} {a} {c}.
MonadFail m =>
(a, ByteString, c) -> m a
finish
  where
    progress :: (Builder, ByteString, ByteString -> Decoding)
-> Word8 -> m (Builder, ByteString, ByteString -> Decoding)
progress (!Builder
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)
try (Decoding -> IO Decoding
forall a. a -> IO a
evaluate (ByteString -> Decoding
decode (Word8 -> ByteString
K.singleton Word8
byte)))) of
        Right (B.Some Text
decodedChunk ByteString
undecodedBytes ByteString -> Decoding
newDecode) ->
          (Builder, ByteString, ByteString -> Decoding)
-> m (Builder, ByteString, ByteString -> Decoding)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder
builder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
J.text Text
decodedChunk, ByteString
undecodedBytes, ByteString -> Decoding
newDecode)
        Left (L.DecodeError String
error Maybe Word8
_) ->
          String -> m (Builder, ByteString, ByteString -> Decoding)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ShowS
showString String
"UTF8 decoding: " String
error)
        Left UnicodeException
_ ->
          String -> m (Builder, 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
K.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 -> ShowS
showString String
"UTF8 decoding: Bytes remaining: " (ByteString -> String
forall a. Show a => a -> String
show ByteString
undecodedBytes))

{-# INLINE urlEncodedByte #-}
urlEncodedByte :: Parser Word8
urlEncodedByte :: Parser Text Word8
urlEncodedByte =
  do
    Char -> Parser Char
char Char
'%'
    Word8
digit1 <- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Parser Text Int -> Parser Text Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
hexadecimalDigit
    Word8
digit2 <- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Parser Text Int -> Parser Text Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
hexadecimalDigit
    Word8 -> Parser Text Word8
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: Parser Text Int
hexadecimalDigit =
  do
    Char
c <- Parser Char
anyChar
    let x :: Int
x = Char -> Int
ord Char
c
    if Int
x Int -> Predicate
forall a. Ord a => a -> a -> Bool
>= Int
48 Bool -> Bool -> Bool
&& Int
x Int -> Predicate
forall a. Ord a => a -> a -> Bool
< Int
58
      then Int -> Parser Text Int
forall a. a -> Parser Text 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 -> Predicate
forall a. Ord a => a -> a -> Bool
>= Int
65 Bool -> Bool -> Bool
&& Int
x Int -> Predicate
forall a. Ord a => a -> a -> Bool
< Int
71
          then Int -> Parser Text Int
forall a. a -> Parser Text 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 -> Predicate
forall a. Ord a => a -> a -> Bool
>= Int
97 Bool -> Bool -> Bool
&& Int
x Int -> Predicate
forall a. Ord a => a -> a -> Bool
< Int
103
              then Int -> Parser Text Int
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
97)
              else String -> Parser Text Int
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Not a hexadecimal digit: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c)

{-# INLINEABLE query #-}
query :: Parser Query
query :: Parser Query
query =
  String -> Parser Query -> Parser Query
forall a. String -> Parser a -> Parser a
labeled String
"Query"
    (Parser Query -> Parser Query) -> Parser Query -> Parser Query
forall a b. (a -> b) -> a -> b
$ (Char -> Parser Char
char Char
'?' Parser Char -> Parser Query -> Parser Query
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Query
queryBody)
    Parser Query -> Parser Query -> Parser Query
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Query -> Parser Query
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Query
Query ByteString
forall a. Monoid a => a
mempty)

-- |
-- The stuff after the question mark.
{-# INLINEABLE queryBody #-}
queryBody :: Parser Query
queryBody :: Parser Query
queryBody =
  (ByteString -> Query) -> Parser Text ByteString -> Parser Query
forall a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Query
Query ((Char -> Bool) -> Parser Text ByteString
urlEncodedComponent (Predicate
C.unencodedQuery Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord))

{-# INLINEABLE fragment #-}
fragment :: Parser Fragment
fragment :: Parser Fragment
fragment =
  String -> Parser Fragment -> Parser Fragment
forall a. String -> Parser a -> Parser a
labeled String
"Fragment"
    (Parser Fragment -> Parser Fragment)
-> Parser Fragment -> Parser Fragment
forall a b. (a -> b) -> a -> b
$ (Char -> Parser Char
char Char
'#' Parser Char -> Parser Fragment -> Parser Fragment
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ByteString -> Fragment
Fragment (ByteString -> Fragment)
-> Parser Text ByteString -> Parser Fragment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text ByteString
urlEncodedComponent (Predicate
C.unencodedFragment Predicate -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord)))
    Parser Fragment -> Parser Fragment -> Parser Fragment
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Fragment -> Parser Fragment
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Fragment
Fragment ByteString
forall a. Monoid a => a
mempty)