{-# 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 =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m a
p
    ipLiteral :: m ()
ipLiteral =
      forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'[') (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
']') forall a b. (a -> b) -> a -> b
$
        forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m ()
ipv6Address forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
ipvFuture
    ipv6Address :: m ()
ipv6Address = do
      Int
pos <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      (Text
toks, [[Token Text]]
xs) <- forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match forall a b. (a -> b) -> a -> b
$ do
        [[Token Text]]
xs' <- forall a. Maybe a -> [a]
maybeToList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"::")
        [[Token Text]]
xs <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':') forall a b. (a -> b) -> a -> b
$ do
          (Bool
skip, Bool
hasMore) <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden forall a b. (a -> b) -> a -> b
$ do
            Bool
skip <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':')
            Bool
hasMore <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar)
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
skip, Bool
hasMore)
          case (Bool
skip, Bool
hasMore) of
            (Bool
True, Bool
True) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            (Bool
True, Bool
False) -> [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
            (Bool
False, Bool
_) -> forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
1 Int
4 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
        forall (m :: * -> *) a. Monad m => a -> m a
return ([[Token Text]]
xs' forall a. [a] -> [a] -> [a]
++ [[Token Text]]
xs)
      let nskips :: Int
nskips = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Token Text]]
xs)
          npieces :: Int
npieces = forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Token Text]]
xs
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
nskips forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
&& (Int
npieces forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
|| (Int
nskips forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
npieces forall a. Ord a => a -> a -> Bool
< Int
8))) forall a b. (a -> b) -> a -> b
$ do
        forall e s (m :: * -> *). MonadParsec e s m => Int -> m ()
setOffset Int
pos
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
Maybe (ErrorItem (Token s)) -> Set (ErrorItem (Token s)) -> m a
failure
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. NonEmpty t -> ErrorItem t
Tokens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
toks)
          (forall a. a -> Set a
E.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty Char -> ErrorItem t
Label forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ String
"valid IPv6 address")
    ipvFuture :: m ()
ipvFuture = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'v')
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.')
      forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':')
    regName :: m String
regName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> [[a]] -> [a]
intercalate String
".") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.') forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
        if Bool
pe
          then forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar
          else 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 = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiAlpha 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 = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiAlphaNum 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 = forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"unreserved character" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy forall a b. (a -> b) -> a -> b
$ \Char
x ->
  Char -> Bool
isAsciiAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x 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 = forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"unreserved character" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy forall a b. (a -> b) -> a -> b
$ \Char
x ->
  Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x 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
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'%')
  Int
h <- Char -> Int
digitToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
  Int
l <- Char -> Int
digitToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr forall a b. (a -> b) -> a -> b
$ Int
h forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ Int
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 = forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Char
s forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter"
  where
    s :: Set Char
s = 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 =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar,
      forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar,
      forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar,
      forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':',
      forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'@'
    ]
{-# 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' =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall e (m :: * -> *). MonadParsec e Text m => m Char
unreservedChar,
      forall e (m :: * -> *). MonadParsec e Text m => m Char
percentEncChar,
      forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'+' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
' ',
      forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf Set Char
s forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"sub-delimiter",
      forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':',
      forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'@'
    ]
  where
    s :: Set Char
s = 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