{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
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)
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
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 #-}
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 #-}
liftR ::
(MonadParsec e ByteString m) =>
String ->
(Text -> Maybe r) ->
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"