diff --git a/Network/URI.hs b/Network/URI.hs new file mode 100644 --- /dev/null +++ b/Network/URI.hs @@ -0,0 +1,1349 @@ +{-# LANGUAGE CPP #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.URI +-- Copyright : (c) 2004, Graham Klyne +-- License : BSD-style (see end of this file) +-- +-- Maintainer : Graham Klyne +-- 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. +-- +-- In addition, four methods are provided for parsing different +-- kinds of URI string (as noted in RFC3986): +-- 'parseURI', +-- 'parseURIReference', +-- 'parseRelativeReference' and +-- 'parseAbsoluteURI'. +-- +-- Further, four methods are provided for classifying different +-- kinds of URI string (as noted in RFC3986): +-- 'isURI', +-- 'isURIReference', +-- 'isRelativeReference' and +-- 'isAbsoluteURI'. +-- +-- The long-standing official reference for URI handling was RFC2396 [1], +-- as updated by RFC 2732 [2], but this was replaced by a new specification, +-- RFC3986 [3] in January 2005. This latter specification has been used +-- as the primary reference for constructing the URI parser implemented +-- here, and it is intended that there is a direct relationship between +-- the syntax definition in that document and this parser implementation. +-- +-- RFC 1808 [4] contains a number of test cases for relative URI handling. +-- Dan Connolly's Python module @uripath.py@ [5] also contains useful details +-- and test cases. +-- +-- Some of the code has been copied from the previous GHC implementation, +-- but the parser is replaced with one that performs more complete +-- syntax checking of the URI itself, according to RFC3986 [3]. +-- +-- References +-- +-- (1) +-- +-- (2) +-- +-- (3) +-- +-- (4) +-- +-- (5) +-- +-------------------------------------------------------------------------------- + +module Network.URI + ( + -- * The URI type + URI(..) + , URIAuth(..) + , nullURI + + -- * Parsing + , parseURI + , parseURIReference + , parseRelativeReference + , parseAbsoluteURI + + -- * Test for strings containing various kinds of URI + , isURI + , isURIReference + , isRelativeReference + , isAbsoluteURI + , isIPv6address + , isIPv4address + + -- * Predicates + , uriIsAbsolute + , uriIsRelative + + -- * Relative URIs + , relativeTo + , nonStrictRelativeTo + , relativeFrom + + -- * Operations on URI strings + -- | Support for putting strings into URI-friendly + -- escaped format and getting them back again. + -- This can't be done transparently in all cases, because certain + -- characters have different meanings in different kinds of URI. + -- 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 + , isReserved, isUnreserved + , isAllowedInURI, isUnescapedInURI + , isUnescapedInURIComponent + , escapeURIChar + , escapeURIString + , unEscapeString + + -- * URI Normalization functions + , normalizeCase + , normalizeEscape + , normalizePathSegments + + -- * Deprecated functions + , parseabsoluteURI + , escapeString + , reserved, unreserved + , scheme, authority, path, query, fragment + ) where + +import Text.ParserCombinators.Parsec + ( GenParser, ParseError + , parse, (<|>), (), try + , option, many, many1, count, notFollowedBy + , char, satisfy, oneOf, string, eof + , unexpected + ) + +import Control.Monad (MonadPlus(..)) +import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) +import Data.Bits ((.|.),(.&.),shiftL,shiftR) +import Debug.Trace (trace) +import Numeric (showIntAtBase) + +import Data.Typeable (Typeable) +#if MIN_VERSION_base(4,0,0) +import Data.Data (Data) +#else +import Data.Generics (Data) +#endif + +------------------------------------------------------------ +-- The URI datatype +------------------------------------------------------------ + +-- |Represents a general universal resource identifier using +-- its component parts. +-- +-- For example, for the URI +-- +-- > foo://anonymous@www.haskell.org:42/ghc?query#frag +-- +-- the components are: +-- +data URI = URI + { uriScheme :: String -- ^ @foo:@ + , uriAuthority :: Maybe URIAuth -- ^ @\/\/anonymous\@www.haskell.org:42@ + , uriPath :: String -- ^ @\/ghc@ + , uriQuery :: String -- ^ @?query@ + , uriFragment :: String -- ^ @#frag@ + } deriving (Eq, Ord, Typeable, Data) + +-- |Type for authority value within a URI +data URIAuth = URIAuth + { uriUserInfo :: String -- ^ @anonymous\@@ + , uriRegName :: String -- ^ @www.haskell.org@ + , uriPort :: String -- ^ @:42@ + } deriving (Eq, Ord, Show, Typeable, Data) + +-- |Blank URI +nullURI :: URI +nullURI = URI + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } + +-- 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 +-- argument @id@ (noting that this returns a ShowS value rather than a string). +-- +-- [[[Another design would be to embed the userinfo mapping function in +-- the URIAuth value, with the default value suppressing userinfo formatting, +-- but providing a function to return a new URI value with userinfo +-- data exposed by show.]]] +-- +instance Show URI where + showsPrec _ = uriToString defaultUserInfoMap + +defaultUserInfoMap :: String -> String +defaultUserInfoMap uinf = user++newpass + where + (user,pass) = break (==':') uinf + newpass = if null pass || (pass == "@") + || (pass == ":@") + then pass + else ":...@" + +testDefaultUserInfoMap :: [Bool] +testDefaultUserInfoMap = + [ defaultUserInfoMap "" == "" + , defaultUserInfoMap "@" == "@" + , defaultUserInfoMap "user@" == "user@" + , defaultUserInfoMap "user:@" == "user:@" + , defaultUserInfoMap "user:anonymous@" == "user:...@" + , defaultUserInfoMap "user:pass@" == "user:...@" + , defaultUserInfoMap "user:pass" == "user:...@" + , defaultUserInfoMap "user:anonymous" == "user:...@" + ] + +------------------------------------------------------------ +-- Parse a URI +------------------------------------------------------------ + +-- |Turn a string containing a URI into a 'URI'. +-- Returns 'Nothing' if the string is not a valid URI; +-- (an absolute URI with optional fragment identifier). +-- +-- NOTE: this is different from the previous network.URI, +-- whose @parseURI@ function works like 'parseURIReference' +-- in this module. +-- +parseURI :: String -> Maybe URI +parseURI = parseURIAny uri + +-- |Parse a URI reference to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid URI reference. +-- (an absolute or relative URI with optional fragment identifier). +-- +parseURIReference :: String -> Maybe URI +parseURIReference = parseURIAny uriReference + +-- |Parse a relative URI to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid relative URI. +-- (a relative URI with optional fragment identifier). +-- +parseRelativeReference :: String -> Maybe URI +parseRelativeReference = parseURIAny relativeRef + +-- |Parse an absolute URI to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid absolute URI. +-- (an absolute URI without a fragment identifier). +-- +parseAbsoluteURI :: String -> Maybe URI +parseAbsoluteURI = parseURIAny absoluteURI + +-- |Test if string contains a valid URI +-- (an absolute URI with optional fragment identifier). +-- +isURI :: String -> Bool +isURI = isValidParse uri + +-- |Test if string contains a valid URI reference +-- (an absolute or relative URI with optional fragment identifier). +-- +isURIReference :: String -> Bool +isURIReference = isValidParse uriReference + +-- |Test if string contains a valid relative URI +-- (a relative URI with optional fragment identifier). +-- +isRelativeReference :: String -> Bool +isRelativeReference = isValidParse relativeRef + +-- |Test if string contains a valid absolute URI +-- (an absolute URI without a fragment identifier). +-- +isAbsoluteURI :: String -> Bool +isAbsoluteURI = isValidParse absoluteURI + +-- |Test if string contains a valid IPv6 address +-- +isIPv6address :: String -> Bool +isIPv6address = isValidParse ipv6address + +-- |Test if string contains a valid IPv4 address +-- +isIPv4address :: String -> Bool +isIPv4address = isValidParse ipv4address + +-- |Test function: parse and reconstruct a URI reference +-- +testURIReference :: String -> String +testURIReference uristr = show (parseAll uriReference "" uristr) + +-- Helper function for turning a string into a URI +-- +parseURIAny :: URIParser URI -> String -> Maybe URI +parseURIAny parser uristr = case parseAll parser "" uristr of + Left _ -> Nothing + Right u -> Just u + +-- Helper function to test a string match to a parser +-- +isValidParse :: URIParser a -> String -> Bool +isValidParse parser uristr = case parseAll parser "" uristr of + -- Left e -> error (show e) + Left _ -> False + Right _ -> True + +parseAll :: URIParser a -> String -> String -> Either ParseError a +parseAll parser filename uristr = parse newparser filename uristr + where + newparser = + do { res <- parser + ; eof + ; return res + } + +------------------------------------------------------------ +-- Predicates +------------------------------------------------------------ + +uriIsAbsolute :: URI -> Bool +uriIsAbsolute (URI {uriScheme = scheme}) = scheme /= "" + +uriIsRelative :: URI -> Bool +uriIsRelative = not . uriIsAbsolute + +------------------------------------------------------------ +-- URI parser body based on Parsec elements and combinators +------------------------------------------------------------ + +-- Parser parser type. +-- Currently +type URIParser a = GenParser Char () a + +-- RFC3986, section 2.1 +-- +-- Parse and return a 'pct-encoded' sequence +-- +escaped :: URIParser String +escaped = + do { char '%' + ; h1 <- hexDigitChar + ; h2 <- hexDigitChar + ; return $ ['%',h1,h2] + } + +-- RFC3986, section 2.2 +-- +-- |Returns 'True' if the character is a \"reserved\" character in a +-- URI. To include a literal instance of one of these characters in a +-- component of a URI, it must be escaped. +-- +isReserved :: Char -> Bool +isReserved c = isGenDelims c || isSubDelims c + +isGenDelims :: Char -> Bool +isGenDelims c = c `elem` ":/?#[]@" + +isSubDelims :: Char -> Bool +isSubDelims c = c `elem` "!$&'()*+,;=" + +genDelims :: URIParser String +genDelims = do { c <- satisfy isGenDelims ; return [c] } + +subDelims :: URIParser String +subDelims = do { c <- satisfy isSubDelims ; return [c] } + +-- RFC3986, section 2.3 +-- +-- |Returns 'True' if the character is an \"unreserved\" character in +-- a URI. These characters do not need to be escaped in a URI. The +-- only characters allowed in a URI are either \"reserved\", +-- \"unreserved\", or an escape sequence (@%@ followed by two hex digits). +-- +isUnreserved :: Char -> Bool +isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") + +unreservedChar :: URIParser String +unreservedChar = do { c <- satisfy isUnreserved ; return [c] } + +-- RFC3986, section 3 +-- +-- URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +-- +-- hier-part = "//" authority path-abempty +-- / path-abs +-- / path-rootless +-- / path-empty + +uri :: URIParser URI +uri = + do { us <- try uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- hierPart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; uf <- option "" ( do { char '#' ; ufragment } ) + ; return $ URI + { uriScheme = us + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = uf + } + } + +hierPart :: URIParser ((Maybe URIAuth),String) +hierPart = + do { try (string "//") + ; ua <- uauthority + ; up <- pathAbEmpty + ; return (ua,up) + } + <|> do { up <- pathAbs + ; return (Nothing,up) + } + <|> do { up <- pathRootLess + ; return (Nothing,up) + } + <|> do { return (Nothing,"") + } + +-- RFC3986, section 3.1 + +uscheme :: URIParser String +uscheme = + do { s <- oneThenMany alphaChar (satisfy isSchemeChar) + ; char ':' + ; return $ s++":" + } + +-- RFC3986, section 3.2 + +uauthority :: URIParser (Maybe URIAuth) +uauthority = + do { uu <- option "" (try userinfo) + ; uh <- host + ; up <- option "" port + ; return $ Just $ URIAuth + { uriUserInfo = uu + , uriRegName = uh + , uriPort = up + } + } + +-- RFC3986, section 3.2.1 + +userinfo :: URIParser String +userinfo = + do { uu <- many (uchar ";:&=+$,") + ; char '@' + ; return (concat uu ++"@") + } + +-- RFC3986, section 3.2.2 + +host :: URIParser String +host = ipLiteral <|> try ipv4address <|> regName + +ipLiteral :: URIParser String +ipLiteral = + do { char '[' + ; ua <- ( ipv6address <|> ipvFuture ) + ; char ']' + ; return $ "[" ++ ua ++ "]" + } + "IP address literal" + +ipvFuture :: URIParser String +ipvFuture = + do { char 'v' + ; h <- hexDigitChar + ; char '.' + ; a <- many1 (satisfy isIpvFutureChar) + ; return $ 'v':h:'.':a + } + +isIpvFutureChar :: Char -> Bool +isIpvFutureChar c = isUnreserved c || isSubDelims c || (c==';') + +ipv6address :: URIParser String +ipv6address = + try ( do + { a2 <- count 6 h4c + ; a3 <- ls32 + ; return $ concat a2 ++ a3 + } ) + <|> try ( do + { string "::" + ; a2 <- count 5 h4c + ; a3 <- ls32 + ; return $ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 0 + ; string "::" + ; a2 <- count 4 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 1 + ; string "::" + ; a2 <- count 3 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 2 + ; string "::" + ; a2 <- count 2 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 3 + ; string "::" + ; a2 <- h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 4 + ; string "::" + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 5 + ; string "::" + ; a3 <- h4 + ; return $ a1 ++ "::" ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 6 + ; string "::" + ; return $ a1 ++ "::" + } ) + "IPv6 address" + +opt_n_h4c_h4 :: Int -> URIParser String +opt_n_h4c_h4 n = option "" $ + do { a1 <- countMinMax 0 n h4c + ; a2 <- h4 + ; return $ concat a1 ++ a2 + } + +ls32 :: URIParser String +ls32 = try ( do + { a1 <- h4c + ; a2 <- h4 + ; return (a1++a2) + } ) + <|> ipv4address + +h4c :: URIParser String +h4c = try $ + do { a1 <- h4 + ; char ':' + ; notFollowedBy (char ':') + ; return $ a1 ++ ":" + } + +h4 :: URIParser String +h4 = countMinMax 1 4 hexDigitChar + +ipv4address :: URIParser String +ipv4address = + do { a1 <- decOctet ; char '.' + ; a2 <- decOctet ; char '.' + ; a3 <- decOctet ; char '.' + ; a4 <- decOctet + ; notFollowedBy regName + ; return $ a1++"."++a2++"."++a3++"."++a4 + } + "IPv4 Address" + +decOctet :: URIParser String +decOctet = + do { a1 <- countMinMax 1 3 digitChar + ; if (read a1 :: Integer) > 255 then + fail "Decimal octet value too large" + else + return a1 + } + +regName :: URIParser String +regName = + do { ss <- countMinMax 0 255 ( unreservedChar <|> escaped <|> subDelims ) + ; return $ concat ss + } + "Registered name" + +-- RFC3986, section 3.2.3 + +port :: URIParser String +port = + do { char ':' + ; p <- many digitChar + ; return (':':p) + } + +-- +-- RFC3986, section 3.3 +-- +-- path = path-abempty ; begins with "/" or is empty +-- / path-abs ; begins with "/" but not "//" +-- / path-noscheme ; begins with a non-colon segment +-- / path-rootless ; begins with a segment +-- / path-empty ; zero characters +-- +-- path-abempty = *( "/" segment ) +-- path-abs = "/" [ segment-nz *( "/" segment ) ] +-- path-noscheme = segment-nzc *( "/" segment ) +-- path-rootless = segment-nz *( "/" segment ) +-- path-empty = 0 +-- +-- segment = *pchar +-- segment-nz = 1*pchar +-- segment-nzc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +-- +-- pchar = unreserved / pct-encoded / sub-delims / ":" / "@" + +{- +upath :: URIParser String +upath = pathAbEmpty + <|> pathAbs + <|> pathNoScheme + <|> pathRootLess + <|> pathEmpty +-} + +pathAbEmpty :: URIParser String +pathAbEmpty = + do { ss <- many slashSegment + ; return $ concat ss + } + +pathAbs :: URIParser String +pathAbs = + do { char '/' + ; ss <- option "" pathRootLess + ; return $ '/':ss + } + +pathNoScheme :: URIParser String +pathNoScheme = + do { s1 <- segmentNzc + ; ss <- many slashSegment + ; return $ concat (s1:ss) + } + +pathRootLess :: URIParser String +pathRootLess = + do { s1 <- segmentNz + ; ss <- many slashSegment + ; return $ concat (s1:ss) + } + +slashSegment :: URIParser String +slashSegment = + do { char '/' + ; s <- segment + ; return ('/':s) + } + +segment :: URIParser String +segment = + do { ps <- many pchar + ; return $ concat ps + } + +segmentNz :: URIParser String +segmentNz = + do { ps <- many1 pchar + ; return $ concat ps + } + +segmentNzc :: URIParser String +segmentNzc = + do { ps <- many1 (uchar "@") + ; return $ concat ps + } + +pchar :: URIParser String +pchar = uchar ":@" + +-- helper function for pchar and friends +uchar :: String -> URIParser String +uchar extras = + unreservedChar + <|> escaped + <|> subDelims + <|> do { c <- oneOf extras ; return [c] } + +-- RFC3986, section 3.4 + +uquery :: URIParser String +uquery = + do { ss <- many $ uchar (":@"++"/?") + ; return $ '?':concat ss + } + +-- RFC3986, section 3.5 + +ufragment :: URIParser String +ufragment = + do { ss <- many $ uchar (":@"++"/?") + ; return $ '#':concat ss + } + +-- Reference, Relative and Absolute URI forms +-- +-- RFC3986, section 4.1 + +uriReference :: URIParser URI +uriReference = uri <|> relativeRef + +-- RFC3986, section 4.2 +-- +-- relative-URI = relative-part [ "?" query ] [ "#" fragment ] +-- +-- relative-part = "//" authority path-abempty +-- / path-abs +-- / path-noscheme +-- / path-empty + +relativeRef :: URIParser URI +relativeRef = + do { notMatching uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- relativePart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; uf <- option "" ( do { char '#' ; ufragment } ) + ; return $ URI + { uriScheme = "" + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = uf + } + } + +relativePart :: URIParser ((Maybe URIAuth),String) +relativePart = + do { try (string "//") + ; ua <- uauthority + ; up <- pathAbEmpty + ; return (ua,up) + } + <|> do { up <- pathAbs + ; return (Nothing,up) + } + <|> do { up <- pathNoScheme + ; return (Nothing,up) + } + <|> do { return (Nothing,"") + } + +-- RFC3986, section 4.3 + +absoluteURI :: URIParser URI +absoluteURI = + do { us <- uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- hierPart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; return $ URI + { uriScheme = us + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = "" + } + } + +-- Imports from RFC 2234 + + -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859 + -- (and possibly Unicode!) chars. + -- [[[Above was a comment originally in GHC Network/URI.hs: + -- when IRIs are introduced then most codepoints above 128(?) should + -- be treated as unreserved, and higher codepoints for letters should + -- certainly be allowed. + -- ]]] + +isAlphaChar :: Char -> Bool +isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') + +isDigitChar :: Char -> Bool +isDigitChar c = (c >= '0' && c <= '9') + +isAlphaNumChar :: Char -> Bool +isAlphaNumChar c = isAlphaChar c || isDigitChar c + +isHexDigitChar :: Char -> Bool +isHexDigitChar c = isHexDigit c + +isSchemeChar :: Char -> Bool +isSchemeChar c = (isAlphaNumChar c) || (c `elem` "+-.") + +alphaChar :: URIParser Char +alphaChar = satisfy isAlphaChar -- or: Parsec.letter ? + +digitChar :: URIParser Char +digitChar = satisfy isDigitChar -- or: Parsec.digit ? + +alphaNumChar :: URIParser Char +alphaNumChar = satisfy isAlphaNumChar + +hexDigitChar :: URIParser Char +hexDigitChar = satisfy isHexDigitChar -- or: Parsec.hexDigit ? + +-- Additional parser combinators for common patterns + +oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a] +oneThenMany p1 pr = + do { a1 <- p1 + ; ar <- many pr + ; return (a1:ar) + } + +countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a] +countMinMax m n p | m > 0 = + do { a1 <- p + ; ar <- countMinMax (m-1) (n-1) p + ; return (a1:ar) + } +countMinMax _ n _ | n <= 0 = return [] +countMinMax _ n p = option [] $ + do { a1 <- p + ; ar <- countMinMax 0 (n-1) p + ; return (a1:ar) + } + +notMatching :: Show a => GenParser tok st a -> GenParser tok st () +notMatching p = do { a <- try p ; unexpected (show a) } <|> return () + +------------------------------------------------------------ +-- Reconstruct a URI string +------------------------------------------------------------ +-- +-- |Turn a 'URI' into a string. +-- +-- Uses a supplied function to map the userinfo part of the URI. +-- +-- The Show instance for URI uses a mapping that hides any password +-- that may be present in the URI. Use this function with argument @id@ +-- to preserve the password in the formatted output. +-- +uriToString :: (String->String) -> URI -> ShowS +uriToString userinfomap URI { uriScheme=myscheme + , uriAuthority=myauthority + , uriPath=mypath + , uriQuery=myquery + , uriFragment=myfragment + } = + (myscheme++) . (uriAuthToString userinfomap myauthority) + . (mypath++) . (myquery++) . (myfragment++) + +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)++)) + . (myregname++) + . (myport++) + +------------------------------------------------------------ +-- Character classes +------------------------------------------------------------ + +-- | Returns 'True' if the character is allowed in a URI. +-- +isAllowedInURI :: Char -> Bool +isAllowedInURI c = isReserved c || isUnreserved c || c == '%' -- escape char + +-- | Returns 'True' if the character is allowed unescaped in a URI. +-- +isUnescapedInURI :: Char -> Bool +isUnescapedInURI c = isReserved c || isUnreserved c + +-- | Returns 'True' if the character is allowed unescaped in a URI component. +-- +isUnescapedInURIComponent :: Char -> Bool +isUnescapedInURIComponent c = not (isReserved c || not (isUnescapedInURI c)) + +------------------------------------------------------------ +-- Escape sequence handling +------------------------------------------------------------ + +-- |Escape character if supplied predicate is not satisfied, +-- otherwise return character as singleton string. +-- +escapeURIChar :: (Char->Bool) -> Char -> String +escapeURIChar p c + | p c = [c] + | otherwise = concatMap (\i -> '%' : myShowHex i "") (utf8EncodeChar c) + where + myShowHex :: Int -> ShowS + myShowHex n r = case showIntAtBase 16 (toChrHex) n r of + [] -> "00" + [x] -> ['0',x] + cs -> cs + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d) + | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + +-- From http://hackage.haskell.org/package/utf8-string +-- by Eric Mertens, BSD3 +-- Returns [Int] for use with showIntAtBase +utf8EncodeChar :: Char -> [Int] +utf8EncodeChar = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + +-- |Can be used to make a string valid for use in a URI. +-- +escapeURIString + :: (Char->Bool) -- ^ a predicate which returns 'False' + -- if the character should be escaped + -> String -- ^ the string to process + -> String -- ^ the resulting URI string +escapeURIString p s = concatMap (escapeURIChar p) s + +-- |Turns all instances of escaped characters in the string back +-- into literal characters. +-- +unEscapeString :: String -> String +unEscapeString [] = "" +unEscapeString s@(c:cs) = case unEscapeByte s of + Just (byte, rest) -> unEscapeUtf8 byte rest + Nothing -> c : unEscapeString cs + +unEscapeByte :: String -> Maybe (Int, String) +unEscapeByte ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + Just (digitToInt x1 * 16 + digitToInt x2, s) +unEscapeByte _ = Nothing + +-- Adapted from http://hackage.haskell.org/package/utf8-string +-- by Eric Mertens, BSD3 +unEscapeUtf8 :: Int -> String -> String +unEscapeUtf8 c rest + | c < 0x80 = chr c : unEscapeString rest + | c < 0xc0 = replacement_character : unEscapeString rest + | c < 0xe0 = multi1 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : unEscapeString rest + where + replacement_character = '\xfffd' + multi1 = case unEscapeByte rest of + Just (c1, ds) | c1 .&. 0xc0 == 0x80 -> + let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) + in if d >= 0x000080 then toEnum d : unEscapeString ds + else replacement_character : unEscapeString ds + _ -> replacement_character : unEscapeString rest + + multi_byte i mask overlong = + aux i rest (unEscapeByte rest) (c .&. mask) + where + aux 0 rs _ acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : unEscapeString rs + | otherwise = replacement_character : unEscapeString rs + + aux n _ (Just (r, rs)) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs (unEscapeByte rs) + $! shiftL acc 6 .|. (r .&. 0x3f) + + aux _ rs _ _ = replacement_character : unEscapeString rs + +------------------------------------------------------------ +-- Resolving a relative URI relative to a base URI +------------------------------------------------------------ + +-- |Returns a new 'URI' which represents the value of the +-- first 'URI' interpreted as relative to the second 'URI'. +-- For example: +-- +-- > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo" +-- > "http:foo" `nonStrictRelativeTo` "http://bar.org/" = "http://bar.org/foo" +-- +-- Algorithm from RFC3986 [3], section 5.2.2 +-- + +nonStrictRelativeTo :: URI -> URI -> URI +nonStrictRelativeTo ref base = relativeTo ref' base + where + ref' = if uriScheme ref == uriScheme base + then ref { uriScheme="" } + else ref + +isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool +isDefined a = a /= mzero + +-- | Returns a new 'URI' which represents the value of the first 'URI' +-- interpreted as relative to the second 'URI'. +-- +-- Algorithm from RFC3986 [3], section 5.2 +relativeTo :: URI -> URI -> URI +relativeTo ref base + | isDefined ( uriScheme ref ) = + just_segments ref + | isDefined ( uriAuthority ref ) = + just_segments ref { uriScheme = uriScheme base } + | isDefined ( uriPath ref ) = + if (head (uriPath ref) == '/') then + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + } + else + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = mergePaths base ref + } + | isDefined ( uriQuery ref ) = + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = uriPath base + } + | otherwise = + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = uriPath base + , uriQuery = uriQuery base + } + where + just_segments u = + u { uriPath = removeDotSegments (uriPath u) } + mergePaths b r + | isDefined (uriAuthority b) && null pb = '/':pr + | otherwise = dropLast pb ++ pr + where + pb = uriPath b + pr = uriPath r + dropLast = fst . splitLast -- reverse . dropWhile (/='/') . reverse + +-- Remove dot segments, but protect leading '/' character +removeDotSegments :: String -> String +removeDotSegments ('/':ps) = '/':elimDots ps [] +removeDotSegments ps = elimDots ps [] + +-- Second arg accumulates segments processed so far in reverse order +elimDots :: String -> [String] -> String +-- elimDots ps rs | traceVal "\nps " ps $ traceVal "rs " rs $ False = error "" +elimDots [] [] = "" +elimDots [] rs = concat (reverse rs) +elimDots ( '.':'/':ps) rs = elimDots ps rs +elimDots ( '.':[] ) rs = elimDots [] rs +elimDots ( '.':'.':'/':ps) rs = elimDots ps (drop 1 rs) +elimDots ( '.':'.':[] ) rs = elimDots [] (drop 1 rs) +elimDots ps rs = elimDots ps1 (r:rs) + where + (r,ps1) = nextSegment ps + +-- Returns the next segment and the rest of the path from a path string. +-- Each segment ends with the next '/' or the end of string. +-- +nextSegment :: String -> (String,String) +nextSegment ps = + case break (=='/') ps of + (r,'/':ps1) -> (r++"/",ps1) + (r,_) -> (r,[]) + +-- Split last (name) segment from path, returning (path,name) +splitLast :: String -> (String,String) +splitLast p = (reverse revpath,reverse revname) + where + (revname,revpath) = break (=='/') $ reverse p + +------------------------------------------------------------ +-- Finding a URI relative to a base URI +------------------------------------------------------------ + +-- |Returns a new 'URI' which represents the relative location of +-- the first 'URI' with respect to the second 'URI'. Thus, the +-- values supplied are expected to be absolute URIs, and the result +-- returned may be a relative URI. +-- +-- Example: +-- +-- > "http://example.com/Root/sub1/name2#frag" +-- > `relativeFrom` "http://example.com/Root/sub2/name2#frag" +-- > == "../sub1/name2#frag" +-- +-- There is no single correct implementation of this function, +-- but any acceptable implementation must satisfy the following: +-- +-- > (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs +-- +-- For any valid absolute URI. +-- (cf. +-- ) +-- +relativeFrom :: URI -> URI -> URI +relativeFrom uabs base + | diff uriScheme uabs base = uabs + | diff uriAuthority uabs base = uabs { uriScheme = "" } + | diff uriPath uabs base = uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = relPathFrom (removeBodyDotSegments $ uriPath uabs) + (removeBodyDotSegments $ uriPath base) + } + | diff uriQuery uabs base = uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + } + | otherwise = uabs -- Always carry fragment from uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + } + where + diff :: Eq b => (a -> b) -> a -> a -> Bool + diff sel u1 u2 = sel u1 /= sel u2 + -- Remove dot segments except the final segment + removeBodyDotSegments p = removeDotSegments p1 ++ p2 + where + (p1,p2) = splitLast p + +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 + 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 :: String -> String -> String +relPathFrom1 pabs base = relName + where + (sa,na) = splitLast pabs + (sb,nb) = splitLast base + rp = relSegsFrom sa sb + relName = if null rp then + if (na == nb) then "" + else if protect na then "./"++na + else na + else + rp++na + -- Precede name with some path if it is null or contains a ':' + 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 +-- 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 + | traceVal "\nrelSegsFrom\nsabs " sabs $ traceVal "base " base $ + False = error "" +-} +relSegsFrom [] [] = "" -- paths are identical +relSegsFrom sabs base = + if sa1 == sb1 + then relSegsFrom ra1 rb1 + else difSegsFrom sabs base + where + (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. +-- +difSegsFrom :: String -> String -> String +{- +difSegsFrom sabs base + | traceVal "\ndifSegsFrom\nsabs " sabs $ traceVal "base " base $ + False = error "" +-} +difSegsFrom sabs "" = sabs +difSegsFrom sabs base = difSegsFrom ("../"++sabs) (snd $ nextSegment base) + +------------------------------------------------------------ +-- Other normalization functions +------------------------------------------------------------ + +-- |Case normalization; cf. RFC3986 section 6.2.2.1 +-- NOTE: authority case normalization is not performed +-- +normalizeCase :: String -> String +normalizeCase uristr = ncScheme uristr + where + ncScheme (':':cs) = ':':ncEscape cs + ncScheme (c:cs) | isSchemeChar c = toLower c:ncScheme cs + ncScheme _ = ncEscape uristr -- no scheme present + ncEscape ('%':h1:h2:cs) = '%':toUpper h1:toUpper h2:ncEscape cs + ncEscape (c:cs) = c:ncEscape cs + ncEscape [] = [] + +-- |Encoding normalization; cf. RFC3986 section 6.2.2.2 +-- +normalizeEscape :: String -> String +normalizeEscape ('%':h1:h2:cs) + | isHexDigit h1 && isHexDigit h2 && isUnreserved escval = + escval:normalizeEscape cs + where + escval = chr (digitToInt h1*16+digitToInt h2) +normalizeEscape (c:cs) = c:normalizeEscape cs +normalizeEscape [] = [] + +-- |Path segment normalization; cf. RFC3986 section 6.2.2.4 +-- +normalizePathSegments :: String -> String +normalizePathSegments uristr = normstr juri + where + juri = parseURI uristr + normstr Nothing = uristr + normstr (Just u) = show (normuri u) + normuri u = u { uriPath = removeDotSegments (uriPath u) } + +------------------------------------------------------------ +-- Local trace helper functions +------------------------------------------------------------ + +traceShow :: Show a => String -> a -> a +traceShow msg x = trace (msg ++ show x) x + +traceVal :: Show a => String -> a -> b -> b +traceVal msg x y = trace (msg ++ show x) y + +------------------------------------------------------------ +-- Deprecated functions +------------------------------------------------------------ + +{-# DEPRECATED parseabsoluteURI "use parseAbsoluteURI" #-} +parseabsoluteURI :: String -> Maybe URI +parseabsoluteURI = parseAbsoluteURI + +{-# DEPRECATED escapeString "use escapeURIString, and note the flipped arguments" #-} +escapeString :: String -> (Char->Bool) -> String +escapeString = flip escapeURIString + +{-# DEPRECATED reserved "use isReserved" #-} +reserved :: Char -> Bool +reserved = isReserved + +{-# DEPRECATED unreserved "use isUnreserved" #-} +unreserved :: Char -> Bool +unreserved = isUnreserved + +-- Additional component access functions for backward compatibility + +{-# DEPRECATED scheme "use uriScheme" #-} +scheme :: URI -> String +scheme = orNull init . uriScheme + +{-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-} +authority :: URI -> String +authority = dropss . ($"") . uriAuthToString id . uriAuthority + where + -- Old-style authority component does not include leading '//' + dropss ('/':'/':s) = s + dropss s = s + +{-# DEPRECATED path "use uriPath" #-} +path :: URI -> String +path = uriPath + +{-# DEPRECATED query "use uriQuery, and note changed functionality" #-} +query :: URI -> String +query = orNull tail . uriQuery + +{-# DEPRECATED fragment "use uriFragment, and note changed functionality" #-} +fragment :: URI -> String +fragment = orNull tail . uriFragment + +orNull :: ([a]->[a]) -> [a] -> [a] +orNull _ [] = [] +orNull f as = f as + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- Distributed as free software under the following license. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- - Neither name of the copyright holders nor the names of its +-- contributors may be used to endorse or promote products derived from +-- this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +-- OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +-- TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +-------------------------------------------------------------------------------- diff --git a/network-uri.cabal b/network-uri.cabal --- a/network-uri.cabal +++ b/network-uri.cabal @@ -1,12 +1,8 @@ name: network-uri -version: 2.5.0.0 +version: 2.6.0.0 synopsis: URI manipulation description: - This package provides an URI manipulation interface. - . - Version 2.5 (unlike the following versions) is a dummy package that - prevents module name clashes between network-uri and network, if - used together with a Cabal flag as described below. + This package provides an URI manipulation inteface. . 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@ @@ -20,12 +16,13 @@ > library > -- ... > if flag(network-uri) - > build-depends: network-uri >= 2.6, network >= 2.6 + > build-depends: network-uri >= 2.6 > else - > build-depends: network-uri < 2.6, network < 2.6 + > build-depends: network < 2.6 . - That is, get the module from either network < 2.6 or from - network-uri >= 2.6. + If you want to use other modules from the network package while + using the @Network.URI@ modules from this package, add a @network > + 2.6@ clause to the first @build-depends@ line. homepage: https://github.com/haskell/network-uri bug-reports: https://github.com/haskell/network-uri/issues license: BSD3 @@ -36,6 +33,28 @@ cabal-version: >=1.10 library + exposed-modules: + Network.URI + build-depends: + base >= 3 && < 5, + parsec >= 3.0 && < 3.2 + default-extensions: CPP, DeriveDataTypeable + ghc-options: -Wall -fwarn-tabs + default-language: Haskell98 + +test-suite uri + hs-source-dirs: tests + main-is: uri001.hs + type: exitcode-stdio-1.0 + + build-depends: + base < 5, + HUnit, + network, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 + ghc-options: -Wall -fwarn-tabs default-language: Haskell98 diff --git a/tests/uri001.hs b/tests/uri001.hs new file mode 100644 --- /dev/null +++ b/tests/uri001.hs @@ -0,0 +1,1431 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-------------------------------------------------------------------------------- +-- $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) +-- +-- Maintainer : Graham Klyne +-- Stability : provisional +-- Portability : H98 +-- +-- 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): +-- 1. Install Haskell platform +-- 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 + +import Network.URI + ( URI(..), URIAuth(..) + , nullURI + , parseURI, parseURIReference, parseRelativeReference, parseAbsoluteURI + , parseAbsoluteURI + , isURI, isURIReference, isRelativeReference, isAbsoluteURI + , uriIsAbsolute, uriIsRelative + , relativeTo, nonStrictRelativeTo + , relativeFrom + , uriToString + , isUnescapedInURIComponent + , isUnescapedInURI, escapeURIString, unEscapeString + , normalizeCase, normalizeEscape, normalizePathSegments + ) + +import Test.HUnit + +import Data.Maybe (fromJust) +import System.IO (openFile, IOMode(WriteMode), hClose) +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 + | InvRf -- Invalid URI reference +isValidT :: URIType -> Bool +isValidT InvRf = False +isValidT _ = True + +isAbsRfT :: URIType -> Bool +isAbsRfT AbsId = True +isAbsRfT AbsRf = True +isAbsRfT _ = False + +isRelRfT :: URIType -> Bool +isRelRfT RelRf = True +isRelRfT _ = False + +isAbsIdT :: URIType -> Bool +isAbsIdT AbsId = True +isAbsIdT _ = False + +testEq :: (Eq a, Show a) => String -> a -> a -> Assertion +testEq lab a1 a2 = assertEqual lab a1 a2 + +testURIRef :: URIType -> String -> Assertion +testURIRef t u = sequence_ + [ testEq ("test_isURIReference:"++u) (isValidT t) (isURIReference u) + , testEq ("test_isRelativeReference:"++u) (isRelRfT t) (isRelativeReference u) + , testEq ("test_isAbsoluteURI:"++u) (isAbsIdT t) (isAbsoluteURI u) + ] + +testURIRefComponents :: String -> (Maybe URI) -> String -> Assertion +testURIRefComponents _lab uv us = + testEq ("testURIRefComponents:"++us) uv (parseURIReference us) + + +testURIRef001 = testURIRef AbsRf "http://example.org/aaa/bbb#ccc" +testURIRef002 = testURIRef AbsId "mailto:local@domain.org" +testURIRef003 = testURIRef AbsRf "mailto:local@domain.org#frag" +testURIRef004 = testURIRef AbsRf "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" +testURIRef005 = testURIRef RelRf "//example.org/aaa/bbb#ccc" +testURIRef006 = testURIRef RelRf "/aaa/bbb#ccc" +testURIRef007 = testURIRef RelRf "bbb#ccc" +testURIRef008 = testURIRef RelRf "#ccc" +testURIRef009 = testURIRef RelRf "#" +testURIRef010 = testURIRef RelRf "/" +-- escapes +testURIRef011 = testURIRef AbsRf "http://example.org/aaa%2fbbb#ccc" +testURIRef012 = testURIRef AbsRf "http://example.org/aaa%2Fbbb#ccc" +testURIRef013 = testURIRef RelRf "%2F" +testURIRef014 = testURIRef RelRf "aaa%2Fbbb" +-- ports +testURIRef015 = testURIRef AbsRf "http://example.org:80/aaa/bbb#ccc" +testURIRef016 = testURIRef AbsRf "http://example.org:/aaa/bbb#ccc" +testURIRef017 = testURIRef AbsRf "http://example.org./aaa/bbb#ccc" +testURIRef018 = testURIRef AbsRf "http://example.123./aaa/bbb#ccc" +-- bare authority +testURIRef019 = testURIRef AbsId "http://example.org" +-- IPv6 literals (from RFC2732): +testURIRef021 = testURIRef AbsId "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html" +testURIRef022 = testURIRef AbsId "http://[1080:0:0:0:8:800:200C:417A]/index.html" +testURIRef023 = testURIRef AbsId "http://[3ffe:2a00:100:7031::1]" +testURIRef024 = testURIRef AbsId "http://[1080::8:800:200C:417A]/foo" +testURIRef025 = testURIRef AbsId "http://[::192.9.5.5]/ipng" +testURIRef026 = testURIRef AbsId "http://[::FFFF:129.144.52.38]:80/index.html" +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]" +-- RFC2396 test cases +testURIRef031 = testURIRef RelRf "./aaa" +testURIRef032 = testURIRef RelRf "../aaa" +testURIRef033 = testURIRef AbsId "g:h" +testURIRef034 = testURIRef RelRf "g" +testURIRef035 = testURIRef RelRf "./g" +testURIRef036 = testURIRef RelRf "g/" +testURIRef037 = testURIRef RelRf "/g" +testURIRef038 = testURIRef RelRf "//g" +testURIRef039 = testURIRef RelRf "?y" +testURIRef040 = testURIRef RelRf "g?y" +testURIRef041 = testURIRef RelRf "#s" +testURIRef042 = testURIRef RelRf "g#s" +testURIRef043 = testURIRef RelRf "g?y#s" +testURIRef044 = testURIRef RelRf ";x" +testURIRef045 = testURIRef RelRf "g;x" +testURIRef046 = testURIRef RelRf "g;x?y#s" +testURIRef047 = testURIRef RelRf "." +testURIRef048 = testURIRef RelRf "./" +testURIRef049 = testURIRef RelRf ".." +testURIRef050 = testURIRef RelRf "../" +testURIRef051 = testURIRef RelRf "../g" +testURIRef052 = testURIRef RelRf "../.." +testURIRef053 = testURIRef RelRf "../../" +testURIRef054 = testURIRef RelRf "../../g" +testURIRef055 = testURIRef RelRf "../../../g" +testURIRef056 = testURIRef RelRf "../../../../g" +testURIRef057 = testURIRef RelRf "/./g" +testURIRef058 = testURIRef RelRf "/../g" +testURIRef059 = testURIRef RelRf "g." +testURIRef060 = testURIRef RelRf ".g" +testURIRef061 = testURIRef RelRf "g.." +testURIRef062 = testURIRef RelRf "..g" +testURIRef063 = testURIRef RelRf "./../g" +testURIRef064 = testURIRef RelRf "./g/." +testURIRef065 = testURIRef RelRf "g/./h" +testURIRef066 = testURIRef RelRf "g/../h" +testURIRef067 = testURIRef RelRf "g;x=1/./y" +testURIRef068 = testURIRef RelRf "g;x=1/../y" +testURIRef069 = testURIRef RelRf "g?y/./x" +testURIRef070 = testURIRef RelRf "g?y/../x" +testURIRef071 = testURIRef RelRf "g#s/./x" +testURIRef072 = testURIRef RelRf "g#s/../x" +testURIRef073 = testURIRef RelRf "" +testURIRef074 = testURIRef RelRf "A'C" +testURIRef075 = testURIRef RelRf "A$C" +testURIRef076 = testURIRef RelRf "A@C" +testURIRef077 = testURIRef RelRf "A,C" +-- Invalid +testURIRef080 = testURIRef InvRf "http://foo.org:80Path/More" +testURIRef081 = testURIRef InvRf "::" +testURIRef082 = testURIRef InvRf " " +testURIRef083 = testURIRef InvRf "%" +testURIRef084 = testURIRef InvRf "A%Z" +testURIRef085 = testURIRef InvRf "%ZZ" +testURIRef086 = testURIRef InvRf "%AZ" +testURIRef087 = testURIRef InvRf "A C" +-- testURIRef088 = -- (case removed) +-- testURIRef089 = -- (case removed) +testURIRef090 = testURIRef InvRf "A\"C" +testURIRef091 = testURIRef InvRf "A`C" +testURIRef092 = testURIRef InvRf "AC" +testURIRef094 = testURIRef InvRf "A^C" +testURIRef095 = testURIRef InvRf "A\\C" +testURIRef096 = testURIRef InvRf "A{C" +testURIRef097 = testURIRef InvRf "A|C" +testURIRef098 = testURIRef InvRf "A}C" +-- From RFC2396: +-- rel_segment = 1*( unreserved | escaped | +-- ";" | "@" | "&" | "=" | "+" | "$" | "," ) +-- unreserved = alphanum | mark +-- mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | +-- "(" | ")" +-- Note RFC 2732 allows '[', ']' ONLY for reserved purpose of IPv6 literals, +-- or does it? +testURIRef101 = testURIRef InvRf "A[C" +testURIRef102 = testURIRef InvRf "A]C" +testURIRef103 = testURIRef InvRf "A[**]C" +testURIRef104 = testURIRef InvRf "http://[xyz]/" +testURIRef105 = testURIRef InvRf "http://]/" +testURIRef106 = testURIRef InvRf "http://example.org/[2010:836B:4179::836B:4179]" +testURIRef107 = testURIRef InvRf "http://example.org/abc#[2010:836B:4179::836B:4179]" +testURIRef108 = testURIRef InvRf "http://example.org/xxx/[qwerty]#a[b]" +-- Random other things that crop up +testURIRef111 = testURIRef AbsRf "http://example/Andrȷ" +testURIRef112 = testURIRef AbsId "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" +testURIRef113 = testURIRef AbsId "http://46229EFFE16A9BD60B9F1BE88B2DB047ADDED785/demo.mp3" +testURIRef114 = testURIRef InvRf "http://example.org/xxx/qwerty#a#b" +testURIRef115 = testURIRef InvRf "dcp.tcp.pft://192.168.0.1:1002:3002?fec=1&crc=0" +testURIRef116 = testURIRef AbsId "dcp.tcp.pft://192.168.0.1:1002?fec=1&crc=0" +testURIRef117 = testURIRef AbsId "foo://" +-- URIs prefixed with IPv4 addresses +testURIRef118 = testURIRef AbsId "http://192.168.0.1.example.com/" +testURIRef119 = testURIRef AbsId "http://192.168.0.1.example.com./" +-- URI prefixed with 3 octets of an IPv4 address and a subdomain part with a leading digit. +testURIRef120 = testURIRef AbsId "http://192.168.0.1test.example.com/" +-- URI with IPv(future) address +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/") +-- 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 + , TF.testCase "testURIRef002" testURIRef002 + , TF.testCase "testURIRef003" testURIRef003 + , TF.testCase "testURIRef004" testURIRef004 + , TF.testCase "testURIRef005" testURIRef005 + , TF.testCase "testURIRef006" testURIRef006 + , TF.testCase "testURIRef007" testURIRef007 + , TF.testCase "testURIRef008" testURIRef008 + , TF.testCase "testURIRef009" testURIRef009 + , TF.testCase "testURIRef010" testURIRef010 + -- + , TF.testCase "testURIRef011" testURIRef011 + , TF.testCase "testURIRef012" testURIRef012 + , TF.testCase "testURIRef013" testURIRef013 + , TF.testCase "testURIRef014" testURIRef014 + , TF.testCase "testURIRef015" testURIRef015 + , TF.testCase "testURIRef016" testURIRef016 + , TF.testCase "testURIRef017" testURIRef017 + , TF.testCase "testURIRef018" testURIRef018 + -- + , TF.testCase "testURIRef019" testURIRef019 + -- + , TF.testCase "testURIRef021" testURIRef021 + , TF.testCase "testURIRef022" testURIRef022 + , TF.testCase "testURIRef023" testURIRef023 + , TF.testCase "testURIRef024" testURIRef024 + , TF.testCase "testURIRef025" testURIRef025 + , TF.testCase "testURIRef026" testURIRef026 + , TF.testCase "testURIRef027" testURIRef027 + , TF.testCase "testURIRef028" testURIRef028 + , TF.testCase "testURIRef029" testURIRef029 + -- + , TF.testCase "testURIRef031" testURIRef031 + , TF.testCase "testURIRef032" testURIRef032 + , TF.testCase "testURIRef033" testURIRef033 + , TF.testCase "testURIRef034" testURIRef034 + , TF.testCase "testURIRef035" testURIRef035 + , TF.testCase "testURIRef036" testURIRef036 + , TF.testCase "testURIRef037" testURIRef037 + , TF.testCase "testURIRef038" testURIRef038 + , TF.testCase "testURIRef039" testURIRef039 + , TF.testCase "testURIRef040" testURIRef040 + , TF.testCase "testURIRef041" testURIRef041 + , TF.testCase "testURIRef042" testURIRef042 + , TF.testCase "testURIRef043" testURIRef043 + , TF.testCase "testURIRef044" testURIRef044 + , TF.testCase "testURIRef045" testURIRef045 + , TF.testCase "testURIRef046" testURIRef046 + , TF.testCase "testURIRef047" testURIRef047 + , TF.testCase "testURIRef048" testURIRef048 + , TF.testCase "testURIRef049" testURIRef049 + , TF.testCase "testURIRef050" testURIRef050 + , TF.testCase "testURIRef051" testURIRef051 + , TF.testCase "testURIRef052" testURIRef052 + , TF.testCase "testURIRef053" testURIRef053 + , TF.testCase "testURIRef054" testURIRef054 + , TF.testCase "testURIRef055" testURIRef055 + , TF.testCase "testURIRef056" testURIRef056 + , TF.testCase "testURIRef057" testURIRef057 + , TF.testCase "testURIRef058" testURIRef058 + , TF.testCase "testURIRef059" testURIRef059 + , TF.testCase "testURIRef060" testURIRef060 + , TF.testCase "testURIRef061" testURIRef061 + , TF.testCase "testURIRef062" testURIRef062 + , TF.testCase "testURIRef063" testURIRef063 + , TF.testCase "testURIRef064" testURIRef064 + , TF.testCase "testURIRef065" testURIRef065 + , TF.testCase "testURIRef066" testURIRef066 + , TF.testCase "testURIRef067" testURIRef067 + , TF.testCase "testURIRef068" testURIRef068 + , TF.testCase "testURIRef069" testURIRef069 + , TF.testCase "testURIRef070" testURIRef070 + , TF.testCase "testURIRef071" testURIRef071 + , TF.testCase "testURIRef072" testURIRef072 + , TF.testCase "testURIRef073" testURIRef073 + , TF.testCase "testURIRef074" testURIRef074 + , TF.testCase "testURIRef075" testURIRef075 + , TF.testCase "testURIRef076" testURIRef076 + , TF.testCase "testURIRef077" testURIRef077 + -- + , TF.testCase "testURIRef080" testURIRef080 + , TF.testCase "testURIRef081" testURIRef081 + , TF.testCase "testURIRef082" testURIRef082 + , TF.testCase "testURIRef083" testURIRef083 + , TF.testCase "testURIRef084" testURIRef084 + , TF.testCase "testURIRef085" testURIRef085 + , TF.testCase "testURIRef086" testURIRef086 + , TF.testCase "testURIRef087" testURIRef087 + -- testURIRef088, + -- testURIRef089, + , TF.testCase "testURIRef090" testURIRef090 + , TF.testCase "testURIRef091" testURIRef091 + , TF.testCase "testURIRef092" testURIRef092 + , TF.testCase "testURIRef093" testURIRef093 + , TF.testCase "testURIRef094" testURIRef094 + , TF.testCase "testURIRef095" testURIRef095 + , TF.testCase "testURIRef096" testURIRef096 + , TF.testCase "testURIRef097" testURIRef097 + , TF.testCase "testURIRef098" testURIRef098 + -- testURIRef099, + -- + , TF.testCase "testURIRef101" testURIRef101 + , TF.testCase "testURIRef102" testURIRef102 + , TF.testCase "testURIRef103" testURIRef103 + , TF.testCase "testURIRef104" testURIRef104 + , TF.testCase "testURIRef105" testURIRef105 + , TF.testCase "testURIRef106" testURIRef106 + , TF.testCase "testURIRef107" testURIRef107 + , TF.testCase "testURIRef108" testURIRef108 + -- + , TF.testCase "testURIRef111" testURIRef111 + , TF.testCase "testURIRef112" testURIRef112 + , TF.testCase "testURIRef113" testURIRef113 + , TF.testCase "testURIRef114" testURIRef114 + , TF.testCase "testURIRef115" testURIRef115 + , TF.testCase "testURIRef116" testURIRef116 + , TF.testCase "testURIRef117" testURIRef117 + -- + , TF.testCase "testURIRef118" testURIRef118 + , TF.testCase "testURIRef119" testURIRef119 + , TF.testCase "testURIRef120" testURIRef120 + -- + , TF.testCase "testURIRef121" testURIRef121 + , TF.testCase "testURIRef122" testURIRef122 + -- IRI test cases not currently supported + -- , TF.testCase "testURIRef123" testURIRef123 + -- , TF.testCase "testURIRef124" testURIRef124 + ] + +-- test decomposition of URI into components +testComponent01 = testURIRefComponents "testComponent01" + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?qqq" + , uriFragment = "#fff" + } ) + "http://user:pass@example.org:99/aaa/bbb?qqq#fff" +testComponent02 = testURIRefComponents "testComponent02" + ( 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 + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "" + , uriQuery = "?aaa/bbb" + , uriFragment = "" + } ) + "http://user:pass@example.org:99?aaa/bbb" +testComponent04 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "" + , uriQuery = "" + , uriFragment = "#aaa/bbb" + } ) + "http://user:pass@example.org:99#aaa/bbb" +-- These test cases contributed by Robert Buck (mathworks.com) +testComponent11 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "about:" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } ) + "about:" +testComponent12 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "file:" + , uriAuthority = Just (URIAuth "" "windowsauth" "") + , uriPath = "/d$" + , uriQuery = "" + , uriFragment = "" + } ) + "file://windowsauth/d$" + +testComponentSuite = TF.testGroup "Test URIrefs" $ + [ TF.testCase "testComponent01" testComponent01 + , TF.testCase "testComponent02" testComponent02 + , TF.testCase "testComponent03" testComponent03 + , TF.testCase "testComponent04" testComponent04 + , TF.testCase "testComponent11" testComponent11 + , TF.testCase "testComponent12" testComponent12 + ] + +-- Get reference relative to given base +-- relativeRef :: String -> String -> String +-- +-- Get absolute URI given base and relative reference +-- absoluteURI :: String -> String -> String +-- +-- Test cases taken from: http://www.w3.org/2000/10/swap/uripath.py +-- (Thanks, Dan Connolly) +-- +-- NOTE: absoluteURI base (relativeRef base u) is always equivalent to u. +-- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html + +testRelSplit :: String -> String -> String -> String -> Assertion +testRelSplit label base uabs urel = + testEq label urel (mkrel puabs pubas) + where + mkrel (Just u1) (Just u2) = show (u1 `relativeFrom` u2) + mkrel Nothing _ = "Invalid URI: "++urel + mkrel _ Nothing = "Invalid URI: "++uabs + puabs = parseURIReference uabs + pubas = parseURIReference base + +testRelJoin :: String -> String -> String -> String -> Assertion +testRelJoin label base urel uabs = + testEq label uabs (mkabs purel pubas) + where + mkabs (Just u1) (Just u2) = show (u1 `relativeTo` u2) + mkabs Nothing _ = "Invalid URI: "++urel + mkabs _ Nothing = "Invalid URI: "++uabs + purel = parseURIReference urel + pubas = parseURIReference base + +testRelative :: String -> String -> String -> String -> Assertion +testRelative label base uabs urel = sequence_ + [ + (testRelSplit (label++"(rel)") base uabs urel), + (testRelJoin (label++"(abs)") base urel uabs) + ] + +testRelative01 = testRelative "testRelative01" + "foo:xyz" "bar:abc" "bar:abc" +testRelative02 = testRelative "testRelative02" + "http://example/x/y/z" "http://example/x/abc" "../abc" +testRelative03 = testRelative "testRelative03" + "http://example2/x/y/z" "http://example/x/abc" "//example/x/abc" + -- "http://example2/x/y/z" "http://example/x/abc" "http://example/x/abc" +testRelative04 = testRelative "testRelative04" + "http://ex/x/y/z" "http://ex/x/r" "../r" +testRelative05 = testRelative "testRelative05" + "http://ex/x/y/z" "http://ex/r" "/r" + -- "http://ex/x/y/z" "http://ex/r" "../../r" +testRelative06 = testRelative "testRelative06" + "http://ex/x/y/z" "http://ex/x/y/q/r" "q/r" +testRelative07 = testRelative "testRelative07" + "http://ex/x/y" "http://ex/x/q/r#s" "q/r#s" +testRelative08 = testRelative "testRelative08" + "http://ex/x/y" "http://ex/x/q/r#s/t" "q/r#s/t" +testRelative09 = testRelative "testRelative09" + "http://ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" +testRelative10 = testRelative "testRelative10" + -- "http://ex/x/y" "http://ex/x/y" "y" + "http://ex/x/y" "http://ex/x/y" "" +testRelative11 = testRelative "testRelative11" + -- "http://ex/x/y/" "http://ex/x/y/" "./" + "http://ex/x/y/" "http://ex/x/y/" "" +testRelative12 = testRelative "testRelative12" + -- "http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq" + "http://ex/x/y/pdq" "http://ex/x/y/pdq" "" +testRelative13 = testRelative "testRelative13" + "http://ex/x/y/" "http://ex/x/y/z/" "z/" +testRelative14 = testRelative "testRelative14" + -- "file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal" + "file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal" +testRelative15 = testRelative "testRelative15" + "file:/e/x/y/z" "file:/e/x/abc" "../abc" +testRelative16 = testRelative "testRelative16" + "file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc" +testRelative17 = testRelative "testRelative17" + "file:/ex/x/y/z" "file:/ex/x/r" "../r" +testRelative18 = testRelative "testRelative18" + "file:/ex/x/y/z" "file:/r" "/r" +testRelative19 = testRelative "testRelative19" + "file:/ex/x/y" "file:/ex/x/q/r" "q/r" +testRelative20 = testRelative "testRelative20" + "file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s" +testRelative21 = testRelative "testRelative21" + "file:/ex/x/y" "file:/ex/x/q/r#" "q/r#" +testRelative22 = testRelative "testRelative22" + "file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t" +testRelative23 = testRelative "testRelative23" + "file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" +testRelative24 = testRelative "testRelative24" + -- "file:/ex/x/y" "file:/ex/x/y" "y" + "file:/ex/x/y" "file:/ex/x/y" "" +testRelative25 = testRelative "testRelative25" + -- "file:/ex/x/y/" "file:/ex/x/y/" "./" + "file:/ex/x/y/" "file:/ex/x/y/" "" +testRelative26 = testRelative "testRelative26" + -- "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq" + "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "" +testRelative27 = testRelative "testRelative27" + "file:/ex/x/y/" "file:/ex/x/y/z/" "z/" +testRelative28 = testRelative "testRelative28" + "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" + "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" + -- "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" + -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" +testRelative29 = testRelative "testRelative29" + "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" + "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" + -- "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" + -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" +testRelative30 = testRelative "testRelative30" + "file:/some/dir/foo" "file:/some/dir/#blort" "./#blort" +testRelative31 = testRelative "testRelative31" + "file:/some/dir/foo" "file:/some/dir/#" "./#" +testRelative32 = testRelative "testRelative32" + "http://ex/x/y" "http://ex/x/q:r" "./q:r" + -- see RFC2396bis, section 5 ^^ +testRelative33 = testRelative "testRelative33" + "http://ex/x/y" "http://ex/x/p=q:r" "./p=q:r" + -- "http://ex/x/y" "http://ex/x/p=q:r" "p=q:r" +testRelative34 = testRelative "testRelative34" + "http://ex/x/y?pp/qq" "http://ex/x/y?pp/rr" "?pp/rr" +testRelative35 = testRelative "testRelative35" + "http://ex/x/y?pp/qq" "http://ex/x/y/z" "y/z" +testRelative36 = testRelative "testRelative36" + "mailto:local" + "mailto:local/qual@domain.org#frag" + "local/qual@domain.org#frag" +testRelative37 = testRelative "testRelative37" + "mailto:local/qual1@domain1.org" + "mailto:local/more/qual2@domain2.org#frag" + "more/qual2@domain2.org#frag" +testRelative38 = testRelative "testRelative38" + "http://ex/x/z?q" "http://ex/x/y?q" "y?q" +testRelative39 = testRelative "testRelative39" + "http://ex?p" "http://ex/x/y?q" "/x/y?q" +testRelative40 = testRelative "testRelative40" + "foo:a/b" "foo:a/c/d" "c/d" +testRelative41 = testRelative "testRelative41" + "foo:a/b" "foo:/c/d" "/c/d" +testRelative42 = testRelative "testRelative42" + "foo:a/b?c#d" "foo:a/b?c" "" +testRelative43 = testRelative "testRelative42" + "foo:a" "foo:b/c" "b/c" +testRelative44 = testRelative "testRelative44" + "foo:/a/y/z" "foo:/a/b/c" "../b/c" +testRelative45 = testRelJoin "testRelative45" + "foo:a" "./b/c" "foo:b/c" +testRelative46 = testRelJoin "testRelative46" + "foo:a" "/./b/c" "foo:/b/c" +testRelative47 = testRelJoin "testRelative47" + "foo://a//b/c" "../../d" "foo://a/d" +testRelative48 = testRelJoin "testRelative48" + "foo:a" "." "foo:" +testRelative49 = testRelJoin "testRelative49" + "foo:a" ".." "foo:" + +-- add escape tests +testRelative50 = testRelative "testRelative50" + "http://example/x/y%2Fz" "http://example/x/abc" "abc" +testRelative51 = testRelative "testRelative51" + "http://example/a/x/y/z" "http://example/a/x%2Fabc" "../../x%2Fabc" +testRelative52 = testRelative "testRelative52" + "http://example/a/x/y%2Fz" "http://example/a/x%2Fabc" "../x%2Fabc" +testRelative53 = testRelative "testRelative53" + "http://example/x%2Fy/z" "http://example/x%2Fy/abc" "abc" +testRelative54 = testRelative "testRelative54" + "http://ex/x/y" "http://ex/x/q%3Ar" "q%3Ar" +testRelative55 = testRelative "testRelative55" + "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 fuctions +-- that satisfy the basic equivalence axiom: +-- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html +testRelative56 = testRelative "testRelative56" + "http://example/x/y/z" "http://example/x%2Fabc" "/x%2Fabc" +testRelative57 = testRelative "testRelative57" + "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" + +-- Other oddball tests + -- Check segment normalization code: +testRelative60 = testRelJoin "testRelative60" + "ftp://example/x/y" "http://example/a/b/../../c" "http://example/c" +testRelative61 = testRelJoin "testRelative61" + "ftp://example/x/y" "http://example/a/b/c/../../" "http://example/a/" +testRelative62 = testRelJoin "testRelative62" + "ftp://example/x/y" "http://example/a/b/c/./" "http://example/a/b/c/" +testRelative63 = testRelJoin "testRelative63" + "ftp://example/x/y" "http://example/a/b/c/.././" "http://example/a/b/" +testRelative64 = testRelJoin "testRelative64" + "ftp://example/x/y" "http://example/a/b/c/d/../../../../e" "http://example/e" +testRelative65 = testRelJoin "testRelative65" + "ftp://example/x/y" "http://example/a/b/c/d/../.././../../e" "http://example/e" + -- Check handling of queries and fragments with non-relative paths +testRelative70 = testRelative "testRelative70" + "mailto:local1@domain1?query1" "mailto:local2@domain2" + "local2@domain2" +testRelative71 = testRelative "testRelative71" + "mailto:local1@domain1" "mailto:local2@domain2?query2" + "local2@domain2?query2" +testRelative72 = testRelative "testRelative72" + "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" + "local2@domain2?query2" +testRelative73 = testRelative "testRelative73" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "?query2" +testRelative74 = testRelative "testRelative74" + "mailto:?query1" "mailto:local@domain?query2" + "local@domain?query2" +testRelative75 = testRelative "testRelative75" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "?query2" +testRelative76 = testRelative "testRelative76" + "foo:bar" "http://example/a/b?c/../d" "http://example/a/b?c/../d" +testRelative77 = testRelative "testRelative77" + "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 + 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" + "test.xml" +testRelative79 = testRelative "testRelative79" + "file:/some/dir/foo" "file:/some/dir/#blort" "./#blort" +testRelative80 = testRelative "testRelative80" + "file:/some/dir/foo" "file:/some/dir/#" "./#" +testRelative81 = testRelative "testRelative81" + "file:/some/dir/.." "file:/some/dir/#blort" "./#blort" + +-- testRelative base abs rel +-- testRelSplit base abs rel +-- testRelJoin base rel abs +testRelative91 = testRelSplit "testRelative91" + "http://example.org/base/uri" "http:this" + "this" +testRelative92 = testRelJoin "testRelative92" + "http://example.org/base/uri" "http:this" + "http:this" +testRelative93 = testRelJoin "testRelative93" + "http:base" "http:this" + "http:this" +testRelative94 = testRelJoin "testRelative94" + "f:/a" ".//g" + "f://g" +testRelative95 = testRelJoin "testRelative95" + "f://example.org/base/a" "b/c//d/e" + "f://example.org/base/b/c//d/e" +testRelative96 = testRelJoin "testRelative96" + "mid:m@example.ord/c@example.org" "m2@example.ord/c2@example.org" + "mid:m@example.ord/m2@example.ord/c2@example.org" +testRelative97 = testRelJoin "testRelative97" + "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" "mini1.xml" + "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/mini1.xml" +testRelative98 = testRelative "testRelative98" + "foo:a/y/z" "foo:a/b/c" "../b/c" +testRelative99 = testRelJoin "testRelative99" + "f:/a/" "..//g" + "f://g" + + +testRelativeSuite = TF.testGroup "Test Relative URIs" testRelativeList +testRelativeList = + [ TF.testCase "testRelative01" testRelative01 + , TF.testCase "testRelative02" testRelative02 + , TF.testCase "testRelative03" testRelative03 + , TF.testCase "testRelative04" testRelative04 + , TF.testCase "testRelative05" testRelative05 + , TF.testCase "testRelative06" testRelative06 + , TF.testCase "testRelative07" testRelative07 + , TF.testCase "testRelative08" testRelative08 + , TF.testCase "testRelative09" testRelative09 + , TF.testCase "testRelative10" testRelative10 + , TF.testCase "testRelative11" testRelative11 + , TF.testCase "testRelative12" testRelative12 + , TF.testCase "testRelative13" testRelative13 + , TF.testCase "testRelative14" testRelative14 + , TF.testCase "testRelative15" testRelative15 + , TF.testCase "testRelative16" testRelative16 + , TF.testCase "testRelative17" testRelative17 + , TF.testCase "testRelative18" testRelative18 + , TF.testCase "testRelative19" testRelative19 + , TF.testCase "testRelative20" testRelative20 + , TF.testCase "testRelative21" testRelative21 + , TF.testCase "testRelative22" testRelative22 + , TF.testCase "testRelative23" testRelative23 + , TF.testCase "testRelative24" testRelative24 + , TF.testCase "testRelative25" testRelative25 + , TF.testCase "testRelative26" testRelative26 + , TF.testCase "testRelative27" testRelative27 + , TF.testCase "testRelative28" testRelative28 + , TF.testCase "testRelative29" testRelative29 + , TF.testCase "testRelative30" testRelative30 + , TF.testCase "testRelative31" testRelative31 + , TF.testCase "testRelative32" testRelative32 + , TF.testCase "testRelative33" testRelative33 + , TF.testCase "testRelative34" testRelative34 + , TF.testCase "testRelative35" testRelative35 + , TF.testCase "testRelative36" testRelative36 + , TF.testCase "testRelative37" testRelative37 + , TF.testCase "testRelative38" testRelative38 + , TF.testCase "testRelative39" testRelative39 + , TF.testCase "testRelative40" testRelative40 + , TF.testCase "testRelative41" testRelative41 + , TF.testCase "testRelative42" testRelative42 + , TF.testCase "testRelative43" testRelative43 + , TF.testCase "testRelative44" testRelative44 + , TF.testCase "testRelative45" testRelative45 + , TF.testCase "testRelative46" testRelative46 + , TF.testCase "testRelative47" testRelative47 + , TF.testCase "testRelative48" testRelative48 + , TF.testCase "testRelative49" testRelative49 + -- + , TF.testCase "testRelative50" testRelative50 + , TF.testCase "testRelative51" testRelative51 + , TF.testCase "testRelative52" testRelative52 + , TF.testCase "testRelative53" testRelative53 + , TF.testCase "testRelative54" testRelative54 + , TF.testCase "testRelative55" testRelative55 + , TF.testCase "testRelative56" testRelative56 + , TF.testCase "testRelative57" testRelative57 + -- + , TF.testCase "testRelative60" testRelative60 + , TF.testCase "testRelative61" testRelative61 + , TF.testCase "testRelative62" testRelative62 + , TF.testCase "testRelative63" testRelative63 + , TF.testCase "testRelative64" testRelative64 + , TF.testCase "testRelative65" testRelative65 + -- + , TF.testCase "testRelative70" testRelative70 + , TF.testCase "testRelative71" testRelative71 + , TF.testCase "testRelative72" testRelative72 + , TF.testCase "testRelative73" testRelative73 + , TF.testCase "testRelative74" testRelative74 + , TF.testCase "testRelative75" testRelative75 + , TF.testCase "testRelative76" testRelative76 + , TF.testCase "testRelative77" testRelative77 + -- Awkward cases: + , TF.testCase "testRelative78" testRelative78 + , TF.testCase "testRelative79" testRelative79 + , TF.testCase "testRelative80" testRelative80 + , TF.testCase "testRelative81" testRelative81 + -- + -- , TF.testCase "testRelative90" testRelative90 + , TF.testCase "testRelative91" testRelative91 + , TF.testCase "testRelative92" testRelative92 + , TF.testCase "testRelative93" testRelative93 + , TF.testCase "testRelative94" testRelative94 + , TF.testCase "testRelative95" testRelative95 + , TF.testCase "testRelative96" testRelative96 + , TF.testCase "testRelative97" testRelative97 + , TF.testCase "testRelative98" testRelative98 + , TF.testCase "testRelative99" testRelative99 + ] + +-- RFC2396 relative-to-absolute URI tests + +rfcbase = "http://a/b/c/d;p?q" +-- normal cases, RFC2396bis 5.4.1 +testRFC01 = testRelJoin "testRFC01" rfcbase "g:h" "g:h" +testRFC02 = testRelJoin "testRFC02" rfcbase "g" "http://a/b/c/g" +testRFC03 = testRelJoin "testRFC03" rfcbase "./g" "http://a/b/c/g" +testRFC04 = testRelJoin "testRFC04" rfcbase "g/" "http://a/b/c/g/" +testRFC05 = testRelJoin "testRFC05" rfcbase "/g" "http://a/g" +testRFC06 = testRelJoin "testRFC06" rfcbase "//g" "http://g" +testRFC07 = testRelJoin "testRFC07" rfcbase "?y" "http://a/b/c/d;p?y" +testRFC08 = testRelJoin "testRFC08" rfcbase "g?y" "http://a/b/c/g?y" +testRFC09 = testRelJoin "testRFC09" rfcbase "?q#s" "http://a/b/c/d;p?q#s" +testRFC23 = testRelJoin "testRFC10" rfcbase "#s" "http://a/b/c/d;p?q#s" +testRFC10 = testRelJoin "testRFC11" rfcbase "g#s" "http://a/b/c/g#s" +testRFC11 = testRelJoin "testRFC12" rfcbase "g?y#s" "http://a/b/c/g?y#s" +testRFC12 = testRelJoin "testRFC13" rfcbase ";x" "http://a/b/c/;x" +testRFC13 = testRelJoin "testRFC14" rfcbase "g;x" "http://a/b/c/g;x" +testRFC14 = testRelJoin "testRFC15" rfcbase "g;x?y#s" "http://a/b/c/g;x?y#s" +testRFC24 = testRelJoin "testRFC16" rfcbase "" "http://a/b/c/d;p?q" +testRFC15 = testRelJoin "testRFC17" rfcbase "." "http://a/b/c/" +testRFC16 = testRelJoin "testRFC18" rfcbase "./" "http://a/b/c/" +testRFC17 = testRelJoin "testRFC19" rfcbase ".." "http://a/b/" +testRFC18 = testRelJoin "testRFC20" rfcbase "../" "http://a/b/" +testRFC19 = testRelJoin "testRFC21" rfcbase "../g" "http://a/b/g" +testRFC20 = testRelJoin "testRFC22" rfcbase "../.." "http://a/" +testRFC21 = testRelJoin "testRFC23" rfcbase "../../" "http://a/" +testRFC22 = testRelJoin "testRFC24" rfcbase "../../g" "http://a/g" +-- abnormal cases, RFC2396bis 5.4.2 +testRFC31 = testRelJoin "testRFC31" rfcbase "?q" rfcbase +testRFC32 = testRelJoin "testRFC32" rfcbase "../../../g" "http://a/g" +testRFC33 = testRelJoin "testRFC33" rfcbase "../../../../g" "http://a/g" +testRFC34 = testRelJoin "testRFC34" rfcbase "/./g" "http://a/g" +testRFC35 = testRelJoin "testRFC35" rfcbase "/../g" "http://a/g" +testRFC36 = testRelJoin "testRFC36" rfcbase "g." "http://a/b/c/g." +testRFC37 = testRelJoin "testRFC37" rfcbase ".g" "http://a/b/c/.g" +testRFC38 = testRelJoin "testRFC38" rfcbase "g.." "http://a/b/c/g.." +testRFC39 = testRelJoin "testRFC39" rfcbase "..g" "http://a/b/c/..g" +testRFC40 = testRelJoin "testRFC40" rfcbase "./../g" "http://a/b/g" +testRFC41 = testRelJoin "testRFC41" rfcbase "./g/." "http://a/b/c/g/" +testRFC42 = testRelJoin "testRFC42" rfcbase "g/./h" "http://a/b/c/g/h" +testRFC43 = testRelJoin "testRFC43" rfcbase "g/../h" "http://a/b/c/h" +testRFC44 = testRelJoin "testRFC44" rfcbase "g;x=1/./y" "http://a/b/c/g;x=1/y" +testRFC45 = testRelJoin "testRFC45" rfcbase "g;x=1/../y" "http://a/b/c/y" +testRFC46 = testRelJoin "testRFC46" rfcbase "g?y/./x" "http://a/b/c/g?y/./x" +testRFC47 = testRelJoin "testRFC47" rfcbase "g?y/../x" "http://a/b/c/g?y/../x" +testRFC48 = testRelJoin "testRFC48" rfcbase "g#s/./x" "http://a/b/c/g#s/./x" +testRFC49 = testRelJoin "testRFC49" rfcbase "g#s/../x" "http://a/b/c/g#s/../x" +testRFC50 = testRelJoin "testRFC50" rfcbase "http:x" "http:x" + +-- Null path tests +-- See RFC2396bis, section 5.2, +-- "If the base URI's path component is the empty string, then a single +-- slash character is copied to the buffer" +testRFC60 = testRelative "testRFC60" "http://ex" "http://ex/x/y?q" "/x/y?q" +testRFC61 = testRelJoin "testRFC61" "http://ex" "x/y?q" "http://ex/x/y?q" +testRFC62 = testRelative "testRFC62" "http://ex?p" "http://ex/x/y?q" "/x/y?q" +testRFC63 = testRelJoin "testRFC63" "http://ex?p" "x/y?q" "http://ex/x/y?q" +testRFC64 = testRelative "testRFC64" "http://ex#f" "http://ex/x/y?q" "/x/y?q" +testRFC65 = testRelJoin "testRFC65" "http://ex#f" "x/y?q" "http://ex/x/y?q" +testRFC66 = testRelative "testRFC66" "http://ex?p" "http://ex/x/y#g" "/x/y#g" +testRFC67 = testRelJoin "testRFC67" "http://ex?p" "x/y#g" "http://ex/x/y#g" +testRFC68 = testRelative "testRFC68" "http://ex" "http://ex/" "/" +testRFC69 = testRelJoin "testRFC69" "http://ex" "./" "http://ex/" +testRFC70 = testRelative "testRFC70" "http://ex" "http://ex/a/b" "/a/b" +testRFC71 = testRelative "testRFC71" "http://ex/a/b" "http://ex" "./" + +testRFC2396Suite = TF.testGroup "Test RFC2396 examples" testRFC2396List +testRFC2396List = + [ TF.testCase "testRFC01" testRFC01 + , TF.testCase "testRFC02" testRFC02 + , TF.testCase "testRFC03" testRFC03 + , TF.testCase "testRFC04" testRFC04 + , TF.testCase "testRFC05" testRFC05 + , TF.testCase "testRFC06" testRFC06 + , TF.testCase "testRFC07" testRFC07 + , TF.testCase "testRFC08" testRFC08 + , TF.testCase "testRFC09" testRFC09 + , TF.testCase "testRFC10" testRFC10 + , TF.testCase "testRFC11" testRFC11 + , TF.testCase "testRFC12" testRFC12 + , TF.testCase "testRFC13" testRFC13 + , TF.testCase "testRFC14" testRFC14 + , TF.testCase "testRFC15" testRFC15 + , TF.testCase "testRFC16" testRFC16 + , TF.testCase "testRFC17" testRFC17 + , TF.testCase "testRFC18" testRFC18 + , TF.testCase "testRFC19" testRFC19 + , TF.testCase "testRFC20" testRFC20 + , TF.testCase "testRFC21" testRFC21 + , TF.testCase "testRFC22" testRFC22 + , TF.testCase "testRFC23" testRFC23 + , TF.testCase "testRFC24" testRFC24 + -- testRFC30, + , TF.testCase "testRFC31" testRFC31 + , TF.testCase "testRFC32" testRFC32 + , TF.testCase "testRFC33" testRFC33 + , TF.testCase "testRFC34" testRFC34 + , TF.testCase "testRFC35" testRFC35 + , TF.testCase "testRFC36" testRFC36 + , TF.testCase "testRFC37" testRFC37 + , TF.testCase "testRFC38" testRFC38 + , TF.testCase "testRFC39" testRFC39 + , TF.testCase "testRFC40" testRFC40 + , TF.testCase "testRFC41" testRFC41 + , TF.testCase "testRFC42" testRFC42 + , TF.testCase "testRFC43" testRFC43 + , TF.testCase "testRFC44" testRFC44 + , TF.testCase "testRFC45" testRFC45 + , TF.testCase "testRFC46" testRFC46 + , TF.testCase "testRFC47" testRFC47 + , TF.testCase "testRFC48" testRFC48 + , TF.testCase "testRFC49" testRFC49 + , TF.testCase "testRFC50" testRFC50 + -- + , TF.testCase "testRFC60" testRFC60 + , TF.testCase "testRFC61" testRFC61 + , TF.testCase "testRFC62" testRFC62 + , TF.testCase "testRFC63" testRFC63 + , TF.testCase "testRFC64" testRFC64 + , TF.testCase "testRFC65" testRFC65 + , TF.testCase "testRFC66" testRFC66 + , TF.testCase "testRFC67" testRFC67 + , TF.testCase "testRFC68" testRFC68 + , TF.testCase "testRFC69" testRFC69 + , TF.testCase "testRFC70" testRFC70 + ] + +-- And some other oddballs: +mailbase = "mailto:local/option@domain.org?notaquery#frag" +testMail01 = testRelJoin "testMail01" + mailbase "more@domain" + "mailto:local/more@domain" +testMail02 = testRelJoin "testMail02" + mailbase "#newfrag" + "mailto:local/option@domain.org?notaquery#newfrag" +testMail03 = testRelJoin "testMail03" + mailbase "l1/q1@domain" + "mailto:local/l1/q1@domain" + +testMail11 = testRelJoin "testMail11" + "mailto:local1@domain1?query1" "mailto:local2@domain2" + "mailto:local2@domain2" +testMail12 = testRelJoin "testMail12" + "mailto:local1@domain1" "mailto:local2@domain2?query2" + "mailto:local2@domain2?query2" +testMail13 = testRelJoin "testMail13" + "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" + "mailto:local2@domain2?query2" +testMail14 = testRelJoin "testMail14" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "mailto:local@domain?query2" +testMail15 = testRelJoin "testMail15" + "mailto:?query1" "mailto:local@domain?query2" + "mailto:local@domain?query2" +testMail16 = testRelJoin "testMail16" + "mailto:local@domain?query1" "?query2" + "mailto:local@domain?query2" +testInfo17 = testRelJoin "testInfo17" + "info:name/1234/../567" "name/9876/../543" + "info:name/name/543" +testInfo18 = testRelJoin "testInfo18" + "info:/name/1234/../567" "name/9876/../543" + "info:/name/name/543" + +testOddballSuite = TF.testGroup "Test oddball examples" testOddballList +testOddballList = + [ TF.testCase "testMail01" testMail01 + , TF.testCase "testMail02" testMail02 + , TF.testCase "testMail03" testMail03 + , TF.testCase "testMail11" testMail11 + , TF.testCase "testMail12" testMail12 + , TF.testCase "testMail13" testMail13 + , TF.testCase "testMail14" testMail14 + , TF.testCase "testMail15" testMail15 + , TF.testCase "testMail16" testMail16 + , TF.testCase "testInfo17" testInfo17 + ] + +-- Normalization tests + +-- Case normalization; cf. RFC2396bis section 6.2.2.1 +-- NOTE: authority case normalization is not performed +testNormalize01 = testEq "testNormalize01" + "http://EXAMPLE.com/Root/%2A?%2B#%2C" + (normalizeCase "HTTP://EXAMPLE.com/Root/%2a?%2b#%2c") + +-- Encoding normalization; cf. RFC2396bis section 6.2.2.2 +testNormalize11 = testEq "testNormalize11" + "HTTP://EXAMPLE.com/Root/~Me/" + (normalizeEscape "HTTP://EXAMPLE.com/Root/%7eMe/") +testNormalize12 = testEq "testNormalize12" + "foo:%40AZ%5b%60az%7b%2f09%3a-._~" + (normalizeEscape "foo:%40%41%5a%5b%60%61%7a%7b%2f%30%39%3a%2d%2e%5f%7e") +testNormalize13 = testEq "testNormalize13" + "foo:%3a%2f%3f%23%5b%5d%40" + (normalizeEscape "foo:%3a%2f%3f%23%5b%5d%40") + +-- Path segment normalization; cf. RFC2396bis section 6.2.2.4 +testNormalize21 = testEq "testNormalize21" + "http://example/c" + (normalizePathSegments "http://example/a/b/../../c") +testNormalize22 = testEq "testNormalize22" + "http://example/a/" + (normalizePathSegments "http://example/a/b/c/../../") +testNormalize23 = testEq "testNormalize23" + "http://example/a/b/c/" + (normalizePathSegments "http://example/a/b/c/./") +testNormalize24 = testEq "testNormalize24" + "http://example/a/b/" + (normalizePathSegments "http://example/a/b/c/.././") +testNormalize25 = testEq "testNormalize25" + "http://example/e" + (normalizePathSegments "http://example/a/b/c/d/../../../../e") +testNormalize26 = testEq "testNormalize26" + "http://example/e" + (normalizePathSegments "http://example/a/b/c/d/../.././../../e") +testNormalize27 = testEq "testNormalize27" + "http://example/e" + (normalizePathSegments "http://example/a/b/../.././../../e") +testNormalize28 = testEq "testNormalize28" + "foo:e" + (normalizePathSegments "foo:a/b/../.././../../e") + +testNormalizeSuite = TF.testGroup "testNormalizeSuite" + [ TF.testCase "testNormalize01" testNormalize01 + , TF.testCase "testNormalize11" testNormalize11 + , TF.testCase "testNormalize12" testNormalize12 + , TF.testCase "testNormalize13" testNormalize13 + , TF.testCase "testNormalize21" testNormalize21 + , TF.testCase "testNormalize22" testNormalize22 + , TF.testCase "testNormalize23" testNormalize23 + , TF.testCase "testNormalize24" testNormalize24 + , TF.testCase "testNormalize25" testNormalize25 + , TF.testCase "testNormalize26" testNormalize26 + , TF.testCase "testNormalize27" testNormalize27 + , TF.testCase "testNormalize28" testNormalize28 + ] + +-- URI formatting (show) tests + +ts02URI = URI { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?ccc" + , uriFragment = "#ddd/eee" + } + +ts04URI = URI { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:anonymous@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?ccc" + , uriFragment = "#ddd/eee" + } + +ts02str = "http://user:...@example.org:99/aaa/bbb?ccc#ddd/eee" +ts03str = "http://user:pass@example.org:99/aaa/bbb?ccc#ddd/eee" +ts04str = "http://user:...@example.org:99/aaa/bbb?ccc#ddd/eee" + +testShowURI01 = testEq "testShowURI01" "" (show nullURI) +testShowURI02 = testEq "testShowURI02" ts02str (show ts02URI) +testShowURI03 = testEq "testShowURI03" ts03str ((uriToString id ts02URI) "") +testShowURI04 = testEq "testShowURI04" ts04str (show ts04URI) + +testShowURI = TF.testGroup "testShowURI" + [ TF.testCase "testShowURI01" testShowURI01 + , TF.testCase "testShowURI02" testShowURI02 + , TF.testCase "testShowURI03" testShowURI03 + , TF.testCase "testShowURI04" testShowURI04 + ] + + +-- URI escaping tests + +te01str = "http://example.org/az/09-_/.~:/?#[]@!$&'()*+,;=" +te02str = "http://example.org/a/c%/d /e" +te02esc = "http://example.org/a%3C/b%3E/c%25/d%20/e" + +testEscapeURIString01 = testEq "testEscapeURIString01" + te01str (escapeURIString isUnescapedInURI te01str) + +testEscapeURIString02 = testEq "testEscapeURIString02" + te02esc (escapeURIString isUnescapedInURI te02str) + +testEscapeURIString03 = testEq "testEscapeURIString03" + te01str (unEscapeString te01str) + +testEscapeURIString04 = testEq "testEscapeURIString04" + te02str (unEscapeString te02esc) + +testEscapeURIString05 = testEq "testEscapeURIString05" + "http%3A%2F%2Fexample.org%2Faz%2F09-_%2F.~%3A%2F%3F%23%5B%5D%40%21%24%26%27%28%29%2A%2B%2C%3B%3D" + (escapeURIString isUnescapedInURIComponent te01str) + +testEscapeURIString06 = testEq "testEscapeURIString06" + "hello%C3%B8%C2%A9%E6%97%A5%E6%9C%AC" + (escapeURIString isUnescapedInURIComponent "helloø©日本") + +propEscapeUnEscapeLoop :: String -> Bool +propEscapeUnEscapeLoop s = s == (unEscapeString $! escaped) + where + escaped = escapeURIString (const False) s + {-# NOINLINE escaped #-} + +testEscapeURIString = TF.testGroup "testEscapeURIString" + [ TF.testCase "testEscapeURIString01" testEscapeURIString01 + , TF.testCase "testEscapeURIString02" testEscapeURIString02 + , TF.testCase "testEscapeURIString03" testEscapeURIString03 + , TF.testCase "testEscapeURIString04" testEscapeURIString04 + , TF.testCase "testEscapeURIString05" testEscapeURIString05 + , TF.testCase "testEscapeURIString06" testEscapeURIString06 + , TF.testProperty "propEscapeUnEscapeLoop" propEscapeUnEscapeLoop + ] + +-- URI string normalization tests + +tn01str = "eXAMPLE://a/b/%7bfoo%7d" +tn01nrm = "example://a/b/%7Bfoo%7D" + +tn02str = "example://a/b/%63/" +tn02nrm = "example://a/b/c/" + +tn03str = "example://a/./b/../b/c/foo" +tn03nrm = "example://a/b/c/foo" + +tn04str = "eXAMPLE://a/b/%7bfoo%7d" -- From RFC2396bis, 6.2.2 +tn04nrm = "example://a/b/%7Bfoo%7D" + +tn06str = "file:/x/..//y" +tn06nrm = "file://y" + +tn07str = "file:x/..//y/" +tn07nrm = "file:/y/" + +testNormalizeURIString01 = testEq "testNormalizeURIString01" + tn01nrm (normalizeCase tn01str) +testNormalizeURIString02 = testEq "testNormalizeURIString02" + tn02nrm (normalizeEscape tn02str) +testNormalizeURIString03 = testEq "testNormalizeURIString03" + tn03nrm (normalizePathSegments tn03str) +testNormalizeURIString04 = testEq "testNormalizeURIString04" + tn04nrm ((normalizeCase . normalizeEscape . normalizePathSegments) tn04str) +testNormalizeURIString05 = testEq "testNormalizeURIString05" + tn04nrm ((normalizePathSegments . normalizeEscape . normalizeCase) tn04str) +testNormalizeURIString06 = testEq "testNormalizeURIString06" + tn06nrm (normalizePathSegments tn06str) +testNormalizeURIString07 = testEq "testNormalizeURIString07" + tn07nrm (normalizePathSegments tn07str) + +testNormalizeURIString = TF.testGroup "testNormalizeURIString" + [ TF.testCase "testNormalizeURIString01" testNormalizeURIString01 + , TF.testCase "testNormalizeURIString02" testNormalizeURIString02 + , TF.testCase "testNormalizeURIString03" testNormalizeURIString03 + , TF.testCase "testNormalizeURIString04" testNormalizeURIString04 + , TF.testCase "testNormalizeURIString05" testNormalizeURIString05 + , TF.testCase "testNormalizeURIString06" testNormalizeURIString06 + , TF.testCase "testNormalizeURIString07" testNormalizeURIString07 + ] + +-- Test strict vs non-strict relativeTo logic + +trbase = fromJust $ parseURIReference "http://bar.org/" + +testRelativeTo01 = testEq "testRelativeTo01" + "http://bar.org/foo" + (show $ + (fromJust $ parseURIReference "foo") `relativeTo` trbase) + +testRelativeTo02 = testEq "testRelativeTo02" + "http:foo" + (show $ + (fromJust $ parseURIReference "http:foo") `relativeTo` trbase) + +testRelativeTo03 = testEq "testRelativeTo03" + "http://bar.org/foo" + (show $ + (fromJust $ parseURIReference "http:foo") `nonStrictRelativeTo` trbase) + +testRelativeTo = TF.testGroup "testRelativeTo" + [ TF.testCase "testRelativeTo01" testRelativeTo01 + , TF.testCase "testRelativeTo02" testRelativeTo02 + , TF.testCase "testRelativeTo03" testRelativeTo03 + ] + +-- Test alternative parsing functions +testAltFn01 = testEq "testAltFn01" "Just http://a.b/c#f" + (show . parseURI $ "http://a.b/c#f") +testAltFn02 = testEq "testAltFn02" "Just http://a.b/c#f" + (show . parseURIReference $ "http://a.b/c#f") +testAltFn03 = testEq "testAltFn03" "Just c/d#f" + (show . parseRelativeReference $ "c/d#f") +testAltFn04 = testEq "testAltFn04" "Nothing" + (show . parseRelativeReference $ "http://a.b/c#f") +testAltFn05 = testEq "testAltFn05" "Just http://a.b/c" + (show . parseAbsoluteURI $ "http://a.b/c") +testAltFn06 = testEq "testAltFn06" "Nothing" + (show . parseAbsoluteURI $ "http://a.b/c#f") +testAltFn07 = testEq "testAltFn07" "Nothing" + (show . parseAbsoluteURI $ "c/d") +testAltFn08 = testEq "testAltFn08" "Just http://a.b/c" + (show . parseAbsoluteURI $ "http://a.b/c") + +testAltFn11 = testEq "testAltFn11" True (isURI "http://a.b/c#f") +testAltFn12 = testEq "testAltFn12" True (isURIReference "http://a.b/c#f") +testAltFn13 = testEq "testAltFn13" True (isRelativeReference "c/d#f") +testAltFn14 = testEq "testAltFn14" False (isRelativeReference "http://a.b/c#f") +testAltFn15 = testEq "testAltFn15" True (isAbsoluteURI "http://a.b/c") +testAltFn16 = testEq "testAltFn16" False (isAbsoluteURI "http://a.b/c#f") +testAltFn17 = testEq "testAltFn17" False (isAbsoluteURI "c/d") + +testAltFn = TF.testGroup "testAltFn" + [ TF.testCase "testAltFn01" testAltFn01 + , TF.testCase "testAltFn02" testAltFn02 + , TF.testCase "testAltFn03" testAltFn03 + , TF.testCase "testAltFn04" testAltFn04 + , TF.testCase "testAltFn05" testAltFn05 + , TF.testCase "testAltFn06" testAltFn06 + , TF.testCase "testAltFn07" testAltFn07 + , TF.testCase "testAltFn08" testAltFn08 + , TF.testCase "testAltFn11" testAltFn11 + , TF.testCase "testAltFn12" testAltFn12 + , TF.testCase "testAltFn13" testAltFn13 + , TF.testCase "testAltFn14" testAltFn14 + , TF.testCase "testAltFn15" testAltFn15 + , TF.testCase "testAltFn16" testAltFn16 + , TF.testCase "testAltFn17" testAltFn17 + ] + +testUriIsAbsolute :: String -> Assertion +testUriIsAbsolute str = + assertBool str (uriIsAbsolute uri) + where + Just uri = parseURIReference str + +testUriIsRelative :: String -> Assertion +testUriIsRelative str = + assertBool str (uriIsRelative uri) + where + Just uri = parseURIReference str + +testIsAbsolute = TF.testGroup "testIsAbsolute" + [ TF.testCase "testIsAbsolute01" $ testUriIsAbsolute "http://google.com" + , TF.testCase "testIsAbsolute02" $ testUriIsAbsolute "ftp://p.x.ca/woo?hai=a" + , TF.testCase "testIsAbsolute03" $ testUriIsAbsolute "mailto:bob@example.com" + ] + +testIsRelative = TF.testGroup "testIsRelative" + [ TF.testCase "testIsRelative01" $ testUriIsRelative "//google.com" + , TF.testCase "testIsRelative02" $ testUriIsRelative "/hello" + , TF.testCase "testIsRelative03" $ testUriIsRelative "this/is/a/path" + , TF.testCase "testIsRelative04" $ testUriIsRelative "?what=that" + ] + +-- Full test suite +allTests = + [ testURIRefSuite + , testComponentSuite + , testRelativeSuite + , testRFC2396Suite + , testOddballSuite + , testNormalizeSuite + , testShowURI + , testEscapeURIString + , testNormalizeURIString + , testRelativeTo + , testAltFn + , testIsAbsolute + , testIsRelative + ] + +main = TF.defaultMain allTests + +runTestFile t = do + h <- openFile "a.tmp" WriteMode + _ <- runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +-- Miscellaneous values for hand-testing/debugging in Hugs: + +uref = testURIRefSuite +tr01 = testRelative01 +tr02 = testRelative02 +tr03 = testRelative03 +tr04 = testRelative04 +rel = testRelativeSuite +rfc = testRFC2396Suite +oddb = testOddballSuite + +(Just bu02) = parseURIReference "http://example/x/y/z" +(Just ou02) = parseURIReference "../abc" +(Just ru02) = parseURIReference "http://example/x/abc" +-- fileuri = testURIReference "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" + +cu02 = ou02 `relativeTo` bu02 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- Distributed as free software under the following license. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- - Neither name of the copyright holders nor the names of its +-- contributors may be used to endorse or promote products derived from +-- this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +-- OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +-- TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +-------------------------------------------------------------------------------- +-- $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. +--