diff --git a/Network/URI.hs b/Network/URI.hs --- a/Network/URI.hs +++ b/Network/URI.hs @@ -118,16 +118,18 @@ import Text.ParserCombinators.Parsec ( GenParser, ParseError - , parse, (<|>), (), try - , option, many, many1, count, notFollowedBy + , parse, (), try + , option, many1, count, notFollowedBy , char, satisfy, oneOf, string, eof , unexpected ) -import Control.Monad (MonadPlus(..)) +import Control.Applicative +import Control.Monad (MonadPlus(..), void) +import Data.Traversable (sequenceA) +import Control.DeepSeq (NFData(rnf), deepseq) import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) import Data.Bits ((.|.),(.&.),shiftL,shiftR) -import Debug.Trace (trace) import Numeric (showIntAtBase) import Data.Typeable (Typeable) @@ -137,6 +139,11 @@ import Data.Generics (Data) #endif +#if MIN_VERSION_base(4,6,0) +import GHC.Generics (Generic) +#else +#endif + ------------------------------------------------------------ -- The URI datatype ------------------------------------------------------------ @@ -156,8 +163,16 @@ , uriPath :: String -- ^ @\/ghc@ , uriQuery :: String -- ^ @?query@ , uriFragment :: String -- ^ @#frag@ +#if MIN_VERSION_base(4,6,0) + } deriving (Eq, Ord, Typeable, Data, Generic) +#else } deriving (Eq, Ord, Typeable, Data) +#endif +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\@@ @@ -165,6 +180,9 @@ , uriPort :: String -- ^ @:42@ } deriving (Eq, Ord, Show, Typeable, Data) +instance NFData URIAuth where + rnf (URIAuth ui rn p) = ui `deepseq` rn `deepseq` p `deepseq` () + -- |Blank URI nullURI :: URI nullURI = URI @@ -197,18 +215,6 @@ then pass else ":...@" -testDefaultUserInfoMap :: [Bool] -testDefaultUserInfoMap = - [ defaultUserInfoMap "" == "" - , defaultUserInfoMap "@" == "@" - , defaultUserInfoMap "user@" == "user@" - , defaultUserInfoMap "user:@" == "user:@" - , defaultUserInfoMap "user:anonymous@" == "user:...@" - , defaultUserInfoMap "user:pass@" == "user:...@" - , defaultUserInfoMap "user:pass" == "user:...@" - , defaultUserInfoMap "user:anonymous" == "user:...@" - ] - ------------------------------------------------------------ -- Parse a URI ------------------------------------------------------------ @@ -279,11 +285,6 @@ isIPv4address :: String -> Bool isIPv4address = isValidParse ipv4address --- |Test function: parse and reconstruct a URI reference --- -testURIReference :: String -> String -testURIReference uristr = show (parseAll uriReference "" uristr) - -- Helper function for turning a string into a URI -- parseURIAny :: URIParser URI -> String -> Maybe URI @@ -313,7 +314,7 @@ ------------------------------------------------------------ uriIsAbsolute :: URI -> Bool -uriIsAbsolute (URI {uriScheme = scheme}) = scheme /= "" +uriIsAbsolute (URI {uriScheme = scheme'}) = scheme' /= "" uriIsRelative :: URI -> Bool uriIsRelative = not . uriIsAbsolute @@ -331,12 +332,7 @@ -- Parse and return a 'pct-encoded' sequence -- escaped :: URIParser String -escaped = - do { char '%' - ; h1 <- hexDigitChar - ; h2 <- hexDigitChar - ; return $ ['%',h1,h2] - } +escaped = sequenceA [char '%', hexDigitChar, hexDigitChar] -- RFC3986, section 2.2 -- @@ -353,11 +349,8 @@ isSubDelims :: Char -> Bool isSubDelims c = c `elem` "!$&'()*+,;=" -genDelims :: URIParser String -genDelims = do { c <- satisfy isGenDelims ; return [c] } - subDelims :: URIParser String -subDelims = do { c <- satisfy isSubDelims ; return [c] } +subDelims = (:[]) <$> oneOf "!$&'()*+,;=" -- RFC3986, section 2.3 -- @@ -370,7 +363,7 @@ isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") unreservedChar :: URIParser String -unreservedChar = do { c <- satisfy isUnreserved ; return [c] } +unreservedChar = (:[]) <$> satisfy isUnreserved -- RFC3986, section 3 -- @@ -387,8 +380,8 @@ -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) -- ; up <- upath ; (ua,up) <- hierPart - ; uq <- option "" ( do { char '?' ; uquery } ) - ; uf <- option "" ( do { char '#' ; ufragment } ) + ; uq <- option "" ( do { void $ char '?' ; uquery } ) + ; uf <- option "" ( do { void $ char '#' ; ufragment } ) ; return $ URI { uriScheme = us , uriAuthority = ua @@ -400,7 +393,7 @@ hierPart :: URIParser ((Maybe URIAuth),String) hierPart = - do { try (string "//") + do { void $ try (string "//") ; ua <- uauthority ; up <- pathAbEmpty ; return (ua,up) @@ -419,7 +412,7 @@ uscheme :: URIParser String uscheme = do { s <- oneThenMany alphaChar (satisfy isSchemeChar) - ; char ':' + ; void $ char ':' ; return $ s++":" } @@ -442,7 +435,7 @@ userinfo :: URIParser String userinfo = do { uu <- many (uchar ";:&=+$,") - ; char '@' + ; void $ char '@' ; return (concat uu ++"@") } @@ -453,18 +446,18 @@ ipLiteral :: URIParser String ipLiteral = - do { char '[' + do { void $ char '[' ; ua <- ( ipv6address <|> ipvFuture ) - ; char ']' + ; void $ char ']' ; return $ "[" ++ ua ++ "]" } "IP address literal" ipvFuture :: URIParser String ipvFuture = - do { char 'v' + do { void $ char 'v' ; h <- hexDigitChar - ; char '.' + ; void $ char '.' ; a <- many1 (satisfy isIpvFutureChar) ; return $ 'v':h:'.':a } @@ -480,54 +473,54 @@ ; return $ concat a2 ++ a3 } ) <|> try ( do - { string "::" + { void $ string "::" ; a2 <- count 5 h4c ; a3 <- ls32 ; return $ "::" ++ concat a2 ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 0 - ; string "::" + ; void $ string "::" ; a2 <- count 4 h4c ; a3 <- ls32 ; return $ a1 ++ "::" ++ concat a2 ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 1 - ; string "::" + ; void $ string "::" ; a2 <- count 3 h4c ; a3 <- ls32 ; return $ a1 ++ "::" ++ concat a2 ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 2 - ; string "::" + ; void $ string "::" ; a2 <- count 2 h4c ; a3 <- ls32 ; return $ a1 ++ "::" ++ concat a2 ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 3 - ; string "::" + ; void $ string "::" ; a2 <- h4c ; a3 <- ls32 ; return $ a1 ++ "::" ++ a2 ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 4 - ; string "::" + ; void $ string "::" ; a3 <- ls32 ; return $ a1 ++ "::" ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 5 - ; string "::" + ; void $ string "::" ; a3 <- h4 ; return $ a1 ++ "::" ++ a3 } ) <|> try ( do { a1 <- opt_n_h4c_h4 6 - ; string "::" + ; void $ string "::" ; return $ a1 ++ "::" } ) "IPv6 address" @@ -550,8 +543,8 @@ h4c :: URIParser String h4c = try $ do { a1 <- h4 - ; char ':' - ; notFollowedBy (char ':') + ; void $ char ':' + ; void $ notFollowedBy (char ':') ; return $ a1 ++ ":" } @@ -560,11 +553,11 @@ ipv4address :: URIParser String ipv4address = - do { a1 <- decOctet ; char '.' - ; a2 <- decOctet ; char '.' - ; a3 <- decOctet ; char '.' + do { a1 <- decOctet ; void $ char '.' + ; a2 <- decOctet ; void $ char '.' + ; a3 <- decOctet ; void $ char '.' ; a4 <- decOctet - ; notFollowedBy regName + ; void $ notFollowedBy regName ; return $ a1++"."++a2++"."++a3++"."++a4 } "IPv4 Address" @@ -589,7 +582,7 @@ port :: URIParser String port = - do { char ':' + do { void $ char ':' ; p <- many digitChar ; return (':':p) } @@ -632,7 +625,7 @@ pathAbs :: URIParser String pathAbs = - do { char '/' + do { void $ char '/' ; ss <- option "" pathRootLess ; return $ '/':ss } @@ -653,7 +646,7 @@ slashSegment :: URIParser String slashSegment = - do { char '/' + do { void $ char '/' ; s <- segment ; return ('/':s) } @@ -725,8 +718,8 @@ -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) -- ; up <- upath ; (ua,up) <- relativePart - ; uq <- option "" ( do { char '?' ; uquery } ) - ; uf <- option "" ( do { char '#' ; ufragment } ) + ; uq <- option "" ( do { void $ char '?' ; uquery } ) + ; uf <- option "" ( do { void $ char '#' ; ufragment } ) ; return $ URI { uriScheme = "" , uriAuthority = ua @@ -738,7 +731,7 @@ relativePart :: URIParser ((Maybe URIAuth),String) relativePart = - do { try (string "//") + do { void $ try (string "//") ; ua <- uauthority ; up <- pathAbEmpty ; return (ua,up) @@ -760,7 +753,7 @@ -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) -- ; up <- upath ; (ua,up) <- hierPart - ; uq <- option "" ( do { char '?' ; uquery } ) + ; uq <- option "" ( do { void $ char '?' ; uquery } ) ; return $ URI { uriScheme = us , uriAuthority = ua @@ -801,9 +794,6 @@ digitChar :: URIParser Char digitChar = satisfy isDigitChar -- or: Parsec.digit ? -alphaNumChar :: URIParser Char -alphaNumChar = satisfy isAlphaNumChar - hexDigitChar :: URIParser Char hexDigitChar = satisfy isHexDigitChar -- or: Parsec.hexDigit ? @@ -972,6 +962,7 @@ 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 @@ -1244,7 +1235,7 @@ normalizeEscape (c:cs) = c:normalizeEscape cs normalizeEscape [] = [] --- |Path segment normalization; cf. RFC3986 section 6.2.2.4 +-- |Path segment normalization; cf. RFC3986 section 6.2.2.3 -- normalizePathSegments :: String -> String normalizePathSegments uristr = normstr juri @@ -1253,16 +1244,6 @@ normstr Nothing = uristr normstr (Just u) = show (normuri u) normuri u = u { uriPath = removeDotSegments (uriPath u) } - ------------------------------------------------------------- --- Local trace helper functions ------------------------------------------------------------- - -traceShow :: Show a => String -> a -> a -traceShow msg x = trace (msg ++ show x) x - -traceVal :: Show a => String -> a -> b -> b -traceVal msg x y = trace (msg ++ show x) y ------------------------------------------------------------ -- Deprecated functions diff --git a/network-uri.cabal b/network-uri.cabal --- a/network-uri.cabal +++ b/network-uri.cabal @@ -1,5 +1,5 @@ name: network-uri -version: 2.6.0.1 +version: 2.6.0.2 synopsis: URI manipulation description: This package provides an URI manipulation inteface. @@ -26,7 +26,7 @@ bug-reports: https://github.com/haskell/network-uri/issues license: BSD3 license-file: LICENSE -maintainer: johan.tibell@gmail.com +maintainer: ezra@ezrakilty.net category: Network build-type: Simple cabal-version: >=1.10 @@ -36,8 +36,11 @@ Network.URI build-depends: base >= 3 && < 5, + deepseq >= 1.1 && < 1.5, parsec >= 3.0 && < 3.2 default-extensions: CPP, DeriveDataTypeable + if impl(ghc >= 7.6) + default-extensions: DeriveGeneric ghc-options: -Wall -fwarn-tabs default-language: Haskell98 @@ -49,7 +52,7 @@ build-depends: base < 5, HUnit, - network, + network-uri, test-framework, test-framework-hunit, test-framework-quickcheck2 diff --git a/tests/uri001.hs b/tests/uri001.hs --- a/tests/uri001.hs +++ b/tests/uri001.hs @@ -232,9 +232,9 @@ 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" +testURIRef122 = testEq "v.future authority" (Just (URIAuth "" "[v9.123.abc;456.def]" ":42")) - ((maybe Nothing uriAuthority) . parseURI $ "http://[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. @@ -1106,9 +1106,9 @@ propEscapeUnEscapeLoop :: String -> Bool propEscapeUnEscapeLoop s = s == (unEscapeString $! escaped) - where - escaped = escapeURIString (const False) s - {-# NOINLINE escaped #-} + where + escaped = escapeURIString (const False) s + {-# NOINLINE escaped #-} testEscapeURIString = TF.testGroup "testEscapeURIString" [ TF.testCase "testEscapeURIString01" testEscapeURIString01