diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +0.2.1.1 +* Add URI normalization features. + 0.2.1.0 * Widen dependency on base. diff --git a/src/URI/ByteString.hs b/src/URI/ByteString.hs --- a/src/URI/ByteString.hs +++ b/src/URI/ByteString.hs @@ -39,6 +39,12 @@ , URIParserOptions(..) , strictURIParserOptions , laxURIParserOptions + , URINormalizationOptions(..) + , noNormalization + , rfc3986Normalization + , httpNormalization + , aggressiveNormalization + , httpDefaultPorts -- * Operations , toAbsolute -- * Parsing @@ -49,6 +55,9 @@ -- * Serializing , serializeURIRef , serializeURIRef' + -- ** Normalized Serialization + , normalizeURIRef + , normalizeURIRef' -- * Low level utility functions , urlDecode , urlDecodeQuery diff --git a/src/URI/ByteString/Internal.hs b/src/URI/ByteString/Internal.hs --- a/src/URI/ByteString/Internal.hs +++ b/src/URI/ByteString/Internal.hs @@ -16,12 +16,15 @@ import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Char (ord) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (ord, toLower) import Data.Ix import Data.List (delete, intersperse, - stripPrefix, (\\)) + sortBy, stripPrefix, (\\)) +import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid +import Data.Ord (comparing) import Data.Word import Text.Read (readMaybe) ------------------------------------------------------------------------------- @@ -51,12 +54,60 @@ ------------------------------------------------------------------------------- +-- | All normalization options disabled +noNormalization :: URINormalizationOptions +noNormalization = URINormalizationOptions False False False False False False False httpDefaultPorts + + +------------------------------------------------------------------------------- +-- | The set of known default ports to schemes. Currently only +-- contains http\/80 and https\/443. Feel free to extend it if needed +-- with 'unoDefaultPorts'. +httpDefaultPorts :: M.Map Scheme Port +httpDefaultPorts = M.fromList [ (Scheme "http", Port 80) + , (Scheme "https", Port 443) + ] + + +------------------------------------------------------------------------------- +-- | Only normalizations deemed appropriate for all protocols by +-- RFC3986 enabled, namely: +-- +-- * Downcase Scheme +-- * Downcase Host +-- * Remove Dot Segments +rfc3986Normalization :: URINormalizationOptions +rfc3986Normalization = noNormalization { unoDowncaseScheme = True + , unoDowncaseHost = True + , unoRemoveDotSegments = True + } + + +------------------------------------------------------------------------------- +-- | The same as 'rfc3986Normalization' but with additional enabled +-- features if you're working with HTTP URIs: +-- +-- * Drop Default Port (with 'httpDefaultPorts') +-- * Drop Extra Slashes +httpNormalization :: URINormalizationOptions +httpNormalization = rfc3986Normalization { unoDropDefPort = True + , unoSlashEmptyPath = True + } + +------------------------------------------------------------------------------- +-- | All options enabled +aggressiveNormalization :: URINormalizationOptions +aggressiveNormalization = URINormalizationOptions True True True True True True True httpDefaultPorts + + +------------------------------------------------------------------------------- -- | @toAbsolute scheme ref@ converts @ref@ to an absolute URI. -- If @ref@ is already absolute, then it is unchanged. toAbsolute :: Scheme -> URIRef a -> URIRef Absolute toAbsolute scheme (RelativeRef {..}) = URI scheme rrAuthority rrPath rrQuery rrFragment toAbsolute _ uri@(URI {..}) = uri + ------------------------------------------------------------------------------- -- | URI Serializer ------------------------------------------------------------------------------- @@ -68,59 +119,168 @@ -- >>> BB.toLazyByteString $ serializeURIRef $ URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"} -- "http://www.example.org/foo?bar=baz#quux" serializeURIRef :: URIRef a -> Builder -serializeURIRef uri@(URI {..}) = serializeURI uri -serializeURIRef uri@(RelativeRef {..}) = serializeRelativeRef uri +serializeURIRef = normalizeURIRef noNormalization + +------------------------------------------------------------------------------- -- | Like 'serializeURIRef', with conversion into a strict 'ByteString'. serializeURIRef' :: URIRef a -> ByteString serializeURIRef' = BB.toByteString . serializeURIRef + +------------------------------------------------------------------------------- -- | Serialize a URI into a Builder. serializeURI :: URIRef Absolute -> Builder -serializeURI URI {..} = scheme <> BB.fromString ":" <> serializeRelativeRef rr +serializeURI = normalizeURIRef noNormalization +{-# DEPRECATED serializeURI "Use 'serializeURIRef' instead" #-} + + +------------------------------------------------------------------------------- +-- | Similar to 'serializeURIRef' but performs configurable degrees of +-- URI normalization. If your goal is the fastest serialization speed +-- possible, 'serializeURIRef' will be fine. If you intend on +-- comparing URIs (say for caching purposes), you'll want to use this. +normalizeURIRef :: URINormalizationOptions -> URIRef a -> Builder +normalizeURIRef o uri@(URI {..}) = normalizeURI o uri +normalizeURIRef o uri@(RelativeRef {}) = normalizeRelativeRef o Nothing uri + + +------------------------------------------------------------------------------- +normalizeURIRef' :: URINormalizationOptions -> URIRef a -> ByteString +normalizeURIRef' o = BB.toByteString . normalizeURIRef o + + +------------------------------------------------------------------------------- +normalizeURI :: URINormalizationOptions -> URIRef Absolute -> Builder +normalizeURI o@URINormalizationOptions {..} URI {..} = + scheme <> BB.fromString ":" <> normalizeRelativeRef o (Just uriScheme) rr where - scheme = bs $ schemeBS uriScheme + scheme = bs (sCase (schemeBS uriScheme)) + sCase + | unoDowncaseScheme = downcaseBS + | otherwise = id rr = RelativeRef uriAuthority uriPath uriQuery uriFragment -{-# DEPRECATED serializeURI "Use 'serializeURIRef' instead" #-} + +------------------------------------------------------------------------------- +normalizeRelativeRef :: URINormalizationOptions -> Maybe Scheme -> URIRef Relative -> Builder +normalizeRelativeRef o@URINormalizationOptions {..} mScheme RelativeRef {..} = + authority <> path <> query <> fragment + where + path + | unoSlashEmptyPath && BS.null rrPath = "/" + | otherwise = mconcat (intersperse (c8 '/') (map urlEncodePath segs)) + segs = dropSegs (BS.split slash (pathRewrite rrPath)) + pathRewrite + | unoRemoveDotSegments = removeDotSegments + | otherwise = id + dropSegs [] = [] + dropSegs (h:t) + | unoDropExtraSlashes = h:(filter (not . BS.null) t) + | otherwise = h:t + authority = maybe mempty (serializeAuthority o mScheme) rrAuthority + query = serializeQuery o rrQuery + fragment = maybe mempty (\s -> c8 '#' <> bs s) rrFragment + + +------------------------------------------------------------------------------- +--TODO: this is probably ripe for benchmarking +-- | Algorithm described in +-- , reproduced +-- artlessly. +removeDotSegments :: ByteString -> ByteString +removeDotSegments path = mconcat (rl2L (go path (RL []))) + where + go inBuf outBuf + -- A. If the input buffer begins with prefix of ../ or ./ then + -- remove the prefix from the input buffer + | BS8.isPrefixOf "../" inBuf = go (BS8.drop 3 inBuf) outBuf + | BS8.isPrefixOf "./" inBuf = go (BS8.drop 2 inBuf) outBuf + -- B. If the input buffer begins with a prefix of "/./" or "/.", + -- where "." is a complete path segment, then replace that + -- prefix with "/" in the input buffer. TODO: I think "a + -- complete path segment" means its the whole thing? + | BS.isPrefixOf "/./" inBuf = go (BS8.drop 2 inBuf) outBuf + | inBuf == "/." = go "/" outBuf + -- C. If the input buffer begins with a prefix of "/../" or + -- "/..", where ".." is a complete path segment, then replace + -- that prefix with "/" in the input buffer and remove the last + -- segment and its preceding "/" (if any) from the output buffer + | BS.isPrefixOf "/../" inBuf = go (BS8.drop 3 inBuf) (unsnoc (unsnoc outBuf)) + | inBuf == "/.." = go "/" (unsnoc (unsnoc outBuf)) + -- D. If the input buffer consists only of "." or "..", then + -- remove that from the input buffer + | inBuf == "." = go mempty outBuf + | inBuf == ".." = go mempty outBuf + -- E. Move the first path segment in the input buffer to the end + -- of the output buffer, including the initial "/" character (if + -- any) and any subsequent characters up to, but not including, + -- the next "/" character or the end of the input buffer. + | otherwise = case BS8.uncons inBuf of + Just ('/', rest) -> + let (thisSeg, inBuf') = BS8.span (/= '/') rest + in go inBuf' (outBuf |> "/" |> thisSeg) + Just (_, _) -> + let (thisSeg, inBuf') = BS8.span (/= '/') inBuf + in go inBuf' (outBuf |> thisSeg) + Nothing -> outBuf + + + +------------------------------------------------------------------------------- -- | Like 'serializeURI', with conversion into a strict 'ByteString'. serializeURI' :: URIRef Absolute -> ByteString serializeURI' = BB.toByteString . serializeURI {-# DEPRECATED serializeURI' "Use 'serializeURIRef'' instead" #-} + +------------------------------------------------------------------------------- -- | Like 'serializeURI', but do not render scheme. serializeRelativeRef :: URIRef Relative -> Builder -serializeRelativeRef RelativeRef {..} = authority <> path <> query <> fragment - where - path = mconcat $ intersperse (c8 '/') $ map urlEncodePath segs - segs = BS.split slash rrPath - authority = maybe mempty serializeAuthority rrAuthority - query = serializeQuery rrQuery - fragment = maybe mempty (\s -> c8 '#' <> bs s) rrFragment +serializeRelativeRef = normalizeRelativeRef noNormalization Nothing {-# DEPRECATED serializeRelativeRef "Use 'serializeURIRef' instead" #-} + +------------------------------------------------------------------------------- -- | Like 'serializeRelativeRef', with conversion into a strict 'ByteString'. serializeRelativeRef' :: URIRef Relative -> ByteString serializeRelativeRef' = BB.toByteString . serializeRelativeRef {-# DEPRECATED serializeRelativeRef' "Use 'serializeURIRef'' instead" #-} + ------------------------------------------------------------------------------- -serializeQuery :: Query -> Builder -serializeQuery (Query []) = mempty -serializeQuery (Query ps) = - c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps)) +serializeQuery :: URINormalizationOptions -> Query -> Builder +serializeQuery _ (Query []) = mempty +serializeQuery URINormalizationOptions {..} (Query ps) = + c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps')) where serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v + ps' + | unoSortParameters = sortBy (comparing fst) ps + | otherwise = ps ------------------------------------------------------------------------------- -serializeAuthority :: Authority -> Builder -serializeAuthority Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port +serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder +serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port where userinfo = maybe mempty serializeUserInfo authorityUserInfo - host = hostBS authorityHost - port = maybe mempty packPort authorityPort + host = hCase (hostBS authorityHost) + hCase + | unoDowncaseHost = downcaseBS + | otherwise = id + port = maybe mempty packPort effectivePort + effectivePort = do + p <- authorityPort + scheme <- mScheme + dropPort scheme p packPort (Port p) = c8 ':' <> BB.fromString (show p) + dropPort scheme + | unoDropDefPort = dropPort' scheme + | otherwise = Just + dropPort' s p + | M.lookup s unoDefaultPorts == Just p = Nothing + | otherwise = Just p ------------------------------------------------------------------------------- @@ -704,10 +864,10 @@ ------------------------------------------------------------------------------- -- | Stronger-typed variation of parseOnly'. Consumes all input. parseOnly' :: (Read e) - => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality. - -> Parser' e a - -> ByteString - -> Either e a + => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality. + -> Parser' e a + -> ByteString + -> Either e a parseOnly' noParse (Parser' p) = fmapL readWithFallback . parseOnly p where readWithFallback s = fromMaybe (noParse s) (readMaybe . stripAttoparsecGarbage $ s) @@ -793,3 +953,26 @@ -- | Encode a ByteString for use in the path section of a URL urlEncodePath :: ByteString -> Builder urlEncodePath = urlEncode unreservedPath8 + + +------------------------------------------------------------------------------- +downcaseBS :: ByteString -> ByteString +downcaseBS = BS8.map toLower + + +------------------------------------------------------------------------------- +-- | Simple data structure to get O(1) prepends on a list and defers the O(n) +newtype RL a = RL [a] deriving (Show) + + +(|>) :: RL a -> a -> RL a +RL as |> a = RL (a:as) + + +rl2L :: RL a -> [a] +rl2L (RL as) = reverse as + + +unsnoc :: RL a -> RL a +unsnoc (RL []) = RL [] +unsnoc (RL (_:xs)) = RL xs diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs --- a/src/URI/ByteString/Types.hs +++ b/src/URI/ByteString/Types.hs @@ -8,6 +8,7 @@ ------------------------------------------------------------------------------- import Data.ByteString (ByteString) +import qualified Data.Map.Strict as M import Data.Monoid import Data.Typeable import Data.Word @@ -101,6 +102,27 @@ data URIParserOptions = URIParserOptions { upoValidQueryChar :: Word8 -> Bool } + + +------------------------------------------------------------------------------- +data URINormalizationOptions = URINormalizationOptions { + unoDowncaseScheme :: Bool + -- ^ hTtP -> http + , unoDowncaseHost :: Bool + -- ^ eXaMpLe.org -> example.org + , unoDropDefPort :: Bool + -- ^ If the scheme is known and the port is the default (e.g. 80 for http) it is removed. + , unoSlashEmptyPath :: Bool + -- ^ If the path is empty, set it to \/ + , unoDropExtraSlashes :: Bool + -- ^ Rewrite path from \/foo\/\/bar\/\/\/baz to \/foo\/bar\/baz + , unoSortParameters :: Bool + -- ^ Sorts parameters by parameter name + , unoRemoveDotSegments :: Bool + -- ^ Remove dot segments as per + , unoDefaultPorts :: M.Map Scheme Port + -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled. + } deriving (Show, Eq) ------------------------------------------------------------------------------- diff --git a/test/URI/ByteString/Arbitrary.hs b/test/URI/ByteString/Arbitrary.hs --- a/test/URI/ByteString/Arbitrary.hs +++ b/test/URI/ByteString/Arbitrary.hs @@ -63,5 +63,15 @@ arbitrary = URIParserOptions <$> arbitrary +instance Arbitrary URINormalizationOptions where + arbitrary = URINormalizationOptions <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + $(derive makeArbitrary ''SchemaError) $(derive makeArbitrary ''URIParseError) diff --git a/test/URI/ByteStringTests.hs b/test/URI/ByteStringTests.hs --- a/test/URI/ByteStringTests.hs +++ b/test/URI/ByteStringTests.hs @@ -7,6 +7,8 @@ import qualified Blaze.ByteString.Builder as BB import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 +import Data.Either +import qualified Data.Map.Strict as M import Data.Monoid import Lens.Simple import Test.Tasty @@ -26,6 +28,7 @@ , uriParseErrorInstancesTests , lensTests , serializeURITests + , normalizeURITests ] @@ -332,3 +335,75 @@ let res = BB.toLazyByteString (serializeURIRef uri) res @?= "http://www.example.org/weird%20path" ] + + +------------------------------------------------------------------------------- +normalizeURITests :: TestTree +normalizeURITests = testGroup "normalization" + [ + testCase "downcase schema" $ do + normalizeURIBS o { unoDowncaseScheme = True } "hTtP://example.org" @?= + "http://example.org" + + , testCase "downcase host" $ do + normalizeURIBS o { unoDowncaseHost = True } "http://ExAmPlE.org" @?= + "http://example.org" + + , testCase "drop default port http" $ do + normalizeURIBS o { unoDropDefPort = True } "http://example.org:80" @?= + "http://example.org" + , testCase "drop default port https" $ do + normalizeURIBS o { unoDropDefPort = True } "https://example.org:443" @?= + "https://example.org" + , testCase "drop default port no port" $ do + normalizeURIBS o { unoDropDefPort = True } "http://example.org" @?= + "http://example.org" + , testCase "drop default port nondefault" $ do + normalizeURIBS o { unoDropDefPort = True } "http://example.org:8000" @?= + "http://example.org:8000" + , testCase "drop default unknown schema" $ do + normalizeURIBS o { unoDropDefPort = True } "bogus://example.org:9999" @?= + "bogus://example.org:9999" + , testCase "user-extensable port defaulting hit" $ do + normalizeURIBS o { unoDropDefPort = True + , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } + "ftp://example.org:21" @?= + "ftp://example.org" + , testCase "user-extensable port defaulting off" $ do + normalizeURIBS o { unoDropDefPort = False + , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } + "ftp://example.org:21" @?= + "ftp://example.org:21" + , testCase "user-extensable port defaulting miss" $ do + normalizeURIBS o { unoDropDefPort = True + , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } + "http://example.org:80" @?= + "http://example.org:80" + + , testCase "slash empty path" $ do + normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org" @?= + "http://example.org/" + , testCase "slash empty path with nonempty path" $ do + normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org/foo/bar" @?= + "http://example.org/foo/bar" + + , testCase "drop redundant slashes" $ do + normalizeURIBS o { unoDropExtraSlashes = True } "http://example.org/foo//bar///baz" @?= + "http://example.org/foo/bar/baz" + + , testCase "sort params" $ do + normalizeURIBS o { unoSortParameters = True } "http://example.org/foo?zulu=1&charlie=&alpha=1" @?= + "http://example.org/foo?alpha=1&charlie=&zulu=1" + + , testCase "remove dot segments" $ do + normalizeURIBS o { unoRemoveDotSegments = True } "http://example.org/a/b/c/./../../g" @?= + "http://example.org/a/g" + + , testCase "percent encoding is upcased automatically" $ do + normalizeURIBS o "http://example.org/a?foo%3abar=baz" @?= + "http://example.org/a?foo%3Abar=baz" + ] + where + o = noNormalization + normalizeURIBS opts bs = let Right x = parseURI laxURIParserOptions bs + in normalizeURIRef' opts x diff --git a/uri-bytestring.cabal b/uri-bytestring.cabal --- a/uri-bytestring.cabal +++ b/uri-bytestring.cabal @@ -1,5 +1,5 @@ name: uri-bytestring -version: 0.2.1.0 +version: 0.2.1.1 synopsis: Haskell URI parsing as ByteStrings description: uri-bytestring aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the URI data. license: BSD3 @@ -40,6 +40,7 @@ , base >= 4.6 && < 4.10 , bytestring >= 0.9.1 && < 0.11 , blaze-builder >= 0.3.0.0 && < 0.5 + , containers hs-source-dirs: src default-language: Haskell2010 @@ -74,6 +75,7 @@ , lens-simple , quickcheck-instances , semigroups + , containers default-language: Haskell2010 if flag(lib-Werror)