diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,43 +1,2 @@ -# network-uri-2.6.4.2 (2022-12-18) -* Fix warnings, `-Wtrustworthy-safe` and `-Woperator-whitespace-ext-conflict` on GHC 9.4. -* Slightly improved test coverage. - -# network-uri-2.6.4.1 (2021-02-07) -* Fix: Restore "Safe" designation which was accidentally removed. - -# network-uri-2.6.4.0 (2021-02-07) -* Add compatibility with GHC 9.0.1. - -# network-uri-2.6.3.0 (2020-02-18) -* Add official support for SafeHaskell - NOTE: This is the first version whose SafeHaskell properties have become an - intentional part of the API contract; previous versions were merely - accidentally safe-inferred (or not depending on various factors; in other - words, this was a fragile property). -* Derive `Lift` instances using `DeriveLift` extension, when available. - -# network-uri-2.6.2.0 (2020-01-30) -* Mark the modules as Safe for SafeHaskell. - -# network-uri-2.6.2.0 (2020-01-30) -* Merge network-uri-static (Network.URI.Static) into this - package, which offers a way to parse URI strings at compile time. -* Add `Lens`es for the `URI` types -* Add `Generic` instances for the `URI` type -* Add `Lift` instances for the `URI` type -* Optimize `isReserved` and related character-class functions. -* Start to add some benchmarks for performance analysis -* Fix a bug: Correctly parse IPv6 addresses in URIs. -* Add `rectify` which normalizes a URI if it is missing certain - separator characters required by the module. Some users found adding - those characters inconvenient when building a URI from parts. -* Add `nullURIAuth` and `uriAuthToString`, paralleling `nullURI` and `uriToString`. - -# network-uri-2.6.0.3 -* Fix a bug with IPv4 address parsing. - -# network-uri-2.6.0.2 -* Implement Generic and NFData. - -# network-uri-2.6.0.0 -* Initial release: Module split off from `network`. +# network-uri-2.6.2.0 (2019-??-??) +* Added a `Generic` instance for `URIAuth`. diff --git a/Network/URI.hs b/Network/URI.hs --- a/Network/URI.hs +++ b/Network/URI.hs @@ -1,18 +1,7 @@ -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE RecordWildCards #-} -#endif -{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, CPP #-} #if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DeriveLift, StandaloneDeriving #-} -#else -{-# LANGUAGE TemplateHaskell #-} -#endif -#if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_parsec(3,1,13) -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TemplateHaskellQuotes #-} #endif - -------------------------------------------------------------------------------- -- | -- Module : Network.URI @@ -151,7 +140,15 @@ import Data.List (unfoldr, isPrefixOf, isSuffixOf) import Numeric (showIntAtBase) +#if __GLASGOW_HASKELL__ >= 800 +#ifndef MIN_VERSION_network_uri_static import Language.Haskell.TH.Syntax (Lift(..)) +#else +#if MIN_VERSION_network_uri_static(0,1,2) +import Language.Haskell.TH.Syntax (Lift(..)) +#endif +#endif +#endif #if !MIN_VERSION_base(4,8,0) import Data.Traversable (sequenceA) @@ -164,8 +161,9 @@ import Data.Generics (Data) #endif -#if __GLASGOW_HASKELL__ >= 702 +#if MIN_VERSION_base(4,6,0) import GHC.Generics (Generic) +#else #endif ------------------------------------------------------------ @@ -187,7 +185,7 @@ , uriPath :: String -- ^ @\/ghc@ , uriQuery :: String -- ^ @?query@ , uriFragment :: String -- ^ @#frag@ -#if __GLASGOW_HASKELL__ >= 702 +#if MIN_VERSION_base(4,6,0) } deriving (Eq, Ord, Typeable, Data, Generic) #else } deriving (Eq, Ord, Typeable, Data) @@ -195,11 +193,11 @@ -- | Add a prefix to a string, unless it already has it. ensurePrefix :: String -> String -> String -ensurePrefix p s = if p `isPrefixOf` s then s else p ++ s +ensurePrefix p s = if isPrefixOf p s then s else p ++ s -- | Add a suffix to a string, unless it already has it. ensureSuffix :: String -> String -> String -ensureSuffix p s = if p `isSuffixOf` s then s else s ++ p +ensureSuffix p s = if isSuffixOf p s then s else s ++ p -- | Given a URIAuth in "nonstandard" form (lacking required separator characters), -- return one that is standard. @@ -236,7 +234,7 @@ { uriUserInfo :: String -- ^ @anonymous\@@ , uriRegName :: String -- ^ @www.haskell.org@ , uriPort :: String -- ^ @:42@ -#if __GLASGOW_HASKELL__ >= 702 +#if MIN_VERSION_base(4,6,0) } deriving (Eq, Ord, Show, Typeable, Data, Generic) #else } deriving (Eq, Ord, Show, Typeable, Data) @@ -374,18 +372,17 @@ parseAll parser filename uristr = parse newparser filename uristr where newparser = - do { result <- parser + do { res <- parser ; eof - ; return result + ; return res } - ------------------------------------------------------------ -- Predicates ------------------------------------------------------------ uriIsAbsolute :: URI -> Bool -uriIsAbsolute URI{uriScheme = scheme'} = scheme' /= "" +uriIsAbsolute (URI {uriScheme = scheme'}) = scheme' /= "" uriIsRelative :: URI -> Bool uriIsRelative = not . uriIsAbsolute @@ -415,7 +412,7 @@ isReserved c = isGenDelims c || isSubDelims c -- As per https://github.com/haskell/network-uri/pull/46, it was found --- that the explicit case statement was noticeably faster than a nicer +-- that the explicit case statement was noticably faster than a nicer -- expression in terms of `elem`. isGenDelims :: Char -> Bool isGenDelims c = @@ -430,7 +427,7 @@ _ -> False -- As per https://github.com/haskell/network-uri/pull/46, it was found --- that the explicit case statement was noticeably faster than a nicer +-- that the explicit case statement was noticably faster than a nicer -- expression in terms of `elem`. isSubDelims :: Char -> Bool isSubDelims c = @@ -490,7 +487,7 @@ } } -hierPart :: URIParser (Maybe URIAuth, String) +hierPart :: URIParser ((Maybe URIAuth),String) hierPart = do { _ <- try (string "//") ; ua <- uauthority @@ -547,7 +544,7 @@ ipLiteral :: URIParser String ipLiteral = do { _ <- char '[' - ; ua <- ipv6addrz <|> ipvFuture + ; ua <- ( ipv6addrz <|> ipvFuture ) ; _ <- char ']' ; return $ "[" ++ ua ++ "]" } @@ -840,7 +837,7 @@ } } -relativePart :: URIParser (Maybe URIAuth, String) +relativePart :: URIParser ((Maybe URIAuth),String) relativePart = do { _ <- try (string "//") ; ua <- uauthority @@ -888,7 +885,7 @@ isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') isDigitChar :: Char -> Bool -isDigitChar c = c >= '0' && c <= '9' +isDigitChar c = (c >= '0' && c <= '9') isAlphaNumChar :: Char -> Bool isAlphaNumChar c = isAlphaChar c || isDigitChar c @@ -897,7 +894,7 @@ isHexDigitChar c = isHexDigit c isSchemeChar :: Char -> Bool -isSchemeChar c = isAlphaNumChar c || (c `elem` "+-.") +isSchemeChar c = (isAlphaNumChar c) || (c `elem` "+-.") alphaChar :: URIParser Char alphaChar = satisfy isAlphaChar -- or: Parsec.letter ? @@ -952,17 +949,17 @@ , uriQuery=myquery , uriFragment=myfragment } = - (myscheme++) . uriAuthToString userinfomap myauthority + (myscheme++) . (uriAuthToString userinfomap myauthority) . (mypath++) . (myquery++) . (myfragment++) -uriAuthToString :: (String->String) -> Maybe URIAuth -> ShowS +uriAuthToString :: (String->String) -> (Maybe URIAuth) -> ShowS uriAuthToString _ Nothing = id -- shows "" uriAuthToString userinfomap (Just URIAuth { uriUserInfo = myuinfo , uriRegName = myregname , uriPort = myport } ) = - ("//"++) . (if null myuinfo then id else (userinfomap myuinfo ++)) + ("//"++) . (if null myuinfo then id else ((userinfomap myuinfo)++)) . (myregname++) . (myport++) @@ -1002,7 +999,7 @@ | otherwise = concatMap (\i -> '%' : myShowHex i "") (utf8EncodeChar c) where myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of + myShowHex n r = case showIntAtBase 16 (toChrHex) n r of [] -> "00" [x] -> ['0',x] cs -> cs @@ -1128,7 +1125,7 @@ | isDefined ( uriAuthority ref ) = just_segments ref { uriScheme = uriScheme base } | isDefined ( uriPath ref ) = - if head (uriPath ref) == '/' then + if (head (uriPath ref) == '/') then just_segments ref { uriScheme = uriScheme base , uriAuthority = uriAuthority base @@ -1273,8 +1270,8 @@ relPathFrom pabs [] = pabs relPathFrom pabs base = if sa1 == sb1 -- If the first segments are equal - then if sa1 == "/" -- and they're absolute, - then if sa2 == sb2 -- then if the 2nd segs are equal, + then if (sa1 == "/") -- and they're absolute, + then if (sa2 == sb2) -- then if the 2nd segs are equal, then relPathFrom1 ra2 rb2 -- relativize from there. else pabs -- Otherwise it's not worth trying. @@ -1298,7 +1295,7 @@ relName = if null rp then -- If the relative path is empty, and the basenames are -- the same, then the paths must be exactly the same. - if na == nb then "" + if (na == nb) then "" -- If the name is vulnerable to being misinterpreted, -- add a dot segment in advance to protect it. else if protect na then "./"++na @@ -1381,15 +1378,22 @@ ------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 800 -deriving instance Lift URI -deriving instance Lift URIAuth +#ifndef MIN_VERSION_network_uri_static +instance Lift URI where + lift (URI {..}) = [| URI {..} |] + +instance Lift URIAuth where + lift (URIAuth {..}) = [| URIAuth {..} |] #else +#if MIN_VERSION_network_uri_static(0,1,2) instance Lift URI where lift (URI {..}) = [| URI {..} |] instance Lift URIAuth where lift (URIAuth {..}) = [| URIAuth {..} |] #endif +#endif +#endif ------------------------------------------------------------ -- Deprecated functions @@ -1417,12 +1421,9 @@ scheme :: URI -> String scheme = orNull init . uriScheme -runShowS :: ShowS -> String -runShowS s = s "" - {-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-} authority :: URI -> String -authority = dropss . runShowS . uriAuthToString id . uriAuthority +authority = dropss . ($"") . uriAuthToString id . uriAuthority where -- Old-style authority component does not include leading '//' dropss ('/':'/':s) = s diff --git a/Network/URI/Lens.hs b/Network/URI/Lens.hs --- a/Network/URI/Lens.hs +++ b/Network/URI/Lens.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#if __GLASGOW_HASKELL__ > 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ > 702 -{-# LANGUAGE Trustworthy #-} -#endif -- | Network uri lenses module Network.URI.Lens ( uriRegNameLens @@ -17,9 +11,7 @@ , uriFragmentLens ) where -#if __GLASGOW_HASKELL__ < 710 import Control.Applicative -#endif import Network.URI type Lens' s a = Lens s s a a diff --git a/Network/URI/Static.hs b/Network/URI/Static.hs --- a/Network/URI/Static.hs +++ b/Network/URI/Static.hs @@ -1,37 +1,24 @@ #if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} +module Network.URI.Static () where #else + {-# LANGUAGE RecordWildCards, TemplateHaskellQuotes, ViewPatterns #-} -#endif -#if MIN_VERSION_template_haskell(2,12,0) -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif + module Network.URI.Static ( -- * Absolute URIs uri -#if __GLASGOW_HASKELL__ >= 708 , staticURI -#endif - , staticURI' -- * Relative URIs , relativeReference -#if __GLASGOW_HASKELL__ >= 708 , staticRelativeReference -#endif - , staticRelativeReference' ) where -import Language.Haskell.TH.Lib (ExpQ) +import Language.Haskell.TH (unType) +import Language.Haskell.TH.Lib (TExpQ) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Network.URI (URI(..), parseURI, parseRelativeReference) -#if __GLASGOW_HASKELL__ >= 708 -import Language.Haskell.TH.Syntax.Compat (SpliceQ, unTypeCode, toCode) -#endif - -- $setup -- >>> :set -XTemplateHaskell -- >>> :set -XQuasiQuotes @@ -40,7 +27,6 @@ -- Absolute URIs ---------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 708 -- | 'staticURI' parses a specified string at compile time -- and return an expression representing the URI when it's a valid URI. -- Otherwise, it emits an error. @@ -53,23 +39,10 @@ -- ... -- ... Invalid URI: http://www.google.com/## -- ... -staticURI :: String -- ^ String representation of a URI - -> SpliceQ URI -- ^ URI +staticURI :: String -- ^ String representation of a URI + -> TExpQ URI -- ^ URI staticURI (parseURI -> Just u) = [|| u ||] -staticURI s = error $ "Invalid URI: " ++ s -#endif - --- | 'staticURI'' parses a specified string at compile time. --- --- The typed template haskell 'staticURI' is available only with GHC-7.8+. -staticURI' :: String -- ^ String representation of a URI - -> ExpQ -- ^ URI -#if __GLASGOW_HASKELL__ >= 708 -staticURI' = unTypeCode . toCode . staticURI -#else -staticURI' (parseURI -> Just u) = [| u |] -staticURI' s = fail $ "Invalid URI: " ++ s -#endif +staticURI s = fail $ "Invalid URI: " ++ s -- | 'uri' is a quasi quoter for 'staticURI'. -- @@ -83,7 +56,7 @@ -- ... uri :: QuasiQuoter uri = QuasiQuoter { - quoteExp = staticURI', + quoteExp = fmap unType . staticURI, quotePat = undefined, quoteType = undefined, quoteDec = undefined @@ -93,7 +66,6 @@ -- Relative URIs ---------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 708 -- | 'staticRelativeReference' parses a specified string at compile time and -- return an expression representing the URI when it's a valid relative -- reference. Otherwise, it emits an error. @@ -106,25 +78,10 @@ -- ... -- ... Invalid relative reference: http://www.google.com/ -- ... -staticRelativeReference :: String -- ^ String representation of a reference - -> SpliceQ URI -- ^ Refererence +staticRelativeReference :: String -- ^ String representation of a reference + -> TExpQ URI -- ^ Refererence staticRelativeReference (parseRelativeReference -> Just ref) = [|| ref ||] -staticRelativeReference ref = error $ "Invalid relative reference: " ++ ref -#endif - --- | 'staticRelativeReference'' parses a specified string at compile time and --- return an expression representing the URI when it's a valid relative --- reference. Otherwise, it emits an error. --- --- The typed template haskell 'staticRelativeReference' is available only with GHC-7.8+. -staticRelativeReference' :: String -- ^ String representation of a reference - -> ExpQ -- ^ Refererence -#if __GLASGOW_HASKELL__ >= 708 -staticRelativeReference' = unTypeCode . toCode . staticRelativeReference -#else -staticRelativeReference' (parseRelativeReference -> Just ref) = [| ref |] -staticRelativeReference' ref = fail $ "Invalid relative reference: " ++ ref -#endif +staticRelativeReference ref = fail $ "Invalid relative reference: " ++ ref -- | 'relativeReference' is a quasi quoter for 'staticRelativeReference'. -- @@ -138,8 +95,10 @@ -- ... relativeReference :: QuasiQuoter relativeReference = QuasiQuoter { - quoteExp = staticRelativeReference', + quoteExp = fmap unType . staticRelativeReference, quotePat = undefined, quoteType = undefined, quoteDec = undefined } + +#endif diff --git a/network-uri.cabal b/network-uri.cabal --- a/network-uri.cabal +++ b/network-uri.cabal @@ -1,5 +1,5 @@ name: network-uri -version: 2.6.4.2 +version: 2.7.0.0 synopsis: URI manipulation description: This package provides facilities for parsing and unparsing URIs, and creating @@ -45,21 +45,7 @@ category: Network build-type: Simple cabal-version: >=1.10 -tested-with: - GHC ==9.2.2 - || ==9.0.2 - || ==8.10.1 - || ==8.8.2 - || ==8.6.5 - || ==8.4.4 - || ==8.2.2 - || ==8.0.2 - || ==7.10.3 - || ==7.8.4 - || ==7.6.3 - || ==7.4.2 - || ==7.2.2 - || ==7.0.4 +tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 library exposed-modules: @@ -69,22 +55,15 @@ build-depends: base >= 3 && < 5, deepseq >= 1.1 && < 1.5, - parsec >= 3.1.12.0 && < 3.2, - th-compat >= 0.1.1 && < 1.0 - build-depends: template-haskell + parsec >= 3.0 && < 3.2 + if impl(ghc >= 8.0) + build-depends: template-haskell default-extensions: CPP, DeriveDataTypeable - if impl(ghc < 7.6) - build-depends: ghc-prim - if impl(ghc >= 7.2) + if impl(ghc >= 7.6) default-extensions: DeriveGeneric ghc-options: -Wall -fwarn-tabs default-language: Haskell98 - if impl(ghc >= 9.0) - -- these flags may abort compilation with GHC-8.10 - -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 - ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode - test-suite uri hs-source-dirs: tests main-is: uri001.hs @@ -94,15 +73,14 @@ base < 5, HUnit, network-uri, - tasty, - tasty-hunit, - tasty-quickcheck, - QuickCheck + test-framework, + test-framework-hunit, + test-framework-quickcheck2 ghc-options: -Wall -fwarn-tabs default-language: Haskell98 -benchmark uri-bench +test-suite uri-bench hs-source-dirs: tests main-is: uri-bench.hs type: exitcode-stdio-1.0 diff --git a/tests/uri-bench.hs b/tests/uri-bench.hs --- a/tests/uri-bench.hs +++ b/tests/uri-bench.hs @@ -53,7 +53,4 @@ bench "isReserved a" $ nf isReserved 'a' , bench "isReserved :" $ nf isReserved ':' ] - , - bench "parseURI" $ - nf parseURI "http://foo@bar.quix.gov/flip/flop?a=b&c=d" ] diff --git a/tests/uri001.hs b/tests/uri001.hs --- a/tests/uri001.hs +++ b/tests/uri001.hs @@ -17,12 +17,20 @@ -- This Module contains test cases for module URI. -- -- To run this test without using Cabal to build the package --- (2013-01-05, instructions tested on macOS): +-- (2013-01-05, instructions tested on MacOS): -- 1. Install Haskell platform --- 2. cabal install tasty tasty-hunit tasty-quickcheck QuickCheck --- 3. ghc -XDeriveDataTypeable -XDeriveGeneric -package QuickCheck -package tasty -package HUnit ../Network/URI.hs uri001.hs +-- 2. cabal install test-framework +-- 3. cabal install test-framework-hunit +-- 4. ghc -XDeriveDataTypeable -D"MIN_VERSION_base(x,y,z)=1" ../Network/URI.hs uri001.hs -- 5. ./uri001 -- +-- Previous build instructions: +-- Using GHC, I compile with this command line: +-- ghc --make -fglasgow-exts +-- -i..\;C:\Dev\Haskell\Lib\HUnit;C:\Dev\Haskell\Lib\Parsec +-- -o URITest.exe URITest -main-is URITest.main +-- The -i line may need changing for alternative installations. +-- -------------------------------------------------------------------------------- module Main where @@ -46,16 +54,20 @@ import Test.HUnit -import Data.Bits ((.&.), (.|.)) -import Data.Char (ord, chr) import Data.Maybe (fromJust) import Data.List (intercalate) import System.IO (openFile, IOMode(WriteMode), hClose) -import qualified Test.Tasty as TF -import qualified Test.Tasty.HUnit as TF -import qualified Test.Tasty.QuickCheck as TF -import Test.QuickCheck ((==>), Property) +import qualified Test.Framework as TF +import qualified Test.Framework.Providers.HUnit as TF +import qualified Test.Framework.Providers.QuickCheck2 as TF +-- Test supplied string for valid URI reference syntax +-- isValidURIRef :: String -> Bool +-- Test supplied string for valid absolute URI reference syntax +-- isAbsoluteURIRef :: String -> Bool +-- Test supplied string for valid absolute URI syntax +-- isAbsoluteURI :: String -> Bool + data URIType = AbsId -- URI form (absolute, no fragment) | AbsRf -- Absolute URI reference | RelRf -- Relative URI reference @@ -87,7 +99,7 @@ , testEq ("test_isAbsoluteURI:"++u) (isAbsIdT t) (isAbsoluteURI u) ] -testURIRefComponents :: String -> Maybe URI -> String -> Assertion +testURIRefComponents :: String -> (Maybe URI) -> String -> Assertion testURIRefComponents _lab uv us = testEq ("testURIRefComponents:"++us) uv (parseURIReference us) @@ -226,12 +238,19 @@ testURIRef121 = testURIRef AbsId "http://[v9.123.abc;456.def]/" testURIRef122 = testEq "v.future authority" (Just (URIAuth "" "[v9.123.abc;456.def]" ":42")) - (maybe Nothing uriAuthority . parseURI $ "http://[v9.123.abc;456.def]:42/") --- URIs with non-ASCII characters (IRIs), are not supported by Network.URI, but --- captured here for possible future reference when IRI support may be added. + ((maybe Nothing uriAuthority) . parseURI $ "http://[v9.123.abc;456.def]:42/") +-- URI with non-ASCII characters, fail with Network.HTTP escaping code (see below) +-- Currently not supported by Network.URI, but captured here for possible future reference +-- when IRI support may be added. testURIRef123 = testURIRef AbsId "http://example.com/test123/䡥汬漬⁗潲汤/index.html" testURIRef124 = testURIRef AbsId "http://example.com/test124/Москва/index.html" +-- From report by Alexander Ivanov: +-- should return " 䡥汬漬⁗潲汤", but returns "Hello, World" instead +-- print $ urlDecode $ urlEncode " 䡥汬漬⁗潲汤" +-- should return "Москва" +-- print $ urlDecode $ urlEncode "Москва" + testURIRefSuite = TF.testGroup "Test URIrefs" testURIRefList testURIRefList = [ TF.testCase "testURIRef001" testURIRef001 @@ -374,7 +393,15 @@ } ) "http://user:pass@example.org:99/aaa/bbb?qqq#fff" testComponent02 = testURIRefComponents "testComponent02" - Nothing + ( const Nothing + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "aaa/bbb" + , uriQuery = "" + , uriFragment = "" + } ) + ) "http://user:pass@example.org:99aaa/bbb" testComponent03 = testURIRefComponents "testComponent03" ( Just $ URI @@ -385,7 +412,7 @@ , uriFragment = "" } ) "http://user:pass@example.org:99?aaa/bbb" -testComponent04 = testURIRefComponents "testComponent04" +testComponent04 = testURIRefComponents "testComponent03" ( Just $ URI { uriScheme = "http:" , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") @@ -394,35 +421,8 @@ , uriFragment = "#aaa/bbb" } ) "http://user:pass@example.org:99#aaa/bbb" -testComponent05 = testURIRefComponents "testComponent05" - ( Just $ URI - { uriScheme = "news:" - , uriAuthority = Nothing - , uriPath = "comp.infosystems.www.servers.unix" - , uriQuery = "" - , uriFragment = "" - } ) - "news:comp.infosystems.www.servers.unix" -testComponent06 = testURIRefComponents "testComponent06" - ( Just $ URI - { uriScheme = "mailto:" - , uriAuthority = Nothing - , uriPath = "John.Doe@example.com" - , uriQuery = "" - , uriFragment = "" - } ) - "mailto:John.Doe@example.com" -testComponent07 = testURIRefComponents "testComponent07" - ( Just $ URI - { uriScheme = "tel:" - , uriAuthority = Nothing - , uriPath = "+1-816-555-1212" - , uriQuery = "" - , uriFragment = "" - } ) - "tel:+1-816-555-1212" -- These test cases contributed by Robert Buck (mathworks.com) -testComponent11 = testURIRefComponents "testComponent11" +testComponent11 = testURIRefComponents "testComponent03" ( Just $ URI { uriScheme = "about:" , uriAuthority = Nothing @@ -431,7 +431,7 @@ , uriFragment = "" } ) "about:" -testComponent12 = testURIRefComponents "testComponent12" +testComponent12 = testURIRefComponents "testComponent03" ( Just $ URI { uriScheme = "file:" , uriAuthority = Just (URIAuth "" "windowsauth" "") @@ -441,14 +441,11 @@ } ) "file://windowsauth/d$" -testComponentSuite = TF.testGroup "Test URIrefs" +testComponentSuite = TF.testGroup "Test URIrefs" $ [ TF.testCase "testComponent01" testComponent01 , TF.testCase "testComponent02" testComponent02 , TF.testCase "testComponent03" testComponent03 , TF.testCase "testComponent04" testComponent04 - , TF.testCase "testComponent05" testComponent05 - , TF.testCase "testComponent06" testComponent06 - , TF.testCase "testComponent07" testComponent07 , TF.testCase "testComponent11" testComponent11 , TF.testCase "testComponent12" testComponent12 ] @@ -488,8 +485,8 @@ testRelative :: String -> String -> String -> String -> Assertion testRelative label base uabs urel = sequence_ [ - testRelSplit (label++"(rel)") base uabs urel, - testRelJoin (label++"(abs)") base urel uabs + (testRelSplit (label++"(rel)") base uabs urel), + (testRelJoin (label++"(abs)") base urel uabs) ] testRelative01 = testRelative "testRelative01" @@ -627,7 +624,7 @@ "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" -- Apparently, TimBL prefers the following way to 41, 42 above -- cf. http://lists.w3.org/Archives/Public/uri/2003Feb/0028.html --- He also notes that there may be different relative functions +-- He also notes that there may be different relative fuctions -- that satisfy the basic equivalence axiom: -- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html testRelative56 = testRelative "testRelative56" @@ -674,9 +671,9 @@ "foo:bar" "http://example/a/b#c/../d" "http://example/a/b#c/../d" {- These (78-81) are some awkward test cases thrown up by a question on the URI list: http://lists.w3.org/Archives/Public/uri/2005Jul/0013 - Note that RFC 3986 discards path segments after the final '/' only when merging two - paths - otherwise the final segment in the base URI is maintained. This leads to - difficulty in constructing a reversible relativeTo/relativeFrom pair of functions. + Mote that RFC 3986 discards path segents after the final '/' only when merging two + paths - otherwise the final segment in the base URI is mnaintained. This leads to + difficulty in constructinmg a reversible relativeTo/relativeFrom pair of functions. -} testRelative78 = testRelative "testRelative78" "http://www.example.com/data/limit/.." "http://www.example.com/data/limit/test.xml" @@ -1074,7 +1071,7 @@ testShowURI01 = testEq "testShowURI01" "" (show nullURI) testShowURI02 = testEq "testShowURI02" ts02str (show ts02URI) -testShowURI03 = testEq "testShowURI03" ts03str (uriToString id ts02URI "") +testShowURI03 = testEq "testShowURI03" ts03str ((uriToString id ts02URI) "") testShowURI04 = testEq "testShowURI04" ts04str (show ts04URI) testShowURI = TF.testGroup "testShowURI" @@ -1111,40 +1108,12 @@ "hello%C3%B8%C2%A9%E6%97%A5%E6%9C%AC" (escapeURIString isUnescapedInURIComponent "helloø©日本") --- From report by Alexander Ivanov: --- should return " 䡥汬漬⁗潲汤", but returns "Hello, World" instead --- print $ urlDecode $ urlEncode " 䡥汬漬⁗潲汤" -assertUnescapeEscapeInverse lab x = testEq lab x (unEscapeString $ escapeURIString isUnescapedInURIComponent x) -testUnescapeEscape01 = assertUnescapeEscapeInverse "testUnescapeEscape01" " 䡥汬漬⁗潲汤" --- should return "Москва" --- print $ urlDecode $ urlEncode "Москва" -testUnescapeEscape02 = assertUnescapeEscapeInverse "testUnescapeEscape02" "Москва" - -validUnicodePoint :: Char -> Bool -validUnicodePoint c = - case ord c of - a | a >= 0xFDD0 && a <= 0xFDEF -> False - a | a .&. 0xFFFE == 0xFFFE -> False - _ -> True - -propEscapeUnEscapeLoop :: String -> Property -propEscapeUnEscapeLoop s = - all validUnicodePoint s ==> - s == (unEscapeString $! escaped) +propEscapeUnEscapeLoop :: String -> Bool +propEscapeUnEscapeLoop s = s == (unEscapeString $! escaped) where escaped = escapeURIString (const False) s {-# NOINLINE escaped #-} --- Test some Unicode chars high in the Basic Multilingual Plane. -propEscapeUnEscapeLoopHiChars :: Char -> Property -propEscapeUnEscapeLoopHiChars c' = - let c = chr $ ord c' .|. 0xff00 in - validUnicodePoint c ==> - [c] == (unEscapeString $! escaped c) - where - escaped c = escapeURIString (const False) [c] - {-# NOINLINE escaped #-} - testEscapeURIString = TF.testGroup "testEscapeURIString" [ TF.testCase "testEscapeURIString01" testEscapeURIString01 , TF.testCase "testEscapeURIString02" testEscapeURIString02 @@ -1152,10 +1121,7 @@ , TF.testCase "testEscapeURIString04" testEscapeURIString04 , TF.testCase "testEscapeURIString05" testEscapeURIString05 , TF.testCase "testEscapeURIString06" testEscapeURIString06 - , TF.testCase "testUnescapeEscape01" testUnescapeEscape01 - , TF.testCase "testUnescapeEscape02" testUnescapeEscape02 , TF.testProperty "propEscapeUnEscapeLoop" propEscapeUnEscapeLoop - , TF.testProperty "propEscapeUnEscapeLoopHiChars" propEscapeUnEscapeLoopHiChars ] -- URI string normalization tests @@ -1210,17 +1176,17 @@ testRelativeTo01 = testEq "testRelativeTo01" "http://bar.org/foo" (show $ - fromJust (parseURIReference "foo") `relativeTo` trbase) + (fromJust $ parseURIReference "foo") `relativeTo` trbase) testRelativeTo02 = testEq "testRelativeTo02" "http:foo" (show $ - fromJust (parseURIReference "http:foo") `relativeTo` trbase) + (fromJust $ parseURIReference "http:foo") `relativeTo` trbase) testRelativeTo03 = testEq "testRelativeTo03" "http://bar.org/foo" (show $ - fromJust (parseURIReference "http:foo") `nonStrictRelativeTo` trbase) + (fromJust $ parseURIReference "http:foo") `nonStrictRelativeTo` trbase) testRelativeTo = TF.testGroup "testRelativeTo" [ TF.testCase "testRelativeTo01" testRelativeTo01 @@ -1364,7 +1330,7 @@ ] -- Full test suite -allTests = TF.testGroup "all" +allTests = [ testURIRefSuite , testComponentSuite , testRelativeSuite @@ -1444,3 +1410,94 @@ -------------------------------------------------------------------------------- -- $Source: /srv/cvs/cvs.haskell.org/fptools/libraries/network/tests/URITest.hs,v $ -- $Author: gklyne $ +-- $Revision: 1.8 $ +-- $Log: URITest.hs,v $ +-- Revision 1.81 2012/08/01 aaronfriel +-- Added additional test case for the "xip.io" service style URLs and absolute URLs prefixed with ipv4 addresses. +-- +-- Revision 1.8 2005/07/19 22:01:27 gklyne +-- Added some additional test cases raised by discussion on URI@w3.org mailing list about 2005-07-19. The test p[roposed by this discussion exposed a subtle bug in relativeFrom not being an exact inverse of relativeTo. +-- +-- Revision 1.7 2005/06/06 16:31:44 gklyne +-- Added two new test cases. +-- +-- Revision 1.6 2005/05/31 17:18:36 gklyne +-- Added some additional test cases triggered by URI-list discussions. +-- +-- Revision 1.5 2005/04/07 11:09:37 gklyne +-- Added test cases for alternate parsing functions (including deprecated 'parseabsoluteURI') +-- +-- Revision 1.4 2005/04/05 12:47:32 gklyne +-- Added test case. +-- Changed module name, now requires GHC -main-is to compile. +-- All tests run OK with GHC 6.4 on MS-Windows. +-- +-- Revision 1.3 2004/11/05 17:29:09 gklyne +-- Changed password-obscuring logic to reflect late change in revised URI +-- specification (password "anonymous" is no longer a special case). +-- Updated URI test module to use function 'escapeURIString'. +-- (Should unEscapeString be similarly updated?) +-- +-- Revision 1.2 2004/10/27 13:06:55 gklyne +-- Updated URI module function names per: +-- http://www.haskell.org//pipermail/cvs-libraries/2004-October/002916.html +-- Added test cases to give better covereage of module functions. +-- +-- Revision 1.1 2004/10/14 16:11:30 gklyne +-- Add URI unit test to cvs.haskell.org repository +-- +-- Revision 1.17 2004/10/14 11:51:09 graham +-- Confirm that URITest runs with GHC. +-- Fix up some comments and other minor details. +-- +-- Revision 1.16 2004/10/14 11:45:30 graham +-- Use moduke name main for GHC 6.2 +-- +-- Revision 1.15 2004/08/11 11:07:39 graham +-- Add new test case. +-- +-- Revision 1.14 2004/06/30 11:35:27 graham +-- Update URI code to use hierarchical libraries for Parsec and Network. +-- +-- Revision 1.13 2004/06/22 16:19:16 graham +-- New URI test case added. +-- +-- Revision 1.12 2004/04/21 15:13:29 graham +-- Add test case +-- +-- Revision 1.11 2004/04/21 14:54:05 graham +-- Fix up some tests +-- +-- Revision 1.10 2004/04/20 14:54:13 graham +-- Fix up test cases related to port number in authority, +-- and add some more URI decomposition tests. +-- +-- Revision 1.9 2004/04/07 15:06:17 graham +-- Add extra test case +-- Revise syntax in line with changes to RFC2396bis +-- +-- Revision 1.8 2004/03/17 14:34:58 graham +-- Add Network.HTTP files to CVS +-- +-- Revision 1.7 2004/03/16 14:19:38 graham +-- Change licence to BSD style; add nullURI definition; new test cases. +-- +-- Revision 1.6 2004/02/20 12:12:00 graham +-- Add URI normalization functions +-- +-- Revision 1.5 2004/02/19 23:19:35 graham +-- Network.URI module passes all test cases +-- +-- Revision 1.4 2004/02/17 20:06:02 graham +-- Revised URI parser to reflect latest RFC2396bis (-04) +-- +-- Revision 1.3 2004/02/11 14:32:14 graham +-- Added work-in-progress notes. +-- +-- Revision 1.2 2004/02/02 14:00:39 graham +-- Fix optional host name in URI. Add test cases. +-- +-- Revision 1.1 2004/01/27 21:13:45 graham +-- New URI module and test suite added, +-- implementing the GHC Network.URI interface. +--