module Text.URI.Parser.Text
( mkURI
, parser )
where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Data.Maybe (isJust, catMaybes)
import Data.Text (Text)
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.URI.Parser.Text.Utils
import Text.URI.Types
import qualified Data.ByteString.Char8 as B8
import qualified Data.List.NonEmpty as NE
import qualified Data.Text.Encoding as TE
import qualified Text.Megaparsec.Char.Lexer as L
mkURI :: MonadThrow m => Text -> m URI
mkURI input =
case runParser (parser <* eof :: Parsec Void Text URI) "" input of
Left err -> throwM (ParseException input err)
Right x -> return x
parser :: MonadParsec e Text m => m URI
parser = do
uriScheme <- optional (try pScheme)
mauth <- optional pAuthority
(absPath, uriPath) <- pPath (isJust mauth)
uriQuery <- option [] pQuery
uriFragment <- optional pFragment
let uriAuthority = maybe (Left absPath) Right mauth
return URI {..}
pScheme :: MonadParsec e Text m => m (RText 'Scheme)
pScheme = do
x <- asciiAlphaChar
xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.')
void (char ':')
liftR mkScheme (x:xs)
pAuthority :: MonadParsec e Text m => m Authority
pAuthority = do
void (string "//")
authUserInfo <- optional pUserInfo
authHost <- pHost True >>= liftR mkHost
authPort <- optional (char ':' *> L.decimal)
return Authority {..}
pUserInfo :: MonadParsec e Text m => m UserInfo
pUserInfo = try $ do
uiUsername <- label "username" $
many (unreservedChar <|> percentEncChar <|> subDelimChar)
>>= liftR mkUsername
uiPassword <- optional $ do
void (char ':')
many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':')
>>= liftR mkPassword
void (char '@')
return UserInfo {..}
pPath :: MonadParsec e Text m => Bool -> m (Bool, [RText 'PathPiece])
pPath hasAuth = do
doubleSlash <- lookAhead (option False (True <$ string "//"))
when (doubleSlash && not hasAuth) $
(unexpected . Tokens . NE.fromList) "//"
absPath <- option False (True <$ char '/')
path <- flip sepBy (char '/') . label "path piece" $
many pchar
pieces <- mapM (liftR mkPathPiece) (filter (not . null) path)
return (absPath, pieces)
pQuery :: MonadParsec e Text m => m [QueryParam]
pQuery = do
void (char '?')
fmap catMaybes . flip sepBy (char '&') . label "query parameter" $ do
let p = many (pchar' <|> char '/' <|> char '?')
k' <- p
mv <- optional (char '=' *> p)
k <- liftR mkQueryKey k'
if null k'
then return Nothing
else Just <$> case mv of
Nothing -> return (QueryFlag k)
Just v -> QueryParam k <$> liftR mkQueryValue v
pFragment :: MonadParsec e Text m => m (RText 'Fragment)
pFragment = do
void (char '#')
xs <- many . label "fragment character" $
pchar <|> char '/' <|> char '?'
liftR mkFragment xs
liftR :: MonadParsec e s m
=> (forall n. MonadThrow n => Text -> n r)
-> String
-> m r
liftR f = maybe empty return . f . TE.decodeUtf8 . B8.pack