uri-bytestring 0.2.1.0 → 0.2.1.1

raw patch · 7 files changed

+331/−27 lines, 7 filesdep +containersPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: containers

API changes (from Hackage documentation)

Files

• changelog.md +3/−0
• src/URI/ByteString.hs +9/−0
• src/URI/ByteString/Internal.hs +209/−26
• src/URI/ByteString/Types.hs +22/−0
• test/URI/ByteString/Arbitrary.hs +10/−0
• test/URI/ByteStringTests.hs +75/−0
• uri-bytestring.cabal +3/−1

@@ -1,3 +1,6 @@+0.2.1.1+* Add URI normalization features.+ 0.2.1.0 * Widen dependency on base. 

@@ -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

@@ -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+-- <https://tools.ietf.org/html/rfc3986#section-5.2.4>, 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

@@ -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 <https://tools.ietf.org/html/rfc3986#section-5.2.4 RFC3986 Section 5.2.4>+    , unoDefaultPorts      :: M.Map Scheme Port+    -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled.+    } deriving (Show, Eq)   -------------------------------------------------------------------------------

@@ -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)

@@ -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

@@ -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)