modern-uri 0.3.6.0 → 0.3.6.1
raw patch · 12 files changed
+138/−109 lines, 12 filesdep −contravariantdep ~QuickCheckdep ~basedep ~bytestring
Dependencies removed: contravariant
Dependency ranges changed: QuickCheck, base, bytestring, containers, deepseq, hashable, hspec, hspec-megaparsec, megaparsec, mtl, profunctors, reflection, template-haskell, text
Files
- CHANGELOG.md +6/−0
- Text/URI/Lens.hs +7/−3
- Text/URI/Parser/ByteString.hs +19/−19
- Text/URI/Parser/Text.hs +9/−9
- Text/URI/Parser/Text/Utils.hs +19/−23
- Text/URI/Render.hs +11/−11
- Text/URI/Types.hs +16/−11
- bench/memory/Main.hs +2/−2
- bench/speed/Main.hs +2/−2
- modern-uri.cabal +16/−17
- tests/Text/QQSpec.hs +1/−2
- tests/Text/URISpec.hs +30/−10
CHANGELOG.md view
@@ -1,3 +1,9 @@+## 0.3.6.1++* Host now can contain unreserved characters rather than simply alpha+ numeric ones, which was against RFC 3986. [Issue+ 73](https://github.com/mrkkrp/modern-uri/issues/73).+ ## 0.3.6.0 * Now colons are not escaped in paths, unless the `URI` in question is a
Text/URI/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}@@ -34,7 +35,6 @@ ) where -import Control.Applicative (liftA2) import Data.Foldable (find) import Data.Functor.Contravariant import qualified Data.List.NonEmpty as NE@@ -51,6 +51,10 @@ ) import qualified Text.URI.Types as URI +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+ -- | 'URI' scheme lens. uriScheme :: Lens' URI (Maybe (RText 'Scheme)) uriScheme f s = (\x -> s {URI.uriScheme = x}) <$> f (URI.uriScheme s)@@ -158,10 +162,10 @@ -- Helpers type Lens' s a =- forall f. Functor f => (a -> f a) -> s -> f s+ forall f. (Functor f) => (a -> f a) -> s -> f s type Traversal' s a =- forall f. Applicative f => (a -> f a) -> s -> f s+ forall f. (Applicative f) => (a -> f a) -> s -> f s type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s
Text/URI/Parser/ByteString.hs view
@@ -51,7 +51,7 @@ -- use directly in a Megaparsec parser. -- -- @since 0.3.3.0-mkURIBs :: MonadThrow m => ByteString -> m URI+mkURIBs :: (MonadThrow m) => ByteString -> m URI mkURIBs input = case runParser (parserBs <* eof :: Parsec Void ByteString URI) "" input of Left b -> throwM (ParseExceptionBs b)@@ -61,7 +61,7 @@ -- Remember to use a concrete non-polymorphic parser type for efficiency. -- -- @since 0.0.2.0-parserBs :: MonadParsec e ByteString m => m URI+parserBs :: (MonadParsec e ByteString m) => m URI parserBs = do uriScheme <- optional (try pScheme) mauth <- optional pAuthority@@ -73,7 +73,7 @@ {-# INLINEABLE parserBs #-} {-# SPECIALIZE parserBs :: Parsec Void ByteString URI #-} -pScheme :: MonadParsec e ByteString m => m (RText 'Scheme)+pScheme :: (MonadParsec e ByteString m) => m (RText 'Scheme) pScheme = do r <- liftR "scheme" mkScheme $ do x <- asciiAlphaChar@@ -83,7 +83,7 @@ return r {-# INLINE pScheme #-} -pAuthority :: MonadParsec e ByteString m => m Authority+pAuthority :: (MonadParsec e ByteString m) => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo@@ -93,7 +93,7 @@ {-# INLINE pAuthority #-} -- | Parser that can parse host names.-pHost :: MonadParsec e ByteString m => m [Word8]+pHost :: (MonadParsec e ByteString m) => m [Word8] pHost = choice [ try (asConsumed ipLiteral),@@ -101,7 +101,7 @@ regName ] where- asConsumed :: MonadParsec e ByteString m => m a -> m [Word8]+ asConsumed :: (MonadParsec e ByteString m) => m a -> m [Word8] asConsumed p = B.unpack . fst <$> match p ipLiteral = between (char 91) (char 93) $@@ -143,7 +143,7 @@ void (char 46) skipSome (unreservedChar <|> subDelimChar <|> char 58) regName = fmap (intercalate [46]) . flip sepBy1 (char 46) $ do- let ch = percentEncChar <|> asciiAlphaNumChar+ let ch = percentEncChar <|> unreservedChar mx <- optional ch case mx of Nothing -> return []@@ -155,7 +155,7 @@ xs <- many r return (x : xs) -pUserInfo :: MonadParsec e ByteString m => m UserInfo+pUserInfo :: (MonadParsec e ByteString m) => m UserInfo pUserInfo = try $ do uiUsername <- liftR@@ -175,7 +175,7 @@ {-# INLINE pUserInfo #-} pPath ::- MonadParsec e ByteString m =>+ (MonadParsec e ByteString m) => Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do@@ -203,7 +203,7 @@ ) {-# INLINE pPath #-} -pQuery :: MonadParsec e ByteString m => m [QueryParam]+pQuery :: (MonadParsec e ByteString m) => m [QueryParam] pQuery = do void (char 63) void (optional (char 38))@@ -222,7 +222,7 @@ ) {-# INLINE pQuery #-} -pFragment :: MonadParsec e ByteString m => m (RText 'Fragment)+pFragment :: (MonadParsec e ByteString m) => m (RText 'Fragment) pFragment = do void (char 35) liftR@@ -238,7 +238,7 @@ -- | Lift a smart constructor that consumes 'Text' into a parser. liftR ::- MonadParsec e ByteString m =>+ (MonadParsec e ByteString m) => -- | What is being parsed String -> -- | The smart constructor that produces the result@@ -263,20 +263,20 @@ Right text -> maybe empty return (f text) {-# INLINE liftR #-} -asciiAlphaChar :: MonadParsec e ByteString m => m Word8+asciiAlphaChar :: (MonadParsec e ByteString m) => m Word8 asciiAlphaChar = satisfy isAsciiAlpha <?> "ASCII alpha character" {-# INLINE asciiAlphaChar #-} -asciiAlphaNumChar :: MonadParsec e ByteString m => m Word8+asciiAlphaNumChar :: (MonadParsec e ByteString m) => m Word8 asciiAlphaNumChar = satisfy isAsciiAlphaNum <?> "ASCII alpha-numeric character" {-# INLINE asciiAlphaNumChar #-} -unreservedChar :: MonadParsec e ByteString m => m Word8+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 :: (MonadParsec e ByteString m) => m Word8 percentEncChar = do void (char 37) h <- restoreDigit <$> hexDigitChar@@ -284,13 +284,13 @@ return (h * 16 + l) {-# INLINE percentEncChar #-} -subDelimChar :: MonadParsec e ByteString m => m Word8+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 :: (MonadParsec e ByteString m) => m Word8 pchar = choice [ unreservedChar,@@ -301,7 +301,7 @@ ] {-# INLINE pchar #-} -pchar' :: MonadParsec e ByteString m => m Word8+pchar' :: (MonadParsec e ByteString m) => m Word8 pchar' = choice [ unreservedChar,
Text/URI/Parser/Text.hs view
@@ -45,7 +45,7 @@ -- -- This function uses the 'parser' parser under the hood, which you can also -- use directly in a Megaparsec parser.-mkURI :: MonadThrow m => Text -> m URI+mkURI :: (MonadThrow m) => Text -> m URI mkURI input = case runParser (parser <* eof :: Parsec Void Text URI) "" input of Left b -> throwM (ParseException b)@@ -53,7 +53,7 @@ -- | This parser can be used to parse 'URI' from strict 'Text'. Remember to -- use a concrete non-polymorphic parser type for efficiency.-parser :: MonadParsec e Text m => m URI+parser :: (MonadParsec e Text m) => m URI parser = do uriScheme <- optional (try pScheme) mauth <- optional pAuthority@@ -65,7 +65,7 @@ {-# INLINEABLE parser #-} {-# SPECIALIZE parser :: Parsec Void Text URI #-} -pScheme :: MonadParsec e Text m => m (RText 'Scheme)+pScheme :: (MonadParsec e Text m) => m (RText 'Scheme) pScheme = do r <- liftR "scheme" mkScheme $ do x <- asciiAlphaChar@@ -75,7 +75,7 @@ return r {-# INLINE pScheme #-} -pAuthority :: MonadParsec e Text m => m Authority+pAuthority :: (MonadParsec e Text m) => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo@@ -84,7 +84,7 @@ return Authority {..} {-# INLINE pAuthority #-} -pUserInfo :: MonadParsec e Text m => m UserInfo+pUserInfo :: (MonadParsec e Text m) => m UserInfo pUserInfo = try $ do uiUsername <- liftR@@ -104,7 +104,7 @@ {-# INLINE pUserInfo #-} pPath ::- MonadParsec e Text m =>+ (MonadParsec e Text m) => Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do@@ -132,7 +132,7 @@ ) {-# INLINE pPath #-} -pQuery :: MonadParsec e Text m => m [QueryParam]+pQuery :: (MonadParsec e Text m) => m [QueryParam] pQuery = do void (char '?') void (optional (char '&'))@@ -151,7 +151,7 @@ ) {-# INLINE pQuery #-} -pFragment :: MonadParsec e Text m => m (RText 'Fragment)+pFragment :: (MonadParsec e Text m) => m (RText 'Fragment) pFragment = do void (char '#') liftR@@ -167,7 +167,7 @@ -- | Lift a smart constructor that consumes 'Text' into a parser. liftR ::- MonadParsec e Text m =>+ (MonadParsec e Text m) => -- | What is being parsed String -> -- | The smart constructor that produces the result
Text/URI/Parser/Text/Utils.hs view
@@ -36,7 +36,7 @@ -- | Parser that can parse host names. pHost ::- MonadParsec e Text m =>+ (MonadParsec e Text m) => -- | Demand percent-encoding in reg names Bool -> m String@@ -46,7 +46,7 @@ regName ] where- asConsumed :: MonadParsec e Text m => m a -> m String+ asConsumed :: (MonadParsec e Text m) => m a -> m String asConsumed p = T.unpack . fst <$> match p ipLiteral = between (char '[') (char ']') $@@ -78,40 +78,36 @@ void (char '.') skipSome (unreservedChar <|> subDelimChar <|> char ':') regName = fmap (intercalate ".") . flip sepBy1 (char '.') $ do- let ch =- if pe- then percentEncChar <|> asciiAlphaNumChar- else alphaNumChar- 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)+ many $+ if pe+ then percentEncChar <|> unreservedChar+ else unreservedCharUnicode {-# INLINEABLE pHost #-} -- | Parse an ASCII alpha character.-asciiAlphaChar :: MonadParsec e Text m => m Char+asciiAlphaChar :: (MonadParsec e Text m) => m Char asciiAlphaChar = satisfy isAsciiAlpha <?> "ASCII alpha character" {-# INLINE asciiAlphaChar #-} -- | Parse an ASCII alpha-numeric character.-asciiAlphaNumChar :: MonadParsec e Text m => m Char+asciiAlphaNumChar :: (MonadParsec e Text m) => m Char asciiAlphaNumChar = satisfy isAsciiAlphaNum <?> "ASCII alpha-numeric character" {-# INLINE asciiAlphaNumChar #-} -- | Parse an unreserved character.-unreservedChar :: MonadParsec e Text m => m Char+unreservedChar :: (MonadParsec e Text m) => m Char unreservedChar = label "unreserved character" . satisfy $ \x -> isAsciiAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' {-# INLINE unreservedChar #-} +-- | Parse an unreserved character allowing Unicode.+unreservedCharUnicode :: (MonadParsec e Text m) => m Char+unreservedCharUnicode = label "unreserved character" . satisfy $ \x ->+ isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'+{-# INLINE unreservedCharUnicode #-}+ -- | Parse a percent-encoded character.-percentEncChar :: MonadParsec e Text m => m Char+percentEncChar :: (MonadParsec e Text m) => m Char percentEncChar = do void (char '%') h <- digitToInt <$> hexDigitChar@@ -120,14 +116,14 @@ {-# INLINE percentEncChar #-} -- | Parse a sub-delimiter character.-subDelimChar :: MonadParsec e Text m => m Char+subDelimChar :: (MonadParsec e Text m) => m Char subDelimChar = oneOf s <?> "sub-delimiter" where s = E.fromList "!$&'()*+,;=" {-# INLINE subDelimChar #-} -- | PCHAR thing from the spec.-pchar :: MonadParsec e Text m => m Char+pchar :: (MonadParsec e Text m) => m Char pchar = choice [ unreservedChar,@@ -139,7 +135,7 @@ {-# INLINE pchar #-} -- | 'pchar' adjusted for query parsing.-pchar' :: MonadParsec e Text m => m Char+pchar' :: (MonadParsec e Text m) => m Char pchar' = choice [ unreservedChar,
Text/URI/Render.hs view
@@ -134,21 +134,21 @@ data Renders b = Renders { rWord :: Word -> b,- rText :: forall l. RLabel l => Maybe Word8 -> RText l -> b+ rText :: forall l. (RLabel l) => Maybe Word8 -> RText l -> b } equip :: forall b. (Word -> b) ->- (forall l. RLabel l => Maybe Word8 -> RText l -> b) ->- (forall (s :: Type). Reifies s (Renders b) => Tagged s b) ->+ (forall l. (RLabel l) => Maybe Word8 -> RText l -> b) ->+ (forall (s :: Type). (Reifies s (Renders b)) => Tagged s b) -> b equip rWord rText f = reify Renders {..} $ \(Proxy :: Proxy s') -> unTagged (f :: Tagged s' b) renderWord :: forall s b.- Reifies s (Renders b) =>+ (Reifies s (Renders b)) => Word -> Tagged s b renderWord = Tagged . rWord (reflect (Proxy :: Proxy s))@@ -189,7 +189,7 @@ ] {-# INLINE genericRender #-} -rJust :: Monoid m => (a -> m) -> Maybe a -> m+rJust :: (Monoid m) => (a -> m) -> Maybe a -> m rJust = maybe mempty rScheme :: Render (RText 'Scheme) b@@ -271,7 +271,7 @@ -- | Percent-encode a 'Text' value. percentEncode :: forall l.- RLabel l =>+ (RLabel l) => -- | Scheme of the URI Maybe (RText 'Scheme) -> -- | A byte to additionally escape@@ -291,11 +291,11 @@ Just (w, bs'') -> Just $ if- | sap && w == 32 -> ('+', (bs'', []))- | nne w -> (chr (fromIntegral w), (bs'', []))- | otherwise ->- let c :| cs = encodeByte w- in (c, (bs'', cs))+ | sap && w == 32 -> ('+', (bs'', []))+ | nne w -> (chr (fromIntegral w), (bs'', []))+ | otherwise ->+ let c :| cs = encodeByte w+ in (c, (bs'', cs)) f (bs', x : xs) = Just (x, (bs', xs)) encodeByte x = '%' :| [intToDigit h, intToDigit l] where
Text/URI/Types.hs view
@@ -267,7 +267,7 @@ instance NFData (RText l) -- | @since 0.3.1.0-instance Typeable l => TH.Lift (RText l) where+instance (Typeable l) => TH.Lift (RText l) where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift @@ -321,7 +321,7 @@ -- converting them to lower case. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.1>-mkScheme :: MonadThrow m => Text -> m (RText 'Scheme)+mkScheme :: (MonadThrow m) => Text -> m (RText 'Scheme) mkScheme = mkRText instance RLabel 'Scheme where@@ -346,7 +346,7 @@ -- converting them to lower case. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.2.2>-mkHost :: MonadThrow m => Text -> m (RText 'Host)+mkHost :: (MonadThrow m) => Text -> m (RText 'Host) mkHost = mkRText instance RLabel 'Host where@@ -362,7 +362,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.2.1>-mkUsername :: MonadThrow m => Text -> m (RText 'Username)+mkUsername :: (MonadThrow m) => Text -> m (RText 'Username) mkUsername = mkRText instance RLabel 'Username where@@ -378,7 +378,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.2.1>-mkPassword :: MonadThrow m => Text -> m (RText 'Password)+mkPassword :: (MonadThrow m) => Text -> m (RText 'Password) mkPassword = mkRText instance RLabel 'Password where@@ -394,7 +394,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.3>-mkPathPiece :: MonadThrow m => Text -> m (RText 'PathPiece)+mkPathPiece :: (MonadThrow m) => Text -> m (RText 'PathPiece) mkPathPiece = mkRText instance RLabel 'PathPiece where@@ -410,7 +410,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.4>-mkQueryKey :: MonadThrow m => Text -> m (RText 'QueryKey)+mkQueryKey :: (MonadThrow m) => Text -> m (RText 'QueryKey) mkQueryKey = mkRText instance RLabel 'QueryKey where@@ -426,7 +426,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.4>-mkQueryValue :: MonadThrow m => Text -> m (RText 'QueryValue)+mkQueryValue :: (MonadThrow m) => Text -> m (RText 'QueryValue) mkQueryValue = mkRText instance RLabel 'QueryValue where@@ -442,7 +442,7 @@ -- This smart constructor does not perform any sort of normalization. -- -- See also: <https://tools.ietf.org/html/rfc3986#section-3.5>-mkFragment :: MonadThrow m => Text -> m (RText 'Fragment)+mkFragment :: (MonadThrow m) => Text -> m (RText 'Fragment) mkFragment = mkRText instance RLabel 'Fragment where@@ -526,7 +526,7 @@ ] return ("v" ++ [v] ++ "." ++ xs) domainLabel = do- let g = arbitrary `suchThat` isAlphaNum+ let g = arbitrary `suchThat` isUnreservedChar x <- g xs <- listOf $@@ -535,6 +535,11 @@ return ([x] ++ xs ++ [x']) regName = intercalate "." <$> resize 5 (listOf1 domainLabel) +-- | Return 'True' if the given character is unreserved.+isUnreservedChar :: Char -> Bool+isUnreservedChar x =+ isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'+ -- | Make generator for refined text given how to lift a possibly empty -- arbitrary 'Text' value into a refined type. arbText :: (Text -> Maybe (RText l)) -> Gen (RText l)@@ -551,5 +556,5 @@ liftData :: (Data a, TH.Quote m) => a -> m TH.Exp liftData = TH.dataToExpQ (fmap liftText . cast) -liftText :: TH.Quote m => Text -> m TH.Exp+liftText :: (TH.Quote m) => Text -> m TH.Exp liftText t = TH.AppE (TH.VarE 'T.pack) <$> TH.lift (T.unpack t)
bench/memory/Main.hs view
@@ -9,7 +9,7 @@ import Data.Void import Text.Megaparsec import Text.URI (URI)-import qualified Text.URI as URI+import Text.URI qualified as URI import Weigh main :: IO ()@@ -25,7 +25,7 @@ -- Helpers -- | Test 'URI' as a polymorphic string.-turiStr :: IsString a => a+turiStr :: (IsString a) => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form.
bench/speed/Main.hs view
@@ -10,7 +10,7 @@ import Data.Void import Text.Megaparsec import Text.URI (URI)-import qualified Text.URI as URI+import Text.URI qualified as URI main :: IO () main =@@ -26,7 +26,7 @@ -- Helpers -- | Test 'URI' as a polymorphic string.-turiStr :: IsString a => a+turiStr :: (IsString a) => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form.
modern-uri.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.4 name: modern-uri-version: 0.3.6.0+version: 0.3.6.1 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com> author: Mark Karpov <markkarpov92@gmail.com>-tested-with: ghc ==9.0.2 ghc ==9.2.4 ghc ==9.4.1+tested-with: ghc ==9.2.8 ghc ==9.4.5 ghc ==9.6.2 homepage: https://github.com/mrkkrp/modern-uri bug-reports: https://github.com/mrkkrp/modern-uri/issues synopsis: Modern library for working with URIs@@ -44,7 +44,6 @@ base >=4.15 && <5.0, bytestring >=0.2 && <0.12, containers >=0.5 && <0.7,- contravariant >=1.3 && <2.0, deepseq >=1.3 && <1.5, exceptions >=0.6 && <0.11, hashable >=1.3 && <2.0,@@ -53,20 +52,15 @@ profunctors >=5.2.1 && <6.0, reflection >=2.0 && <3.0, tagged >=0.8 && <0.9,- template-haskell >=2.10 && <2.20,+ template-haskell >=2.10 && <2.21, text >=0.2 && <2.1 if flag(dev)- ghc-options: -Wall -Werror+ ghc-options: -Wall -Werror -Wpartial-fields -Wunused-packages else ghc-options: -O2 -Wall - if flag(dev)- ghc-options:- -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances- test-suite tests type: exitcode-stdio-1.0 main-is: Spec.hs@@ -76,7 +70,7 @@ Text.QQSpec Text.URISpec - default-language: Haskell2010+ default-language: GHC2021 build-depends: QuickCheck >=2.4 && <3.0, base >=4.15 && <5.0,@@ -88,7 +82,9 @@ text >=0.2 && <2.1 if flag(dev)- ghc-options: -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall@@ -97,7 +93,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/speed- default-language: Haskell2010+ default-language: GHC2021 build-depends: base >=4.15 && <5.0, bytestring >=0.2 && <0.12,@@ -107,7 +103,9 @@ text >=0.2 && <2.1 if flag(dev)- ghc-options: -O2 -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall@@ -116,18 +114,19 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/memory- default-language: Haskell2010+ default-language: GHC2021 build-depends: base >=4.15 && <5.0, bytestring >=0.2 && <0.12,- deepseq >=1.3 && <1.5, megaparsec >=8.0 && <10.0, modern-uri, text >=0.2 && <2.1, weigh >=0.0.4 if flag(dev)- ghc-options: -O2 -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall
tests/Text/QQSpec.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Text.QQSpec (spec) where import Test.Hspec import Text.URI-import qualified Text.URI.QQ as QQ+import Text.URI.QQ qualified as QQ spec :: Spec spec = do
tests/Text/URISpec.hs view
@@ -6,18 +6,18 @@ import Control.Monad import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, isNothing) import Data.String (IsString (..)) import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Data.Void import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck import Text.Megaparsec import Text.URI (RTextException (..), RTextLabel (..), URI (..))-import qualified Text.URI as URI+import Text.URI qualified as URI instance Arbitrary Text where arbitrary = T.pack <$> arbitrary@@ -28,6 +28,24 @@ it "accepts valid URIs" $ do uri <- mkTestURI URI.mkURI testURI `shouldReturn` uri+ it "accepts a URI with an underscore in host name" $ do+ scheme <- URI.mkScheme "http"+ host <- URI.mkHost "auth_service"+ path <- mapM URI.mkPathPiece ["api", "v1", "users", "validate"]+ URI.mkURI "http://auth_service:3000/api/v1/users/validate"+ `shouldReturn` URI+ { uriScheme = Just scheme,+ uriAuthority =+ Right+ URI.Authority+ { URI.authUserInfo = Nothing,+ URI.authHost = host,+ URI.authPort = Just 3000+ },+ uriPath = Just (False, NE.fromList path),+ uriQuery = [],+ uriFragment = Nothing+ } it "rejects invalid URIs" $ do let e = err 0 . mconcat $@@ -122,9 +140,12 @@ URI.mkHost "104.155.144.4.sslip.io" `shouldRText` "104.155.144.4.sslip.io" URI.mkHost "юникод.рф" `shouldRText` "юникод.рф" URI.mkHost "" `shouldRText` ""+ URI.mkHost "." `shouldRText` "."+ URI.mkHost "my-host." `shouldRText` "my-host."+ URI.mkHost "auth_service" `shouldRText` "auth_service" it "rejects invalid hosts" $ do- URI.mkHost "_something"- `shouldThrow` (== RTextException Host "_something")+ URI.mkHost ")something"+ `shouldThrow` (== RTextException Host ")something") URI.mkHost "some@thing" `shouldThrow` (== RTextException Host "some@thing") describe "mkUsername" $ do@@ -204,9 +225,9 @@ etok ':', etok '?', etok '[',- elabel "ASCII alpha-numeric character",- elabel "username", elabel "path piece",+ elabel "unreserved character",+ elabel "username", eeof ] )@@ -274,9 +295,8 @@ ( mconcat [ utoks "foo%f0bar", etok '%',- etok '-', etok '.',- elabel "ASCII alpha-numeric character",+ elabel "unreserved character", elabel "host that can be decoded as UTF-8" ] )@@ -381,7 +401,7 @@ } -- | Polymorphic textual rendering of the 'URI' generated by 'mkTestURI'.-testURI :: IsString a => a+testURI :: (IsString a) => a testURI = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri%2b:%40?foo:@=bar+:@#fragment:@" -- | A utility wrapper around 'URI.parser'.