{-# 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 :: 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 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 :: 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 e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m ()
ipv6Address m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
ipvFuture
    ipv6Address :: m ()
ipv6Address = do
      Int
pos <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      (Text
toks, [String]
xs) <- m [String] -> m (Tokens Text, [String])
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match (m [String] -> m (Tokens Text, [String]))
-> m [String] -> m (Tokens Text, [String])
forall a b. (a -> b) -> a -> b
$ do
        [String]
xs' <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> m (Maybe String) -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String -> m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([] String -> m Text -> m String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"::")
        [String]
xs <- (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
          (Bool
skip, Bool
hasMore) <- m (Bool, Bool) -> m (Bool, Bool)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (m (Bool, Bool) -> m (Bool, Bool))
-> (m (Bool, Bool) -> m (Bool, Bool))
-> m (Bool, Bool)
-> m (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Bool, Bool) -> m (Bool, Bool)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (m (Bool, Bool) -> m (Bool, Bool))
-> m (Bool, Bool) -> m (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ do
            Bool
skip <- Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool -> m Char -> m Bool
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
hasMore <- Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool -> m Char -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar)
            (Bool, Bool) -> m (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
skip, Bool
hasMore)
          case (Bool
skip, Bool
hasMore) of
            (Bool
True, Bool
True) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return []
            (Bool
True, Bool
False) -> [] String -> m Char -> m String
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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
        [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
xs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs)
      let nskips :: Int
nskips = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs)
          npieces :: Int
npieces = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
nskips Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
&& (Int
npieces Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
|| (Int
nskips Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
npieces Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> m ()
forall e s (m :: * -> *). MonadParsec e s m => Int -> m ()
setOffset Int
pos
        Maybe (ErrorItem (Token Text))
-> Set (ErrorItem (Token Text)) -> m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> m a
failure
          ((NonEmpty Char -> ErrorItem Char)
-> Maybe (NonEmpty Char) -> Maybe (ErrorItem Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens (Maybe (NonEmpty Char) -> Maybe (ErrorItem Char))
-> (Text -> Maybe (NonEmpty Char))
-> Text
-> Maybe (ErrorItem Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (String -> Maybe (NonEmpty Char))
-> (Text -> String) -> Text -> Maybe (NonEmpty Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe (ErrorItem Char)) -> Text -> Maybe (ErrorItem Char)
forall a b. (a -> b) -> a -> b
$ Text
toks)
          (ErrorItem Char -> Set (ErrorItem Char)
forall a. a -> Set a
E.singleton (ErrorItem Char -> Set (ErrorItem Char))
-> (String -> ErrorItem Char) -> String -> Set (ErrorItem Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> ErrorItem Char
forall t. NonEmpty Char -> ErrorItem t
Label (NonEmpty Char -> ErrorItem Char)
-> (String -> NonEmpty Char) -> String -> ErrorItem Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty Char
forall a. [a] -> NonEmpty a
NE.fromList (String -> Set (ErrorItem Char)) -> String -> Set (ErrorItem Char)
forall a b. (a -> b) -> a -> b
$ String
"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
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 (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 (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 (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
      let ch :: m Char
ch =
            if Bool
pe
              then m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaNumChar
              else m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
      Maybe Char
mx <- m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Char
ch
      case Maybe Char
mx of
        Maybe Char
Nothing -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        Just Char
x -> do
          let r :: m Char
r =
                m Char
ch
                  m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char -> m Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
                    (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (m Char -> m Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (m Char -> m Char) -> (m Char -> m Char) -> m Char -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Char -> m Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (m Char
ch m Char -> m Char -> m Char
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
'-'))
          String
xs <- m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m Char
r
          String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
{-# INLINEABLE pHost #-}

-- | Parse an ASCII alpha character.
asciiAlphaChar :: MonadParsec e Text m => m Char
asciiAlphaChar :: 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 :: 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 :: m Char
unreservedChar = String -> m Char -> m Char
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
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 a percent-encoded character.
percentEncChar :: MonadParsec e Text m => m Char
percentEncChar :: 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
'%')
  Int
h <- Char -> Int
digitToInt (Char -> Int) -> m Char -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
  Int
l <- Char -> Int
digitToInt (Char -> Int) -> m Char -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
  Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> m Char) -> (Int -> Char) -> Int -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr (Int -> m Char) -> Int -> m Char
forall a b. (a -> b) -> a -> b
$ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l
{-# INLINE percentEncChar #-}

-- | Parse a sub-delimiter character.
subDelimChar :: MonadParsec e Text m => m Char
subDelimChar :: 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 :: 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' :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> m Char
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