{-# 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 forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (forall e (m :: * -> *). MonadParsec e Text m => m URI
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: Parsec Void Text URI) String
"" Text
input of
    Left ParseErrorBundle Text Void
b -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseErrorBundle Text Void -> ParseException
ParseException ParseErrorBundle Text Void
b)
    Right URI
x -> 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
  Maybe (RText 'Scheme)
uriScheme <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Scheme)
pScheme)
  Maybe Authority
mauth <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e (m :: * -> *). MonadParsec e Text m => m Authority
pAuthority
  (Bool
absPath, Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath) <- forall e (m :: * -> *).
MonadParsec e Text m =>
Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
pPath (forall a. Maybe a -> Bool
isJust Maybe Authority
mauth)
  [QueryParam]
uriQuery <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option [] forall e (m :: * -> *). MonadParsec e Text m => m [QueryParam]
pQuery
  Maybe (RText 'Fragment)
uriFragment <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e (m :: * -> *). MonadParsec e Text m => m (RText 'Fragment)
pFragment
  let uriAuthority :: Either Bool Authority
uriAuthority = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Bool
absPath) forall a b. b -> Either a b
Right Maybe Authority
mauth
  forall (m :: * -> *) a. Monad m => a -> m a
return URI {[QueryParam]
Maybe (Bool, NonEmpty (RText 'PathPiece))
Maybe (RText 'Scheme)
Maybe (RText 'Fragment)
Either Bool Authority
uriFragment :: Maybe (RText 'Fragment)
uriQuery :: [QueryParam]
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriAuthority :: Either Bool Authority
uriScheme :: Maybe (RText 'Scheme)
uriAuthority :: Either Bool Authority
uriFragment :: Maybe (RText 'Fragment)
uriQuery :: [QueryParam]
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriScheme :: Maybe (RText 'Scheme)
..}
{-# 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
  RText 'Scheme
r <- forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"scheme" forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
mkScheme forall a b. (a -> b) -> a -> b
$ do
    Char
x <- forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaChar
    String
xs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e (m :: * -> *). MonadParsec e Text m => m Char
asciiAlphaNumChar 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
'+' 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
'-' 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
'.')
    forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x forall a. a -> [a] -> [a]
: String
xs)
  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. Monad m => a -> m a
return RText 'Scheme
r
{-# INLINE pScheme #-}

pAuthority :: (MonadParsec e Text m) => m Authority
pAuthority :: forall e (m :: * -> *). MonadParsec e Text m => m Authority
pAuthority = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"//")
  Maybe UserInfo
authUserInfo <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e (m :: * -> *). MonadParsec e Text m => m UserInfo
pUserInfo
  RText 'Host
authHost <- forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"host" forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
mkHost (forall e (m :: * -> *). MonadParsec e Text m => Bool -> m String
pHost Bool
True)
  Maybe Word
authPort <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)
  forall (m :: * -> *) a. Monad m => a -> m a
return Authority {Maybe Word
Maybe UserInfo
RText 'Host
authPort :: Maybe Word
authHost :: RText 'Host
authUserInfo :: Maybe UserInfo
authPort :: Maybe Word
authHost :: RText 'Host
authUserInfo :: Maybe UserInfo
..}
{-# INLINE pAuthority #-}

pUserInfo :: (MonadParsec e Text m) => m UserInfo
pUserInfo :: forall e (m :: * -> *). MonadParsec e Text m => m UserInfo
pUserInfo = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
  RText 'Username
uiUsername <-
    forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
      String
"username"
      forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
mkUsername
      ( forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"username" forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (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
percentEncChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e (m :: * -> *). MonadParsec e Text m => m Char
subDelimChar)
      )
  Maybe (RText 'Password)
uiPassword <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ 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
':')
    forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
      String
"password"
      forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Password)
mkPassword
      (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (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
percentEncChar 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
':'))
  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. Monad m => a -> m a
return UserInfo {Maybe (RText 'Password)
RText 'Username
uiPassword :: Maybe (RText 'Password)
uiUsername :: RText 'Username
uiPassword :: Maybe (RText 'Password)
uiUsername :: RText 'Username
..}
{-# 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
  Bool
doubleSlash <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (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 =>
Tokens s -> m (Tokens s)
string Tokens Text
"//"))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
doubleSlash Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasAuth) forall a b. (a -> b) -> a -> b
$
    (forall e s (m :: * -> *) a.
MonadParsec e s m =>
ErrorItem (Token s) -> m a
unexpected forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. NonEmpty t -> ErrorItem t
Tokens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NE.fromList) [Token Text]
"//"
  Bool
absPath <- 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
'/')
  let mkPathPiece' :: Text -> Maybe (Maybe (RText 'PathPiece))
mkPathPiece' Text
x =
        if Text -> Bool
T.null Text
x
          then forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
          else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
mkPathPiece Text
x
  ([Maybe (RText 'PathPiece)]
maybePieces, Bool
trailingSlash) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
False forall a b. (a -> b) -> a -> b
$
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (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 (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"path piece" Text -> Maybe (Maybe (RText 'PathPiece))
mkPathPiece' forall a b. (a -> b) -> a -> b
$
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"path piece" forall a b. (a -> b) -> a -> b
$ do
          String
x <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar
          forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x)
          forall (m :: * -> *) a. Monad m => a -> m a
return String
x
  let pieces :: [RText 'PathPiece]
pieces = forall a. [Maybe a] -> [a]
catMaybes [Maybe (RText 'PathPiece)]
maybePieces
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Bool
absPath,
      case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [RText 'PathPiece]
pieces of
        Maybe (NonEmpty (RText 'PathPiece))
Nothing -> forall a. Maybe a
Nothing
        Just NonEmpty (RText 'PathPiece)
ps -> 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
  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 (f :: * -> *) a. Functor f => f a -> f ()
void (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'&'))
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes 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]
sepBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'&') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"query parameter" forall a b. (a -> b) -> a -> b
$ do
    let p :: m String
p = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar' 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
'/' 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
'?')
    RText 'QueryKey
k <- forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"query key" forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey m String
p
    Maybe (RText 'QueryValue)
mv <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR String
"query value" forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryValue)
mkQueryValue m String
p)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      if Text -> Bool
T.null (forall (l :: RTextLabel). RText l -> Text
unRText RText 'QueryKey
k)
        then forall a. Maybe a
Nothing
        else
          forall a. a -> Maybe a
Just
            ( case Maybe (RText 'QueryValue)
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
  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 e (m :: * -> *) r.
MonadParsec e Text m =>
String -> (Text -> Maybe r) -> m String -> m r
liftR
    String
"fragment"
    forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Fragment)
mkFragment
    ( forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"fragment character" forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *). MonadParsec e Text m => m Char
pchar 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
'/' 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
'?'
    )
{-# 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
  Int
o <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  (Text
toks, String
s) <- forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m String
p
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' (String -> ByteString
B8.pack String
s) of
    Left UnicodeException
_ -> do
      let unexp :: NonEmpty Char
unexp = forall a. [a] -> NonEmpty a
NE.fromList (Text -> String
T.unpack Text
toks)
          expecting :: NonEmpty Char
expecting = forall a. [a] -> NonEmpty a
NE.fromList (String
lbl forall a. [a] -> [a] -> [a]
++ String
" that can be decoded as UTF-8")
      forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError
        ( forall s e.
Int
-> Maybe (ErrorItem (Token s))
-> Set (ErrorItem (Token s))
-> ParseError s e
TrivialError
            Int
o
            (forall a. a -> Maybe a
Just (forall t. NonEmpty t -> ErrorItem t
Tokens NonEmpty Char
unexp))
            (forall a. a -> Set a
S.singleton (forall t. NonEmpty Char -> ErrorItem t
Label NonEmpty Char
expecting))
        )
    Right Text
text -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe r
f Text
text)
{-# INLINE liftR #-}