1-- | 2-- Module : Text.URI.Parser.Text 3-- Copyright : © 2017–present Mark Karpov 4-- License : BSD 3 clause 5-- 6-- Maintainer : Mark Karpov <markkarpov92@gmail.com> 7-- Stability : experimental 8-- Portability : portable 9-- 10-- URI parser for strict 'Text', an internal module. 11 12{-# LANGUAGE DataKinds #-} 13{-# LANGUAGE FlexibleContexts #-} 14{-# LANGUAGE OverloadedStrings #-} 15{-# LANGUAGE RankNTypes #-} 16{-# LANGUAGE RecordWildCards #-} 17 18module Text.URI.Parser.Text 19 ( mkURI 20 , parser ) 21where 22 23import Control.Monad 24import Control.Monad.Catch (MonadThrow (..)) 25import Control.Monad.State.Strict 26import Data.List.NonEmpty (NonEmpty (..)) 27import Data.Maybe (isJust, catMaybes) 28import Data.Text (Text) 29import Data.Void 30import Text.Megaparsec 31import Text.Megaparsec.Char 32import Text.URI.Parser.Text.Utils 33import Text.URI.Types 34import qualified Data.ByteString.Char8 as B8 35import qualified Data.List.NonEmpty as NE 36import qualified Data.Text.Encoding as TE 37import qualified Text.Megaparsec.Char.Lexer as L 38 39-- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a 40-- valid URI as per RFC 3986, that is, its components should be 41-- percent-encoded where necessary. In case of parse failure 42-- 'ParseException' is thrown. 43-- 44-- This function uses the 'parser' parser under the hood, which you can also 45-- use directly in a Megaparsec parser. 46 47mkURI :: MonadThrow m => Text -> m URI 48mkURI input = 49 case runParser (parser <* eof :: Parsec Void Text URI) "" input of 50 Left b -> throwM (ParseException b) 51 Right x -> return x 52 53-- | This parser can be used to parse 'URI' from strict 'Text'. Remember to 54-- use a concrete non-polymorphic parser type for efficiency. 55 56parser :: MonadParsec e Text m => m URI 57parser = do 58 uriScheme <- optional (try pScheme) 59 mauth <- optional pAuthority 60 (absPath, uriPath) <- pPath (isJust mauth) 61 uriQuery <- option [] pQuery 62 uriFragment <- optional pFragment 63 let uriAuthority = maybe (Left absPath) Right mauth 64 return URI {..} 65{-# INLINEABLE parser #-} 66{-# SPECIALIZE parser :: Parsec Void Text URI #-} 67 68pScheme :: MonadParsec e Text m => m (RText 'Scheme) 69pScheme = do 70 x <- asciiAlphaChar 71 xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') 72 void (char ':') 73 liftR mkScheme (x:xs) 74{-# INLINE pScheme #-} 75 76pAuthority :: MonadParsec e Text m => m Authority 77pAuthority = do 78 void (string "//") 79 authUserInfo <- optional pUserInfo 80 authHost <- pHost True >>= liftR mkHost 81 authPort <- optional (char ':' *> L.decimal) 82 return Authority {..} 83{-# INLINE pAuthority #-} 84 85pUserInfo :: MonadParsec e Text m => m UserInfo 86pUserInfo = try $ do 87 uiUsername <- label "username" $ 88 many (unreservedChar <|> percentEncChar <|> subDelimChar) 89 >>= liftR mkUsername 90 uiPassword <- optional $ do 91 void (char ':') 92 many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':') 93 >>= liftR mkPassword 94 void (char '@') 95 return UserInfo {..} 96{-# INLINE pUserInfo #-} 97 98pPath :: MonadParsec e Text m 99 => Bool 100 -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) 101pPath hasAuth = do 102 doubleSlash <- lookAhead (option False (True <$ string "//")) 103 when (doubleSlash && not hasAuth) $ 104 (unexpected . Tokens . NE.fromList) "//" 105 absPath <- option False (True <$ char '/') 106 (rawPieces, trailingSlash) <- flip runStateT False $ 107 flip sepBy (char '/') . label "path piece" $ do 108 x <- many pchar 109 put (null x) 110 return x 111 pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces) 112 return 113 ( absPath 114 , case NE.nonEmpty pieces of 115 Nothing -> Nothing 116 Just ps -> Just (trailingSlash, ps) 117 ) 118{-# INLINE pPath #-} 119 120pQuery :: MonadParsec e Text m => m [QueryParam] 121pQuery = do 122 void (char '?') 123 void (optional (char '&')) 124 fmap catMaybes . flip sepBy (char '&') . label "query parameter" $ do 125 let p = many (pchar' <|> char '/' <|> char '?') 126 k' <- p 127 mv <- optional (char '=' *> p) 128 k <- liftR mkQueryKey k' 129 if null k' 130 then return Nothing 131 else Just <$> case mv of 132 Nothing -> return (QueryFlag k) 133 Just v -> QueryParam k <$> liftR mkQueryValue v 134{-# INLINE pQuery #-} 135 136pFragment :: MonadParsec e Text m => m (RText 'Fragment) 137pFragment = do 138 void (char '#') 139 xs <- many . label "fragment character" $ 140 pchar <|> char '/' <|> char '?' 141 liftR mkFragment xs 142{-# INLINE pFragment #-} 143 144---------------------------------------------------------------------------- 145-- Helpers 146 147liftR :: MonadParsec e s m 148 => (forall n. MonadThrow n => Text -> n r) 149 -> String 150 -> m r 151liftR f = maybe empty return . f . TE.decodeUtf8 . B8.pack 152{-# INLINE liftR #-} 153