diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# 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,4 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#endif -------------------------------------------------------------------------------- -- | -- Module : Network.URI @@ -9,11 +12,12 @@ -- Stability : provisional -- Portability : portable -- --- This module defines functions for handling URIs. It presents substantially the --- same interface as the older GHC Network.URI module, but is implemented using --- Parsec rather than a Regex library that is not available with Hugs. The internal --- representation of URI has been changed so that URI strings are more --- completely preserved when round-tripping to a URI value and back. +-- This module defines functions for handling URIs. It presents +-- substantially the same interface as the older GHC Network.URI module, but +-- is implemented using Parsec rather than a Regex library that is not +-- available with Hugs. The internal representation of URI has been changed +-- so that URI strings are more completely preserved when round-tripping to a +-- URI value and back. -- -- In addition, four methods are provided for parsing different -- kinds of URI string (as noted in RFC3986): @@ -64,7 +68,10 @@ URI(..) , URIAuth(..) , nullURI + , nullURIAuth + , rectify, rectifyAuth + -- * Parsing , parseURI , parseURIReference @@ -96,7 +103,7 @@ -- The URI spec [3], section 2.4, indicates that all URI components -- should be escaped before they are assembled as a URI: -- \"Once produced, a URI is always in its percent-encoded form\" - , uriToString + , uriToString, uriAuthToString , isReserved, isUnreserved , isAllowedInURI, isUnescapedInURI , isUnescapedInURIComponent @@ -130,9 +137,19 @@ import Control.DeepSeq (NFData(rnf), deepseq) import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) import Data.Bits ((.|.),(.&.),shiftL,shiftR) -import Data.List (unfoldr) +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) #endif @@ -174,6 +191,40 @@ } deriving (Eq, Ord, Typeable, Data) #endif +-- | Add a prefix to a string, unless it already has it. +ensurePrefix :: String -> String -> String +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 isSuffixOf p s then s else s ++ p + +-- | Given a URIAuth in "nonstandard" form (lacking required separator characters), +-- return one that is standard. +rectifyAuth :: URIAuth -> URIAuth +rectifyAuth a = URIAuth { + uriUserInfo = unlessEmpty (ensureSuffix "@") (uriUserInfo a), + uriRegName = uriRegName a, + uriPort = unlessEmpty (ensurePrefix ":") (uriPort a) + } + +-- | Given a URI in "nonstandard" form (lacking required separator characters), +-- return one that is standard. +rectify :: URI -> URI +rectify u = URI { + uriScheme = ensureSuffix ":" (uriScheme u), + uriAuthority = fmap rectifyAuth (uriAuthority u), + uriPath = uriPath u, + uriQuery = unlessEmpty (ensurePrefix "?") (uriQuery u), + uriFragment = unlessEmpty (ensurePrefix "#") (uriFragment u) + } + +-- | Apply the function to the list, unless that list is empty, in +-- which case leave it alone. +unlessEmpty :: ([a] -> [a]) -> [a] -> [a] +unlessEmpty _f [] = [] +unlessEmpty f x = f x + instance NFData URI where rnf (URI s a p q f) = s `deepseq` a `deepseq` p `deepseq` q `deepseq` f `deepseq` () @@ -183,7 +234,11 @@ { uriUserInfo :: String -- ^ @anonymous\@@ , uriRegName :: String -- ^ @www.haskell.org@ , uriPort :: String -- ^ @:42@ +#if MIN_VERSION_base(4,6,0) + } deriving (Eq, Ord, Show, Typeable, Data, Generic) +#else } deriving (Eq, Ord, Show, Typeable, Data) +#endif instance NFData URIAuth where rnf (URIAuth ui rn p) = ui `deepseq` rn `deepseq` p `deepseq` () @@ -198,6 +253,14 @@ , uriFragment = "" } +-- |Blank URIAuth. +nullURIAuth :: URIAuth +nullURIAuth = URIAuth + { uriUserInfo = "" + , uriRegName = "" + , uriPort = "" + } + -- URI as instance of Show. Note that for security reasons, the default -- behaviour is to suppress any userinfo field (see RFC3986, section 7.5). -- This can be overridden by using uriToString directly with first @@ -348,11 +411,39 @@ isReserved :: Char -> Bool 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 noticably faster than a nicer +-- expression in terms of `elem`. isGenDelims :: Char -> Bool -isGenDelims c = c `elem` ":/?#[]@" +isGenDelims c = + case c of + ':' -> True + '/' -> True + '?' -> True + '#' -> True + '[' -> True + ']' -> True + '@' -> True + _ -> False +-- As per https://github.com/haskell/network-uri/pull/46, it was found +-- that the explicit case statement was noticably faster than a nicer +-- expression in terms of `elem`. isSubDelims :: Char -> Bool -isSubDelims c = c `elem` "!$&'()*+,;=" +isSubDelims c = + case c of + '!' -> True + '$' -> True + '&' -> True + '\'' -> True + '(' -> True + ')' -> True + '*' -> True + '+' -> True + ',' -> True + ';' -> True + '=' -> True + _ -> False subDelims :: URIParser String subDelims = (:[]) <$> oneOf "!$&'()*+,;=" @@ -445,6 +536,7 @@ } -- RFC3986, section 3.2.2 +-- RFC6874, section 2 host :: URIParser String host = ipLiteral <|> try ipv4address <|> regName @@ -452,7 +544,7 @@ ipLiteral :: URIParser String ipLiteral = do { _ <- char '[' - ; ua <- ( ipv6address <|> ipvFuture ) + ; ua <- ( ipv6addrz <|> ipvFuture ) ; _ <- char ']' ; return $ "[" ++ ua ++ "]" } @@ -470,6 +562,12 @@ isIpvFutureChar :: Char -> Bool isIpvFutureChar c = isUnreserved c || isSubDelims c || (c==';') +zoneid :: URIParser String +zoneid = concat <$> many1 (unreservedChar <|> escaped) + +ipv6addrz :: URIParser String +ipv6addrz = (++) <$> ipv6address <*> option "" (try $ (++) <$> string "%25" <*> zoneid) + ipv6address :: URIParser String ipv6address = try ( do @@ -1089,6 +1187,7 @@ (r,'/':ps1) -> (r++"/",ps1) (r,_) -> (r,[]) +-- | The segments of the path component of a URI. E.g., segments :: String -> [String] segments str = dropLeadingEmpty $ unfoldr nextSegmentMaybe str where @@ -1165,47 +1264,51 @@ where (p1,p2) = splitLast p +-- | Calculate the path to the first argument, from the second argument. relPathFrom :: String -> String -> String relPathFrom [] _ = "/" relPathFrom pabs [] = pabs -relPathFrom pabs base = -- Construct a relative path segments - if sa1 == sb1 -- if the paths share a leading segment - then if (sa1 == "/") -- other than a leading '/' - then if (sa2 == sb2) - then relPathFrom1 ra2 rb2 - else pabs - else relPathFrom1 ra1 rb1 - else 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 relPathFrom1 ra2 rb2 -- relativize from there. + else + pabs -- Otherwise it's not worth trying. + else relPathFrom1 ra1 rb1 -- If same & relative, relativize. + else pabs -- If 1st segs not equal, just use pabs. where (sa1,ra1) = nextSegment pabs (sb1,rb1) = nextSegment base (sa2,ra2) = nextSegment ra1 (sb2,rb2) = nextSegment rb1 --- relPathFrom1 strips off trailing names from the supplied paths, --- and calls difPathFrom to find the relative path from base to --- target +-- relPathFrom1 strips off trailing names from the supplied paths, and finds +-- the relative path from base to target. relPathFrom1 :: String -> String -> String relPathFrom1 pabs base = relName where + -- Relative paths are reckoned without the basename, so split those off. (sa,na) = splitLast pabs (sb,nb) = splitLast base rp = relSegsFrom sa sb 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 the name is vulnerable to being misinterpreted, + -- add a dot segment in advance to protect it. else if protect na then "./"++na else na else rp++na - -- Precede name with some path if it is null or contains a ':' + -- If a single-segment path is null or contains a ':', it needs + -- "protection" from being interpreted as a different kind of URL. protect s = null s || ':' `elem` s --- relSegsFrom discards any common leading segments from both paths, --- then invokes difSegsFrom to calculate a relative path from the end +-- relSegsFrom discards any equal leading segments from two *directory* +-- paths, then invokes difSegsFrom to calculate a relative path from the end -- of the base path to the end of the target path. --- The final name is handled separately, so this deals only with --- "directory" segtments. --- relSegsFrom :: String -> String -> String {- relSegsFrom sabs base @@ -1221,14 +1324,8 @@ (sa1,ra1) = nextSegment sabs (sb1,rb1) = nextSegment base --- difSegsFrom calculates a path difference from base to target, --- not including the final name at the end of the path --- (i.e. results always ends with '/') --- --- This function operates under the invariant that the supplied --- value of sabs is the desired path relative to the beginning of --- base. Thus, when base is empty, the desired path has been found. --- +-- Given two paths @a@, @b@, count out the necessary number of ".." segments +-- to get from the depth of @b@ to the path @a@. difSegsFrom :: String -> String -> String {- difSegsFrom sabs base @@ -1275,6 +1372,28 @@ normstr Nothing = uristr normstr (Just u) = show (normuri u) normuri u = u { uriPath = removeDotSegments (uriPath u) } + +------------------------------------------------------------ +-- Lift instances to support Network.URI.Static +------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ >= 800 +#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 diff --git a/Network/URI/Lens.hs b/Network/URI/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/URI/Lens.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE Rank2Types #-} +-- | Network uri lenses +module Network.URI.Lens + ( uriRegNameLens + , uriUserInfoLens + , uriPortLens + , uriAuthorityLens + , uriSchemeLens + , uriPathLens + , uriQueryLens + , uriFragmentLens + ) where + +import Control.Applicative +import Network.URI + +type Lens' s a = Lens s s a a +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens sa sbt afb s = sbt s <$> afb (sa s) + +uriRegNameLens :: Lens' URIAuth String +uriRegNameLens = lens uriRegName (\parent newVal -> parent {uriRegName = newVal}) + +uriUserInfoLens :: Lens' URIAuth String +uriUserInfoLens = + lens uriUserInfo (\parent newVal -> parent {uriUserInfo = newVal}) + +uriPortLens :: Lens' URIAuth String +uriPortLens = lens uriPort (\parent newVal -> parent {uriPort = newVal}) + +uriAuthorityLens :: Lens' URI (Maybe URIAuth) +uriAuthorityLens = + lens uriAuthority (\parent newVal -> parent {uriAuthority = newVal}) + +uriSchemeLens :: Lens' URI String +uriSchemeLens = lens uriScheme (\parent newVal -> parent {uriScheme = newVal}) + +uriPathLens :: Lens' URI String +uriPathLens = lens uriPath (\parent newVal -> parent {uriPath = newVal}) + +uriQueryLens :: Lens' URI String +uriQueryLens = lens uriQuery (\parent newVal -> parent {uriQuery = newVal}) + +uriFragmentLens :: Lens' URI String +uriFragmentLens = + lens uriFragment (\parent newVal -> parent {uriFragment = newVal}) diff --git a/Network/URI/Static.hs b/Network/URI/Static.hs new file mode 100644 --- /dev/null +++ b/Network/URI/Static.hs @@ -0,0 +1,104 @@ +#if __GLASGOW_HASKELL__ < 800 +module Network.URI.Static () where +#else + +{-# LANGUAGE RecordWildCards, TemplateHaskellQuotes, ViewPatterns #-} + +module Network.URI.Static + ( + -- * Absolute URIs + uri + , staticURI + -- * Relative URIs + , relativeReference + , staticRelativeReference + ) where + +import Language.Haskell.TH (unType) +import Language.Haskell.TH.Lib (TExpQ) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Network.URI (URI(..), parseURI, parseRelativeReference) + +-- $setup +-- >>> :set -XTemplateHaskell +-- >>> :set -XQuasiQuotes + +---------------------------------------------------------------------------- +-- Absolute URIs +---------------------------------------------------------------------------- + +-- | '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. +-- +-- >>> $$(staticURI "http://www.google.com/") +-- http://www.google.com/ +-- +-- >>> $$(staticURI "http://www.google.com/##") +-- +-- ... +-- ... Invalid URI: http://www.google.com/## +-- ... +staticURI :: String -- ^ String representation of a URI + -> TExpQ URI -- ^ URI +staticURI (parseURI -> Just u) = [|| u ||] +staticURI s = fail $ "Invalid URI: " ++ s + +-- | 'uri' is a quasi quoter for 'staticURI'. +-- +-- >>> [uri|http://www.google.com/|] +-- http://www.google.com/ +-- +-- >>> [uri|http://www.google.com/##|] +-- +-- ... +-- ... Invalid URI: http://www.google.com/## +-- ... +uri :: QuasiQuoter +uri = QuasiQuoter { + quoteExp = fmap unType . staticURI, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined +} + +---------------------------------------------------------------------------- +-- Relative URIs +---------------------------------------------------------------------------- + +-- | '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. +-- +-- >>> $$(staticRelativeReference "/foo?bar=baz#quux") +-- /foo?bar=baz#quux +-- +-- >>> $$(staticRelativeReference "http://www.google.com/") +-- +-- ... +-- ... Invalid relative reference: http://www.google.com/ +-- ... +staticRelativeReference :: String -- ^ String representation of a reference + -> TExpQ URI -- ^ Refererence +staticRelativeReference (parseRelativeReference -> Just ref) = [|| ref ||] +staticRelativeReference ref = fail $ "Invalid relative reference: " ++ ref + +-- | 'relativeReference' is a quasi quoter for 'staticRelativeReference'. +-- +-- >>> [relativeReference|/foo?bar=baz#quux|] +-- /foo?bar=baz#quux +-- +-- >>> [relativeReference|http://www.google.com/|] +-- +-- ... +-- ... Invalid relative reference: http://www.google.com/ +-- ... +relativeReference :: QuasiQuoter +relativeReference = QuasiQuoter { + quoteExp = fmap unType . staticRelativeReference, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined +} + +#endif diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,41 @@ +The network-uri package +======================= + +This package provides facilities for parsing and unparsing URIs, and creating +and resolving relative URI references, closely following the URI spec, IETF +RFC 3986 [1]. + +The main module in this package, `Network.URI`, was split off from the +network package in the network-2.6 release. + +# Network.URI.Static + +Network.URI.Static that allows you to declare static URIs in type-safe manner. + +With the base module, when you declare a static URI, you need to either use `Maybe URI` or use `URI` and give up type safety. + +```haskell +safeButWrappedInMaybeURI :: Maybe URI +safeButWrappedInMaybeURI = parseURI "http://www.google.com/" + +directButUnsafeURI :: URI +directButUnsafeURI = fromJust $ parseURI "http://www.google.com/" +``` + +This library allows you to write static URIs in type-safe manner by checking URIs at compile time using template haskell. + +Now, you can write the following. + +```haskell +directAndSafeURI :: URI +directAndSafeURI = $$(staticURI "http://www.google.com") +``` + +You can even use a quasi quote if you'd like. + +```haskell +directAndSafeURI :: URI +directAndSafeURI = [uri|"http://www.google.com"|] +``` + +These two expressions emit an error at compile time if a specified URI is malformed. diff --git a/network-uri.cabal b/network-uri.cabal --- a/network-uri.cabal +++ b/network-uri.cabal @@ -1,14 +1,27 @@ name: network-uri -version: 2.6.1.0 +version: 2.7.0.0 synopsis: URI manipulation description: - This package provides an URI manipulation interface. + This package provides facilities for parsing and unparsing URIs, and creating + and resolving relative URI references, closely following the URI spec, + . . - In network-2.6 the @Network.URI@ module was split off from the - network package into this package. If you're using the @Network.URI@ - module you can automatically get it from the right package by adding - this to your .cabal file: + == Backward-compatibility . + In @network-2.6@ the "Network.URI" module was split off from the + @network@ package into this package. If you're using the "Network.URI" + module you can be backward compatible and automatically get it from + the right package by using the + + in your @.cabal@ file's build-depends (along with dependencies for + both @network-uri@ and @network@): + . + > build-depends: + > network-uri-flag == 0.1.* + . + Or you can do the same manually by adding this boilerplate to your + @.cabal@ file: + . > flag network-uri > description: Get Network.URI from the network-uri package > default: True @@ -20,24 +33,31 @@ > else > build-depends: network-uri < 2.6, network < 2.6 . - That is, get the module from either network < 2.6 or from - network-uri >= 2.6. + That is, get the module from either @network < 2.6@ or from + @network-uri >= 2.6@. + homepage: https://github.com/haskell/network-uri bug-reports: https://github.com/haskell/network-uri/issues license: BSD3 license-file: LICENSE +extra-source-files: README.md, CHANGELOG.md maintainer: ezra@ezrakilty.net category: Network build-type: Simple cabal-version: >=1.10 +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: Network.URI + Network.URI.Lens + Network.URI.Static build-depends: base >= 3 && < 5, deepseq >= 1.1 && < 1.5, parsec >= 3.0 && < 3.2 + if impl(ghc >= 8.0) + build-depends: template-haskell default-extensions: CPP, DeriveDataTypeable if impl(ghc >= 7.6) default-extensions: DeriveGeneric @@ -56,6 +76,21 @@ test-framework, test-framework-hunit, test-framework-quickcheck2 + + ghc-options: -Wall -fwarn-tabs + default-language: Haskell98 + +test-suite uri-bench + hs-source-dirs: tests + main-is: uri-bench.hs + type: exitcode-stdio-1.0 + + build-depends: + base < 5, + HUnit, + network-uri, + criterion, + deepseq ghc-options: -Wall -fwarn-tabs default-language: Haskell98 diff --git a/tests/uri-bench.hs b/tests/uri-bench.hs new file mode 100644 --- /dev/null +++ b/tests/uri-bench.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE BangPatterns #-} +-------------------------------------------------------------------------------- +-- $Id: URITest.hs,v 1.8 2005/07/19 22:01:27 gklyne Exp $ +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : URITest +-- Copyright : (c) 2004, Graham Klyne +-- License : BSD-style (see end of this file) +-- +-- Performance benchmarks for the network-uri package. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Network.URI + ( parseURI + , parseURIReference + , pathSegments + , relativeFrom + , relativeTo + , isReserved + ) + +import Criterion.Main +import Control.DeepSeq + +main = defaultMain [ + let Just !u = force (parseURI "http://ezample.org/foo/bar/baz//wimple/dimple/simple") in + bgroup "pathSegments" [ + bench "head" $ nf head (pathSegments u) + , bench "tail" $ nf tail (pathSegments u) + ] + , bgroup "relativeFrom" [ + let Just !u1 = force (parseURI "http://ex.it/foo/bar/baz/bop") in + let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in + bench "same 4" $ nf (relativeFrom u1) u2 + , let Just !u1 = force (parseURI "http://ex.it/foo/bar/biz/bop") in + let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in + bench "different 4" $ nf (relativeFrom u1) u2 + ] + , bgroup "relativeTo" [ + let Just !u1 = force (parseURIReference "../../biz/../biz/./bop") in + let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in + bench "dots and double dots" $ nf (relativeTo u1) u2 + ] + , -- Prompted by https://github.com/haskell/network-uri/pull/46 + bgroup "isReserved" [ + bench "isReserved a" $ nf isReserved 'a' + , bench "isReserved :" $ nf isReserved ':' + ] + ] diff --git a/tests/uri001.hs b/tests/uri001.hs --- a/tests/uri001.hs +++ b/tests/uri001.hs @@ -38,13 +38,14 @@ import Network.URI ( URI(..), URIAuth(..) , nullURI + , rectify, rectifyAuth , parseURI, parseURIReference, parseRelativeReference, parseAbsoluteURI , parseAbsoluteURI , isURI, isURIReference, isRelativeReference, isAbsoluteURI , uriIsAbsolute, uriIsRelative , relativeTo, nonStrictRelativeTo , relativeFrom - , uriToString + , uriToString, uriAuthToString , isUnescapedInURIComponent , isUnescapedInURI, escapeURIString, unEscapeString , normalizeCase, normalizeEscape, normalizePathSegments @@ -135,6 +136,7 @@ testURIRef027 = testURIRef AbsId "http://[2010:836B:4179::836B:4179]" testURIRef028 = testURIRef RelRf "//[2010:836B:4179::836B:4179]" testURIRef029 = testURIRef InvRf "[2010:836B:4179::836B:4179]" +testURIRef030 = testURIRef AbsId "http://[fe80::ff:fe00:1%25eth0]" -- RFC2396 test cases testURIRef031 = testURIRef RelRf "./aaa" testURIRef032 = testURIRef RelRf "../aaa" @@ -1303,6 +1305,30 @@ assertJust testPathSegmentsRoundTrip $ parseURI "http://ex.ca/foo//bar/" ] +testRectify = TF.testGroup "testRectify" + [ TF.testCase "" $ testEq "testRectify" + (show $ rectify $ URI { uriScheme = "http" , + uriAuthority = Just (URIAuth "ezra" "www.google.com" "80") , + uriPath = "/foo/bar" , + uriQuery = "foo=bar&baz=quz" , + uriFragment = "chap10" }) + "http://ezra@www.google.com:80/foo/bar?foo=bar&baz=quz#chap10" + , -- According to RFC2986, any URL without a // does not have an authority component. + -- Therefore tag: URIs have all their content in the path component. This is supported + -- by the urn: example in section 3. Note that tag: URIs have no leading slash on their + -- path component. + TF.testCase "" $ testEq "testRectify" + "tag:timothy@hpl.hp.com,2001:web/externalHome" + (show $ rectify $ URI { uriScheme = "tag" , + uriAuthority = Nothing, + uriPath = "timothy@hpl.hp.com,2001:web/externalHome", + uriQuery = "" , + uriFragment = "" }) + , TF.testCase "" $ testEq "testRectifyAuth" + "//ezra@www.google.com:80" + ((uriAuthToString id . Just . rectifyAuth $ URIAuth "ezra" "www.google.com" "80") "") + ] + -- Full test suite allTests = [ testURIRefSuite @@ -1319,6 +1345,7 @@ , testIsAbsolute , testIsRelative , testPathSegments + , testRectify ] main = TF.defaultMain allTests