modern-uri 0.3.4.1 → 0.3.4.2
raw patch · 6 files changed
+175/−80 lines, 6 filesdep ~megaparsecdep ~template-haskell
Dependency ranges changed: megaparsec, template-haskell
Files
- CHANGELOG.md +6/−0
- README.md +8/−9
- Text/URI/Parser/ByteString.hs +70/−32
- Text/URI/Parser/Text.hs +69/−31
- modern-uri.cabal +8/−8
- tests/Text/URISpec.hs +14/−0
CHANGELOG.md view
@@ -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.
README.md view
@@ -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.
Text/URI/Parser/ByteString.hs view
@@ -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
Text/URI/Parser/Text.hs view
@@ -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 #-}
modern-uri.cabal view
@@ -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 <markkarpov92@gmail.com> author: Mark Karpov <markkarpov92@gmail.com>-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
tests/Text/URISpec.hs view
@@ -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