{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Text.URI.Parser.Text
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- URI parser for strict 'Text', an internal module.
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

-- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a
-- valid URI as per RFC 3986, that is, its components should be
-- percent-encoded where necessary. In case of parse failure
-- 'ParseException' is thrown.
--
-- This function uses the 'parser' parser under the hood, which you can also
-- use directly in a Megaparsec parser.
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

-- | This parser can be used to parse 'URI' from strict 'Text'. Remember to
-- use a concrete non-polymorphic parser type for efficiency.
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 #-}

----------------------------------------------------------------------------
-- Helpers

-- | Lift a smart constructor that consumes 'Text' into a parser.
liftR ::
  (MonadParsec e Text m) =>
  -- | What is being parsed
  String ->
  -- | The smart constructor that produces the result
  (Text -> Maybe r) ->
  -- | How to parse 'String' that will be converted to 'Text' and fed to
  -- the smart constructor
  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 #-}