network-uri-2.6.3.0/0000755000000000000000000000000007346545000012337 5ustar0000000000000000network-uri-2.6.3.0/CHANGELOG.md0000755000000000000000000000261407346545000014156 0ustar0000000000000000# network-uri-2.6.3.0 (2020-02-18) * Add official support for SafeHaskell NOTE: This is the first version whose SafeHaskell properties have become an intentional part of the API contract; previous versions were merely accidentally safe-inferred (or not depending on various factors; in other words, this was a fragile property). * Derive `Lift` instances using `DeriveLift` extension, when available. # network-uri-2.6.2.0 (2020-01-30) * Mark the modules as Safe for SafeHaskell. # network-uri-2.6.2.0 (2020-01-30) * Merge network-uri-static (Network.URI.Static) into this package, which offers a way to parse URI strings at compile time. * Add `Lens`es for the `URI` types * Add `Generic` instances for the `URI` type * Add `Lift` instances for the `URI` type * Optimize `isReserved` and related character-class functions. * Start to add some benchmarks for performance analysis * Fix a bug: Correctly parse IPv6 addresses in URIs. * Add `rectify` which normalizes a URI if it is missing certain separator characters required by the module. Some users found adding those characters inconvenient when building a URI from parts. * Add `nullURIAuth` and `uriAuthToString`, paralleling `nullURI` and `uriToString`. # network-uri-2.6.0.3 * Fix a bug with IPv4 address parsing. # network-uri-2.6.0.2 * Implement Generic and NFData. # network-uri-2.6.0.0 * Initial release: Module split off from `network`. network-uri-2.6.3.0/LICENSE0000644000000000000000000000307307346545000013347 0ustar0000000000000000Copyright (c) 2002-2010, The University Court of the University of Glasgow. Copyright (c) 2007-2010, Johan Tibell 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 University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW 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. network-uri-2.6.3.0/Network/0000755000000000000000000000000007346545000013770 5ustar0000000000000000network-uri-2.6.3.0/Network/URI.hs0000644000000000000000000013435407346545000014775 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift, StandaloneDeriving #-} #else {-# LANGUAGE TemplateHaskell #-} #endif #if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_parsec(3,13,0) {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------- -- | -- 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 , nullURIAuth , rectify, rectifyAuth -- * 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, uriAuthToString , isReserved, isUnreserved , isAllowedInURI, isUnescapedInURI , isUnescapedInURIComponent , escapeURIChar , escapeURIString , unEscapeString , pathSegments -- * 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, many1, count, notFollowedBy , char, satisfy, oneOf, string, eof , unexpected ) import Control.Applicative import Control.Monad (MonadPlus(..)) import Control.DeepSeq (NFData(rnf), deepseq) import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) import Data.Bits ((.|.),(.&.),shiftL,shiftR) import Data.List (unfoldr, isPrefixOf, isSuffixOf) import Numeric (showIntAtBase) import Language.Haskell.TH.Syntax (Lift(..)) #if !MIN_VERSION_base(4,8,0) import Data.Traversable (sequenceA) #endif import Data.Typeable (Typeable) #if MIN_VERSION_base(4,0,0) import Data.Data (Data) #else import Data.Generics (Data) #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #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@ #if __GLASGOW_HASKELL__ >= 702 } deriving (Eq, Ord, Typeable, Data, Generic) #else } deriving (Eq, Ord, Typeable, Data) #endif -- | Add a prefix to a string, unless it already has it. ensurePrefix :: String -> String -> String ensurePrefix p s = if isPrefixOf p s then s else p ++ s -- | Add a suffix to a string, unless it already has it. ensureSuffix :: String -> String -> String ensureSuffix p s = if isSuffixOf p s then s else s ++ p -- | Given a URIAuth in "nonstandard" form (lacking required separator characters), -- return one that is standard. rectifyAuth :: URIAuth -> URIAuth rectifyAuth a = URIAuth { uriUserInfo = unlessEmpty (ensureSuffix "@") (uriUserInfo a), uriRegName = uriRegName a, uriPort = unlessEmpty (ensurePrefix ":") (uriPort a) } -- | Given a URI in "nonstandard" form (lacking required separator characters), -- return one that is standard. rectify :: URI -> URI rectify u = URI { uriScheme = ensureSuffix ":" (uriScheme u), uriAuthority = fmap rectifyAuth (uriAuthority u), uriPath = uriPath u, uriQuery = unlessEmpty (ensurePrefix "?") (uriQuery u), uriFragment = unlessEmpty (ensurePrefix "#") (uriFragment u) } -- | Apply the function to the list, unless that list is empty, in -- which case leave it alone. unlessEmpty :: ([a] -> [a]) -> [a] -> [a] unlessEmpty _f [] = [] unlessEmpty f x = f x instance NFData URI where rnf (URI s a p q f) = s `deepseq` a `deepseq` p `deepseq` q `deepseq` f `deepseq` () -- |Type for authority value within a URI data URIAuth = URIAuth { uriUserInfo :: String -- ^ @anonymous\@@ , uriRegName :: String -- ^ @www.haskell.org@ , uriPort :: String -- ^ @:42@ #if __GLASGOW_HASKELL__ >= 702 } deriving (Eq, Ord, Show, Typeable, Data, Generic) #else } deriving (Eq, Ord, Show, Typeable, Data) #endif instance NFData URIAuth where rnf (URIAuth ui rn p) = ui `deepseq` rn `deepseq` p `deepseq` () -- |Blank URI nullURI :: URI nullURI = URI { uriScheme = "" , uriAuthority = Nothing , uriPath = "" , uriQuery = "" , uriFragment = "" } -- |Blank URIAuth. nullURIAuth :: URIAuth nullURIAuth = URIAuth { uriUserInfo = "" , uriRegName = "" , uriPort = "" } -- URI as instance of Show. Note that for security reasons, the default -- behaviour is to suppress any userinfo field (see RFC3986, section 7.5). -- This can be overridden by using uriToString directly with first -- 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 ":...@" ------------------------------------------------------------ -- 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 -- 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 = sequenceA [char '%', hexDigitChar, hexDigitChar] -- 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 -- As per https://github.com/haskell/network-uri/pull/46, it was found -- that the explicit case statement was noticably faster than a nicer -- expression in terms of `elem`. isGenDelims :: Char -> Bool isGenDelims c = case c of ':' -> True '/' -> True '?' -> True '#' -> True '[' -> True ']' -> True '@' -> True _ -> False -- As per https://github.com/haskell/network-uri/pull/46, it was found -- that the explicit case statement was noticably faster than a nicer -- expression in terms of `elem`. isSubDelims :: Char -> Bool isSubDelims c = case c of '!' -> True '$' -> True '&' -> True '\'' -> True '(' -> True ')' -> True '*' -> True '+' -> True ',' -> True ';' -> True '=' -> True _ -> False subDelims :: URIParser String subDelims = (:[]) <$> oneOf "!$&'()*+,;=" -- 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 = (:[]) <$> satisfy isUnreserved -- 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 -- RFC6874, section 2 host :: URIParser String host = ipLiteral <|> try ipv4address <|> regName ipLiteral :: URIParser String ipLiteral = do { _ <- char '[' ; ua <- ( ipv6addrz <|> 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==';') zoneid :: URIParser String zoneid = concat <$> many1 (unreservedChar <|> escaped) ipv6addrz :: URIParser String ipv6addrz = (++) <$> ipv6address <*> option "" (try $ (++) <$> string "%25" <*> zoneid) 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 nameChar ; 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 nameChar ; return $ concat ss } "Registered name" nameChar :: URIParser String nameChar = (unreservedChar <|> escaped <|> subDelims) "Name character" -- 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 ? 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. -- -- >>> escapeURIString isUnescapedInURI "http://haskell.org:80?some_param=true&other_param=їґ" -- "http://haskell.org:80?some_param=true&other_param=%D1%97%D2%91" isUnescapedInURI :: Char -> Bool isUnescapedInURI c = isReserved c || isUnreserved c -- | Returns 'True' if the character is allowed unescaped in a URI component. -- -- >>> escapeURIString isUnescapedInURIComponent "http://haskell.org:80?some_param=true&other_param=їґ" -- "http%3A%2F%2Fhaskell.org%3A80%3Fsome_param%3Dtrue%26other_param%3D%D1%97%D2%91" 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 :: Int -> Int -> Int -> String 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,[]) -- | The segments of the path component of a URI. E.g., segments :: String -> [String] segments str = dropLeadingEmpty $ unfoldr nextSegmentMaybe str where nextSegmentMaybe "" = Nothing nextSegmentMaybe ps = case break (=='/') ps of (seg, '/':ps1) -> Just (seg, ps1) (seg, _) -> Just (seg, "") dropLeadingEmpty ("":xs) = xs dropLeadingEmpty xs = xs -- | Returns the segments of the path component. E.g., -- pathSegments <$> parseURI "http://example.org/foo/bar/baz" -- == ["foo", "bar", "baz"] pathSegments :: URI -> [String] pathSegments = segments . uriPath -- | 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 -- | Calculate the path to the first argument, from the second argument. relPathFrom :: String -> String -> String relPathFrom [] _ = "/" relPathFrom pabs [] = pabs relPathFrom pabs base = if sa1 == sb1 -- If the first segments are equal then if (sa1 == "/") -- and they're absolute, then if (sa2 == sb2) -- then if the 2nd segs are equal, then relPathFrom1 ra2 rb2 -- relativize from there. else pabs -- Otherwise it's not worth trying. else relPathFrom1 ra1 rb1 -- If same & relative, relativize. else pabs -- If 1st segs not equal, just use pabs. where (sa1,ra1) = nextSegment pabs (sb1,rb1) = nextSegment base (sa2,ra2) = nextSegment ra1 (sb2,rb2) = nextSegment rb1 -- relPathFrom1 strips off trailing names from the supplied paths, and finds -- the relative path from base to target. relPathFrom1 :: String -> String -> String relPathFrom1 pabs base = relName where -- Relative paths are reckoned without the basename, so split those off. (sa,na) = splitLast pabs (sb,nb) = splitLast base rp = relSegsFrom sa sb relName = if null rp then -- If the relative path is empty, and the basenames are -- the same, then the paths must be exactly the same. if (na == nb) then "" -- If the name is vulnerable to being misinterpreted, -- add a dot segment in advance to protect it. else if protect na then "./"++na else na else rp++na -- If a single-segment path is null or contains a ':', it needs -- "protection" from being interpreted as a different kind of URL. protect s = null s || ':' `elem` s -- relSegsFrom discards any equal leading segments from two *directory* -- paths, then invokes difSegsFrom to calculate a relative path from the end -- of the base path to the end of the target path. 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 -- Given two paths @a@, @b@, count out the necessary number of ".." segments -- to get from the depth of @b@ to the path @a@. difSegsFrom :: String -> String -> String {- difSegsFrom sabs base | 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.3 -- 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) } ------------------------------------------------------------ -- Lift instances to support Network.URI.Static ------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 800 deriving instance Lift URI deriving instance Lift URIAuth #else instance Lift URI where lift (URI {..}) = [| URI {..} |] instance Lift URIAuth where lift (URIAuth {..}) = [| URIAuth {..} |] #endif ------------------------------------------------------------ -- 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. -- -------------------------------------------------------------------------------- network-uri-2.6.3.0/Network/URI/0000755000000000000000000000000007346545000014427 5ustar0000000000000000network-uri-2.6.3.0/Network/URI/Lens.hs0000644000000000000000000000305507346545000015667 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ > 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ > 702 {-# LANGUAGE Trustworthy #-} #endif -- | Network uri lenses module Network.URI.Lens ( uriRegNameLens , uriUserInfoLens , uriPortLens , uriAuthorityLens , uriSchemeLens , uriPathLens , uriQueryLens , uriFragmentLens ) where import Control.Applicative import Network.URI type Lens' s a = Lens s s a a type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) uriRegNameLens :: Lens' URIAuth String uriRegNameLens = lens uriRegName (\parent newVal -> parent {uriRegName = newVal}) uriUserInfoLens :: Lens' URIAuth String uriUserInfoLens = lens uriUserInfo (\parent newVal -> parent {uriUserInfo = newVal}) uriPortLens :: Lens' URIAuth String uriPortLens = lens uriPort (\parent newVal -> parent {uriPort = newVal}) uriAuthorityLens :: Lens' URI (Maybe URIAuth) uriAuthorityLens = lens uriAuthority (\parent newVal -> parent {uriAuthority = newVal}) uriSchemeLens :: Lens' URI String uriSchemeLens = lens uriScheme (\parent newVal -> parent {uriScheme = newVal}) uriPathLens :: Lens' URI String uriPathLens = lens uriPath (\parent newVal -> parent {uriPath = newVal}) uriQueryLens :: Lens' URI String uriQueryLens = lens uriQuery (\parent newVal -> parent {uriQuery = newVal}) uriFragmentLens :: Lens' URI String uriFragmentLens = lens uriFragment (\parent newVal -> parent {uriFragment = newVal}) network-uri-2.6.3.0/Network/URI/Static.hs0000644000000000000000000001075507346545000016222 0ustar0000000000000000#if __GLASGOW_HASKELL__ < 800 {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} #else {-# LANGUAGE RecordWildCards, TemplateHaskellQuotes, ViewPatterns #-} #endif #if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Network.URI.Static ( -- * Absolute URIs uri #if __GLASGOW_HASKELL__ >= 708 , staticURI #endif , staticURI' -- * Relative URIs , relativeReference #if __GLASGOW_HASKELL__ >= 708 , staticRelativeReference #endif , staticRelativeReference' ) where import Language.Haskell.TH.Lib (ExpQ) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Network.URI (URI(..), parseURI, parseRelativeReference) #if __GLASGOW_HASKELL__ >= 708 import Language.Haskell.TH.Lib (TExpQ) import Language.Haskell.TH.Syntax (unTypeQ) #endif -- $setup -- >>> :set -XTemplateHaskell -- >>> :set -XQuasiQuotes ---------------------------------------------------------------------------- -- Absolute URIs ---------------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 708 -- | 'staticURI' parses a specified string at compile time -- and return an expression representing the URI when it's a valid URI. -- Otherwise, it emits an error. -- -- >>> $$(staticURI "http://www.google.com/") -- http://www.google.com/ -- -- >>> $$(staticURI "http://www.google.com/##") -- -- ... -- ... Invalid URI: http://www.google.com/## -- ... staticURI :: String -- ^ String representation of a URI -> TExpQ URI -- ^ URI staticURI (parseURI -> Just u) = [|| u ||] staticURI s = fail $ "Invalid URI: " ++ s #endif -- | 'staticURI'' parses a specified string at compile time. -- -- The typed template haskell 'staticURI' is available only with GHC-7.8+. staticURI' :: String -- ^ String representation of a URI -> ExpQ -- ^ URI #if __GLASGOW_HASKELL__ >= 708 staticURI' = unTypeQ . staticURI #else staticURI' (parseURI -> Just u) = [| u |] staticURI' s = fail $ "Invalid URI: " ++ s #endif -- | 'uri' is a quasi quoter for 'staticURI'. -- -- >>> [uri|http://www.google.com/|] -- http://www.google.com/ -- -- >>> [uri|http://www.google.com/##|] -- -- ... -- ... Invalid URI: http://www.google.com/## -- ... uri :: QuasiQuoter uri = QuasiQuoter { quoteExp = staticURI', quotePat = undefined, quoteType = undefined, quoteDec = undefined } ---------------------------------------------------------------------------- -- Relative URIs ---------------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 708 -- | 'staticRelativeReference' parses a specified string at compile time and -- return an expression representing the URI when it's a valid relative -- reference. Otherwise, it emits an error. -- -- >>> $$(staticRelativeReference "/foo?bar=baz#quux") -- /foo?bar=baz#quux -- -- >>> $$(staticRelativeReference "http://www.google.com/") -- -- ... -- ... Invalid relative reference: http://www.google.com/ -- ... staticRelativeReference :: String -- ^ String representation of a reference -> TExpQ URI -- ^ Refererence staticRelativeReference (parseRelativeReference -> Just ref) = [|| ref ||] staticRelativeReference ref = fail $ "Invalid relative reference: " ++ ref #endif -- | 'staticRelativeReference'' parses a specified string at compile time and -- return an expression representing the URI when it's a valid relative -- reference. Otherwise, it emits an error. -- -- The typed template haskell 'staticRelativeReference' is available only with GHC-7.8+. staticRelativeReference' :: String -- ^ String representation of a reference -> ExpQ -- ^ Refererence #if __GLASGOW_HASKELL__ >= 708 staticRelativeReference' = unTypeQ . staticRelativeReference #else staticRelativeReference' (parseRelativeReference -> Just ref) = [| ref |] staticRelativeReference' ref = fail $ "Invalid relative reference: " ++ ref #endif -- | 'relativeReference' is a quasi quoter for 'staticRelativeReference'. -- -- >>> [relativeReference|/foo?bar=baz#quux|] -- /foo?bar=baz#quux -- -- >>> [relativeReference|http://www.google.com/|] -- -- ... -- ... Invalid relative reference: http://www.google.com/ -- ... relativeReference :: QuasiQuoter relativeReference = QuasiQuoter { quoteExp = staticRelativeReference', quotePat = undefined, quoteType = undefined, quoteDec = undefined } network-uri-2.6.3.0/README.md0000755000000000000000000000234007346545000013620 0ustar0000000000000000The network-uri package ======================= This package provides facilities for parsing and unparsing URIs, and creating and resolving relative URI references, closely following the URI spec, IETF RFC 3986 [1]. The main module in this package, `Network.URI`, was split off from the network package in the network-2.6 release. # Network.URI.Static Network.URI.Static that allows you to declare static URIs in type-safe manner. With the base module, when you declare a static URI, you need to either use `Maybe URI` or use `URI` and give up type safety. ```haskell safeButWrappedInMaybeURI :: Maybe URI safeButWrappedInMaybeURI = parseURI "http://www.google.com/" directButUnsafeURI :: URI directButUnsafeURI = fromJust $ parseURI "http://www.google.com/" ``` This library allows you to write static URIs in type-safe manner by checking URIs at compile time using template haskell. Now, you can write the following. ```haskell directAndSafeURI :: URI directAndSafeURI = $$(staticURI "http://www.google.com") ``` You can even use a quasi quote if you'd like. ```haskell directAndSafeURI :: URI directAndSafeURI = [uri|"http://www.google.com"|] ``` These two expressions emit an error at compile time if a specified URI is malformed. network-uri-2.6.3.0/Setup.hs0000644000000000000000000000005607346545000013774 0ustar0000000000000000import Distribution.Simple main = defaultMain network-uri-2.6.3.0/network-uri.cabal0000644000000000000000000000552607346545000015621 0ustar0000000000000000name: network-uri version: 2.6.3.0 synopsis: URI manipulation description: This package provides facilities for parsing and unparsing URIs, and creating and resolving relative URI references, closely following the URI spec, . . == Backward-compatibility . In @network-2.6@ the "Network.URI" module was split off from the @network@ package into this package. If you're using the "Network.URI" module you can be backward compatible and automatically get it from the right package by using the in your @.cabal@ file's build-depends (along with dependencies for both @network-uri@ and @network@): . > build-depends: > network-uri-flag == 0.1.* . Or you can do the same manually by adding this boilerplate to your @.cabal@ file: . > flag network-uri > description: Get Network.URI from the network-uri package > default: True > > library > -- ... > if flag(network-uri) > build-depends: network-uri >= 2.6, network >= 2.6 > else > build-depends: network-uri < 2.6, network < 2.6 . That is, get the module from either @network < 2.6@ or from @network-uri >= 2.6@. homepage: https://github.com/haskell/network-uri bug-reports: https://github.com/haskell/network-uri/issues license: BSD3 license-file: LICENSE extra-source-files: README.md, CHANGELOG.md maintainer: ezra@ezrakilty.net category: Network build-type: Simple cabal-version: >=1.10 tested-with: GHC ==8.10.1 || ==8.8.2 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2 || ==7.2.2 || ==7.0.2 library exposed-modules: Network.URI Network.URI.Lens Network.URI.Static build-depends: base >= 3 && < 5, deepseq >= 1.1 && < 1.5, parsec >= 3.1.12.0 && < 3.2 build-depends: template-haskell default-extensions: CPP, DeriveDataTypeable if impl(ghc < 7.6) build-depends: ghc-prim if impl(ghc >= 7.2) default-extensions: DeriveGeneric 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-uri, test-framework, test-framework-hunit, test-framework-quickcheck2 ghc-options: -Wall -fwarn-tabs default-language: Haskell98 test-suite uri-bench hs-source-dirs: tests main-is: uri-bench.hs type: exitcode-stdio-1.0 build-depends: base < 5, HUnit, network-uri, criterion, deepseq ghc-options: -Wall -fwarn-tabs default-language: Haskell98 source-repository head type: git location: git://github.com/haskell/network-uri.git network-uri-2.6.3.0/tests/0000755000000000000000000000000007346545000013501 5ustar0000000000000000network-uri-2.6.3.0/tests/uri-bench.hs0000644000000000000000000000402407346545000015711 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE BangPatterns #-} -------------------------------------------------------------------------------- -- $Id: URITest.hs,v 1.8 2005/07/19 22:01:27 gklyne Exp $ -- -- Copyright (c) 2004, G. KLYNE. All rights reserved. -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : URITest -- Copyright : (c) 2004, Graham Klyne -- License : BSD-style (see end of this file) -- -- Performance benchmarks for the network-uri package. -- -------------------------------------------------------------------------------- module Main where import Network.URI ( parseURI , parseURIReference , pathSegments , relativeFrom , relativeTo , isReserved ) import Criterion.Main import Control.DeepSeq main = defaultMain [ let Just !u = force (parseURI "http://ezample.org/foo/bar/baz//wimple/dimple/simple") in bgroup "pathSegments" [ bench "head" $ nf head (pathSegments u) , bench "tail" $ nf tail (pathSegments u) ] , bgroup "relativeFrom" [ let Just !u1 = force (parseURI "http://ex.it/foo/bar/baz/bop") in let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in bench "same 4" $ nf (relativeFrom u1) u2 , let Just !u1 = force (parseURI "http://ex.it/foo/bar/biz/bop") in let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in bench "different 4" $ nf (relativeFrom u1) u2 ] , bgroup "relativeTo" [ let Just !u1 = force (parseURIReference "../../biz/../biz/./bop") in let Just !u2 = force (parseURI "http://ex.it/foo/bar/baz/bap") in bench "dots and double dots" $ nf (relativeTo u1) u2 ] , -- Prompted by https://github.com/haskell/network-uri/pull/46 bgroup "isReserved" [ bench "isReserved a" $ nf isReserved 'a' , bench "isReserved :" $ nf isReserved ':' ] , bench "parseURI" $ nf parseURI "http://foo@bar.quix.gov/flip/flop?a=b&c=d" ] network-uri-2.6.3.0/tests/uri001.hs0000644000000000000000000020165707346545000015070 0ustar0000000000000000{-# 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 , rectify, rectifyAuth , parseURI, parseURIReference, parseRelativeReference, parseAbsoluteURI , parseAbsoluteURI , isURI, isURIReference, isRelativeReference, isAbsoluteURI , uriIsAbsolute, uriIsRelative , relativeTo, nonStrictRelativeTo , relativeFrom , uriToString, uriAuthToString , isUnescapedInURIComponent , isUnescapedInURI, escapeURIString, unEscapeString , normalizeCase, normalizeEscape, normalizePathSegments , pathSegments ) import Test.HUnit import Data.Maybe (fromJust) import Data.List (intercalate) 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]" testURIRef030 = testURIRef AbsId "http://[fe80::ff:fe00:1%25eth0]" -- 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" ] testPathSegmentsRoundTrip :: URI -> Assertion testPathSegmentsRoundTrip u = let segs = pathSegments u dropSuffix _suf [] = [] dropSuffix suf [x] | suf == x = [] | otherwise = [x] dropSuffix suf (x:xs) = x : dropSuffix suf xs dropPrefix _pre [] = [] dropPrefix pre (x:xs) | pre == x = xs | otherwise = (x:xs) strippedUriPath = dropSuffix '/' $ dropPrefix '/' $ uriPath u in (Data.List.intercalate "/" segs @?= strippedUriPath) assertJust _f Nothing = assertFailure "URI failed to parse" assertJust f (Just x) = f x testPathSegments = TF.testGroup "testPathSegments" [ TF.testCase "testPathSegments03" $ assertJust testPathSegmentsRoundTrip $ parseURIReference "" , TF.testCase "testPathSegments04" $ assertJust testPathSegmentsRoundTrip $ parseURIReference "/" , TF.testCase "testPathSegments05" $ assertJust testPathSegmentsRoundTrip $ parseURIReference "//" , TF.testCase "testPathSegments06" $ assertJust testPathSegmentsRoundTrip $ parseURIReference "foo//bar/" , TF.testCase "testPathSegments07" $ assertJust testPathSegmentsRoundTrip $ parseURIReference "/foo//bar/" , TF.testCase "testPathSegments03" $ assertJust testPathSegmentsRoundTrip $ parseURI "http://example.org" , TF.testCase "testPathSegments04" $ assertJust testPathSegmentsRoundTrip $ parseURI "http://example.org/" , TF.testCase "testPathSegments05" $ assertJust testPathSegmentsRoundTrip $ parseURI "http://example.org//" , TF.testCase "testPathSegments06" $ assertJust testPathSegmentsRoundTrip $ parseURI "http://ex.ca/foo//bar/" , TF.testCase "testPathSegments07" $ assertJust testPathSegmentsRoundTrip $ parseURI "http://ex.ca/foo//bar/" ] testRectify = TF.testGroup "testRectify" [ TF.testCase "" $ testEq "testRectify" (show $ rectify $ URI { uriScheme = "http" , uriAuthority = Just (URIAuth "ezra" "www.google.com" "80") , uriPath = "/foo/bar" , uriQuery = "foo=bar&baz=quz" , uriFragment = "chap10" }) "http://ezra@www.google.com:80/foo/bar?foo=bar&baz=quz#chap10" , -- According to RFC2986, any URL without a // does not have an authority component. -- Therefore tag: URIs have all their content in the path component. This is supported -- by the urn: example in section 3. Note that tag: URIs have no leading slash on their -- path component. TF.testCase "" $ testEq "testRectify" "tag:timothy@hpl.hp.com,2001:web/externalHome" (show $ rectify $ URI { uriScheme = "tag" , uriAuthority = Nothing, uriPath = "timothy@hpl.hp.com,2001:web/externalHome", uriQuery = "" , uriFragment = "" }) , TF.testCase "" $ testEq "testRectifyAuth" "//ezra@www.google.com:80" ((uriAuthToString id . Just . rectifyAuth $ URIAuth "ezra" "www.google.com" "80") "") ] -- Full test suite allTests = [ testURIRefSuite , testComponentSuite , testRelativeSuite , testRFC2396Suite , testOddballSuite , testNormalizeSuite , testShowURI , testEscapeURIString , testNormalizeURIString , testRelativeTo , testAltFn , testIsAbsolute , testIsRelative , testPathSegments , testRectify ] 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. --