modern-uri-0.0.2.0: Text/URI/Parser/ByteString.hs
-- |
-- Module : Text.URI.Parser.ByteString
-- Copyright : © 2017 Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov92@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- URI parsers for string 'ByteString', an internal module.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Text.URI.Parser.ByteString
( parserBs )
where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadThrow (..))
import Data.ByteString (ByteString)
import Data.Char
import Data.List (intercalate)
import Data.Maybe (isNothing, catMaybes, maybeToList)
import Data.Text (Text)
import Data.Word (Word8)
import Text.Megaparsec
import Text.Megaparsec.Byte
import Text.URI.Types hiding (pHost)
import qualified Data.ByteString as B
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as E
import qualified Data.Text.Encoding as TE
import qualified Text.Megaparsec.Byte.Lexer as L
-- | This parser can be used to parse 'URI' from strict 'ByteString'.
-- Remember to use a concrete non-polymorphic parser type for efficiency.
--
-- @since 0.0.2.0
parserBs :: MonadParsec e ByteString m => m URI
parserBs = do
uriScheme <- optional (try pScheme)
uriAuthority <- optional pAuthority
uriPath <- pPath (isNothing uriAuthority)
uriQuery <- option [] pQuery
uriFragment <- optional pFragment
return URI {..}
{-# INLINEABLE parserBs #-}
pScheme :: MonadParsec e ByteString m => m (RText 'Scheme)
pScheme = do
x <- asciiAlphaChar
xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46)
void (char 58)
liftR mkScheme (x:xs)
{-# INLINE pScheme #-}
pAuthority :: MonadParsec e ByteString m => m Authority
pAuthority = do
void (string "//")
authUserInfo <- optional pUserInfo
authHost <- pHost >>= liftR mkHost
authPort <- optional (char 58 *> L.decimal)
return Authority {..}
{-# INLINE pAuthority #-}
-- | Parser that can parse host names.
pHost :: MonadParsec e ByteString m => m [Word8]
pHost = choice
[ try (asConsumed ipLiteral)
, try (asConsumed ipv4Address)
, regName ]
where
asConsumed :: MonadParsec e ByteString m => m a -> m [Word8]
asConsumed p = B.unpack . fst <$> match p
ipLiteral = between (char 91) (char 93) $
try ipv6Address <|> ipvFuture
octet = do
pos <- getNextTokenPosition
(toks, x) <- match L.decimal
when (x >= (256 :: Integer)) $ do
mapM_ setPosition pos
failure
(fmap Tokens . NE.nonEmpty . B.unpack $ toks)
(E.singleton . Label . NE.fromList $ "decimal number from 0 to 255")
ipv4Address =
count 3 (octet <* char 46) *> octet
ipv6Address = do
pos <- getNextTokenPosition
(toks, xs) <- match $ do
xs' <- maybeToList <$> optional ([] <$ string "::")
xs <- flip sepBy1 (char 58) $ do
(skip, hasMore) <- lookAhead . hidden $ do
skip <- option False (True <$ char 58)
hasMore <- option False (True <$ hexDigitChar)
return (skip, hasMore)
case (skip, hasMore) of
(True, True) -> return []
(True, False) -> [] <$ char 58
(False, _) -> count' 1 4 hexDigitChar
return (xs' ++ xs)
let nskips = length (filter null xs)
npieces = length xs
unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do
mapM_ setPosition pos
failure
(fmap Tokens . NE.nonEmpty . B.unpack $ toks)
(E.singleton . Label . NE.fromList $ "valid IPv6 address")
ipvFuture = do
void (char 118)
void hexDigitChar
void (char 46)
skipSome (unreservedChar <|> subDelimChar <|> char 58)
regName = fmap (intercalate [46]) . flip sepBy1 (char 46) $ do
let ch = percentEncChar <|> asciiAlphaNumChar
x <- ch
let r = ch <|> try
(char 45 <* (lookAhead . try) (ch <|> char 45))
xs <- many r
return (x:xs)
pUserInfo :: MonadParsec e ByteString m => m UserInfo
pUserInfo = try $ do
uiUsername <- label "username" $
many (unreservedChar <|> percentEncChar <|> subDelimChar)
>>= liftR mkUsername
uiPassword <- optional $ do
void (char 58)
many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58)
>>= liftR mkPassword
void (char 64)
return UserInfo {..}
{-# INLINE pUserInfo #-}
pPath :: MonadParsec e ByteString m => Bool -> m [RText 'PathPiece]
pPath hadNoAuth = do
doubleSlash <- lookAhead (True <$ string "//" <|> pure False)
when (doubleSlash && hadNoAuth) $
(unexpected . Tokens . NE.fromList) [47,47]
path <- flip sepBy (char 47) . label "path piece" $
many pchar
mapM (liftR mkPathPiece) (filter (not . null) path)
{-# INLINE pPath #-}
pQuery :: MonadParsec e ByteString m => m [QueryParam]
pQuery = do
void (char 63)
fmap catMaybes . flip sepBy (char 38) . label "query parameter" $ do
let p = many (pchar' <|> char 47 <|> char 63)
k' <- p
mv <- optional (char 61 *> 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
{-# INLINE pQuery #-}
pFragment :: MonadParsec e ByteString m => m (RText 'Fragment)
pFragment = do
void (char 35)
xs <- many . label "fragment character" $
pchar <|> char 47 <|> char 63
liftR mkFragment xs
{-# INLINE pFragment #-}
----------------------------------------------------------------------------
-- Helpers
liftR :: MonadParsec e s m
=> (forall n. MonadThrow n => Text -> n r)
-> [Word8]
-> m r
liftR f = maybe empty return . f . TE.decodeUtf8 . B.pack
{-# INLINE liftR #-}
asciiAlphaChar :: MonadParsec e ByteString m => m Word8
asciiAlphaChar = satisfy isAsciiAlpha <?> "ASCII alpha character"
{-# INLINE asciiAlphaChar #-}
asciiAlphaNumChar :: MonadParsec e ByteString m => m Word8
asciiAlphaNumChar = satisfy isAsciiAlphaNum <?> "ASCII alpha-numeric character"
{-# INLINE asciiAlphaNumChar #-}
unreservedChar :: MonadParsec e ByteString m => m Word8
unreservedChar = label "unreserved character" . satisfy $ \x ->
isAsciiAlphaNum x || x == 45 || x == 46 || x == 95 || x == 126
{-# INLINE unreservedChar #-}
percentEncChar :: MonadParsec e ByteString m => m Word8
percentEncChar = do
void (char 37)
h <- restoreDigit <$> hexDigitChar
l <- restoreDigit <$> hexDigitChar
return (h * 16 + l)
{-# INLINE percentEncChar #-}
subDelimChar :: MonadParsec e ByteString m => m Word8
subDelimChar = oneOf s <?> "sub-delimiter"
where
s = E.fromList (fromIntegral . ord <$> "!$&'()*+,;=")
{-# INLINE subDelimChar #-}
pchar :: MonadParsec e ByteString m => m Word8
pchar = choice
[ unreservedChar
, percentEncChar
, subDelimChar
, char 58
, char 64 ]
{-# INLINE pchar #-}
pchar' :: MonadParsec e ByteString m => m Word8
pchar' = choice
[ unreservedChar
, percentEncChar
, oneOf s <?> "sub-delimiter"
, char 58
, char 64 ]
where
s = E.fromList (fromIntegral . ord <$> "!$'()*+,;")
{-# INLINE pchar' #-}
isAsciiAlpha :: Word8 -> Bool
isAsciiAlpha x
| 65 <= x && x <= 90 = True
| 97 <= x && x <= 122 = True
| otherwise = False
isAsciiAlphaNum :: Word8 -> Bool
isAsciiAlphaNum x
| isAsciiAlpha x = True
| 48 <= x && x <= 57 = True
| otherwise = False
restoreDigit :: Word8 -> Word8
restoreDigit x
| 48 <= x && x <= 57 = x - 48
| 65 <= x && x <= 70 = x - 55
| 97 <= x && x <= 102 = x - 87
| otherwise = error "Text.URI.Parser.restoreDigit: bad input"