{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Text.URI.Parser.ByteString
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- URI parser for string 'ByteString', an internal module.
module Text.URI.Parser.ByteString
  ( mkURIBs,
    parserBs,
  )
where

import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.State.Strict
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Char
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes, isJust, maybeToList)
import qualified Data.Set as E
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Void
import Data.Word (Word8)
import Text.Megaparsec
import Text.Megaparsec.Byte
import qualified Text.Megaparsec.Byte.Lexer as L
import Text.URI.Types hiding (pHost)

-- | Construct a 'URI' from 'ByteString'. The input you pass to 'mkURIBs'
-- must be a valid URI as per RFC 3986, that is, its components should be
-- percent-encoded where necessary. In case of parse failure
-- 'ParseExceptionBs' is thrown.
--
-- This function uses the 'parserBs' parser under the hood, which you can also
-- use directly in a Megaparsec parser.
--
-- @since 0.3.3.0
mkURIBs :: (MonadThrow m) => ByteString -> m URI
mkURIBs :: forall (m :: * -> *). MonadThrow m => ByteString -> m URI
mkURIBs ByteString
input =
  case Parsec Void ByteString URI
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) URI
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void ByteString URI
forall e (m :: * -> *). MonadParsec e ByteString m => m URI
parserBs Parsec Void ByteString URI
-> ParsecT Void ByteString Identity ()
-> Parsec Void ByteString URI
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: Parsec Void ByteString URI) String
"" ByteString
input of
    Left ParseErrorBundle ByteString Void
b -> ParseExceptionBs -> m URI
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ParseErrorBundle ByteString Void -> ParseExceptionBs
ParseExceptionBs ParseErrorBundle ByteString Void
b)
    Right URI
x -> URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return URI
x

-- | This parser can be used to parse 'URI' from strict 'ByteString'.
-- Remember to use a concrete non-polymorphic parser type for efficiency.
--
-- @since 0.0.2.0
parserBs :: (MonadParsec e ByteString m) => m URI
parserBs :: forall e (m :: * -> *). MonadParsec e ByteString m => m URI
parserBs = do
  uriScheme <- m (RText 'Scheme) -> m (Maybe (RText 'Scheme))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m (RText 'Scheme) -> m (RText 'Scheme)
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m (RText 'Scheme)
forall e (m :: * -> *).
MonadParsec e ByteString m =>
m (RText 'Scheme)
pScheme)
  mauth <- optional pAuthority
  (absPath, uriPath) <- pPath (isJust mauth)
  uriQuery <- option [] pQuery
  uriFragment <- optional pFragment
  let uriAuthority = Either Bool Authority
-> (Authority -> Either Bool Authority)
-> Maybe Authority
-> Either Bool Authority
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Either Bool Authority
forall a b. a -> Either a b
Left Bool
absPath) Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Maybe Authority
mauth
  return URI {..}
{-# INLINEABLE parserBs #-}
{-# SPECIALIZE parserBs :: Parsec Void ByteString URI #-}

pScheme :: (MonadParsec e ByteString m) => m (RText 'Scheme)
pScheme :: forall e (m :: * -> *).
MonadParsec e ByteString m =>
m (RText 'Scheme)
pScheme = do
  r <- String
-> (Text -> Maybe (RText 'Scheme))
-> m [Word8]
-> m (RText 'Scheme)
forall e (m :: * -> *) r.
MonadParsec e ByteString m =>
String -> (Text -> Maybe r) -> m [Word8] -> m r
liftR String
"scheme" Text -> Maybe (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
mkScheme (m [Word8] -> m (RText 'Scheme)) -> m [Word8] -> m (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ do
    x <- m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
asciiAlphaChar
    xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46)
    return (x : xs)
  void (char 58)
  return r
{-# INLINE pScheme #-}

pAuthority :: (MonadParsec e ByteString m) => m Authority
pAuthority :: forall e (m :: * -> *). MonadParsec e ByteString m => m Authority
pAuthority = do
  m (Tokens ByteString) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens ByteString -> m (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"//")
  authUserInfo <- m UserInfo -> m (Maybe UserInfo)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m UserInfo
forall e (m :: * -> *). MonadParsec e ByteString m => m UserInfo
pUserInfo
  authHost <- liftR "host" mkHost pHost
  authPort <- optional (char 58 *> L.decimal)
  return Authority {..}
{-# INLINE pAuthority #-}

-- | Parser that can parse host names.
pHost :: (MonadParsec e ByteString m) => m [Word8]
pHost :: forall e (m :: * -> *). MonadParsec e ByteString m => m [Word8]
pHost =
  [m [Word8]] -> m [Word8]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m [Word8] -> m [Word8]
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m () -> m [Word8]
forall e (m :: * -> *) a.
MonadParsec e ByteString m =>
m a -> m [Word8]
asConsumed m ()
ipLiteral),
      m [Word8] -> m [Word8]
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m () -> m [Word8]
forall e (m :: * -> *) a.
MonadParsec e ByteString m =>
m a -> m [Word8]
asConsumed m ()
ipv4Address),
      m [Word8]
regName
    ]
  where
    asConsumed :: (MonadParsec e ByteString m) => m a -> m [Word8]
    asConsumed :: forall e (m :: * -> *) a.
MonadParsec e ByteString m =>
m a -> m [Word8]
asConsumed m a
p = ByteString -> [Word8]
B.unpack (ByteString -> [Word8])
-> ((ByteString, a) -> ByteString) -> (ByteString, a) -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, a) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, a) -> [Word8]) -> m (ByteString, a) -> m [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m (Tokens ByteString, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m a
p
    ipLiteral :: m ()
ipLiteral =
      m Word8 -> m Word8 -> m () -> m ()
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
91) (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
93) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        m () -> m ()
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m ()
ipv6Address m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
ipvFuture
    octet :: m ()
octet = do
      o <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      (toks, x) <- match L.decimal
      when (x >= (256 :: Integer)) $ do
        setOffset o
        failure
          (fmap Tokens . NE.nonEmpty . B.unpack $ toks)
          (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255")
    ipv4Address :: m ()
ipv4Address =
      Int -> m () -> m [()]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
3 (m ()
octet m () -> m Word8 -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
46) m [()] -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
octet
    ipv6Address :: m ()
ipv6Address = do
      o <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      (toks, xs) <- match $ do
        xs' <- maybeToList <$> optional ([] <$ string "::")
        xs <- flip sepBy1 (char 58) $ do
          (skip, hasMore) <- lookAhead . hidden $ do
            skip <- option False (True <$ char 58)
            hasMore <- option False (True <$ hexDigitChar)
            return (skip, hasMore)
          case (skip, hasMore) of
            (Bool
True, Bool
True) -> [Word8] -> m [Word8]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            (Bool
True, Bool
False) -> [] [Word8] -> m Word8 -> m [Word8]
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
58
            (Bool
False, Bool
_) -> Int -> Int -> m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
1 Int
4 m Word8
m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
hexDigitChar
        return (xs' ++ xs)
      let nskips = [[Word8]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([Word8] -> Bool) -> [[Word8]] -> [[Word8]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Word8] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Word8]]
xs)
          npieces = [[Word8]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Word8]]
xs
      unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do
        setOffset o
        failure
          (fmap Tokens . NE.nonEmpty . B.unpack $ toks)
          (E.singleton . Label . NE.fromList $ "valid IPv6 address")
    ipvFuture :: m ()
ipvFuture = do
      m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
118)
      m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Word8
m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
hexDigitChar
      m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
46)
      m Word8 -> m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
subDelimChar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
58)
    regName :: m [Word8]
regName = ([[Word8]] -> [Word8]) -> m [[Word8]] -> m [Word8]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Word8] -> [[Word8]] -> [Word8]
forall a. [a] -> [[a]] -> [a]
intercalate [Word8
46]) (m [[Word8]] -> m [Word8])
-> (m [Word8] -> m [[Word8]]) -> m [Word8] -> m [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m [Word8] -> m Word8 -> m [[Word8]])
-> m Word8 -> m [Word8] -> m [[Word8]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m [Word8] -> m Word8 -> m [[Word8]]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
46) (m [Word8] -> m [Word8]) -> m [Word8] -> m [Word8]
forall a b. (a -> b) -> a -> b
$ do
      let ch :: m Word8
ch = m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
percentEncChar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar
      mx <- m Word8 -> m (Maybe Word8)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Word8
ch
      case mx of
        Maybe Word8
Nothing -> [Word8] -> m [Word8]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Word8
x -> do
          let r :: m Word8
r =
                m Word8
ch
                  m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Word8 -> m Word8
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
                    (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
45 m Word8 -> m Word8 -> m Word8
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (m Word8 -> m Word8
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (m Word8 -> m Word8) -> (m Word8 -> m Word8) -> m Word8 -> m Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Word8 -> m Word8
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (m Word8
ch m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
45))
          xs <- m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m Word8
r
          return (x : xs)

pUserInfo :: (MonadParsec e ByteString m) => m UserInfo
pUserInfo :: forall e (m :: * -> *). MonadParsec e ByteString m => m UserInfo
pUserInfo = m UserInfo -> m UserInfo
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m UserInfo -> m UserInfo) -> m UserInfo -> m UserInfo
forall a b. (a -> b) -> a -> b
$ do
  uiUsername <-
    String
-> (Text -> Maybe (RText 'Username))
-> m [Word8]
-> m (RText 'Username)
forall e (m :: * -> *) r.
MonadParsec e ByteString m =>
String -> (Text -> Maybe r) -> m [Word8] -> m r
liftR
      String
"username"
      Text -> Maybe (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
mkUsername
      ( String -> m [Word8] -> m [Word8]
forall a. String -> m a -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"username" (m [Word8] -> m [Word8]) -> m [Word8] -> m [Word8]
forall a b. (a -> b) -> a -> b
$
          m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
percentEncChar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
subDelimChar)
      )
  uiPassword <- optional $ do
    void (char 58)
    liftR
      "password"
      mkPassword
      (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58))
  void (char 64)
  return UserInfo {..}
{-# INLINE pUserInfo #-}

pPath ::
  (MonadParsec e ByteString m) =>
  Bool ->
  m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath :: forall e (m :: * -> *).
MonadParsec e ByteString m =>
Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath Bool
hasAuth = do
  doubleSlash <- m Bool -> m Bool
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool -> m (Tokens ByteString) -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens ByteString -> m (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"//"))
  when (doubleSlash && not hasAuth) $
    (unexpected . Tokens . NE.fromList) [47, 47]
  absPath <- option False (True <$ char 47)
  let mkPathPiece' Text
x =
        if Text -> Bool
T.null Text
x
          then Maybe (RText 'PathPiece) -> Maybe (Maybe (RText 'PathPiece))
forall a. a -> Maybe a
Just Maybe (RText 'PathPiece)
forall a. Maybe a
Nothing
          else RText 'PathPiece -> Maybe (RText 'PathPiece)
forall a. a -> Maybe a
Just (RText 'PathPiece -> Maybe (RText 'PathPiece))
-> Maybe (RText 'PathPiece) -> Maybe (Maybe (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
mkPathPiece Text
x
  (maybePieces, trailingSlash) <- flip runStateT False $
    flip sepBy (char 47) $
      liftR "path piece" mkPathPiece' $
        label "path piece" $ do
          x <- many pchar
          put (null x)
          return x
  let pieces = [Maybe (RText 'PathPiece)] -> [RText 'PathPiece]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (RText 'PathPiece)]
maybePieces
  return
    ( absPath,
      case NE.nonEmpty pieces of
        Maybe (NonEmpty (RText 'PathPiece))
Nothing -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing
        Just NonEmpty (RText 'PathPiece)
ps -> (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just (Bool
trailingSlash, NonEmpty (RText 'PathPiece)
ps)
    )
{-# INLINE pPath #-}

pQuery :: (MonadParsec e ByteString m) => m [QueryParam]
pQuery :: forall e (m :: * -> *).
MonadParsec e ByteString m =>
m [QueryParam]
pQuery = do
  m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
63)
  m (Maybe Word8) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word8 -> m (Maybe Word8)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
38))
  ([Maybe QueryParam] -> [QueryParam])
-> m [Maybe QueryParam] -> m [QueryParam]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe QueryParam] -> [QueryParam]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe QueryParam] -> m [QueryParam])
-> (m (Maybe QueryParam) -> m [Maybe QueryParam])
-> m (Maybe QueryParam)
-> m [QueryParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (Maybe QueryParam) -> m Word8 -> m [Maybe QueryParam])
-> m Word8 -> m (Maybe QueryParam) -> m [Maybe QueryParam]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Maybe QueryParam) -> m Word8 -> m [Maybe QueryParam]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
38) (m (Maybe QueryParam) -> m [Maybe QueryParam])
-> (m (Maybe QueryParam) -> m (Maybe QueryParam))
-> m (Maybe QueryParam)
-> m [Maybe QueryParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe QueryParam) -> m (Maybe QueryParam)
forall a. String -> m a -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"query parameter" (m (Maybe QueryParam) -> m [QueryParam])
-> m (Maybe QueryParam) -> m [QueryParam]
forall a b. (a -> b) -> a -> b
$ do
    let p :: m [Word8]
p = m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
pchar' m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
47 m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
63)
    k <- String
-> (Text -> Maybe (RText 'QueryKey))
-> m [Word8]
-> m (RText 'QueryKey)
forall e (m :: * -> *) r.
MonadParsec e ByteString m =>
String -> (Text -> Maybe r) -> m [Word8] -> m r
liftR String
"query key" Text -> Maybe (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey m [Word8]
p
    mv <- optional (char 61 *> liftR "query value" mkQueryValue p)
    return $
      if T.null (unRText k)
        then Nothing
        else
          Just
            ( case mv of
                Maybe (RText 'QueryValue)
Nothing -> RText 'QueryKey -> QueryParam
QueryFlag RText 'QueryKey
k
                Just RText 'QueryValue
v -> RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k RText 'QueryValue
v
            )
{-# INLINE pQuery #-}

pFragment :: (MonadParsec e ByteString m) => m (RText 'Fragment)
pFragment :: forall e (m :: * -> *).
MonadParsec e ByteString m =>
m (RText 'Fragment)
pFragment = do
  m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
35)
  String
-> (Text -> Maybe (RText 'Fragment))
-> m [Word8]
-> m (RText 'Fragment)
forall e (m :: * -> *) r.
MonadParsec e ByteString m =>
String -> (Text -> Maybe r) -> m [Word8] -> m r
liftR
    String
"fragment"
    Text -> Maybe (RText 'Fragment)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Fragment)
mkFragment
    ( m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Word8 -> m [Word8])
-> (m Word8 -> m Word8) -> m Word8 -> m [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Word8 -> m Word8
forall a. String -> m a -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"fragment character" (m Word8 -> m [Word8]) -> m Word8 -> m [Word8]
forall a b. (a -> b) -> a -> b
$
        m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
pchar m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
47 m Word8 -> m Word8 -> m Word8
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
63
    )
{-# INLINE pFragment #-}

----------------------------------------------------------------------------
-- Helpers

-- | Lift a smart constructor that consumes 'Text' into a parser.
liftR ::
  (MonadParsec e ByteString m) =>
  -- | What is being parsed
  String ->
  -- | The smart constructor that produces the result
  (Text -> Maybe r) ->
  -- | How to parse @['Word8']@ that will be converted to 'Text' and fed to
  -- the smart constructor
  m [Word8] ->
  m r
liftR :: forall e (m :: * -> *) r.
MonadParsec e ByteString m =>
String -> (Text -> Maybe r) -> m [Word8] -> m r
liftR String
lbl Text -> Maybe r
f m [Word8]
p = do
  o <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  (toks, s) <- match p
  case TE.decodeUtf8' (B.pack s) of
    Left UnicodeException
_ -> do
      let unexp :: NonEmpty Word8
unexp = [Word8] -> NonEmpty Word8
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (ByteString -> [Word8]
B.unpack ByteString
toks)
          expecting :: NonEmpty Char
expecting = String -> NonEmpty Char
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" that can be decoded as UTF-8")
      ParseError ByteString e -> m r
forall a. ParseError ByteString e -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError
        ( Int
-> Maybe (ErrorItem (Token ByteString))
-> Set (ErrorItem (Token ByteString))
-> ParseError ByteString e
forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError
            Int
o
            (ErrorItem Word8 -> Maybe (ErrorItem Word8)
forall a. a -> Maybe a
Just (NonEmpty Word8 -> ErrorItem Word8
forall t. NonEmpty t -> ErrorItem t
Tokens NonEmpty Word8
unexp))
            (ErrorItem Word8 -> Set (ErrorItem Word8)
forall a. a -> Set a
S.singleton (NonEmpty Char -> ErrorItem Word8
forall t. NonEmpty Char -> ErrorItem t
Label NonEmpty Char
expecting))
        )
    Right Text
text -> m r -> (r -> m r) -> Maybe r -> m r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m r
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty r -> m r
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe r
f Text
text)
{-# INLINE liftR #-}

asciiAlphaChar :: (MonadParsec e ByteString m) => m Word8
asciiAlphaChar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
asciiAlphaChar = (Token ByteString -> Bool) -> m (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Word8 -> Bool
Token ByteString -> Bool
isAsciiAlpha m Word8 -> String -> m Word8
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"ASCII alpha character"
{-# INLINE asciiAlphaChar #-}

asciiAlphaNumChar :: (MonadParsec e ByteString m) => m Word8
asciiAlphaNumChar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
asciiAlphaNumChar = (Token ByteString -> Bool) -> m (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Word8 -> Bool
Token ByteString -> Bool
isAsciiAlphaNum m Word8 -> String -> m Word8
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"ASCII alpha-numeric character"
{-# INLINE asciiAlphaNumChar #-}

unreservedChar :: (MonadParsec e ByteString m) => m Word8
unreservedChar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar = String -> m Word8 -> m Word8
forall a. String -> m a -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"unreserved character" (m Word8 -> m Word8)
-> ((Word8 -> Bool) -> m Word8) -> (Word8 -> Bool) -> m Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> m Word8
(Token ByteString -> Bool) -> m (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Word8 -> Bool) -> m Word8) -> (Word8 -> Bool) -> m Word8
forall a b. (a -> b) -> a -> b
$ \Word8
x ->
  Word8 -> Bool
isAsciiAlphaNum Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
45 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
46 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
95 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
126
{-# INLINE unreservedChar #-}

percentEncChar :: (MonadParsec e ByteString m) => m Word8
percentEncChar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
percentEncChar = do
  m Word8 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
37)
  h <- Word8 -> Word8
restoreDigit (Word8 -> Word8) -> m Word8 -> m Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word8
m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
hexDigitChar
  l <- restoreDigit <$> hexDigitChar
  return (h * 16 + l)
{-# INLINE percentEncChar #-}

subDelimChar :: (MonadParsec e ByteString m) => m Word8
subDelimChar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
subDelimChar = Set (Token ByteString) -> m (Token ByteString)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Word8
Set (Token ByteString)
s m Word8 -> String -> m Word8
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter"
  where
    s :: Set Word8
s = [Word8] -> Set Word8
forall a. Ord a => [a] -> Set a
E.fromList (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Word8) -> String -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
"!$&'()*+,;=")
{-# INLINE subDelimChar #-}

pchar :: (MonadParsec e ByteString m) => m Word8
pchar :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
pchar =
  [m Word8] -> m Word8
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar,
      m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
percentEncChar,
      m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
subDelimChar,
      Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
58,
      Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
64
    ]
{-# INLINE pchar #-}

pchar' :: (MonadParsec e ByteString m) => m Word8
pchar' :: forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
pchar' =
  [m Word8] -> m Word8
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
unreservedChar,
      m Word8
forall e (m :: * -> *). MonadParsec e ByteString m => m Word8
percentEncChar,
      Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
43 m Word8 -> m Word8 -> m Word8
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> m Word8
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word8
32,
      Set (Token ByteString) -> m (Token ByteString)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Word8
Set (Token ByteString)
s m Word8 -> String -> m Word8
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter",
      Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
58,
      Token ByteString -> m (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
char Word8
Token ByteString
64
    ]
  where
    s :: Set Word8
s = [Word8] -> Set Word8
forall a. Ord a => [a] -> Set a
E.fromList (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Word8) -> String -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
"!$'()*,;")
{-# INLINE pchar' #-}

isAsciiAlpha :: Word8 -> Bool
isAsciiAlpha :: Word8 -> Bool
isAsciiAlpha Word8
x
  | Word8
65 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90 = Bool
True
  | Word8
97 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122 = Bool
True
  | Bool
otherwise = Bool
False

isAsciiAlphaNum :: Word8 -> Bool
isAsciiAlphaNum :: Word8 -> Bool
isAsciiAlphaNum Word8
x
  | Word8 -> Bool
isAsciiAlpha Word8
x = Bool
True
  | Word8
48 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57 = Bool
True
  | Bool
otherwise = Bool
False

restoreDigit :: Word8 -> Word8
restoreDigit :: Word8 -> Word8
restoreDigit Word8
x
  | Word8
48 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57 = Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
48
  | Word8
65 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
70 = Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
55
  | Word8
97 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
102 = Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
87
  | Bool
otherwise = String -> Word8
forall a. HasCallStack => String -> a
error String
"Text.URI.Parser.restoreDigit: bad input"