{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Text.URI.Parser.Text
( mkURI,
parser,
)
where
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as B8
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes, isJust)
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 Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.URI.Parser.Text.Utils
import Text.URI.Types
mkURI :: (MonadThrow m) => Text -> m URI
mkURI :: forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI Text
input =
case Parsec Void Text URI
-> String -> Text -> Either (ParseErrorBundle Text Void) URI
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void Text URI
forall e (m :: * -> *). MonadParsec e Text m => m URI
parser Parsec Void Text URI
-> ParsecT Void Text Identity () -> Parsec Void Text URI
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: Parsec Void Text URI) String
"" Text
input of
Left ParseErrorBundle Text Void
b -> ParseException -> 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 Text Void -> ParseException
ParseException ParseErrorBundle Text Void
b)
Right URI
x -> URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return URI
x
parser :: (MonadParsec e Text m) => m URI
parser :: forall e (m :: * -> *). MonadParsec e Text m => m URI
parser = 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 Text 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 parser #-}
{-# SPECIALIZE parser :: Parsec Void Text URI #-}
pScheme :: (MonadParsec e Text m) => m (RText 'Scheme)
pScheme :: forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Scheme)
pScheme = do
r <- String
-> (Text -> Maybe (RText 'Scheme)) -> m String -> m (RText 'Scheme)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"scheme" Text -> Maybe (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
mkScheme (m String -> m (RText 'Scheme)) -> m String -> m (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ do
x <- m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaChar
xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.')
return (x : xs)
void (char ':')
return r
{-# INLINE pScheme #-}
pAuthority :: (MonadParsec e Text m) => m Authority
pAuthority :: forall e (m :: * -> *). MonadParsec e Text m => m Authority
pAuthority = do
m (Tokens Text) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"//")
authUserInfo <- m UserInfo -> m (Maybe UserInfo)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m UserInfo
forall e (m :: * -> *). MonadParsec e Text m => m UserInfo
pUserInfo
authHost <- liftR "host" mkHost (pHost True)
authPort <- optional (char ':' *> L.decimal)
return Authority {..}
{-# INLINE pAuthority #-}
pUserInfo :: (MonadParsec e Text m) => m UserInfo
pUserInfo :: forall e (m :: * -> *). MonadParsec e Text 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 String
-> m (RText 'Username)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
String
"username"
Text -> Maybe (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
mkUsername
( String -> m String -> m String
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 String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$
m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (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
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
subDelimChar)
)
uiPassword <- optional $ do
void (char ':')
liftR
"password"
mkPassword
(many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':'))
void (char '@')
return UserInfo {..}
{-# INLINE pUserInfo #-}
pPath ::
(MonadParsec e Text m) =>
Bool ->
m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath :: forall e (m :: * -> *).
MonadParsec e Text 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 Text) -> m Bool
forall a b. a -> m b -> m a
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
"//"))
when (doubleSlash && not hasAuth) $
(unexpected . Tokens . NE.fromList) "//"
absPath <- option False (True <$ char '/')
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 '/') $
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 Text m) => m [QueryParam]
pQuery :: forall e (m :: * -> *). MonadParsec e Text m => m [QueryParam]
pQuery = 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
'?')
m (Maybe Char) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (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
'&'))
([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 Char -> m [Maybe QueryParam])
-> m Char -> m (Maybe QueryParam) -> m [Maybe QueryParam]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Maybe QueryParam) -> m Char -> m [Maybe QueryParam]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (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 (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 String
p = m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar' 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
'/' 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
'?')
k <- String
-> (Text -> Maybe (RText 'QueryKey))
-> m String
-> m (RText 'QueryKey)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"query key" Text -> Maybe (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey m String
p
mv <- optional (char '=' *> 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 Text m) => m (RText 'Fragment)
pFragment :: forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Fragment)
pFragment = 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
'#')
String
-> (Text -> Maybe (RText 'Fragment))
-> m String
-> m (RText 'Fragment)
forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
String
"fragment"
Text -> Maybe (RText 'Fragment)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Fragment)
mkFragment
( m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char -> m String) -> (m Char -> m Char) -> m Char -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"fragment character" (m Char -> m String) -> m Char -> m String
forall a b. (a -> b) -> a -> b
$
m Char
forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar 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
'/' 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
'?'
)
{-# INLINE pFragment #-}
liftR ::
(MonadParsec e Text m) =>
String ->
(Text -> Maybe r) ->
m String ->
m r
liftR :: forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
lbl Text -> Maybe r
f m String
p = do
o <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
(toks, s) <- match p
case TE.decodeUtf8' (B8.pack s) of
Left UnicodeException
_ -> do
let unexp :: NonEmpty Char
unexp = String -> NonEmpty Char
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (Text -> String
T.unpack Text
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 Text e -> m r
forall a. ParseError Text e -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError
( Int
-> Maybe (ErrorItem (Token Text))
-> Set (ErrorItem (Token Text))
-> ParseError Text e
forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError
Int
o
(ErrorItem Char -> Maybe (ErrorItem Char)
forall a. a -> Maybe a
Just (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens NonEmpty Char
unexp))
(ErrorItem Char -> Set (ErrorItem Char)
forall a. a -> Set a
S.singleton (NonEmpty Char -> ErrorItem Char
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 #-}