diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## Modern URI 0.3.4.2 + +* Improved handling of percent-encoded sequences of bytes that cannot be + decoded as UTF-8 text. Now friendly error messages are reported in these + cases. + ## Modern URI 0.3.4.1 * Works with GHC 9.0.1. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,19 +15,18 @@ The `modern-uri` package features: * Correct by construction `URI` data type. The correctness is ensured by - making sure that every sub-component of the `URI` record is by itself - cannot be invalid. This boils down to careful use of types and a set of - smart constructors. + making sure that every sub-component of the `URI` record cannot be + invalid. * Textual components in the `URI` data type are represented as `Text` rather than `ByteString`, because they are percent-decoded and so they can contain characters outside of ASCII range (i.e. Unicode). This allows for easier manipulation of `URI`s, while encoding and decoding headaches are handled by the parsers and renders for you. * Absolute and relative URIs differ only by the scheme component: if it's - `Nothing`, then URI is relative, otherwise it's absolute. -* Megaparsec parser that can be used as a standalone smart constructor for - the `URI` data type (see `mkURI`) as well as be seamlessly integrated into - a bigger Megaparsec parser that consumes strict `Text` (see `parser`) or + `Nothing`, then the URI is relative, otherwise it's absolute. +* A Megaparsec parser that can be used as a standalone smart constructor for + the `URI` data type (see `mkURI`) as well as seamlessly integrated into a + bigger Megaparsec parser that consumes a strict `Text` (see `parser`) or strict `ByteString` (see `parserBs`). * The parser performs some normalization, for example it collapses consecutive slashes. Some smart constructors such as `mkScheme` and @@ -88,7 +87,7 @@ Text -> m (RText 'Scheme)`. For example, if argument to `mkScheme` is not a valid scheme, an exception will be thrown. Note that monads such as `Maybe` are also instances of the `MonadThrow` type class, and so the smart -constructors may be used in pure setting as well. +constructors can be used in pure environment as well. There is a smart constructor that can make an entire `URI` too, it's called (unsurprisingly) `mkURI`: @@ -147,7 +146,7 @@ for scheme, host, and other components. Finally, the package provides two Megaparsec parsers: `parser` and -`parserBs`. The first works on strict `Text`, while other one works on +`parserBs`. The first works on strict `Text`, while the other one works on strict `ByteString`s. You can use the parsers in a bigger Megaparsec parser to parse `URI`s. diff --git a/Text/URI/Parser/ByteString.hs b/Text/URI/Parser/ByteString.hs --- a/Text/URI/Parser/ByteString.hs +++ b/Text/URI/Parser/ByteString.hs @@ -31,7 +31,9 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, isJust, maybeToList) import qualified Data.Set as E +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 Data.Word (Word8) @@ -73,17 +75,19 @@ pScheme :: MonadParsec e ByteString m => m (RText 'Scheme) pScheme = do - x <- asciiAlphaChar - xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46) + r <- liftR "scheme" mkScheme $ do + x <- asciiAlphaChar + xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46) + return (x : xs) void (char 58) - liftR mkScheme (x : xs) + return r {-# INLINE pScheme #-} pAuthority :: MonadParsec e ByteString m => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo - authHost <- pHost >>= liftR mkHost + authHost <- liftR "host" mkHost pHost authPort <- optional (char 58 *> L.decimal) return Authority {..} {-# INLINE pAuthority #-} @@ -154,13 +158,18 @@ pUserInfo :: MonadParsec e ByteString m => m UserInfo pUserInfo = try $ do uiUsername <- - label "username" $ - many (unreservedChar <|> percentEncChar <|> subDelimChar) - >>= liftR mkUsername + liftR + "username" + mkUsername + ( label "username" $ + many (unreservedChar <|> percentEncChar <|> subDelimChar) + ) uiPassword <- optional $ do void (char 58) - many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58) - >>= liftR mkPassword + liftR + "password" + mkPassword + (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58)) void (char 64) return UserInfo {..} {-# INLINE pUserInfo #-} @@ -174,12 +183,18 @@ when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) [47, 47] absPath <- option False (True <$ char 47) - (rawPieces, trailingSlash) <- flip runStateT False $ - flip sepBy (char 47) . label "path piece" $ do - x <- many pchar - put (null x) - return x - pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces) + let mkPathPiece' x = + if T.null x + then Just Nothing + else Just <$> mkPathPiece x + (maybePieces, trailingSlash) <- flip runStateT False $ + flip sepBy (char 47) $ + liftR "path piece" mkPathPiece' $ + label "path piece" $ do + x <- many pchar + put (null x) + return x + let pieces = catMaybes maybePieces return ( absPath, case NE.nonEmpty pieces of @@ -194,35 +209,58 @@ void (optional (char 38)) 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 + k <- liftR "query key" mkQueryKey p + mv <- optional (char 61 *> liftR "query value" mkQueryValue p) + return $ + if T.null (unRText k) + then Nothing + else + Just + ( case mv of + Nothing -> QueryFlag k + Just v -> QueryParam k 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 + liftR + "fragment" + mkFragment + ( many . label "fragment character" $ + pchar <|> char 47 <|> char 63 + ) {-# INLINE pFragment #-} ---------------------------------------------------------------------------- -- Helpers +-- | Lift a smart constructor that consumes 'Text' into a parser. liftR :: - MonadParsec e s m => - (forall n. MonadThrow n => Text -> n r) -> - [Word8] -> + MonadParsec e ByteString m => + -- | What is being parsed + String -> + -- | The smart constructor that produces the result + (Text -> Maybe r) -> + -- | How to parse @['Word8']@ that will be converted to 'Text' and fed to + -- the smart constructor + m [Word8] -> m r -liftR f = maybe empty return . f . TE.decodeUtf8 . B.pack +liftR lbl f p = do + o <- getOffset + (toks, s) <- match p + case TE.decodeUtf8' (B.pack s) of + Left _ -> do + let unexp = NE.fromList (B.unpack toks) + expecting = NE.fromList (lbl ++ " that can be decoded as UTF-8") + parseError + ( TrivialError + o + (Just (Tokens unexp)) + (S.singleton (Label expecting)) + ) + Right text -> maybe empty return (f text) {-# INLINE liftR #-} asciiAlphaChar :: MonadParsec e ByteString m => m Word8 diff --git a/Text/URI/Parser/Text.hs b/Text/URI/Parser/Text.hs --- a/Text/URI/Parser/Text.hs +++ b/Text/URI/Parser/Text.hs @@ -27,7 +27,9 @@ 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 @@ -65,17 +67,19 @@ pScheme :: MonadParsec e Text m => m (RText 'Scheme) pScheme = do - x <- asciiAlphaChar - xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') + r <- liftR "scheme" mkScheme $ do + x <- asciiAlphaChar + xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') + return (x : xs) void (char ':') - liftR mkScheme (x : xs) + return r {-# INLINE pScheme #-} pAuthority :: MonadParsec e Text m => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo - authHost <- pHost True >>= liftR mkHost + authHost <- liftR "host" mkHost (pHost True) authPort <- optional (char ':' *> L.decimal) return Authority {..} {-# INLINE pAuthority #-} @@ -83,13 +87,18 @@ pUserInfo :: MonadParsec e Text m => m UserInfo pUserInfo = try $ do uiUsername <- - label "username" $ - many (unreservedChar <|> percentEncChar <|> subDelimChar) - >>= liftR mkUsername + liftR + "username" + mkUsername + ( label "username" $ + many (unreservedChar <|> percentEncChar <|> subDelimChar) + ) uiPassword <- optional $ do void (char ':') - many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':') - >>= liftR mkPassword + liftR + "password" + mkPassword + (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':')) void (char '@') return UserInfo {..} {-# INLINE pUserInfo #-} @@ -103,12 +112,18 @@ when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) "//" absPath <- option False (True <$ char '/') - (rawPieces, trailingSlash) <- flip runStateT False $ - flip sepBy (char '/') . label "path piece" $ do - x <- many pchar - put (null x) - return x - pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces) + let mkPathPiece' x = + if T.null x + then Just Nothing + else Just <$> mkPathPiece 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 = catMaybes maybePieces return ( absPath, case NE.nonEmpty pieces of @@ -123,33 +138,56 @@ void (optional (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 + k <- liftR "query key" mkQueryKey p + mv <- optional (char '=' *> liftR "query value" mkQueryValue p) + return $ + if T.null (unRText k) + then Nothing + else + Just + ( case mv of + Nothing -> QueryFlag k + Just v -> QueryParam k v + ) {-# INLINE pQuery #-} pFragment :: MonadParsec e Text m => m (RText 'Fragment) pFragment = do void (char '#') - xs <- - many . label "fragment character" $ - pchar <|> char '/' <|> char '?' - liftR mkFragment xs + liftR + "fragment" + mkFragment + ( many . label "fragment character" $ + pchar <|> char '/' <|> char '?' + ) {-# INLINE pFragment #-} ---------------------------------------------------------------------------- -- Helpers +-- | Lift a smart constructor that consumes 'Text' into a parser. liftR :: - MonadParsec e s m => - (forall n. MonadThrow n => Text -> n r) -> + 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 f = maybe empty return . f . TE.decodeUtf8 . B8.pack +liftR lbl f p = do + o <- getOffset + (toks, s) <- match p + case TE.decodeUtf8' (B8.pack s) of + Left _ -> do + let unexp = NE.fromList (T.unpack toks) + expecting = NE.fromList (lbl ++ " that can be decoded as UTF-8") + parseError + ( TrivialError + o + (Just (Tokens unexp)) + (S.singleton (Label expecting)) + ) + Right text -> maybe empty return (f text) {-# INLINE liftR #-} diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 name: modern-uri -version: 0.3.4.1 +version: 0.3.4.2 license: BSD3 license-file: LICENSE.md maintainer: Mark Karpov author: Mark Karpov -tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.4 ghc ==9.0.1 +tested-with: ghc ==8.8.4 ghc ==8.10.5 ghc ==9.0.1 homepage: https://github.com/mrkkrp/modern-uri bug-reports: https://github.com/mrkkrp/modern-uri/issues synopsis: Modern library for working with URIs @@ -82,8 +82,8 @@ bytestring >=0.2 && <0.12, hspec >=2.0 && <3.0, hspec-megaparsec >=2.0 && <3.0, - megaparsec >=7.0 && <10.0, - modern-uri -any, + megaparsec >=8.0 && <10.0, + modern-uri, text >=0.2 && <1.3 if flag(dev) @@ -101,8 +101,8 @@ base >=4.13 && <5.0, bytestring >=0.2 && <0.12, criterion >=0.6.2.1 && <1.6, - megaparsec >=7.0 && <10.0, - modern-uri -any, + megaparsec >=8.0 && <10.0, + modern-uri, text >=0.2 && <1.3 if flag(dev) @@ -120,8 +120,8 @@ base >=4.13 && <5.0, bytestring >=0.2 && <0.12, deepseq >=1.3 && <1.5, - megaparsec >=7.0 && <10.0, - modern-uri -any, + megaparsec >=8.0 && <10.0, + modern-uri, text >=0.2 && <1.3, weigh >=0.0.4 diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -248,6 +248,20 @@ uri <- mkTestURI let s = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri+%3a@?&foo:@=bar+:@#fragment:@" parse urip "" s `shouldParse` uri + it "treats gracefully percent-encoded sequences that are not UTF-8 encoded Text" $ do + let s = "https://foo%f0bar" + parse urip "" s + `shouldFailWith` err + 8 + ( mconcat + [ utoks "foo%f0bar", + etok '%', + etok '-', + etok '.', + elabel "ASCII alpha-numeric character", + elabel "host that can be decoded as UTF-8" + ] + ) describe "render" $ do it "sort of works" $ fmap URI.render mkTestURI `shouldReturn` testURI