diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,14 @@ +# Contribution Guidelines + +1. Configure your project with `--enable-tests -flib-Werror`. This + will make sure tests get built and will treat all warnings as + errors. We are shooting for 0 warnings in this project. +2. If you are considering some major functionality, please run it by + us in an issue first so you don't have to do a bunch of work that + will get rejected. This project is shooting for very minimal + dependencies and compliance with the RFC3986 spec, so we can't + include every feature under the sun. +3. Please try to write a test if applicable. +4. Please try to write a benchmark if applicable. +5. If we forget to add you to the Contributors section of the README, + please let us know! diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,12 @@ # uri-bytestring -[![Build Status](https://travis-ci.org/Soostone/uri-bytestring.svg)](https://travis-ci.org/Soostone/uri-bytestring) +[![Build Status](https://travis-ci.org/Soostone/uri-bytestring.svg?branch=master)](https://travis-ci.org/Soostone/uri-bytestring) +[![Hackage](https://img.shields.io/hackage/v/uri-bytestring.svg?style=flat)](https://hackage.haskell.org/package/uri-bytestring) Haskell URI parsing as ByteStrings + + +## Contributors +* [Michael Xavier](http://github.com/MichaelXavier) +* [Doug Beardsley](http://github.com/mightybyte) +* [Ozgun Ataman](http://github.com/ozataman) +* [fisx](http://github.com/fisx) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -16,6 +16,7 @@ instance NFData Authority instance NFData UserInfo instance NFData URI +instance NFData RelativeRef instance NFData NU.URI instance NFData SchemaError instance NFData URIParseError @@ -30,10 +31,13 @@ bench "Network.URI.parseURI" $ nf NU.parseURI exampleURIS , bench "URI.ByteString.parseURI strict" $ nf (parseURI strictURIParserOptions) exampleURIS , bench "URI.ByteString.parseURI lax" $ nf (parseURI laxURIParserOptions) exampleURIS + , bench "URI.ByteString.parseRelativeRef strict" $ nf (parseRelativeRef strictURIParserOptions) exampleRelativeRefS + , bench "URI.ByteString.parseRelativeRef lax" $ nf (parseRelativeRef laxURIParserOptions) exampleRelativeRefS ] , bgroup "serializing" [ bench "URI.ByteString.serializeURI" $ nf (toLazyByteString . serializeURI) exampleURI + , bench "URI.ByteString.serializeRelativeRef" $ nf (toLazyByteString . serializeRelativeRef) exampleRelativeRef ] ] @@ -42,6 +46,10 @@ exampleURIS = "http://google.com/example?params=youbetcha" +exampleRelativeRefS :: IsString s => s +exampleRelativeRefS = "/example?params=youbetcha#17u" + + exampleURI :: URI exampleURI = URI { uriScheme = Scheme "http" @@ -53,4 +61,17 @@ , uriPath = "/example" , uriQuery = Query [("params", "youbetcha")] , uriFragment = Nothing + } + + +exampleRelativeRef :: RelativeRef +exampleRelativeRef = RelativeRef { + rrAuthority = Just Authority { + authorityUserInfo = Nothing + , authorityHost = Host "google.com" + , authorityPort = Nothing + } + , rrPath = "/example" + , rrQuery = Query [("params", "youbetcha")] + , rrFragment = Nothing } diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.1 +* Add generic lenses (breaking field name changes). +* Add support for relative refs. +* Make Query instance of Generic, Typeable. + 0.0.1 * Initial release. diff --git a/src/URI/ByteString.hs b/src/URI/ByteString.hs --- a/src/URI/ByteString.hs +++ b/src/URI/ByteString.hs @@ -1,15 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-| Module : URI.ByteString Description : ByteString URI Parser and Serializer -Copyright : (c) Soostone Inc., 2014 - Michael Xavier, 2014 +Copyright : (c) Soostone Inc., 2014-2015 + Michael Xavier, 2014-2015 License : BSD3 Maintainer : michael.xavier@soostone.com Stability : experimental @@ -23,6 +17,11 @@ encountered, however. Please report any issues encountered to the issue tracker. +This module also provides analogs to Lens over the various types in +this library. These are written in a generic way to avoid a dependency +on any particular lens library. You should be able to use these with a +number of packages including lens and lens-family-core. + -} module URI.ByteString (-- * URI-related types @@ -33,6 +32,7 @@ , UserInfo(..) , Query(..) , URI(..) + , RelativeRef(..) , SchemaError(..) , URIParseError(..) , URIParserOptions(..) @@ -40,795 +40,43 @@ , laxURIParserOptions -- * Parsing , parseURI + , parseRelativeRef -- * Serializing , serializeURI + , serializeRelativeRef + -- * Lenses + -- ** Lenses over 'Scheme' + , schemeBSL + -- ** Lenses over 'Host' + , hostBSL + -- ** Lenses over 'Port' + , portNumberL + -- ** Lenses over 'Authority' + , authorityUserInfoL + , authorityHostL + , authorityPortL + -- ** Lenses over 'UserInfo' + , uiUsernameL + , uiPasswordL + -- ** Lenses over 'Query' + , queryPairsL + -- ** Lenses over 'URI' + , uriSchemeL + , uriAuthorityL + , uriPathL + , uriQueryL + , uriFragmentL + -- ** Lenses over 'RelativeRef' + , rrAuthorityL + , rrPathL + , rrQueryL + , rrFragmentL + -- ** Lenses over 'URIParserOptions' + , upoValidQueryCharL ) where ------------------------------------------------------------------------------- -import Control.Applicative -import Control.Monad -import Data.Attoparsec.ByteString -import qualified Data.Attoparsec.ByteString as A -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB -import Data.Char (ord) -import Data.Ix -import Data.List (delete, intersperse, stripPrefix) -import Data.Maybe -import Data.Monoid -import Data.Typeable -import Data.Word -import GHC.Generics (Generic) -import Text.Read (readMaybe) -------------------------------------------------------------------------------- - - --- | Required first component to referring to a specification for the --- remainder of the URI's components, e.g. "http" or "https" -newtype Scheme = Scheme { getScheme :: ByteString } - deriving (Show, Eq, Generic, Typeable) - - -------------------------------------------------------------------------------- -newtype Host = Host { getHost :: ByteString } - deriving (Show, Eq, Generic, Typeable) - - -------------------------------------------------------------------------------- --- | While some libraries have chosen to limit this to a Word16, the --- spec only specifies that the string be comprised of digits. -newtype Port = Port { getPort :: Int } - deriving (Show, Eq, Generic, Typeable) - - -------------------------------------------------------------------------------- -data Authority = Authority { - authorityUserInfo :: Maybe UserInfo - , authorityHost :: Host - , authorityPort :: Maybe Port - } deriving (Show, Eq, Generic, Typeable) - - -------------------------------------------------------------------------------- -data UserInfo = UserInfo { - uiUsername :: ByteString - , uiPassword :: ByteString - } deriving (Show, Eq, Generic, Typeable) - - -------------------------------------------------------------------------------- -newtype Query = Query { getQuery :: [(ByteString, ByteString)] } - deriving (Show, Eq, Monoid) - - -------------------------------------------------------------------------------- -data URI = URI { - uriScheme :: Scheme - , uriAuthority :: Maybe Authority - , uriPath :: ByteString - , uriQuery :: Query - , uriFragment :: Maybe ByteString - -- ^ URI fragment. Does not include the # - } deriving (Show, Eq, Generic, Typeable) - - - -------------------------------------------------------------------------------- --- | Options for the parser. You will probably want to use either --- "strictURIParserOptions" or "laxURIParserOptions" -data URIParserOptions = URIParserOptions { - upoValidQueryChar :: Word8 -> Bool - } - - -------------------------------------------------------------------------------- --- | Strict URI Parser config. Follows RFC3986 as-specified. Use this --- if you can be certain that your URIs are properly encoded or if you --- want parsing to fail if they deviate from the spec at all. -strictURIParserOptions :: URIParserOptions -strictURIParserOptions = URIParserOptions { - upoValidQueryChar = validForQuery - } - - -------------------------------------------------------------------------------- --- | Lax URI Parser config. Use this if you you want to handle common --- deviations from the spec gracefully. --- --- * Allows non-encoded [ and ] in query string -laxURIParserOptions :: URIParserOptions -laxURIParserOptions = URIParserOptions { - upoValidQueryChar = validForQueryLax - } - -------------------------------------------------------------------------------- --- | URI Serializer -------------------------------------------------------------------------------- - --- | Serialize a URI into a strict ByteString --- Example: --- --- >>> BB.toLazyByteString $ serializeURI $ URI {uriScheme = Scheme {getScheme = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {getHost = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {getQuery = [("bar","baz")]}, uriFragment = Just "quux"} --- "http://www.example.org/foo?bar=baz#quux" -serializeURI :: URI -> Builder -serializeURI URI {..} = scheme <> BB.string8 "://" <> - authority <> - path <> - query <> - fragment - where - path = mconcat $ intersperse (c8 '/') $ map urlEncodePath segs - segs = BS.split slash uriPath - scheme = bs $ getScheme uriScheme - authority = maybe mempty serializeAuthority uriAuthority - query = serializeQuery uriQuery - fragment = maybe mempty (\s -> c8 '#' <> bs s) uriFragment - - -------------------------------------------------------------------------------- -serializeQuery :: Query -> Builder -serializeQuery (Query []) = mempty -serializeQuery (Query ps) = - c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps)) - where - serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v - - -------------------------------------------------------------------------------- -serializeAuthority :: Authority -> Builder -serializeAuthority Authority {..} = userinfo <> bs host <> port - where - userinfo = maybe mempty serializeUserInfo authorityUserInfo - host = getHost authorityHost - port = maybe mempty packPort authorityPort - packPort (Port p) = c8 ':' <> BB.string8 (show p) - - -------------------------------------------------------------------------------- -serializeUserInfo :: UserInfo -> Builder -serializeUserInfo UserInfo {..} = bs uiUsername <> c8 ':' <> bs uiPassword - - -------------------------------------------------------------------------------- -bs :: ByteString -> Builder -bs = BB.byteString - - -------------------------------------------------------------------------------- -c8 :: Char -> Builder -c8 = BB.char8 - - -------------------------------------------------------------------------------- --- | URI Parser -------------------------------------------------------------------------------- - - -data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character - | InvalidChars -- ^ Subsequent characters in the schema were invalid - | MissingColon -- ^ Schemas must be followed by a colon - deriving (Show, Eq, Read, Generic, Typeable) - - -------------------------------------------------------------------------------- -data URIParseError = MalformedScheme SchemaError - | MalformedUserInfo - | MalformedQuery - | MalformedFragment - | MalformedHost - | MalformedPort - | MalformedPath - | OtherError String -- ^ Catchall for unpredictable errors - deriving (Show, Eq, Generic, Read, Typeable) - - -------------------------------------------------------------------------------- --- | Parse a strict ByteString into a URI or an error. --- --- Example: --- --- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar=baz#quux" --- Right (URI {uriScheme = Scheme {getScheme = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {getHost = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {getQuery = [("bar","baz")]}, uriFragment = Just "quux"}) --- --- >>> parseURI strictURIParserOptions "$$$$://badurl.example.org" --- Left (MalformedScheme NonAlphaLeading) --- --- There are some urls that you'll encounter which defy the spec, such --- as those with square brackets in the query string. If you must be --- able to parse those, you can use "laxURIParserOptions" or specify your own --- --- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar[]=baz" --- Left MalformedQuery --- --- >>> parseURI laxURIParserOptions "http://www.example.org/foo?bar[]=baz" --- Right (URI {uriScheme = Scheme {getScheme = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {getHost = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {getQuery = [("bar[]","baz")]}, uriFragment = Nothing}) --- --- >>> let myLaxOptions = URIParserOptions { upoValidQueryChar = liftA2 (||) (upoValidQueryChar strictURIParserOptions) (inClass "[]")} --- >>> parseURI myLaxOptions "http://www.example.org/foo?bar[]=baz" --- Right (URI {uriScheme = Scheme {getScheme = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {getHost = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {getQuery = [("bar[]","baz")]}, uriFragment = Nothing}) -parseURI :: URIParserOptions -> ByteString -> Either URIParseError URI -parseURI opts = parseOnly' OtherError (uriParser opts) - - -------------------------------------------------------------------------------- --- | Convenience alias for a parser that can return URIParseError -type URIParser = Parser' URIParseError - - -------------------------------------------------------------------------------- --- | Toplevel parser for URIs -uriParser :: URIParserOptions -> URIParser URI -uriParser opts = do - scheme <- schemeParser - void $ word8 colon `orFailWith` MalformedScheme MissingColon - - (authority, path) <- hierPartParser - query <- queryParser opts - frag <- mFragmentParser - case frag of - Just _ -> endOfInput `orFailWith` MalformedFragment - Nothing -> endOfInput `orFailWith` MalformedQuery - return $ URI scheme authority path query frag - - -------------------------------------------------------------------------------- --- | Parser for scheme, e.g. "http", "https", etc. -schemeParser :: URIParser Scheme -schemeParser = do - c <- satisfy isAlpha `orFailWith` MalformedScheme NonAlphaLeading - rest <- A.takeWhile isSchemeValid `orFailWith` MalformedScheme InvalidChars - return $ Scheme $ c `BS.cons` rest - where - isSchemeValid = inClass $ "-+." ++ alphaNum - - -------------------------------------------------------------------------------- --- | Hier part immediately follows the schema and encompasses the --- authority and path sections. -hierPartParser :: URIParser (Maybe Authority, ByteString) -hierPartParser = authWithPathParser <|> - pathAbsoluteParser <|> - pathRootlessParser <|> - pathEmptyParser - - -------------------------------------------------------------------------------- --- | See the "authority path-abempty" grammar in the RFC -authWithPathParser :: URIParser (Maybe Authority, ByteString) -authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> pathParser) - - -------------------------------------------------------------------------------- --- | See the "path-absolute" grammar in the RFC. Essentially a special --- case of rootless. -pathAbsoluteParser :: URIParser (Maybe Authority, ByteString) -pathAbsoluteParser = string' "/" *> pathRootlessParser - - -------------------------------------------------------------------------------- --- | See the "path-rootless" grammar in the RFC. -pathRootlessParser :: URIParser (Maybe Authority, ByteString) -pathRootlessParser = (,) <$> pure Nothing <*> pathParser1 - - -------------------------------------------------------------------------------- --- | See the "path-empty" grammar in the RFC. Must not be followed --- with a path-valid char. -pathEmptyParser :: URIParser (Maybe Authority, ByteString) -pathEmptyParser = do - nextChar <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" - case nextChar of - Just c -> guard (notInClass pchar c) >> return emptyCase - _ -> return emptyCase - where - emptyCase = (Nothing, mempty) - - -------------------------------------------------------------------------------- --- | Parser whe -mAuthorityParser :: URIParser (Maybe Authority) -mAuthorityParser = mParse authorityParser - - -------------------------------------------------------------------------------- --- | Parses the user info section of a URl (i.e. for HTTP Basic --- Authentication). Note that this will decode any percent-encoded --- data. -userInfoParser :: URIParser UserInfo -userInfoParser = (uiTokenParser <* word8 atSym) `orFailWith` MalformedUserInfo - where - atSym = 64 - uiTokenParser = do - ui <- A.takeWhile1 validForUserInfo - let (user, passWithColon) = BS.break (== colon) $ urlDecode' ui - let pass = BS.drop 1 passWithColon - return $ UserInfo user pass - validForUserInfo = inClass $ pctEncoded ++ subDelims ++ (':' : unreserved) - - -------------------------------------------------------------------------------- --- | Authority consists of host and port -authorityParser :: URIParser Authority -authorityParser = Authority <$> mParse userInfoParser <*> hostParser <*> mPortParser - - -------------------------------------------------------------------------------- --- | Parser that can handle IPV6/Future literals, IPV4, and domain names. -hostParser :: URIParser Host -hostParser = (Host <$> parsers) `orFailWith` MalformedHost - where - parsers = ipLiteralParser <|> ipV4Parser <|> regNameParser - ipLiteralParser = word8 oBracket *> (ipVFutureParser <|> ipV6Parser) <* word8 cBracket - - -------------------------------------------------------------------------------- --- | Parses IPV6 addresses. See relevant section in RFC. -ipV6Parser :: Parser ByteString -ipV6Parser = do - leading <- h16s - elided <- maybe [] (const [""]) <$> optional (string "::") - trailing <- many (A.takeWhile (/= colon) <* word8 colon) - (finalChunkLen, final) <- finalChunk - let len = length (leading ++ trailing) + finalChunkLen - when (len > 8) $ fail "Too many digits in IPv6 address" - return $ rejoin $ [rejoin leading] ++ elided ++ trailing ++ maybeToList final - where - finalChunk = fromMaybe (0, Nothing) <$> optional (finalIpV4 <|> finalH16) - finalH16 = (1, ) . Just <$> h16 - finalIpV4 = (2, ) . Just <$> ipV4Parser - rejoin = BS.intercalate ":" - h16s = h16 `sepBy` word8 colon - h16 = mconcat <$> parseBetween 1 4 (A.takeWhile1 hexDigit) - - -------------------------------------------------------------------------------- --- | Parses IPVFuture addresses. See relevant section in RFC. -ipVFutureParser :: Parser ByteString -ipVFutureParser = do - _ <- word8 lowercaseV - ds <- A.takeWhile1 hexDigit - _ <- word8 period - rest <- A.takeWhile1 $ inClass $ subDelims ++ ":" ++ unreserved - return $ "v" <> ds <> "." <> rest - where - lowercaseV = 118 - - -------------------------------------------------------------------------------- --- | Parses a valid IPV4 address -ipV4Parser :: Parser ByteString -ipV4Parser = mconcat <$> sequence [ decOctet - , dot - , decOctet - , dot - , decOctet - , dot - , decOctet] - where - decOctet = do - s <- A.takeWhile1 isDigit - let len = BS.length s - guard $ len > 0 && len <= 3 - let num = bsToNum s - guard $ num >= 1 && num <= 255 - return s - dot = string "." - - -------------------------------------------------------------------------------- --- | This corresponds to the hostname, e.g. www.example.org -regNameParser :: Parser ByteString -regNameParser = urlDecode' <$> A.takeWhile1 (inClass validForRegName) - where - validForRegName = pctEncoded ++ subDelims ++ unreserved - - -------------------------------------------------------------------------------- --- | Only parse a port if the colon signifier is there. -mPortParser :: URIParser (Maybe Port) -mPortParser = word8' colon `thenJust` portParser - - -------------------------------------------------------------------------------- --- | Parses port number from the hostname. Colon separator must be --- handled elsewhere. -portParser :: URIParser Port -portParser = (Port . bsToNum <$> A.takeWhile1 isDigit) `orFailWith` MalformedPort - - -------------------------------------------------------------------------------- --- | Path with any number of segments -pathParser :: URIParser ByteString -pathParser = pathParser' A.many' - - -------------------------------------------------------------------------------- --- | Path with at least 1 segment -pathParser1 :: URIParser ByteString -pathParser1 = pathParser' A.many1' - - -------------------------------------------------------------------------------- --- | Parses the path section of a url. Note that while this can take --- percent-encoded characters, it does not itself decode them while parsing. -pathParser' :: (Parser ByteString -> Parser [ByteString]) -> URIParser ByteString -pathParser' repeatParser = (mconcat <$> repeatParser segmentParser) `orFailWith` MalformedPath - where - segmentParser = mconcat <$> sequence [string "/", A.takeWhile (inClass pchar)] - - -------------------------------------------------------------------------------- --- | This parser is being a bit pragmatic. The query section in the --- spec does not identify the key/value format used in URIs, but that --- is what most users are expecting to see. One alternative could be --- to just expose the query string as a string and offer functions on --- URI to parse a query string to a Query. -queryParser :: URIParserOptions -> URIParser Query -queryParser opts = do - mc <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" - case mc of - Just c - | c == question -> skip' 1 *> itemsParser - | c == hash -> pure mempty - | otherwise -> fail' MalformedPath - _ -> pure mempty - where - itemsParser = Query <$> A.sepBy' (queryItemParser opts) (word8' ampersand) - - -------------------------------------------------------------------------------- --- | When parsing a single query item string like "foo=bar", turns it --- into a key/value pair as per convention, with the value being --- optional. & separators need to be handled further up. -queryItemParser :: URIParserOptions -> URIParser (ByteString, ByteString) -queryItemParser opts = do - s <- A.takeWhile1 (upoValidQueryChar opts) `orFailWith` MalformedQuery - let (k, vWithEquals) = BS.break (== equals) s - let v = BS.drop 1 vWithEquals - return (urlDecodeQuery k, urlDecodeQuery v) - - -------------------------------------------------------------------------------- -validForQuery :: Word8 -> Bool -validForQuery = inClass ('?':'/':delete '&' pchar) - - -------------------------------------------------------------------------------- -validForQueryLax :: Word8 -> Bool -validForQueryLax = notInClass "&#" - - -------------------------------------------------------------------------------- --- | Only parses a fragment if the # signifiier is there -mFragmentParser :: URIParser (Maybe ByteString) -mFragmentParser = word8' hash `thenJust` fragmentParser - - -------------------------------------------------------------------------------- --- | The final piece of a uri, e.g. #fragment, minus the #. -fragmentParser :: URIParser ByteString -fragmentParser = A.takeWhile1 validFragmentWord `orFailWith` MalformedFragment - where - validFragmentWord = inClass ('?':'/':pchar) - - -------------------------------------------------------------------------------- --- | Grammar Components -------------------------------------------------------------------------------- - - -------------------------------------------------------------------------------- -hexDigit :: Word8 -> Bool -hexDigit = inClass "0-9a-fA-F" - - -------------------------------------------------------------------------------- -isAlpha :: Word8 -> Bool -isAlpha = inClass alpha - - -------------------------------------------------------------------------------- -isDigit :: Word8 -> Bool -isDigit = inClass digit - - -------------------------------------------------------------------------------- -pchar :: String -pchar = pctEncoded ++ subDelims ++ ":@" ++ unreserved - - -------------------------------------------------------------------------------- --- Very important! When concatenating this to other strings to make larger --- character classes, you must put this at the end because the '-' character --- is treated as a range unless it's at the beginning or end. -unreserved :: String -unreserved = alphaNum ++ "~._-" - - -------------------------------------------------------------------------------- -unreserved8 :: [Word8] -unreserved8 = map ord8 unreserved - - -------------------------------------------------------------------------------- -unreservedPath8 :: [Word8] -unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$," - -------------------------------------------------------------------------------- -ord8 :: Char -> Word8 -ord8 = fromIntegral . ord - - -------------------------------------------------------------------------------- --- | pc-encoded technically is % HEXDIG HEXDIG but that's handled by --- the previous alphaNum constraint. May need to double back with a --- parser to ensure pct-encoded never exceeds 2 hexdigs after -pctEncoded :: String -pctEncoded = "%" - - -------------------------------------------------------------------------------- -subDelims :: String -subDelims = "!$&'()*+,;=" - - -------------------------------------------------------------------------------- -alphaNum :: String -alphaNum = alpha ++ digit - - -------------------------------------------------------------------------------- -alpha :: String -alpha = "a-zA-Z" - - -------------------------------------------------------------------------------- -digit :: String -digit = "0-9" - - -------------------------------------------------------------------------------- -colon :: Word8 -colon = 58 - - -------------------------------------------------------------------------------- -oBracket :: Word8 -oBracket = 91 - - -------------------------------------------------------------------------------- -cBracket :: Word8 -cBracket = 93 - - -------------------------------------------------------------------------------- -equals :: Word8 -equals = 61 - - -------------------------------------------------------------------------------- -question :: Word8 -question = 63 - - -------------------------------------------------------------------------------- -ampersand :: Word8 -ampersand = 38 - - -------------------------------------------------------------------------------- -hash :: Word8 -hash = 35 - - -------------------------------------------------------------------------------- -period :: Word8 -period = 46 - - -------------------------------------------------------------------------------- -slash :: Word8 -slash = 47 - - -------------------------------------------------------------------------------- --- | ByteString Utilities -------------------------------------------------------------------------------- - --- FIXME: theres probably a much better way to do this - -------------------------------------------------------------------------------- --- | Convert a bytestring into an int representation. Assumes the --- entire string is comprised of 0-9 digits. -bsToNum :: ByteString -> Int -bsToNum s = sum $ zipWith (*) (reverse ints) [10 ^ x | x <- [0..] :: [Int]] - where - w2i w = fromEnum $ w - 48 - ints = map w2i . BS.unpack $ s - - -------------------------------------------------------------------------------- --- | Decoding specifically for the query string, which decodes + as --- space. -urlDecodeQuery :: ByteString -> ByteString -urlDecodeQuery = urlDecode plusToSpace - where - plusToSpace = True - - -------------------------------------------------------------------------------- --- | Decode any part of the URL besides the query, which decodes + as --- space. -urlDecode' :: ByteString -> ByteString -urlDecode' = urlDecode plusToSpace - where - plusToSpace = False - - -------------------------------------------------------------------------------- --- | Parsing with Strongly-Typed Errors -------------------------------------------------------------------------------- - - --- | A parser with a specific error type. Attoparsec unfortunately --- throws all errors into strings, which cannot be handled well --- programmatically without doing something silly like parsing error --- messages. This wrapper attempts to concentrate these errors into --- one type. -newtype Parser' e a = Parser' (Parser a) - deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , Monoid) - - -------------------------------------------------------------------------------- --- | Use with caution. Catch a parser failing and return Nothing. -mParse :: Parser' e a -> Parser' e (Maybe a) -mParse p = option Nothing (Just <$> p) - - -------------------------------------------------------------------------------- --- | If the first parser succeeds, discard the result and use the --- second parser (which may fail). If the first parser fails, return --- Nothing. This is used to check a benign precondition that indicates --- the presence of a parsible token, i.e. ? preceeding a query. -thenJust :: Parser' e a -> Parser' e b -> Parser' e (Maybe b) -thenJust p1 p2 = p1 *> (Just <$> p2) <|> pure Nothing - - -------------------------------------------------------------------------------- --- | Lift a word8 Parser into a strongly error typed parser. This will --- generate a "stringy" error message if it fails, so you should --- probably be prepared to exit with a nicer error further up. -word8' :: Word8 -> Parser' e Word8 -word8' = Parser' . word8 - - -------------------------------------------------------------------------------- --- | Skip exactly 1 character. Fails if the character isn't --- there. Generates a "stringy" error. -skip' :: Int -> Parser' e () -skip' = Parser' . void . A.take - - -------------------------------------------------------------------------------- --- | Lifted version of the string token parser. Same caveats about --- "stringy" errors apply. -string' :: ByteString -> Parser' e ByteString -string' = Parser' . string - - -------------------------------------------------------------------------------- --- | Combinator for tunnelling more specific error types through the --- attoparsec machinery using read/show. -orFailWith :: (Show e, Read e) => Parser a -> e -> Parser' e a -orFailWith p e = Parser' p <|> fail' e - - -------------------------------------------------------------------------------- --- | Should be preferred to fail' -fail' :: (Show e, Read e) => e -> Parser' e a -fail' = fail . show - - -------------------------------------------------------------------------------- -parseBetween :: (Alternative m, Monad m) => Int -> Int -> m a -> m [a] -parseBetween a b f = choice parsers - where - parsers = map (`count` f) $ reverse $ range (a, b) - - -------------------------------------------------------------------------------- --- | Stronger-typed variation of parseOnly'. Consumes all input. -parseOnly' :: (Read e, Show e) - => (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) - -------------------------------------------------------------------------------- --- | Our pal Control.Monad.fail is how attoparsec propagates --- errors. If you throw an error string with fail (your only choice), --- it will *always* prepend it with "Failed reading: ". At least in --- this version. That may change to something else and break this workaround. -stripAttoparsecGarbage :: String -> String -stripAttoparsecGarbage = stripPrefix' "Failed reading: " - - -------------------------------------------------------------------------------- --- | stripPrefix where it is a noop if the prefix doesn't exist. -stripPrefix' :: Eq a => [a] -> [a] -> [a] -stripPrefix' pfx s = fromMaybe s $ stripPrefix pfx s - - -------------------------------------------------------------------------------- -fmapL :: (a -> b) -> Either a r -> Either b r -fmapL f = either (Left . f) Right - - -------------------------------------------------------------------------------- --- | This function was extract from the @http-types@ package. The --- license can be found in licenses/http-types/LICENSE -urlDecode - :: Bool -- ^ Whether to decode '+' to ' ' - -> BS.ByteString - -> BS.ByteString -urlDecode replacePlus z = fst $ BS.unfoldrN (BS.length z) go z - where - go bs' = - case BS.uncons bs' of - Nothing -> Nothing - Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space - Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent - (x, xs) <- BS.uncons ws - x' <- hexVal x - (y, ys) <- BS.uncons xs - y' <- hexVal y - Just (combine x' y', ys) - Just (w, ws) -> Just (w, ws) - hexVal w - | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 - | 65 <= w && w <= 70 = Just $ w - 55 -- A - F - | 97 <= w && w <= 102 = Just $ w - 87 -- a - f - | otherwise = Nothing - combine :: Word8 -> Word8 -> Word8 - combine a b = shiftL a 4 .|. b - - -------------------------------------------------------------------------------- ---TODO: keep an eye on perf here. seems like a good use case for a DList. the word8 list could be a set/hashset --- | Percent-encoding for URLs. -urlEncode' :: [Word8] -> ByteString -> Builder -urlEncode' extraUnreserved = mconcat . map encodeChar . BS.unpack - where - encodeChar ch | unreserved' ch = BB.word8 ch - | otherwise = h2 ch - - unreserved' ch | ch >= 65 && ch <= 90 = True -- A-Z - | ch >= 97 && ch <= 122 = True -- a-z - | ch >= 48 && ch <= 57 = True -- 0-9 - unreserved' c = c `elem` extraUnreserved - - h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b] -- percent (%) - h i | i < 10 = 48 + i -- zero (0) - | otherwise = 65 + i - 10 -- 65: A - - -------------------------------------------------------------------------------- -urlEncodeQuery :: ByteString -> Builder -urlEncodeQuery = urlEncode' unreserved8 - - +import URI.ByteString.Internal +import URI.ByteString.Lens +import URI.ByteString.Types ------------------------------------------------------------------------------- -urlEncodePath :: ByteString -> Builder -urlEncodePath = urlEncode' unreservedPath8 diff --git a/src/URI/ByteString/Internal.hs b/src/URI/ByteString/Internal.hs new file mode 100644 --- /dev/null +++ b/src/URI/ByteString/Internal.hs @@ -0,0 +1,743 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module URI.ByteString.Internal where + +------------------------------------------------------------------------------- +import Control.Applicative +import Control.Monad +import Data.Attoparsec.ByteString +import qualified Data.Attoparsec.ByteString as A +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB +import Data.Char (ord) +import Data.Ix +import Data.List (delete, intersperse, stripPrefix, (\\)) +import Data.Maybe +import Data.Monoid +import Data.Word +import Text.Read (readMaybe) +------------------------------------------------------------------------------- +import URI.ByteString.Types +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | Strict URI Parser config. Follows RFC3986 as-specified. Use this +-- if you can be certain that your URIs are properly encoded or if you +-- want parsing to fail if they deviate from the spec at all. +strictURIParserOptions :: URIParserOptions +strictURIParserOptions = URIParserOptions { + upoValidQueryChar = validForQuery + } + + +------------------------------------------------------------------------------- +-- | Lax URI Parser config. Use this if you you want to handle common +-- deviations from the spec gracefully. +-- +-- * Allows non-encoded [ and ] in query string +laxURIParserOptions :: URIParserOptions +laxURIParserOptions = URIParserOptions { + upoValidQueryChar = validForQueryLax + } + +------------------------------------------------------------------------------- +-- | URI Serializer +------------------------------------------------------------------------------- + +-- | Serialize a URI into a strict ByteString +-- Example: +-- +-- >>> BB.toLazyByteString $ serializeURI $ 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" +serializeURI :: URI -> Builder +serializeURI URI {..} = scheme <> BB.string8 "://" <> + serializeRelativeRef rr + where + scheme = bs $ schemeBS uriScheme + rr = RelativeRef uriAuthority uriPath uriQuery uriFragment + +-- | Like 'serializeURI', but do not render scheme. +serializeRelativeRef :: RelativeRef -> 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 + + +------------------------------------------------------------------------------- +serializeQuery :: Query -> Builder +serializeQuery (Query []) = mempty +serializeQuery (Query ps) = + c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps)) + where + serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v + + +------------------------------------------------------------------------------- +serializeAuthority :: Authority -> Builder +serializeAuthority Authority {..} = userinfo <> bs host <> port + where + userinfo = maybe mempty serializeUserInfo authorityUserInfo + host = hostBS authorityHost + port = maybe mempty packPort authorityPort + packPort (Port p) = c8 ':' <> BB.string8 (show p) + + +------------------------------------------------------------------------------- +serializeUserInfo :: UserInfo -> Builder +serializeUserInfo UserInfo {..} = bs uiUsername <> c8 ':' <> bs uiPassword + + +------------------------------------------------------------------------------- +bs :: ByteString -> Builder +bs = BB.byteString + + +------------------------------------------------------------------------------- +c8 :: Char -> Builder +c8 = BB.char8 + + +------------------------------------------------------------------------------- +-- | Parse a strict ByteString into a URI or an error. +-- +-- Example: +-- +-- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar=baz#quux" +-- Right (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"}) +-- +-- >>> parseURI strictURIParserOptions "$$$$://badurl.example.org" +-- Left (MalformedScheme NonAlphaLeading) +-- +-- There are some urls that you'll encounter which defy the spec, such +-- as those with square brackets in the query string. If you must be +-- able to parse those, you can use "laxURIParserOptions" or specify your own +-- +-- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar[]=baz" +-- Left MalformedQuery +-- +-- >>> parseURI laxURIParserOptions "http://www.example.org/foo?bar[]=baz" +-- Right (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 = Nothing}) +-- +-- >>> let myLaxOptions = URIParserOptions { upoValidQueryChar = liftA2 (||) (upoValidQueryChar strictURIParserOptions) (inClass "[]")} +-- >>> parseURI myLaxOptions "http://www.example.org/foo?bar[]=baz" +-- Right (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 = Nothing}) +parseURI :: URIParserOptions -> ByteString -> Either URIParseError URI +parseURI opts = parseOnly' OtherError (uriParser opts) + +-- | Like 'parseURI', but do not parse scheme. +parseRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError RelativeRef +parseRelativeRef opts = parseOnly' OtherError (relativeRefParser opts) + + +------------------------------------------------------------------------------- +-- | Convenience alias for a parser that can return URIParseError +type URIParser = Parser' URIParseError + + +------------------------------------------------------------------------------- +-- | Toplevel parser for URIs +uriParser :: URIParserOptions -> URIParser URI +uriParser opts = do + scheme <- schemeParser + void $ word8 colon `orFailWith` MalformedScheme MissingColon + RelativeRef authority path query fragment <- relativeRefParser opts + return $ URI scheme authority path query fragment + + +------------------------------------------------------------------------------- +-- | Toplevel parser for relative refs +relativeRefParser :: URIParserOptions -> URIParser RelativeRef +relativeRefParser opts = do + (authority, path) <- hierPartParser <|> rrPathParser + query <- queryParser opts + frag <- mFragmentParser + case frag of + Just _ -> endOfInput `orFailWith` MalformedFragment + Nothing -> endOfInput `orFailWith` MalformedQuery + return $ RelativeRef authority path query frag + + +------------------------------------------------------------------------------- +-- | Parser for scheme, e.g. "http", "https", etc. +schemeParser :: URIParser Scheme +schemeParser = do + c <- satisfy isAlpha `orFailWith` MalformedScheme NonAlphaLeading + rest <- A.takeWhile isSchemeValid `orFailWith` MalformedScheme InvalidChars + return $ Scheme $ c `BS.cons` rest + where + isSchemeValid = inClass $ "-+." ++ alphaNum + + +------------------------------------------------------------------------------- +-- | Hier part immediately follows the schema and encompasses the +-- authority and path sections. +hierPartParser :: URIParser (Maybe Authority, ByteString) +hierPartParser = authWithPathParser <|> + pathAbsoluteParser <|> + pathRootlessParser <|> + pathEmptyParser + + +------------------------------------------------------------------------------- +-- | Relative references have awkward corner cases. See +-- 'firstRelRefSegmentParser'. +rrPathParser :: URIParser (Maybe Authority, ByteString) +rrPathParser = (Nothing,) <$> + ((<>) <$> firstRelRefSegmentParser <*> pathParser) + + +------------------------------------------------------------------------------- +-- | See the "authority path-abempty" grammar in the RFC +authWithPathParser :: URIParser (Maybe Authority, ByteString) +authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> pathParser) + + +------------------------------------------------------------------------------- +-- | See the "path-absolute" grammar in the RFC. Essentially a special +-- case of rootless. +pathAbsoluteParser :: URIParser (Maybe Authority, ByteString) +pathAbsoluteParser = string' "/" *> pathRootlessParser + + +------------------------------------------------------------------------------- +-- | See the "path-rootless" grammar in the RFC. +pathRootlessParser :: URIParser (Maybe Authority, ByteString) +pathRootlessParser = (,) <$> pure Nothing <*> pathParser1 + + +------------------------------------------------------------------------------- +-- | See the "path-empty" grammar in the RFC. Must not be followed +-- with a path-valid char. +pathEmptyParser :: URIParser (Maybe Authority, ByteString) +pathEmptyParser = do + nextChar <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" + case nextChar of + Just c -> guard (notInClass pchar c) >> return emptyCase + _ -> return emptyCase + where + emptyCase = (Nothing, mempty) + + +------------------------------------------------------------------------------- +-- | Parser whe +mAuthorityParser :: URIParser (Maybe Authority) +mAuthorityParser = mParse authorityParser + + +------------------------------------------------------------------------------- +-- | Parses the user info section of a URL (i.e. for HTTP Basic +-- Authentication). Note that this will decode any percent-encoded +-- data. +userInfoParser :: URIParser UserInfo +userInfoParser = (uiTokenParser <* word8 atSym) `orFailWith` MalformedUserInfo + where + atSym = 64 + uiTokenParser = do + ui <- A.takeWhile1 validForUserInfo + let (user, passWithColon) = BS.break (== colon) $ urlDecode' ui + let pass = BS.drop 1 passWithColon + return $ UserInfo user pass + validForUserInfo = inClass $ pctEncoded ++ subDelims ++ (':' : unreserved) + + +------------------------------------------------------------------------------- +-- | Authority consists of host and port +authorityParser :: URIParser Authority +authorityParser = Authority <$> mParse userInfoParser <*> hostParser <*> mPortParser + + +------------------------------------------------------------------------------- +-- | Parser that can handle IPV6/Future literals, IPV4, and domain names. +hostParser :: URIParser Host +hostParser = (Host <$> parsers) `orFailWith` MalformedHost + where + parsers = ipLiteralParser <|> ipV4Parser <|> regNameParser + ipLiteralParser = word8 oBracket *> (ipVFutureParser <|> ipV6Parser) <* word8 cBracket + + +------------------------------------------------------------------------------- +-- | Parses IPV6 addresses. See relevant section in RFC. +ipV6Parser :: Parser ByteString +ipV6Parser = do + leading <- h16s + elided <- maybe [] (const [""]) <$> optional (string "::") + trailing <- many (A.takeWhile (/= colon) <* word8 colon) + (finalChunkLen, final) <- finalChunk + let len = length (leading ++ trailing) + finalChunkLen + when (len > 8) $ fail "Too many digits in IPv6 address" + return $ rejoin $ [rejoin leading] ++ elided ++ trailing ++ maybeToList final + where + finalChunk = fromMaybe (0, Nothing) <$> optional (finalIpV4 <|> finalH16) + finalH16 = (1, ) . Just <$> h16 + finalIpV4 = (2, ) . Just <$> ipV4Parser + rejoin = BS.intercalate ":" + h16s = h16 `sepBy` word8 colon + h16 = mconcat <$> parseBetween 1 4 (A.takeWhile1 hexDigit) + + +------------------------------------------------------------------------------- +-- | Parses IPVFuture addresses. See relevant section in RFC. +ipVFutureParser :: Parser ByteString +ipVFutureParser = do + _ <- word8 lowercaseV + ds <- A.takeWhile1 hexDigit + _ <- word8 period + rest <- A.takeWhile1 $ inClass $ subDelims ++ ":" ++ unreserved + return $ "v" <> ds <> "." <> rest + where + lowercaseV = 118 + + +------------------------------------------------------------------------------- +-- | Parses a valid IPV4 address +ipV4Parser :: Parser ByteString +ipV4Parser = mconcat <$> sequence [ decOctet + , dot + , decOctet + , dot + , decOctet + , dot + , decOctet] + where + decOctet = do + s <- A.takeWhile1 isDigit + let len = BS.length s + guard $ len > 0 && len <= 3 + let num = bsToNum s + guard $ num >= 1 && num <= 255 + return s + dot = string "." + + +------------------------------------------------------------------------------- +-- | This corresponds to the hostname, e.g. www.example.org +regNameParser :: Parser ByteString +regNameParser = urlDecode' <$> A.takeWhile1 (inClass validForRegName) + where + validForRegName = pctEncoded ++ subDelims ++ unreserved + + +------------------------------------------------------------------------------- +-- | Only parse a port if the colon signifier is there. +mPortParser :: URIParser (Maybe Port) +mPortParser = word8' colon `thenJust` portParser + + +------------------------------------------------------------------------------- +-- | Parses port number from the hostname. Colon separator must be +-- handled elsewhere. +portParser :: URIParser Port +portParser = (Port . bsToNum <$> A.takeWhile1 isDigit) `orFailWith` MalformedPort + + +------------------------------------------------------------------------------- +-- | Path with any number of segments +pathParser :: URIParser ByteString +pathParser = pathParser' A.many' + + +------------------------------------------------------------------------------- +-- | Path with at least 1 segment +pathParser1 :: URIParser ByteString +pathParser1 = pathParser' A.many1' + + +------------------------------------------------------------------------------- +-- | Parses the path section of a url. Note that while this can take +-- percent-encoded characters, it does not itself decode them while parsing. +pathParser' :: (Parser ByteString -> Parser [ByteString]) -> URIParser ByteString +pathParser' repeatParser = (mconcat <$> repeatParser segmentParser) `orFailWith` MalformedPath + where + segmentParser = mconcat <$> sequence [string "/", A.takeWhile (inClass pchar)] + + +------------------------------------------------------------------------------- +-- | Parses the first segment of a path section of a relative-path +-- reference. See RFC 3986, Section 4.2. +-- firstRelRefSegmentParser :: URIParser ByteString +firstRelRefSegmentParser :: URIParser ByteString +firstRelRefSegmentParser = A.takeWhile (inClass (pchar \\ ":")) `orFailWith` MalformedPath + + +------------------------------------------------------------------------------- +-- | This parser is being a bit pragmatic. The query section in the +-- spec does not identify the key/value format used in URIs, but that +-- is what most users are expecting to see. One alternative could be +-- to just expose the query string as a string and offer functions on +-- URI to parse a query string to a Query. +queryParser :: URIParserOptions -> URIParser Query +queryParser opts = do + mc <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" + case mc of + Just c + | c == question -> skip' 1 *> itemsParser + | c == hash -> pure mempty + | otherwise -> fail' MalformedPath + _ -> pure mempty + where + itemsParser = Query <$> A.sepBy' (queryItemParser opts) (word8' ampersand) + + +------------------------------------------------------------------------------- +-- | When parsing a single query item string like "foo=bar", turns it +-- into a key/value pair as per convention, with the value being +-- optional. & separators need to be handled further up. +queryItemParser :: URIParserOptions -> URIParser (ByteString, ByteString) +queryItemParser opts = do + s <- A.takeWhile1 (upoValidQueryChar opts) `orFailWith` MalformedQuery + let (k, vWithEquals) = BS.break (== equals) s + let v = BS.drop 1 vWithEquals + return (urlDecodeQuery k, urlDecodeQuery v) + + +------------------------------------------------------------------------------- +validForQuery :: Word8 -> Bool +validForQuery = inClass ('?':'/':delete '&' pchar) + + +------------------------------------------------------------------------------- +validForQueryLax :: Word8 -> Bool +validForQueryLax = notInClass "&#" + + +------------------------------------------------------------------------------- +-- | Only parses a fragment if the # signifiier is there +mFragmentParser :: URIParser (Maybe ByteString) +mFragmentParser = word8' hash `thenJust` fragmentParser + + +------------------------------------------------------------------------------- +-- | The final piece of a uri, e.g. #fragment, minus the #. +fragmentParser :: URIParser ByteString +fragmentParser = A.takeWhile1 validFragmentWord `orFailWith` MalformedFragment + where + validFragmentWord = inClass ('?':'/':pchar) + + +------------------------------------------------------------------------------- +-- | Grammar Components +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +hexDigit :: Word8 -> Bool +hexDigit = inClass "0-9a-fA-F" + + +------------------------------------------------------------------------------- +isAlpha :: Word8 -> Bool +isAlpha = inClass alpha + + +------------------------------------------------------------------------------- +isDigit :: Word8 -> Bool +isDigit = inClass digit + + +------------------------------------------------------------------------------- +pchar :: String +pchar = pctEncoded ++ subDelims ++ ":@" ++ unreserved + + +------------------------------------------------------------------------------- +-- Very important! When concatenating this to other strings to make larger +-- character classes, you must put this at the end because the '-' character +-- is treated as a range unless it's at the beginning or end. +unreserved :: String +unreserved = alphaNum ++ "~._-" + + +------------------------------------------------------------------------------- +unreserved8 :: [Word8] +unreserved8 = map ord8 unreserved + + +------------------------------------------------------------------------------- +unreservedPath8 :: [Word8] +unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$," + +------------------------------------------------------------------------------- +ord8 :: Char -> Word8 +ord8 = fromIntegral . ord + + +------------------------------------------------------------------------------- +-- | pc-encoded technically is % HEXDIG HEXDIG but that's handled by +-- the previous alphaNum constraint. May need to double back with a +-- parser to ensure pct-encoded never exceeds 2 hexdigs after +pctEncoded :: String +pctEncoded = "%" + + +------------------------------------------------------------------------------- +subDelims :: String +subDelims = "!$&'()*+,;=" + + +------------------------------------------------------------------------------- +alphaNum :: String +alphaNum = alpha ++ digit + + +------------------------------------------------------------------------------- +alpha :: String +alpha = "a-zA-Z" + + +------------------------------------------------------------------------------- +digit :: String +digit = "0-9" + + +------------------------------------------------------------------------------- +colon :: Word8 +colon = 58 + + +------------------------------------------------------------------------------- +oBracket :: Word8 +oBracket = 91 + + +------------------------------------------------------------------------------- +cBracket :: Word8 +cBracket = 93 + + +------------------------------------------------------------------------------- +equals :: Word8 +equals = 61 + + +------------------------------------------------------------------------------- +question :: Word8 +question = 63 + + +------------------------------------------------------------------------------- +ampersand :: Word8 +ampersand = 38 + + +------------------------------------------------------------------------------- +hash :: Word8 +hash = 35 + + +------------------------------------------------------------------------------- +period :: Word8 +period = 46 + + +------------------------------------------------------------------------------- +slash :: Word8 +slash = 47 + + +------------------------------------------------------------------------------- +-- | ByteString Utilities +------------------------------------------------------------------------------- + +-- FIXME: theres probably a much better way to do this + +------------------------------------------------------------------------------- +-- | Convert a bytestring into an int representation. Assumes the +-- entire string is comprised of 0-9 digits. +bsToNum :: ByteString -> Int +bsToNum s = sum $ zipWith (*) (reverse ints) [10 ^ x | x <- [0..] :: [Int]] + where + w2i w = fromEnum $ w - 48 + ints = map w2i . BS.unpack $ s + + +------------------------------------------------------------------------------- +-- | Decoding specifically for the query string, which decodes + as +-- space. +urlDecodeQuery :: ByteString -> ByteString +urlDecodeQuery = urlDecode plusToSpace + where + plusToSpace = True + + +------------------------------------------------------------------------------- +-- | Decode any part of the URL besides the query, which decodes + as +-- space. +urlDecode' :: ByteString -> ByteString +urlDecode' = urlDecode plusToSpace + where + plusToSpace = False + + +------------------------------------------------------------------------------- +-- | Parsing with Strongly-Typed Errors +------------------------------------------------------------------------------- + + +-- | A parser with a specific error type. Attoparsec unfortunately +-- throws all errors into strings, which cannot be handled well +-- programmatically without doing something silly like parsing error +-- messages. This wrapper attempts to concentrate these errors into +-- one type. +newtype Parser' e a = Parser' (Parser a) + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , Monoid) + + +------------------------------------------------------------------------------- +-- | Use with caution. Catch a parser failing and return Nothing. +mParse :: Parser' e a -> Parser' e (Maybe a) +mParse p = option Nothing (Just <$> p) + + +------------------------------------------------------------------------------- +-- | If the first parser succeeds, discard the result and use the +-- second parser (which may fail). If the first parser fails, return +-- Nothing. This is used to check a benign precondition that indicates +-- the presence of a parsible token, i.e. ? preceeding a query. +thenJust :: Parser' e a -> Parser' e b -> Parser' e (Maybe b) +thenJust p1 p2 = p1 *> (Just <$> p2) <|> pure Nothing + + +------------------------------------------------------------------------------- +-- | Lift a word8 Parser into a strongly error typed parser. This will +-- generate a "stringy" error message if it fails, so you should +-- probably be prepared to exit with a nicer error further up. +word8' :: Word8 -> Parser' e Word8 +word8' = Parser' . word8 + + +------------------------------------------------------------------------------- +-- | Skip exactly 1 character. Fails if the character isn't +-- there. Generates a "stringy" error. +skip' :: Int -> Parser' e () +skip' = Parser' . void . A.take + + +------------------------------------------------------------------------------- +-- | Lifted version of the string token parser. Same caveats about +-- "stringy" errors apply. +string' :: ByteString -> Parser' e ByteString +string' = Parser' . string + + +------------------------------------------------------------------------------- +-- | Combinator for tunnelling more specific error types through the +-- attoparsec machinery using read/show. +orFailWith :: (Show e, Read e) => Parser a -> e -> Parser' e a +orFailWith p e = Parser' p <|> fail' e + + +------------------------------------------------------------------------------- +-- | Should be preferred to fail' +fail' :: (Show e, Read e) => e -> Parser' e a +fail' = fail . show + + +------------------------------------------------------------------------------- +parseBetween :: (Alternative m, Monad m) => Int -> Int -> m a -> m [a] +parseBetween a b f = choice parsers + where + parsers = map (`count` f) $ reverse $ range (a, b) + + +------------------------------------------------------------------------------- +-- | Stronger-typed variation of parseOnly'. Consumes all input. +parseOnly' :: (Read e, Show e) + => (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) + +------------------------------------------------------------------------------- +-- | Our pal Control.Monad.fail is how attoparsec propagates +-- errors. If you throw an error string with fail (your only choice), +-- it will *always* prepend it with "Failed reading: ". At least in +-- this version. That may change to something else and break this workaround. +stripAttoparsecGarbage :: String -> String +stripAttoparsecGarbage = stripPrefix' "Failed reading: " + + +------------------------------------------------------------------------------- +-- | stripPrefix where it is a noop if the prefix doesn't exist. +stripPrefix' :: Eq a => [a] -> [a] -> [a] +stripPrefix' pfx s = fromMaybe s $ stripPrefix pfx s + + +------------------------------------------------------------------------------- +fmapL :: (a -> b) -> Either a r -> Either b r +fmapL f = either (Left . f) Right + + +------------------------------------------------------------------------------- +-- | This function was extract from the @http-types@ package. The +-- license can be found in licenses/http-types/LICENSE +urlDecode + :: Bool -- ^ Whether to decode '+' to ' ' + -> BS.ByteString + -> BS.ByteString +urlDecode replacePlus z = fst $ BS.unfoldrN (BS.length z) go z + where + go bs' = + case BS.uncons bs' of + Nothing -> Nothing + Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space + Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent + (x, xs) <- BS.uncons ws + x' <- hexVal x + (y, ys) <- BS.uncons xs + y' <- hexVal y + Just (combine x' y', ys) + Just (w, ws) -> Just (w, ws) + hexVal w + | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 + | 65 <= w && w <= 70 = Just $ w - 55 -- A - F + | 97 <= w && w <= 102 = Just $ w - 87 -- a - f + | otherwise = Nothing + combine :: Word8 -> Word8 -> Word8 + combine a b = shiftL a 4 .|. b + + +------------------------------------------------------------------------------- +--TODO: keep an eye on perf here. seems like a good use case for a DList. the word8 list could be a set/hashset +-- | Percent-encoding for URLs. +urlEncode' :: [Word8] -> ByteString -> Builder +urlEncode' extraUnreserved = mconcat . map encodeChar . BS.unpack + where + encodeChar ch | unreserved' ch = BB.word8 ch + | otherwise = h2 ch + + unreserved' ch | ch >= 65 && ch <= 90 = True -- A-Z + | ch >= 97 && ch <= 122 = True -- a-z + | ch >= 48 && ch <= 57 = True -- 0-9 + unreserved' c = c `elem` extraUnreserved + + h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b] -- percent (%) + h i | i < 10 = 48 + i -- zero (0) + | otherwise = 65 + i - 10 -- 65: A + + +------------------------------------------------------------------------------- +urlEncodeQuery :: ByteString -> Builder +urlEncodeQuery = urlEncode' unreserved8 + + +------------------------------------------------------------------------------- +urlEncodePath :: ByteString -> Builder +urlEncodePath = urlEncode' unreservedPath8 diff --git a/src/URI/ByteString/Lens.hs b/src/URI/ByteString/Lens.hs new file mode 100644 --- /dev/null +++ b/src/URI/ByteString/Lens.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE RankNTypes #-} +module URI.ByteString.Lens where + + +------------------------------------------------------------------------------- +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Word +------------------------------------------------------------------------------- +import URI.ByteString.Types +------------------------------------------------------------------------------- + + +-- | @ +-- schemeBSL :: Lens' 'Scheme' 'ByteString' +-- @ +schemeBSL + :: Functor f => (ByteString -> f ByteString) -> Scheme -> f Scheme +schemeBSL = + lens schemeBS (\a b -> a { schemeBS = b}) +{-# INLINE schemeBSL #-} + +------------------------------------------------------------------------------- +-- | @ +-- hostBSL :: Lens' 'Host' 'ByteString' +-- @ +hostBSL + :: Functor f => (ByteString -> f ByteString) -> Host -> f Host +hostBSL = + lens hostBS (\a b -> a { hostBS = b}) +{-# INLINE hostBSL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- portNumberL :: Lens' 'Port' 'Int' +-- @ +portNumberL + :: Functor f => (Int -> f Int) -> Port -> f Port +portNumberL = + lens portNumber (\a b -> a { portNumber = b}) +{-# INLINE portNumberL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- authorityUserInfoL :: Lens' 'Authority' ('Maybe' 'UserInfo') +-- @ +authorityUserInfoL + :: Functor f => + (Maybe UserInfo -> f (Maybe UserInfo)) -> Authority -> f Authority +authorityUserInfoL = + lens authorityUserInfo (\a b -> a { authorityUserInfo = b}) +{-# INLINE authorityUserInfoL #-} + +------------------------------------------------------------------------------- +-- | @ +-- authorityHostL :: Lens' 'Authority' 'Host' +-- @ +authorityHostL + :: Functor f => (Host -> f Host) -> Authority -> f Authority +authorityHostL = + lens authorityHost (\a b -> a { authorityHost = b}) +{-# INLINE authorityHostL #-} + +------------------------------------------------------------------------------- +-- | @ +-- authorityPortL :: Lens' 'Authority' ('Maybe' 'Port') +-- @ +authorityPortL + :: Functor f => + (Maybe Port -> f (Maybe Port)) -> Authority -> f Authority +authorityPortL = + lens authorityPort (\a b -> a { authorityPort = b}) +{-# INLINE authorityPortL #-} + +------------------------------------------------------------------------------- +-- | @ +-- uiUsernameL :: Lens' 'UserInfo' 'ByteString' +-- @ +uiUsernameL + :: Functor f => + (ByteString -> f ByteString) -> UserInfo -> f UserInfo +uiUsernameL = + lens uiUsername (\a b -> a { uiUsername = b}) +{-# INLINE uiUsernameL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- uiPasswordL :: Lens' 'UserInfo' 'ByteString' +-- @ +uiPasswordL + :: Functor f => + (ByteString -> f ByteString) -> UserInfo -> f UserInfo +uiPasswordL = + lens uiPassword (\a b -> a { uiPassword = b}) +{-# INLINE uiPasswordL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- queryPairsL :: Lens' 'Query' [('ByteString', 'ByteString')] +-- @ +queryPairsL + :: Functor f + => ([(ByteString, ByteString)] -> f [(ByteString, ByteString)]) + -> Query + -> f Query +queryPairsL = + lens queryPairs (\a b -> a { queryPairs = b}) +{-# INLINE queryPairsL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- uriSchemeL :: Lens' 'URI' 'Scheme' +-- @ +uriSchemeL :: Functor f => (Scheme -> f Scheme) -> URI -> f URI +uriSchemeL = + lens uriScheme (\a b -> a { uriScheme = b}) +{-# INLINE uriSchemeL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- uriAuthorityL :: Lens' 'URI' ('Maybe' 'Authority') +-- @ +uriAuthorityL + :: Functor f => + (Maybe Authority -> f (Maybe Authority)) -> URI -> f URI +uriAuthorityL = + lens uriAuthority (\a b -> a { uriAuthority = b}) +{-# INLINE uriAuthorityL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- uriPathL :: Lens' 'URI' 'ByteString' +-- @ +uriPathL + :: Functor f => (ByteString -> f ByteString) -> URI -> f URI +uriPathL = + lens uriPath (\a b -> a { uriPath = b}) +{-# INLINE uriPathL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- uriQueryL :: Lens' 'URI' 'Query' +-- @ +uriQueryL :: Functor f => (Query -> f Query) -> URI -> f URI +uriQueryL = + lens uriQuery (\a b -> a { uriQuery = b}) +{-# INLINE uriQueryL #-} + +------------------------------------------------------------------------------- +-- | @ +-- uriFragmentL :: Lens' 'URI' ('Maybe' 'ByteString') +-- @ +uriFragmentL + :: Functor f => + (Maybe ByteString -> f (Maybe ByteString)) -> URI -> f URI +uriFragmentL = + lens uriFragment (\a b -> a { uriFragment = b}) +{-# INLINE uriFragmentL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- rrAuthorityL :: Lens' 'RelativeRef' ('Maybe' 'Authority') +-- @ +rrAuthorityL + :: Functor f => + (Maybe Authority -> f (Maybe Authority)) -> RelativeRef -> f RelativeRef +rrAuthorityL = + lens rrAuthority (\a b -> a { rrAuthority = b}) +{-# INLINE rrAuthorityL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- rrPathL :: Lens' 'RelativeRef' 'ByteString' +-- @ +rrPathL + :: Functor f => (ByteString -> f ByteString) -> RelativeRef -> f RelativeRef +rrPathL = + lens rrPath (\a b -> a { rrPath = b}) +{-# INLINE rrPathL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- rrQueryL :: Lens' 'RelativeRef' 'Query' +-- @ +rrQueryL :: Functor f => (Query -> f Query) -> RelativeRef -> f RelativeRef +rrQueryL = + lens rrQuery (\a b -> a { rrQuery = b}) +{-# INLINE rrQueryL #-} + +------------------------------------------------------------------------------- +-- | @ +-- rrFragmentL :: Lens' 'RelativeRef' ('Maybe' 'ByteString') +-- @ +rrFragmentL + :: Functor f => + (Maybe ByteString -> f (Maybe ByteString)) -> RelativeRef -> f RelativeRef +rrFragmentL = + lens rrFragment (\a b -> a { rrFragment = b}) +{-# INLINE rrFragmentL #-} + + +------------------------------------------------------------------------------- +-- | @ +-- upoValidQueryCharL :: Lens' URIParserOptions (Word8 -> Bool) +-- @ +upoValidQueryCharL + :: Functor f => + ((Word8 -> Bool) -> f (Word8 -> Bool)) + -> URIParserOptions -> f URIParserOptions +upoValidQueryCharL = + lens upoValidQueryChar (\a b -> a { upoValidQueryChar = b}) +{-# INLINE upoValidQueryCharL #-} + + +------------------------------------------------------------------------------- +-- Lens machinery +------------------------------------------------------------------------------- +type Lens s t a b = 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) +{-# INLINE lens #-} diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs new file mode 100644 --- /dev/null +++ b/src/URI/ByteString/Types.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module URI.ByteString.Types where + +------------------------------------------------------------------------------- +import Data.ByteString (ByteString) +import Data.Monoid +import Data.Typeable +import Data.Word +import GHC.Generics +------------------------------------------------------------------------------- + + +-- | Required first component to referring to a specification for the +-- remainder of the URI's components, e.g. "http" or "https" +newtype Scheme = Scheme { schemeBS :: ByteString } + deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +newtype Host = Host { hostBS :: ByteString } + deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +-- | While some libraries have chosen to limit this to a Word16, the +-- spec only specifies that the string be comprised of digits. +newtype Port = Port { portNumber :: Int } + deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +data Authority = Authority { + authorityUserInfo :: Maybe UserInfo + , authorityHost :: Host + , authorityPort :: Maybe Port + } deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +data UserInfo = UserInfo { + uiUsername :: ByteString + , uiPassword :: ByteString + } deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +newtype Query = Query { queryPairs :: [(ByteString, ByteString)] } + deriving (Show, Eq, Monoid, Generic, Typeable) + + +------------------------------------------------------------------------------- +data URI = URI { + uriScheme :: Scheme + , uriAuthority :: Maybe Authority + , uriPath :: ByteString + , uriQuery :: Query + , uriFragment :: Maybe ByteString + -- ^ URI fragment. Does not include the # + } deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +data RelativeRef = RelativeRef { + rrAuthority :: Maybe Authority + , rrPath :: ByteString + , rrQuery :: Query + , rrFragment :: Maybe ByteString + -- ^ URI fragment. Does not include the # + } deriving (Show, Eq, Generic, Typeable) + + +------------------------------------------------------------------------------- +-- | Options for the parser. You will probably want to use either +-- "strictURIParserOptions" or "laxURIParserOptions" +data URIParserOptions = URIParserOptions { + upoValidQueryChar :: Word8 -> Bool + } + + +------------------------------------------------------------------------------- +-- | URI Parser Types +------------------------------------------------------------------------------- + + +data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character + | InvalidChars -- ^ Subsequent characters in the schema were invalid + | MissingColon -- ^ Schemas must be followed by a colon + deriving (Show, Eq, Read, Generic, Typeable) + + +------------------------------------------------------------------------------- +data URIParseError = MalformedScheme SchemaError + | MalformedUserInfo + | MalformedQuery + | MalformedFragment + | MalformedHost + | MalformedPort + | MalformedPath + | OtherError String -- ^ Catchall for unpredictable errors + deriving (Show, Eq, Generic, Read, Typeable) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,11 +1,17 @@ module Main (main) where +------------------------------------------------------------------------------- import Test.Tasty - +------------------------------------------------------------------------------- import URI.ByteStringTests +------------------------------------------------------------------------------- + main :: IO () main = defaultMain testSuite testSuite :: TestTree -testSuite = testGroup "uri-bytestring" [URI.ByteStringTests.tests] +testSuite = testGroup "uri-bytestring" + [ + URI.ByteStringTests.tests + ] 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.0.1 +version: 0.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 @@ -11,20 +11,21 @@ category: Web build-type: Simple cabal-version: >=1.16 -homepage: https://travis-ci.org/Soostone/uri-bytestring -bug-reports: https://travis-ci.org/Soostone/uri-bytestring/issues +homepage: https://github.com/Soostone/uri-bytestring +bug-reports: https://github.com/Soostone/uri-bytestring/issues extra-source-files: README.md + CONTRIBUTING.md changelog.md bench/*.hs -flag lib-Werror - default: False - manual: True - library exposed-modules: URI.ByteString + other-modules: + URI.ByteString.Lens + URI.ByteString.Types + URI.ByteString.Internal build-depends: @@ -35,9 +36,6 @@ hs-source-dirs: src default-language: Haskell2010 - if flag(lib-Werror) - ghc-options: -Werror - ghc-options: -Wall test-suite test @@ -55,7 +53,12 @@ , attoparsec , base , bytestring + , lens + , quickcheck-instances default-language: Haskell2010 + + ghc-options: -Wall + benchmark bench type: exitcode-stdio-1.0