{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.URI.Parser.Text.Utils
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Random utilities for our 'Text' parsers.
module Text.URI.Parser.Text.Utils
  ( pHost,
    asciiAlphaChar,
    asciiAlphaNumChar,
    unreservedChar,
    percentEncChar,
    subDelimChar,
    pchar,
    pchar',
  )
where

import Control.Monad
import Data.Char
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (maybeToList)
import qualified Data.Set as E
import Data.Text (Text)
import qualified Data.Text as T
import Text.Megaparsec
import Text.Megaparsec.Char

-- | Parser that can parse host names.
pHost ::
  (MonadParsec e Text m) =>
  -- | Demand percent-encoding in reg names
  Bool ->
  m String
pHost :: forall e (m :: * -> *). MonadParsec e Text m => Bool -> m String
pHost Bool
pe =
  [m String] -> m String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m String -> m String
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m () -> m String
forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m String
asConsumed m ()
ipLiteral),
      m String
regName
    ]
  where
    asConsumed :: (MonadParsec e Text m) => m a -> m String
    asConsumed :: forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m String
asConsumed m a
p = Text -> String
T.unpack (Text -> String) -> ((Text, a) -> Text) -> (Text, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, a) -> Text
forall a b. (a, b) -> a
fst ((Text, a) -> String) -> m (Text, a) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m (Tokens Text, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m a
p
    ipLiteral :: m ()
ipLiteral =
      m Char -> m Char -> m () -> m ()
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'[') (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']') (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
    ipv6Address :: m ()
ipv6Address = do
      pos <- 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 ':') $ do
          (skip, hasMore) <- lookAhead . hidden $ do
            skip <- option False (True <$ char ':')
            hasMore <- option False (True <$ hexDigitChar)
            return (skip, hasMore)
          case (skip, hasMore) of
            (Bool
True, Bool
True) -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            (Bool
True, Bool
False) -> [] String -> m Char -> m String
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
            (Bool
False, Bool
_) -> Int -> Int -> m Char -> m String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
1 Int
4 m Char
m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
        return (xs' ++ xs)
      let nskips = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs)
          npieces = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs
      unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do
        setOffset pos
        failure
          (fmap Tokens . NE.nonEmpty . T.unpack $ toks)
          (E.singleton . Label . NE.fromList $ "valid IPv6 address")
    ipvFuture :: m ()
ipvFuture = do
      m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'v')
      m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Char
m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.')
      m Char -> m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':')
    regName :: m String
regName = ([String] -> String) -> m [String] -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
".") (m [String] -> m String)
-> (m String -> m [String]) -> m String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m String -> m Char -> m [String])
-> m Char -> m String -> m [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m String -> m Char -> m [String]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.') (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ do
      m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char -> m String) -> m Char -> m String
forall a b. (a -> b) -> a -> b
$
        if Bool
pe
          then m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar
          else m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedCharUnicode
{-# INLINEABLE pHost #-}

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

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

-- | Parse an unreserved character.
unreservedChar :: (MonadParsec e Text m) => m Char
unreservedChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar = String -> m Char -> m Char
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 Char -> m Char)
-> ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> m Char
(Token Text -> Bool) -> m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall a b. (a -> b) -> a -> b
$ \Char
x ->
  Char -> Bool
isAsciiAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'~'
{-# INLINE unreservedChar #-}

-- | Parse an unreserved character allowing Unicode.
unreservedCharUnicode :: (MonadParsec e Text m) => m Char
unreservedCharUnicode :: forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedCharUnicode = String -> m Char -> m Char
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 Char -> m Char)
-> ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> m Char
(Token Text -> Bool) -> m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall a b. (a -> b) -> a -> b
$ \Char
x ->
  Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'~'
{-# INLINE unreservedCharUnicode #-}

-- | Parse a percent-encoded character.
percentEncChar :: (MonadParsec e Text m) => m Char
percentEncChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'%')
  h <- Char -> Int
digitToInt (Char -> Int) -> m Char -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
  l <- digitToInt <$> hexDigitChar
  return . chr $ h * 16 + l
{-# INLINE percentEncChar #-}

-- | Parse a sub-delimiter character.
subDelimChar :: (MonadParsec e Text m) => m Char
subDelimChar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar = Set (Token Text) -> m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Char
Set (Token Text)
s m Char -> String -> m Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter"
  where
    s :: Set Char
s = String -> Set Char
forall a. Ord a => [a] -> Set a
E.fromList String
"!$&'()*+,;="
{-# INLINE subDelimChar #-}

-- | PCHAR thing from the spec.
pchar :: (MonadParsec e Text m) => m Char
pchar :: forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar =
  [m Char] -> m Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar,
      m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar,
      m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar,
      Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':',
      Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'@'
    ]
{-# INLINE pchar #-}

-- | 'pchar' adjusted for query parsing.
pchar' :: (MonadParsec e Text m) => m Char
pchar' :: forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar' =
  [m Char] -> m Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar,
      m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar,
      Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'+' m Char -> m Char -> m Char
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> m Char
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
' ',
      Set (Token Text) -> m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Char
Set (Token Text)
s m Char -> String -> m Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter",
      Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':',
      Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'@'
    ]
  where
    s :: Set Char
s = String -> Set Char
forall a. Ord a => [a] -> Set a
E.fromList String
"!$'()*,;"
{-# INLINE pchar' #-}

isAsciiAlpha :: Char -> Bool
isAsciiAlpha :: Char -> Bool
isAsciiAlpha Char
x = Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
x

isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum Char
x = Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
x