uri-bytestring 0.0.1 → 0.1
raw patch · 10 files changed
+1191/−807 lines, 10 filesdep +lensdep +quickcheck-instances
Dependencies added: lens, quickcheck-instances
Files
- CONTRIBUTING.md +14/−0
- README.md +9/−1
- bench/Main.hs +21/−0
- changelog.md +5/−0
- src/URI/ByteString.hs +42/−794
- src/URI/ByteString/Internal.hs +743/−0
- src/URI/ByteString/Lens.hs +234/−0
- src/URI/ByteString/Types.hs +102/−0
- test/Main.hs +8/−2
- uri-bytestring.cabal +13/−10
+ CONTRIBUTING.md view
@@ -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!
README.md view
@@ -1,4 +1,12 @@ # uri-bytestring-[](https://travis-ci.org/Soostone/uri-bytestring)+[](https://travis-ci.org/Soostone/uri-bytestring)+[](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)
bench/Main.hs view
@@ -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 }
changelog.md view
@@ -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.
src/URI/ByteString.hs view
@@ -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
+ src/URI/ByteString/Internal.hs view
@@ -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
+ src/URI/ByteString/Lens.hs view
@@ -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 #-}
+ src/URI/ByteString/Types.hs view
@@ -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)
test/Main.hs view
@@ -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+ ]
uri-bytestring.cabal view
@@ -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