diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Modern URI 0.2.2.0 + +* Removed a potentially overlapping instance `Arbitrary (NonEmpty (RText + 'PathPiece))`. + +* Fixed a bug that made it impossible to have empty host names. This allows + us to parse URIs like `file:///etc/hosts`. + ## Modern URI 0.2.1.0 * Added `emptyURI`—`URI` value representing the empty URI. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,6 @@ [![Stackage Nightly](http://stackage.org/package/modern-uri/badge/nightly)](http://stackage.org/nightly/package/modern-uri) [![Stackage LTS](http://stackage.org/package/modern-uri/badge/lts)](http://stackage.org/lts/package/modern-uri) [![Build Status](https://travis-ci.org/mrkkrp/modern-uri.svg?branch=master)](https://travis-ci.org/mrkkrp/modern-uri) -[![Coverage Status](https://coveralls.io/repos/mrkkrp/modern-uri/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/modern-uri?branch=master) This is a modern library for working with URIs in Haskell as per RFC 3986: 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 @@ -128,11 +128,14 @@ 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) + mx <- optional ch + case mx of + Nothing -> return [] + Just x -> do + 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 diff --git a/Text/URI/Parser/Text/Utils.hs b/Text/URI/Parser/Text/Utils.hs --- a/Text/URI/Parser/Text/Utils.hs +++ b/Text/URI/Parser/Text/Utils.hs @@ -90,11 +90,14 @@ if pe then percentEncChar <|> asciiAlphaNumChar else alphaNumChar - x <- ch - let r = ch <|> try - (char '-' <* (lookAhead . try) (ch <|> char '-')) - xs <- many r - return (x:xs) + mx <- optional ch + case mx of + Nothing -> return "" + Just x -> do + let r = ch <|> try + (char '-' <* (lookAhead . try) (ch <|> char '-')) + xs <- many r + return (x:xs) {-# INLINEABLE pHost #-} -- | Parse an ASCII alpha character. diff --git a/Text/URI/Render.hs b/Text/URI/Render.hs --- a/Text/URI/Render.hs +++ b/Text/URI/Render.hs @@ -9,6 +9,7 @@ -- -- URI renders, an internal module. +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -33,7 +34,6 @@ import Data.Char (chr, intToDigit) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid import Data.Proxy import Data.Reflection import Data.Semigroup (Semigroup) @@ -54,6 +54,10 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder.Int as TLB +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif + ---------------------------------------------------------------------------- -- High-level wrappers @@ -264,7 +268,7 @@ instance RLabel 'Host where needsNoEscaping Proxy x = isUnreserved x || isDelim x - skipEscaping Proxy x = T.head x == '[' + skipEscaping Proxy x = T.take 1 x == "[" instance RLabel 'Username where needsNoEscaping Proxy x = isUnreserved x || isDelim x diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs --- a/Text/URI/Types.hs +++ b/Text/URI/Types.hs @@ -339,9 +339,6 @@ instance Arbitrary (RText 'PathPiece) where arbitrary = arbText' mkPathPiece -instance Arbitrary (NonEmpty (RText 'PathPiece)) where - arbitrary = (:|) <$> arbitrary <*> arbitrary - -- | Lift a 'Text' value into @'RText 'QueryKey'@. -- -- This smart constructor does not perform any sort of normalization. @@ -437,7 +434,9 @@ arbHost = fromJust . mkHost . T.pack <$> frequency [ (1, ipLiteral) , (2, ipv4Address) - , (4, regName) ] + , (4, regName) + , (1, return "") + ] where ipLiteral = do xs <- oneof [ipv6Address, ipvFuture] diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,7 +1,7 @@ name: modern-uri -version: 0.2.1.0 -cabal-version: >= 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 +version: 0.2.2.0 +cabal-version: 1.18 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -31,13 +31,13 @@ , containers >= 0.5 && < 0.6 , contravariant >= 1.3 && < 2.0 , deepseq >= 1.3 && < 1.5 - , exceptions >= 0.6 && < 0.9 + , exceptions >= 0.6 && < 0.11 , megaparsec >= 6.0 && < 7.0 , mtl >= 2.0 && < 3.0 , profunctors >= 5.2.1 && < 6.0 , reflection >= 2.0 && < 3.0 , tagged >= 0.8 && < 0.9 - , template-haskell >= 2.10 && < 2.13 + , template-haskell >= 2.10 && < 2.14 , text >= 0.2 && < 1.3 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* @@ -53,6 +53,12 @@ ghc-options: -Wall -Werror else ghc-options: -O2 -Wall + if flag(dev) && impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite tests @@ -67,6 +73,7 @@ , megaparsec >= 6.0 && < 7.0 , modern-uri , text >= 0.2 && < 1.3 + build-tools: hspec-discover >= 2.0 && < 3.0 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* other-modules: Text.URISpec @@ -82,7 +89,7 @@ type: exitcode-stdio-1.0 build-depends: base >= 4.7 && < 5.0 , bytestring >= 0.2 && < 0.11 - , criterion >= 0.6.2.1 && < 1.4 + , criterion >= 0.6.2.1 && < 1.6 , megaparsec >= 6.0 && < 7.0 , modern-uri , text >= 0.2 && < 1.3 diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -5,7 +5,7 @@ import Control.Monad import Data.ByteString (ByteString) -import Data.List.NonEmpty (fromList) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing, isJust) import Data.Monoid ((<>)) import Data.String (IsString (..)) @@ -16,6 +16,7 @@ import Test.QuickCheck import Text.Megaparsec import Text.URI (URI (..), RTextException (..), RTextLabel (..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Text.URI as URI @@ -106,6 +107,7 @@ URI.mkHost "github.com" `shouldRText` "github.com" URI.mkHost "foo.example.com" `shouldRText` "foo.example.com" URI.mkHost "юникод.рф" `shouldRText` "юникод.рф" + URI.mkHost "" `shouldRText` "" it "rejects invalid hosts" $ do URI.mkHost "_something" `shouldThrow` (== RTextException Host "_something") @@ -170,11 +172,19 @@ let s = "https://юникод.рф" parse urip "" s `shouldFailWith` err (posN 8 s) (mconcat [ utok 'ю' + , etok '#' , etok '%' + , etok '.' + , etok '/' + , etok ':' + , etok '?' , etok '[' , elabel "ASCII alpha-numeric character" , elabel "integer" - , elabel "username" ] ) + , elabel "username" + , elabel "path piece" + , eeof + ] ) it "rejects Unicode in path" $ do let s = "https://github.com/марк" parse urip "" s `shouldFailWith` err (posN 19 s) (mconcat @@ -184,6 +194,23 @@ , etok '?' , elabel "path piece" , eeof ] ) + it "parses URIs with empty authority" $ do + scheme <- URI.mkScheme "file" + ppetc <- URI.mkPathPiece "etc" + pphosts <- URI.mkPathPiece "hosts" + host <- URI.mkHost "" + let s = "file:///etc/hosts" + parse urip "" s `shouldParse` URI + { uriScheme = Just scheme + , uriAuthority = Right URI.Authority + { URI.authUserInfo = Nothing + , URI.authHost = host + , URI.authPort = Nothing + } + , uriPath = Just (False, ppetc :| [pphosts]) + , uriQuery = [] + , uriFragment = Nothing + } describe "render" $ do it "sort of works" $ fmap URI.render mkTestURI `shouldReturn` testURI @@ -250,10 +277,12 @@ { URI.uiUsername = username , URI.uiPassword = Just password } , URI.authHost = host - , URI.authPort = Just 443 } - , uriPath = Just (False, fromList path) + , URI.authPort = Just 443 + } + , uriPath = Just (False, NE.fromList path) , uriQuery = [URI.QueryParam k v] - , uriFragment = Just fragment } + , uriFragment = Just fragment + } -- | Polymorphic textual rendering of the 'URI' generated by 'mkTestURI'.