diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,84 +1,94 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Main (main) where ------------------------------------------------------------------------------- -import Blaze.ByteString.Builder -import Control.DeepSeq -import Criterion.Main -import Data.String -import qualified Network.URI as NU +import Blaze.ByteString.Builder +import Control.DeepSeq +import Criterion.Main +import Data.String +import qualified Network.URI as NU ------------------------------------------------------------------------------- -import URI.ByteString +import URI.ByteString + ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- instance NFData Authority + instance NFData Host + instance NFData UserInfo + instance NFData SchemaError + instance NFData URIParseError + instance NFData Scheme + instance NFData Port + instance NFData Query instance NFData (URIRef a) where rnf (URI a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e rnf (RelativeRef b c d e) = rnf b `seq` rnf c `seq` rnf d `seq` rnf e - ------------------------------------------------------------------------------- main :: IO () -main = defaultMain - [ - bgroup "parsing" - [ - 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.serializeURIRef on URI" $ nf (toLazyByteString . serializeURIRef) exampleURI - , bench "URI.ByteString.serializeURIRef on relative ref" $ nf (toLazyByteString . serializeURIRef) exampleRelativeRef +main = + defaultMain + [ bgroup + "parsing" + [ 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.serializeURIRef on URI" $ nf (toLazyByteString . serializeURIRef) exampleURI, + bench "URI.ByteString.serializeURIRef on relative ref" $ nf (toLazyByteString . serializeURIRef) exampleRelativeRef + ] ] - ] - exampleURIS :: IsString s => s exampleURIS = "http://google.com/example?params=youbetcha" - exampleRelativeRefS :: IsString s => s exampleRelativeRefS = "/example?params=youbetcha#17u" - exampleURI :: URI -exampleURI = URI { - uriScheme = Scheme "http" - , uriAuthority = Just Authority { - authorityUserInfo = Nothing - , authorityHost = Host "google.com" - , authorityPort = Nothing - } - , uriPath = "/example" - , uriQuery = Query [("params", "youbetcha")] - , uriFragment = Nothing +exampleURI = + URI + { uriScheme = Scheme "http", + uriAuthority = + Just + Authority + { authorityUserInfo = Nothing, + authorityHost = Host "google.com", + authorityPort = Nothing + }, + 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 +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,9 @@ +0.4.0.1 +* [Fix fragment serilization bug](https://github.com/Soostone/uri-bytestring/pull/65). 0.4.0.0 percent-decoded fragments on parse but did not percent-encode them on serialization, which made it possible for some URLs to not roundtrip. + +0.4.0.0 +* [Improve spec compliance ](https://github.com/Soostone/uri-bytestring/pull/64). Thanks to [hasufell](https://github.com/hasufell). + 0.3.3.1 * Remove >= from cabal version. Thanks to [felixonmars](https://github.com/felixonmars). * Conditionally drop dependency on semigroups library. Thanks to [felixonmars](https://github.com/felixonmars). diff --git a/src/URI/ByteString.hs b/src/URI/ByteString.hs --- a/src/URI/ByteString.hs +++ b/src/URI/ByteString.hs @@ -1,120 +1,133 @@ -{-| - -Module : URI.ByteString -Description : ByteString URI Parser and Serializer -Copyright : (c) Soostone Inc., 2014-2015 - Michael Xavier, 2014-2015 -License : BSD3 -Maintainer : michael.xavier@soostone.com -Stability : experimental - -URI.ByteString aims to be an RFC3986 compliant URI parser that uses -efficient ByteStrings for parsing and representing the data. This -module provides a URI datatype as well as a parser and serializer. - -Note that this library is an early release and may have issues. It is -currently being used in production and no issues have been -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 +-- Description : ByteString URI Parser and Serializer +-- Copyright : (c) Soostone Inc., 2014-2015 +-- Michael Xavier, 2014-2015 +-- License : BSD3 +-- Maintainer : michael.xavier@soostone.com +-- Stability : experimental +-- +-- URI.ByteString aims to be an RFC3986 compliant URI parser that uses +-- efficient ByteStrings for parsing and representing the data. This +-- module provides a URI datatype as well as a parser and serializer. +-- +-- Note that this library is an early release and may have issues. It is +-- currently being used in production and no issues have been +-- 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 - Scheme(..) - , Host(..) - , Port(..) - , Authority(..) - , UserInfo(..) - , Query(..) - , URIRef(..) - , Absolute - , Relative - , SchemaError(..) - , URIParseError(..) - , URIParserOptions(..) - , strictURIParserOptions - , laxURIParserOptions - , URINormalizationOptions(..) - , noNormalization - , rfc3986Normalization - , httpNormalization - , aggressiveNormalization - , httpDefaultPorts + ( -- * URI-related types + Scheme (..), + Host (..), + Port (..), + Authority (..), + UserInfo (..), + Query (..), + URIRef (..), + Absolute, + Relative, + SchemaError (..), + URIParseError (..), + URIParserOptions (..), + strictURIParserOptions, + laxURIParserOptions, + URINormalizationOptions (..), + noNormalization, + rfc3986Normalization, + httpNormalization, + aggressiveNormalization, + httpDefaultPorts, + -- * Operations - , toAbsolute + toAbsolute, + -- * Parsing - , parseURI - , parseRelativeRef - , uriParser - , relativeRefParser + parseURI, + parseRelativeRef, + uriParser, + relativeRefParser, + -- * Serializing - , serializeURIRef - , serializeURIRef' - , serializeQuery - , serializeQuery' - , serializeFragment - , serializeFragment' - , serializeAuthority - , serializeAuthority' - , serializeUserInfo - , serializeUserInfo' + serializeURIRef, + serializeURIRef', + serializeQuery, + serializeQuery', + serializeFragment, + serializeFragment', + serializeAuthority, + serializeAuthority', + serializeUserInfo, + serializeUserInfo', + -- ** Normalized Serialization - , normalizeURIRef - , normalizeURIRef' + normalizeURIRef, + normalizeURIRef', + -- * Low level utility functions - , urlDecode - , urlDecodeQuery - , urlEncodeQuery - , urlEncodePath - , urlEncode + urlEncodeQuery, + urlEncodePath, + urlEncode, + -- * Lenses + -- ** Lenses over 'Scheme' - , schemeBSL + schemeBSL, + -- ** Lenses over 'Host' - , hostBSL + hostBSL, + -- ** Lenses over 'Port' - , portNumberL + portNumberL, + -- ** Lenses over 'Authority' - , authorityUserInfoL - , authorityHostL - , authorityPortL + authorityUserInfoL, + authorityHostL, + authorityPortL, + -- ** Lenses over 'UserInfo' - , uiUsernameL - , uiPasswordL + uiUsernameL, + uiPasswordL, + -- ** Lenses over 'Query' - , queryPairsL + queryPairsL, + -- ** Lenses over 'URIRef' - , uriSchemeL - , authorityL - , pathL - , queryL - , fragmentL + uriSchemeL, + authorityL, + pathL, + queryL, + fragmentL, + -- ** Lenses over 'URIParserOptions' - , upoValidQueryCharL + upoValidQueryCharL, + -- ** Deprecated - , URI - , RelativeRef - , serializeURI - , serializeURI' - , serializeRelativeRef - , serializeRelativeRef' - , uriAuthorityL - , uriPathL - , uriQueryL - , uriFragmentL - , rrAuthorityL - , rrPathL - , rrQueryL - , rrFragmentL - ) where + URI, + RelativeRef, + serializeURI, + serializeURI', + serializeRelativeRef, + serializeRelativeRef', + uriAuthorityL, + uriPathL, + uriQueryL, + uriFragmentL, + rrAuthorityL, + rrPathL, + rrQueryL, + rrFragmentL, + ) +where ------------------------------------------------------------------------------- -import URI.ByteString.Internal -import URI.ByteString.Lens -import URI.ByteString.Types +import URI.ByteString.Internal +import URI.ByteString.Lens +import URI.ByteString.Types + ------------------------------------------------------------------------------- diff --git a/src/URI/ByteString/Internal.hs b/src/URI/ByteString/Internal.hs --- a/src/URI/ByteString/Internal.hs +++ b/src/URI/ByteString/Internal.hs @@ -1,79 +1,99 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + module URI.ByteString.Internal where ------------------------------------------------------------------------------- -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as BB +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB import qualified Blaze.ByteString.Builder.Char.Utf8 as BB -import Control.Applicative -import Control.Monad -import qualified Control.Monad.Fail as F -import Data.Attoparsec.ByteString -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Char8 as A (decimal) -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.Char (ord, toLower) -import Data.Ix -import Data.List (delete, intersperse, - sortBy, stripPrefix, (\\)) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Monoid as Monoid (mempty) -import Data.Ord (comparing) -import Data.Semigroup as Semigroup -import Data.Word -import Text.Read (readMaybe) -------------------------------------------------------------------------------- -import URI.ByteString.Types +import Control.Applicative +import Control.Monad +import qualified Control.Monad.Fail as F +import Data.Attoparsec.ByteString +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A (decimal) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (ord, toLower) +import Data.Ix +import Data.List + ( delete, + intersperse, + sortBy, + stripPrefix, + ) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Monoid as Monoid (mempty) +import Data.Ord (comparing) +import Data.Semigroup as Semigroup +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 +strictURIParserOptions = + URIParserOptions + { upoLaxQueryParsing = False } - ------------------------------------------------------------------------------- + -- | 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 +laxURIParserOptions = + URIParserOptions + { upoLaxQueryParsing = True } - ------------------------------------------------------------------------------- + -- | All normalization options disabled noNormalization :: URINormalizationOptions -noNormalization = URINormalizationOptions False False False False False False False httpDefaultPorts - +noNormalization = URINormalizationOptions + { unoDowncaseScheme = False, + unoDowncaseHost = False, + unoDropDefPort = False, + unoSlashEmptyPath = False, + unoDropExtraSlashes = False, + unoSortParameters = False, + unoRemoveDotSegments = False, + unoDefaultPorts = httpDefaultPorts + } ------------------------------------------------------------------------------- + -- | The set of known default ports to schemes. Currently only -- contains http\/80 and https\/443. Feel free to extend it if needed -- with 'unoDefaultPorts'. httpDefaultPorts :: M.Map Scheme Port -httpDefaultPorts = M.fromList [ (Scheme "http", Port 80) - , (Scheme "https", Port 443) - ] - +httpDefaultPorts = + M.fromList + [ (Scheme "http", Port 80), + (Scheme "https", Port 443) + ] ------------------------------------------------------------------------------- + -- | Only normalizations deemed appropriate for all protocols by -- RFC3986 enabled, namely: -- @@ -81,39 +101,54 @@ -- * Downcase Host -- * Remove Dot Segments rfc3986Normalization :: URINormalizationOptions -rfc3986Normalization = noNormalization { unoDowncaseScheme = True - , unoDowncaseHost = True - , unoRemoveDotSegments = True - } - +rfc3986Normalization = + noNormalization + { unoDowncaseScheme = True, + unoDowncaseHost = True, + unoRemoveDotSegments = True + } ------------------------------------------------------------------------------- + -- | The same as 'rfc3986Normalization' but with additional enabled -- features if you're working with HTTP URIs: -- -- * Drop Default Port (with 'httpDefaultPorts') -- * Drop Extra Slashes httpNormalization :: URINormalizationOptions -httpNormalization = rfc3986Normalization { unoDropDefPort = True - , unoSlashEmptyPath = True - } +httpNormalization = + rfc3986Normalization + { unoDropDefPort = True, + unoSlashEmptyPath = True + } ------------------------------------------------------------------------------- + -- | All options enabled aggressiveNormalization :: URINormalizationOptions -aggressiveNormalization = URINormalizationOptions True True True True True True True httpDefaultPorts - +aggressiveNormalization = URINormalizationOptions + { unoDowncaseScheme = True, + unoDowncaseHost = True, + unoDropDefPort = True, + unoSlashEmptyPath = True, + unoDropExtraSlashes = True, + unoSortParameters = True, + unoRemoveDotSegments = True, + unoDefaultPorts = httpDefaultPorts + } ------------------------------------------------------------------------------- + -- | @toAbsolute scheme ref@ converts @ref@ to an absolute URI. -- If @ref@ is already absolute, then it is unchanged. toAbsolute :: Scheme -> URIRef a -> URIRef Absolute -toAbsolute scheme (RelativeRef {..}) = URI scheme rrAuthority rrPath rrQuery rrFragment -toAbsolute _ uri@(URI {..}) = uri - +toAbsolute scheme RelativeRef {..} = URI scheme rrAuthority rrPath rrQuery rrFragment +toAbsolute _ uri@URI {} = uri ------------------------------------------------------------------------------- + -- | URI Serializer + ------------------------------------------------------------------------------- -- | Serialize a URI reference into a 'Builder'. @@ -125,35 +160,33 @@ serializeURIRef :: URIRef a -> Builder serializeURIRef = normalizeURIRef noNormalization - ------------------------------------------------------------------------------- + -- | Like 'serializeURIRef', with conversion into a strict 'ByteString'. serializeURIRef' :: URIRef a -> ByteString serializeURIRef' = BB.toByteString . serializeURIRef - ------------------------------------------------------------------------------- + -- | Serialize a URI into a Builder. serializeURI :: URIRef Absolute -> Builder serializeURI = normalizeURIRef noNormalization {-# DEPRECATED serializeURI "Use 'serializeURIRef' instead" #-} - ------------------------------------------------------------------------------- + -- | Similar to 'serializeURIRef' but performs configurable degrees of -- URI normalization. If your goal is the fastest serialization speed -- possible, 'serializeURIRef' will be fine. If you intend on -- comparing URIs (say for caching purposes), you'll want to use this. normalizeURIRef :: URINormalizationOptions -> URIRef a -> Builder -normalizeURIRef o uri@(URI {..}) = normalizeURI o uri -normalizeURIRef o uri@(RelativeRef {}) = normalizeRelativeRef o Nothing uri - +normalizeURIRef o uri@URI {} = normalizeURI o uri +normalizeURIRef o uri@RelativeRef {} = normalizeRelativeRef o Nothing uri ------------------------------------------------------------------------------- normalizeURIRef' :: URINormalizationOptions -> URIRef a -> ByteString normalizeURIRef' o = BB.toByteString . normalizeURIRef o - ------------------------------------------------------------------------------- normalizeURI :: URINormalizationOptions -> URIRef Absolute -> Builder normalizeURI o@URINormalizationOptions {..} URI {..} = @@ -165,31 +198,30 @@ | otherwise = id rr = RelativeRef uriAuthority uriPath uriQuery uriFragment - ------------------------------------------------------------------------------- normalizeRelativeRef :: URINormalizationOptions -> Maybe Scheme -> URIRef Relative -> Builder normalizeRelativeRef o@URINormalizationOptions {..} mScheme RelativeRef {..} = authority <> path <> query <> fragment where path - | unoSlashEmptyPath && BS.null rrPath = BB.fromByteString "/" + | unoSlashEmptyPath && BS.null rrPath = BB.fromByteString "/" | segs == [""] = BB.fromByteString "/" - | otherwise = mconcat (intersperse (c8 '/') (map urlEncodePath segs)) + | otherwise = mconcat (intersperse (c8 '/') (map urlEncodePath segs)) segs = dropSegs (BS.split slash (pathRewrite rrPath)) pathRewrite | unoRemoveDotSegments = removeDotSegments | otherwise = id dropSegs [] = [] - dropSegs (h:t) - | unoDropExtraSlashes = h:(filter (not . BS.null) t) - | otherwise = h:t + dropSegs (h : t) + | unoDropExtraSlashes = h : (filter (not . BS.null) t) + | otherwise = h : t authority = maybe Monoid.mempty (serializeAuthority o mScheme) rrAuthority query = serializeQuery o rrQuery fragment = serializeFragment rrFragment - ------------------------------------------------------------------------------- --TODO: this is probably ripe for benchmarking + -- | Algorithm described in -- , reproduced -- artlessly. @@ -200,7 +232,7 @@ -- A. If the input buffer begins with prefix of ../ or ./ then -- remove the prefix from the input buffer | BS8.isPrefixOf "../" inBuf = go (BS8.drop 3 inBuf) outBuf - | BS8.isPrefixOf "./" inBuf = go (BS8.drop 2 inBuf) outBuf + | BS8.isPrefixOf "./" inBuf = go (BS8.drop 2 inBuf) outBuf -- B. If the input buffer begins with a prefix of "/./" or "/.", -- where "." is a complete path segment, then replace that -- prefix with "/" in the input buffer. TODO: I think "a @@ -222,65 +254,60 @@ -- any) and any subsequent characters up to, but not including, -- the next "/" character or the end of the input buffer. | otherwise = case BS8.uncons inBuf of - Just ('/', rest) -> - let (thisSeg, inBuf') = BS8.span (/= '/') rest - in go inBuf' (outBuf |> "/" |> thisSeg) - Just (_, _) -> - let (thisSeg, inBuf') = BS8.span (/= '/') inBuf - in go inBuf' (outBuf |> thisSeg) - Nothing -> outBuf - - + Just ('/', rest) -> + let (thisSeg, inBuf') = BS8.span (/= '/') rest + in go inBuf' (outBuf |> "/" |> thisSeg) + Just (_, _) -> + let (thisSeg, inBuf') = BS8.span (/= '/') inBuf + in go inBuf' (outBuf |> thisSeg) + Nothing -> outBuf ------------------------------------------------------------------------------- + -- | Like 'serializeURI', with conversion into a strict 'ByteString'. serializeURI' :: URIRef Absolute -> ByteString serializeURI' = BB.toByteString . serializeURI {-# DEPRECATED serializeURI' "Use 'serializeURIRef'' instead" #-} - ------------------------------------------------------------------------------- + -- | Like 'serializeURI', but do not render scheme. serializeRelativeRef :: URIRef Relative -> Builder serializeRelativeRef = normalizeRelativeRef noNormalization Nothing {-# DEPRECATED serializeRelativeRef "Use 'serializeURIRef' instead" #-} - ------------------------------------------------------------------------------- + -- | Like 'serializeRelativeRef', with conversion into a strict 'ByteString'. serializeRelativeRef' :: URIRef Relative -> ByteString serializeRelativeRef' = BB.toByteString . serializeRelativeRef {-# DEPRECATED serializeRelativeRef' "Use 'serializeURIRef'' instead" #-} - ------------------------------------------------------------------------------- + -- | Serialize the query part of a url -- @serializeQuery opts mempty = ""@ -- @serializeQuery opts (Query [("a","b"),("c","d")]) = "?a=b&c=d"@ serializeQuery :: URINormalizationOptions -> Query -> Builder serializeQuery _ (Query []) = mempty serializeQuery URINormalizationOptions {..} (Query ps) = - c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps')) + c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps')) where serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v ps' | unoSortParameters = sortBy (comparing fst) ps | otherwise = ps - serializeQuery' :: URINormalizationOptions -> Query -> ByteString serializeQuery' opts = BB.toByteString . serializeQuery opts - ------------------------------------------------------------------------------- serializeFragment :: Maybe ByteString -> Builder -serializeFragment = maybe mempty (\s -> c8 '#' <> bs s) - +serializeFragment = maybe mempty (\s -> c8 '#' <> urlEncodeQuery s) serializeFragment' :: Maybe ByteString -> ByteString serializeFragment' = BB.toByteString . serializeFragment - ------------------------------------------------------------------------------- serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port @@ -303,7 +330,6 @@ | M.lookup s unoDefaultPorts == Just p = Nothing | otherwise = Just p - serializeAuthority' :: URINormalizationOptions -> Maybe Scheme -> Authority -> ByteString serializeAuthority' opts mScheme = BB.toByteString . serializeAuthority opts mScheme @@ -311,22 +337,19 @@ serializeUserInfo :: UserInfo -> Builder serializeUserInfo UserInfo {..} = bs uiUsername <> c8 ':' <> bs uiPassword <> c8 '@' - serializeUserInfo' :: UserInfo -> ByteString serializeUserInfo' = BB.toByteString . serializeUserInfo - ------------------------------------------------------------------------------- bs :: ByteString -> Builder bs = BB.fromByteString - ------------------------------------------------------------------------------- c8 :: Char -> Builder c8 = BB.fromChar - ------------------------------------------------------------------------------- + -- | Parse a strict ByteString into a URI or an error. -- -- Example: @@ -357,137 +380,151 @@ parseRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Relative) parseRelativeRef opts = parseOnly' OtherError (relativeRefParser' opts) - ------------------------------------------------------------------------------- + -- | Convenience alias for a parser that can return URIParseError type URIParser = Parser' URIParseError - ------------------------------------------------------------------------------- + -- | Underlying attoparsec parser. Useful for composing with your own parsers. uriParser :: URIParserOptions -> Parser (URIRef Absolute) uriParser = unParser' . uriParser' - ------------------------------------------------------------------------------- + -- | Toplevel parser for URIs uriParser' :: URIParserOptions -> URIParser (URIRef Absolute) 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 - + (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 ------------------------------------------------------------------------------- + -- | Underlying attoparsec parser. Useful for composing with your own parsers. relativeRefParser :: URIParserOptions -> Parser (URIRef Relative) relativeRefParser = unParser' . relativeRefParser' - ------------------------------------------------------------------------------- + -- | Toplevel parser for relative refs relativeRefParser' :: URIParserOptions -> URIParser (URIRef Relative) relativeRefParser' opts = do - (authority, path) <- hierPartParser <|> rrPathParser + (authority, path) <- relativePartParser query <- queryParser opts - frag <- mFragmentParser + frag <- mFragmentParser case frag of - Just _ -> endOfInput `orFailWith` MalformedFragment + 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 + 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 +-- | Corresponds to 'hier-part' in RFC 3986 section 3. +hierPartParser :: URIParser (Maybe Authority, ByteString) +hierPartParser = + authWithPathParser + <|> ((Nothing,) <$> pathAbsoluteParser `orFailWith` MalformedPath) + <|> ((Nothing,) <$> pathRootlessParser `orFailWith` MalformedPath) + <|> ((Nothing,) <$> pathEmptyParser `orFailWith` MalformedPath) ------------------------------------------------------------------------------- --- | Relative references have awkward corner cases. See --- 'firstRelRefSegmentParser'. -rrPathParser :: URIParser (Maybe Authority, ByteString) -rrPathParser = (Nothing,) <$> - ((<>) <$> firstRelRefSegmentParser <*> pathParser) +-- | Corresponds to 'relative-part' in RFC 3986 section 4.2. +relativePartParser :: URIParser (Maybe Authority, ByteString) +relativePartParser = + authWithPathParser + <|> ((Nothing,) <$> pathAbsoluteParser `orFailWith` MalformedPath) + <|> ((Nothing,) <$> pathNoSchemeParser `orFailWith` MalformedPath) + <|> ((Nothing,) <$> pathEmptyParser `orFailWith` MalformedPath) ------------------------------------------------------------------------------- + -- | See the "authority path-abempty" grammar in the RFC authWithPathParser :: URIParser (Maybe Authority, ByteString) -authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> pathParser) +authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> (pathAbEmptyParser `orFailWith` MalformedPath)) +------------------------------------------------------------------------------- +-- | See the "path-abempty" grammar in the RFC. +pathAbEmptyParser :: Parser ByteString +pathAbEmptyParser = mconcat <$> A.many' (sequenceM [string "/", segmentParser]) + ------------------------------------------------------------------------------- + -- | See the "path-absolute" grammar in the RFC. Essentially a special -- case of rootless. -pathAbsoluteParser :: URIParser (Maybe Authority, ByteString) -pathAbsoluteParser = string' "/" *> pathRootlessParser +pathAbsoluteParser :: Parser ByteString +pathAbsoluteParser = sequenceM [string "/", pathRootlessParser] +------------------------------------------------------------------------------- +-- | See the "path-noscheme" grammar in the RFC. +pathNoSchemeParser :: Parser ByteString +pathNoSchemeParser = sequenceM [segmentNZNCParser, pathAbEmptyParser] + ------------------------------------------------------------------------------- --- | See the "path-rootless" grammar in the RFC. -pathRootlessParser :: URIParser (Maybe Authority, ByteString) -pathRootlessParser = (,) <$> pure Nothing <*> pathParser1 +-- | See the "path-rootless" grammar in the RFC. +pathRootlessParser :: Parser ByteString +pathRootlessParser = sequenceM [segmentNZParser, pathAbEmptyParser] ------------------------------------------------------------------------------- + -- | 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) - +pathEmptyParser :: Parser ByteString +pathEmptyParser = (const BS.empty <$> pcharNotParser) <|> (const BS.empty <$> endOfInput) ------------------------------------------------------------------------------- + -- | 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 +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 + user <- manyC (pctEncodedParser <|> satisfyClass (subDelims ++ unreserved)) + pass <- passParser <|> pure BS.empty return $ UserInfo user pass - validForUserInfo = inClass $ pctEncoded ++ subDelims ++ (':' : unreserved) - + passParser = do + _ <- string ":" + manyC (pctEncodedParser <|> satisfyClass (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 @@ -495,76 +532,78 @@ 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 + 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 + 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 + _ <- 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] +ipV4Parser = + mconcat + <$> sequence + [ decOctet, + dot, + decOctet, + dot, + decOctet, + dot, + decOctet + ] where decOctet :: Parser ByteString decOctet = do - (s,num) <- A.match A.decimal + (s, num) <- A.match A.decimal let len = BS.length s guard $ len <= 3 guard $ num >= (1 :: Int) && 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 - +regNameParser = many1C (pctEncodedParser <|> satisfyClass (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 @@ -572,35 +611,20 @@ ------------------------------------------------------------------------------- --- | 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' +segmentParser :: Parser ByteString +segmentParser = manyC pcharParser +segmentNZParser :: Parser ByteString +segmentNZParser = many1C pcharParser -------------------------------------------------------------------------------- --- | 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 = (urlDecodeQuery . mconcat <$> repeatParser segmentParser) `orFailWith` MalformedPath - where - segmentParser = mconcat <$> sequence [string "/", A.takeWhile (inClass pchar)] +segmentNZNCParser :: Parser ByteString +segmentNZNCParser = many1C (pctEncodedParser <|> satisfyClass (subDelims <> "@" <> unreserved)) ------------------------------------------------------------------------------- --- | 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 @@ -612,78 +636,84 @@ case mc of Just c | c == question -> skip' 1 *> itemsParser - | c == hash -> pure mempty - | otherwise -> fail' MalformedPath - _ -> pure mempty + | c == hash -> pure mempty + | otherwise -> fail' MalformedPath + _ -> pure mempty where itemsParser = Query . filter neQuery <$> A.sepBy' (queryItemParser opts) (word8' ampersand) neQuery (k, _) = not (BS.null k) - ------------------------------------------------------------------------------- + -- | 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.takeWhile (upoValidQueryChar opts) `orFailWith` MalformedQuery - if BS.null s - then return (mempty, mempty) - else do - let (k, vWithEquals) = BS.break (== equals) s - let v = BS.drop 1 vWithEquals - return (urlDecodeQuery k, urlDecodeQuery v) - +queryItemParser opts = (`orFailWith` MalformedQuery) $ do + let parser = if upoLaxQueryParsing opts then queryLaxItemParser else queryItemParser' + k <- manyC parser + if BS.null k + then return (mempty, mempty) + else do + A.peekWord8 >>= \case + Just 61 -> do + _ <- string "=" + v <- manyC parser + return (k, v) + _ -> return (k, mempty) ------------------------------------------------------------------------------- -validForQuery :: Word8 -> Bool -validForQuery = inClass ('?':'/':delete '&' pchar) - +queryItemParser' :: Parser ByteString +queryItemParser' = pctEncodedParser <|> satisfyClass ('?' : '/' : (delete '=' $ delete '&' (subDelims ++ ":@" ++ unreserved))) ------------------------------------------------------------------------------- -validForQueryLax :: Word8 -> Bool -validForQueryLax = notInClass "&#" - +queryLaxItemParser :: Parser ByteString +queryLaxItemParser = pctEncodedParser <|> satisfyNotClass "&#=" ------------------------------------------------------------------------------- + -- | Only parses a fragment if the # signifiier is there mFragmentParser :: URIParser (Maybe ByteString) mFragmentParser = mParse $ word8' hash *> fragmentParser - ------------------------------------------------------------------------------- + -- | The final piece of a uri, e.g. #fragment, minus the #. fragmentParser :: URIParser ByteString -fragmentParser = Parser' $ A.takeWhile validFragmentWord - where - validFragmentWord = inClass ('?':'/':pchar) - +fragmentParser = Parser' $ manyC (pcharParser <|> satisfyClass ['?', '/']) ------------------------------------------------------------------------------- + -- | 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 +pcharParser :: Parser ByteString +pcharParser = pctEncodedParser <|> satisfyClass (subDelims ++ ":@" ++ unreserved) +pcharNotParser :: Parser ByteString +pcharNotParser = notPctEncodedParser <|> satisfyNotClass (subDelims ++ ":@" ++ unreserved) + where + notPctEncodedParser = do + w <- peekWord8 + case w of + Just 37 -> satisfyNotClass (subDelims ++ ":@" ++ unreserved) + _ -> fail "not percent encoded" + ------------------------------------------------------------------------------- -- Very important! When concatenating this to other strings to make larger -- character classes, you must put this at the end because the '-' character @@ -691,12 +721,10 @@ unreserved :: String unreserved = alphaNum ++ "~._-" - ------------------------------------------------------------------------------- unreserved8 :: [Word8] unreserved8 = map ord8 unreserved - ------------------------------------------------------------------------------- unreservedPath8 :: [Word8] unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$," @@ -705,138 +733,116 @@ 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 = "%" +pctEncodedParser :: Parser ByteString +pctEncodedParser = string "%" *> (decode <$> A.satisfy hexDigit <*> A.satisfy hexDigit) + where + decode w1 w2 = BS.singleton $ combine (hexVal w1) (hexVal w2) + hexVal w + | 48 <= w && w <= 57 = w - 48 -- 0 - 9 + | 65 <= w && w <= 70 = w - 55 -- A - F + | 97 <= w && w <= 102 = w - 87 -- a - f + | otherwise = error $ "Not a hex value: " <> show w + combine a b = shiftL a 4 .|. b + ------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- | Decoding specifically for the query string, which decodes + as --- space. Shorthand for @urlDecode True@ -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' { unParser' :: Parser a} - deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , Semigroup.Semigroup - , Monoid) - +newtype Parser' e a = Parser' {unParser' :: Parser a} + deriving + ( Functor, + Applicative, + Alternative, + Monad, + MonadPlus, + Semigroup.Semigroup, + Monoid + ) -instance F.MonadFail (Parser' e) where #if MIN_VERSION_attoparsec(0,13,1) +instance F.MonadFail (Parser' e) where fail e = Parser' (F.fail e) #else +instance F.MonadFail (Parser' e) where fail e = Parser' (fail e) #endif - ------------------------------------------------------------------------------- + -- | Use with caution. Catch a parser failing and return Nothing. mParse :: Parser' e a -> Parser' e (Maybe a) mParse p = A.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 @@ -844,61 +850,63 @@ 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) => Parser a -> e -> Parser' e a orFailWith p e = Parser' p <|> fail' e - ------------------------------------------------------------------------------- + -- | Should be preferred to fail' fail' :: (Show 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) - => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality. - -> Parser' e a - -> ByteString - -> Either e a +parseOnly' :: + (Read e) => + -- | Fallback if we can't parse a failure message for the sake of totality. + (String -> e) -> + 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 @@ -906,99 +914,86 @@ 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 extracted 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. Specify a list of additional -- unreserved characters to permit. urlEncode :: [Word8] -> ByteString -> Builder urlEncode extraUnreserved = mconcat . map encodeChar . BS.unpack - where - encodeChar ch | unreserved' ch = BB.fromWord8 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 + where + encodeChar ch + | unreserved' ch = BB.fromWord8 ch + | otherwise = h2 ch - 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 + 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 ------------------------------------------------------------------------------- + -- | Encode a ByteString for use in the query section of a URL urlEncodeQuery :: ByteString -> Builder urlEncodeQuery = urlEncode unreserved8 - ------------------------------------------------------------------------------- + -- | Encode a ByteString for use in the path section of a URL urlEncodePath :: ByteString -> Builder urlEncodePath = urlEncode unreservedPath8 - ------------------------------------------------------------------------------- downcaseBS :: ByteString -> ByteString downcaseBS = BS8.map toLower - ------------------------------------------------------------------------------- + -- | Simple data structure to get O(1) prepends on a list and defers the O(n) newtype RL a = RL [a] deriving (Show) - (|>) :: RL a -> a -> RL a -RL as |> a = RL (a:as) - +RL as |> a = RL (a : as) rl2L :: RL a -> [a] rl2L (RL as) = reverse as - unsnoc :: RL a -> RL a -unsnoc (RL []) = RL [] -unsnoc (RL (_:xs)) = RL xs +unsnoc (RL []) = RL [] +unsnoc (RL (_ : xs)) = RL xs + + +sequenceM :: (Semigroup a, Monoid a, Traversable t, Monad m) => t (m a) -> m a +sequenceM = fmap (foldr (<>) mempty) . sequence + +satisfy' :: (Word8 -> Bool) -> Parser ByteString +satisfy' f = BS.singleton <$> A.satisfy f + +many1C :: (Monoid a, Semigroup a, MonadPlus m) => m a -> m a +many1C = fmap mconcat . A.many1 + +manyC :: (Monoid a, Semigroup a, MonadPlus m) => m a -> m a +manyC = fmap mconcat . A.many' + +satisfyClass :: String -> Parser ByteString +satisfyClass = satisfy' . inClass + +satisfyNotClass :: String -> Parser ByteString +satisfyNotClass = satisfy' . notInClass + diff --git a/src/URI/ByteString/Lens.hs b/src/URI/ByteString/Lens.hs --- a/src/URI/ByteString/Lens.hs +++ b/src/URI/ByteString/Lens.hs @@ -1,217 +1,203 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -module URI.ByteString.Lens where +module URI.ByteString.Lens where ------------------------------------------------------------------------------- -import Control.Applicative -import Data.ByteString (ByteString) -import Data.Word -------------------------------------------------------------------------------- -import Prelude +import Control.Applicative +import Data.ByteString (ByteString) ------------------------------------------------------------------------------- -import URI.ByteString.Types + ------------------------------------------------------------------------------- +import URI.ByteString.Types +import Prelude +------------------------------------------------------------------------------- ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -schemeBSL - :: Lens' Scheme ByteString +schemeBSL :: + Lens' Scheme ByteString schemeBSL = - lens schemeBS (\a b -> a { schemeBS = b}) + lens schemeBS (\a b -> a {schemeBS = b}) {-# INLINE schemeBSL #-} ------------------------------------------------------------------------------- -hostBSL - :: Lens' Host ByteString +hostBSL :: + Lens' Host ByteString hostBSL = - lens hostBS (\a b -> a { hostBS = b}) + lens hostBS (\a b -> a {hostBS = b}) {-# INLINE hostBSL #-} - ------------------------------------------------------------------------------- -portNumberL - :: Lens' Port Int +portNumberL :: + Lens' Port Int portNumberL = - lens portNumber (\a b -> a { portNumber = b}) + lens portNumber (\a b -> a {portNumber = b}) {-# INLINE portNumberL #-} - ------------------------------------------------------------------------------- -authorityUserInfoL - :: Lens' Authority (Maybe UserInfo) +authorityUserInfoL :: + Lens' Authority (Maybe UserInfo) authorityUserInfoL = - lens authorityUserInfo (\a b -> a { authorityUserInfo = b}) + lens authorityUserInfo (\a b -> a {authorityUserInfo = b}) {-# INLINE authorityUserInfoL #-} ------------------------------------------------------------------------------- -authorityHostL - :: Lens' Authority Host +authorityHostL :: + Lens' Authority Host authorityHostL = - lens authorityHost (\a b -> a { authorityHost = b}) + lens authorityHost (\a b -> a {authorityHost = b}) {-# INLINE authorityHostL #-} ------------------------------------------------------------------------------- -authorityPortL - :: Lens' Authority (Maybe Port) +authorityPortL :: + Lens' Authority (Maybe Port) authorityPortL = - lens authorityPort (\a b -> a { authorityPort = b}) + lens authorityPort (\a b -> a {authorityPort = b}) {-# INLINE authorityPortL #-} ------------------------------------------------------------------------------- -uiUsernameL - :: Lens' UserInfo ByteString +uiUsernameL :: + Lens' UserInfo ByteString uiUsernameL = - lens uiUsername (\a b -> a { uiUsername = b}) + lens uiUsername (\a b -> a {uiUsername = b}) {-# INLINE uiUsernameL #-} - ------------------------------------------------------------------------------- -uiPasswordL - :: Lens' UserInfo ByteString +uiPasswordL :: + Lens' UserInfo ByteString uiPasswordL = - lens uiPassword (\a b -> a { uiPassword = b}) + lens uiPassword (\a b -> a {uiPassword = b}) {-# INLINE uiPasswordL #-} - ------------------------------------------------------------------------------- -queryPairsL - :: Lens' Query [(ByteString, ByteString)] +queryPairsL :: + Lens' Query [(ByteString, ByteString)] queryPairsL = - lens queryPairs (\a b -> a { queryPairs = b}) + lens queryPairs (\a b -> a {queryPairs = b}) {-# INLINE queryPairsL #-} - ------------------------------------------------------------------------------- uriAuthorityL :: Lens' URI (Maybe Authority) uriAuthorityL = - lens uriAuthority (\a b -> a { uriAuthority = b}) + lens uriAuthority (\a b -> a {uriAuthority = b}) {-# INLINE uriAuthorityL #-} {-# DEPRECATED uriAuthorityL "Use 'authorityL' instead" #-} - ------------------------------------------------------------------------------- uriPathL :: Lens' URI ByteString uriPathL = - lens uriPath (\a b -> a { uriPath = b}) + lens uriPath (\a b -> a {uriPath = b}) {-# INLINE uriPathL #-} {-# DEPRECATED uriPathL "Use 'pathL' instead" #-} - ------------------------------------------------------------------------------- uriQueryL :: Lens' URI Query uriQueryL = - lens uriQuery (\a b -> a { uriQuery = b}) + lens uriQuery (\a b -> a {uriQuery = b}) {-# INLINE uriQueryL #-} {-# DEPRECATED uriQueryL "Use 'queryL' instead" #-} - ------------------------------------------------------------------------------- uriFragmentL :: Lens' URI (Maybe ByteString) uriFragmentL = - lens uriFragment (\a b -> a { uriFragment = b}) + lens uriFragment (\a b -> a {uriFragment = b}) {-# INLINE uriFragmentL #-} {-# DEPRECATED uriFragmentL "Use 'fragmentL' instead" #-} - ------------------------------------------------------------------------------- rrAuthorityL :: Lens' RelativeRef (Maybe Authority) rrAuthorityL = - lens rrAuthority (\a b -> a { rrAuthority = b}) + lens rrAuthority (\a b -> a {rrAuthority = b}) {-# INLINE rrAuthorityL #-} {-# DEPRECATED rrAuthorityL "Use 'authorityL' instead" #-} - ------------------------------------------------------------------------------- rrPathL :: Lens' RelativeRef ByteString rrPathL = - lens rrPath (\a b -> a { rrPath = b}) + lens rrPath (\a b -> a {rrPath = b}) {-# INLINE rrPathL #-} {-# DEPRECATED rrPathL "Use 'pathL' instead" #-} - ------------------------------------------------------------------------------- rrQueryL :: Lens' RelativeRef Query rrQueryL = - lens rrQuery (\a b -> a { rrQuery = b}) + lens rrQuery (\a b -> a {rrQuery = b}) {-# INLINE rrQueryL #-} {-# DEPRECATED rrQueryL "Use 'queryL' instead" #-} - ------------------------------------------------------------------------------- rrFragmentL :: Lens' RelativeRef (Maybe ByteString) rrFragmentL = - lens rrFragment (\a b -> a { rrFragment = b}) + lens rrFragment (\a b -> a {rrFragment = b}) {-# INLINE rrFragmentL #-} {-# DEPRECATED rrFragmentL "Use 'fragmentL' instead" #-} - ------------------------------------------------------------------------------- uriSchemeL :: Lens' (URIRef Absolute) Scheme -uriSchemeL = lens uriScheme setter where - setter :: URIRef Absolute -> Scheme -> URIRef Absolute - setter (URI _ b c d e) a' = URI a' b c d e +uriSchemeL = lens uriScheme setter + where + setter :: URIRef Absolute -> Scheme -> URIRef Absolute + setter (URI _ b c d e) a' = URI a' b c d e {-# INLINE uriSchemeL #-} - ------------------------------------------------------------------------------- authorityL :: Lens' (URIRef a) (Maybe Authority) -authorityL = lens getter setter where - getter :: URIRef a -> Maybe Authority - getter (URI {..}) = uriAuthority - getter (RelativeRef {..}) = rrAuthority - setter :: URIRef a -> Maybe Authority -> URIRef a - setter (URI a _ c d e) b' = URI a b' c d e - setter (RelativeRef _ c d e) b' = RelativeRef b' c d e +authorityL = lens getter setter + where + getter :: URIRef a -> Maybe Authority + getter (URI {..}) = uriAuthority + getter (RelativeRef {..}) = rrAuthority + setter :: URIRef a -> Maybe Authority -> URIRef a + setter (URI a _ c d e) b' = URI a b' c d e + setter (RelativeRef _ c d e) b' = RelativeRef b' c d e {-# INLINE authorityL #-} - ------------------------------------------------------------------------------- pathL :: Lens' (URIRef a) ByteString -pathL = lens getter setter where - getter :: URIRef a -> ByteString - getter (URI {..}) = uriPath - getter (RelativeRef {..}) = rrPath - setter :: URIRef a -> ByteString -> URIRef a - setter (URI a b _ d e) c' = URI a b c' d e - setter (RelativeRef b _ d e) c' = RelativeRef b c' d e +pathL = lens getter setter + where + getter :: URIRef a -> ByteString + getter (URI {..}) = uriPath + getter (RelativeRef {..}) = rrPath + setter :: URIRef a -> ByteString -> URIRef a + setter (URI a b _ d e) c' = URI a b c' d e + setter (RelativeRef b _ d e) c' = RelativeRef b c' d e {-# INLINE pathL #-} - ------------------------------------------------------------------------------- queryL :: Lens' (URIRef a) Query -queryL = lens getter setter where - getter :: URIRef a -> Query - getter (URI {..}) = uriQuery - getter (RelativeRef {..}) = rrQuery - setter :: URIRef a -> Query -> URIRef a - setter (URI a b c _ e) d' = URI a b c d' e - setter (RelativeRef b c _ e) d' = RelativeRef b c d' e +queryL = lens getter setter + where + getter :: URIRef a -> Query + getter (URI {..}) = uriQuery + getter (RelativeRef {..}) = rrQuery + setter :: URIRef a -> Query -> URIRef a + setter (URI a b c _ e) d' = URI a b c d' e + setter (RelativeRef b c _ e) d' = RelativeRef b c d' e {-# INLINE queryL #-} - ------------------------------------------------------------------------------- fragmentL :: Lens' (URIRef a) (Maybe ByteString) -fragmentL = lens getter setter where - getter :: URIRef a -> Maybe ByteString - getter (URI {..}) = uriFragment - getter (RelativeRef {..}) = rrFragment - setter :: URIRef a -> Maybe ByteString -> URIRef a - setter (URI a b c d _) e' = URI a b c d e' - setter (RelativeRef b c d _) e' = RelativeRef b c d e' +fragmentL = lens getter setter + where + getter :: URIRef a -> Maybe ByteString + getter (URI {..}) = uriFragment + getter (RelativeRef {..}) = rrFragment + setter :: URIRef a -> Maybe ByteString -> URIRef a + setter (URI a b c d _) e' = URI a b c d e' + setter (RelativeRef b c d _) e' = RelativeRef b c d e' {-# INLINE fragmentL #-} - ------------------------------------------------------------------------------- -upoValidQueryCharL :: Lens' URIParserOptions (Word8 -> Bool) +upoValidQueryCharL :: Lens' URIParserOptions Bool upoValidQueryCharL = - lens upoValidQueryChar (\a b -> a { upoValidQueryChar = b}) + lens upoLaxQueryParsing (\a b -> a {upoLaxQueryParsing = b}) {-# INLINE upoValidQueryCharL #-} - ------------------------------------------------------------------------------- -- Lens machinery ------------------------------------------------------------------------------- @@ -219,7 +205,6 @@ type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t type Lens' s a = Lens s s a a - ------------------------------------------------------------------------------- lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b diff --git a/src/URI/ByteString/QQ.hs b/src/URI/ByteString/QQ.hs --- a/src/URI/ByteString/QQ.hs +++ b/src/URI/ByteString/QQ.hs @@ -1,48 +1,48 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module URI.ByteString.QQ - ( uri - , relativeRef - ) where + ( uri, + relativeRef, + ) +where +import Data.ByteString.Char8 +import Instances.TH.Lift () import Language.Haskell.TH.Quote import URI.ByteString -import Data.ByteString.Char8 -import Instances.TH.Lift() +-- $setup +-- >>> :set -XQuasiQuotes + -- | Allows uri literals via QuasiQuotes language extension. -- --- >>> {-# LANGUAGE QuasiQuotes #-} --- >>> stackage :: URI -- >>> stackage = [uri|http://stackage.org|] uri :: QuasiQuoter -uri = QuasiQuoter { quoteExp = \s -> - let - parsedURI = either (\err -> error $ show err) id (parseURI laxURIParserOptions (pack s)) - in - [| parsedURI |], - quotePat = error "Not implemented.", - quoteType = error "Not implemented.", - quoteDec = error "Not implemented." - } - +uri = + QuasiQuoter + { quoteExp = \s -> + let parsedURI = either (\err -> error $ show err) id (parseURI laxURIParserOptions (pack s)) + in [|parsedURI|], + quotePat = error "Not implemented.", + quoteType = error "Not implemented.", + quoteDec = error "Not implemented." + } ------------------------------------------------------------------------------- + -- | Allows relative ref literals via QuasiQuotes language extension. -- --- >>> {-# LANGUAGE QuasiQuotes #-} --- >>> ref :: RelativeRef -- >>> ref = [relativeRef|/foo?bar=baz#quux|] relativeRef :: QuasiQuoter -relativeRef = QuasiQuoter { quoteExp = \s -> - let - parsedURI = either (\err -> error $ show err) id (parseRelativeRef laxURIParserOptions (pack s)) - in - [| parsedURI |], - quotePat = error "Not implemented.", - quoteType = error "Not implemented.", - quoteDec = error "Not implemented." - } +relativeRef = + QuasiQuoter + { quoteExp = \s -> + let parsedURI = either (\err -> error $ show err) id (parseRelativeRef laxURIParserOptions (pack s)) + in [|parsedURI|], + quotePat = error "Not implemented.", + quoteType = error "Not implemented.", + quoteDec = error "Not implemented." + } diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs --- a/src/URI/ByteString/Types.hs +++ b/src/URI/ByteString/Types.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + #ifdef LIFT_COMPAT {-# LANGUAGE TemplateHaskell #-} #else @@ -12,16 +13,16 @@ module URI.ByteString.Types where ------------------------------------------------------------------------------- -import Data.ByteString (ByteString) -import qualified Data.Map.Strict as M -import Data.Monoid -import Data.Semigroup as Semigroup -import Data.Typeable -import Data.Word -import GHC.Generics -import Instances.TH.Lift () +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Semigroup as Semigroup +import Data.Typeable +import GHC.Generics +import Instances.TH.Lift () ------------------------------------------------------------------------------- -import Prelude +import Prelude + ------------------------------------------------------------------------------- #ifdef LIFT_COMPAT import Language.Haskell.TH.Lift @@ -32,7 +33,7 @@ -- | 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 } +newtype Scheme = Scheme {schemeBS :: ByteString} deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT @@ -42,7 +43,7 @@ #endif ------------------------------------------------------------------------------- -newtype Host = Host { hostBS :: ByteString } +newtype Host = Host {hostBS :: ByteString} deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT @@ -52,9 +53,10 @@ #endif ------------------------------------------------------------------------------- + -- | 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 } +newtype Port = Port {portNumber :: Int} deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT @@ -64,10 +66,11 @@ #endif ------------------------------------------------------------------------------- -data UserInfo = UserInfo { - uiUsername :: ByteString - , uiPassword :: ByteString - } deriving (Show, Eq, Generic, Typeable, Ord) +data UserInfo = UserInfo + { uiUsername :: ByteString, + uiPassword :: ByteString + } + deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''UserInfo @@ -76,11 +79,12 @@ #endif ------------------------------------------------------------------------------- -data Authority = Authority { - authorityUserInfo :: Maybe UserInfo - , authorityHost :: Host - , authorityPort :: Maybe Port - } deriving (Show, Eq, Generic, Typeable, Ord) +data Authority = Authority + { authorityUserInfo :: Maybe UserInfo, + authorityHost :: Host, + authorityPort :: Maybe Port + } + deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Authority @@ -89,8 +93,8 @@ #endif ------------------------------------------------------------------------------- -newtype Query = Query { queryPairs :: [(ByteString, ByteString)] } - deriving (Show, Eq, Semigroup.Semigroup, Monoid, Generic, Typeable, Ord) +newtype Query = Query {queryPairs :: [(ByteString, ByteString)]} + deriving (Show, Eq, Semigroup.Semigroup, Monoid, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Query @@ -99,7 +103,7 @@ #endif ------------------------------------------------------------------------------- -data Absolute deriving(Typeable) +data Absolute deriving (Typeable) #ifdef LIFT_COMPAT deriveLift ''Absolute @@ -108,7 +112,7 @@ #endif ------------------------------------------------------------------------------- -data Relative deriving(Typeable) +data Relative deriving (Typeable) #ifdef LIFT_COMPAT deriveLift ''Relative @@ -117,24 +121,32 @@ #endif ------------------------------------------------------------------------------- + -- | Note: URI fragment does not include the # data URIRef a where - URI :: { uriScheme :: Scheme - , uriAuthority :: Maybe Authority - , uriPath :: ByteString - , uriQuery :: Query - , uriFragment :: Maybe ByteString - } -> URIRef Absolute - RelativeRef :: { rrAuthority :: Maybe Authority - , rrPath :: ByteString - , rrQuery :: Query - , rrFragment :: Maybe ByteString - } -> URIRef Relative + URI :: + { uriScheme :: Scheme, + uriAuthority :: Maybe Authority, + uriPath :: ByteString, + uriQuery :: Query, + uriFragment :: Maybe ByteString + } -> + URIRef Absolute + RelativeRef :: + { rrAuthority :: Maybe Authority, + rrPath :: ByteString, + rrQuery :: Query, + rrFragment :: Maybe ByteString + } -> + URIRef Relative deriving instance Show (URIRef a) + deriving instance Eq (URIRef a) + -- deriving instance Generic (URIRef a) deriving instance Ord (URIRef a) + #ifdef LIFT_COMPAT deriveLift ''URIRef #else @@ -148,58 +160,62 @@ ------------------------------------------------------------------------------- type URI = URIRef Absolute - ------------------------------------------------------------------------------- type RelativeRef = URIRef Relative - ------------------------------------------------------------------------------- + -- | Options for the parser. You will probably want to use either -- "strictURIParserOptions" or "laxURIParserOptions" -data URIParserOptions = URIParserOptions { - upoValidQueryChar :: Word8 -> Bool - } - +data URIParserOptions = URIParserOptions + { upoLaxQueryParsing :: Bool + } ------------------------------------------------------------------------------- -data URINormalizationOptions = URINormalizationOptions { - unoDowncaseScheme :: Bool - -- ^ hTtP -> http - , unoDowncaseHost :: Bool - -- ^ eXaMpLe.org -> example.org - , unoDropDefPort :: Bool - -- ^ If the scheme is known and the port is the default (e.g. 80 for http) it is removed. - , unoSlashEmptyPath :: Bool - -- ^ If the path is empty, set it to \/ - , unoDropExtraSlashes :: Bool - -- ^ Rewrite path from \/foo\/\/bar\/\/\/baz to \/foo\/bar\/baz - , unoSortParameters :: Bool - -- ^ Sorts parameters by parameter name - , unoRemoveDotSegments :: Bool - -- ^ Remove dot segments as per - , unoDefaultPorts :: M.Map Scheme Port - -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled. - } deriving (Show, Eq) - +data URINormalizationOptions = URINormalizationOptions + { -- | hTtP -> http + unoDowncaseScheme :: Bool, + -- | eXaMpLe.org -> example.org + unoDowncaseHost :: Bool, + -- | If the scheme is known and the port is the default (e.g. 80 for http) it is removed. + unoDropDefPort :: Bool, + -- | If the path is empty, set it to \/ + unoSlashEmptyPath :: Bool, + -- | Rewrite path from \/foo\/\/bar\/\/\/baz to \/foo\/bar\/baz + unoDropExtraSlashes :: Bool, + -- | Sorts parameters by parameter name + unoSortParameters :: Bool, + -- | Remove dot segments as per + unoRemoveDotSegments :: Bool, + -- | Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled. + unoDefaultPorts :: M.Map Scheme Port + } + deriving (Show, Eq) ------------------------------------------------------------------------------- --- | URI Parser Types -------------------------------------------------------------------------------- +-- | 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, Enum, Bounded) +------------------------------------------------------------------------------- +data SchemaError + = -- | Scheme must start with an alphabet character + NonAlphaLeading + | -- | Subsequent characters in the schema were invalid + InvalidChars + | -- | Schemas must be followed by a colon + MissingColon + deriving (Show, Eq, Read, Generic, Typeable, Enum, Bounded) ------------------------------------------------------------------------------- -data URIParseError = MalformedScheme SchemaError - | MalformedUserInfo - | MalformedQuery - | MalformedFragment - | MalformedHost - | MalformedPort - | MalformedPath - | OtherError String -- ^ Catchall for unpredictable errors - deriving (Show, Eq, Generic, Read, Typeable) +data URIParseError + = MalformedScheme SchemaError + | MalformedUserInfo + | MalformedQuery + | MalformedFragment + | MalformedHost + | MalformedPort + | MalformedPath + | -- | Catchall for unpredictable errors + OtherError String + 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,19 +1,21 @@ module Main (main) where ------------------------------------------------------------------------------- -import Test.Tasty +import Test.Tasty ------------------------------------------------------------------------------- -import qualified URI.ByteStringTests + import qualified URI.ByteStringQQTests -------------------------------------------------------------------------------- +import qualified URI.ByteStringTests +------------------------------------------------------------------------------- main :: IO () main = defaultMain testSuite testSuite :: TestTree -testSuite = testGroup "uri-bytestring" - [ - URI.ByteStringTests.tests - , URI.ByteStringQQTests.tests - ] +testSuite = + testGroup + "uri-bytestring" + [ URI.ByteStringTests.tests, + URI.ByteStringQQTests.tests + ] diff --git a/test/URI/ByteString/Generators.hs b/test/URI/ByteString/Generators.hs --- a/test/URI/ByteString/Generators.hs +++ b/test/URI/ByteString/Generators.hs @@ -1,69 +1,67 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module URI.ByteString.Generators where +module URI.ByteString.Generators where ------------------------------------------------------------------------------- -import Control.Applicative -import Data.ByteString (ByteString) -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -------------------------------------------------------------------------------- -import Prelude -------------------------------------------------------------------------------- -import URI.ByteString +import Control.Applicative +import Data.ByteString (ByteString) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +import URI.ByteString +import Prelude +------------------------------------------------------------------------------- genUserInfo :: Gen UserInfo genUserInfo = do username <- Gen.utf8 (Range.linear 0 100) Gen.ascii password <- Gen.utf8 (Range.linear 0 100) Gen.ascii - pure $ UserInfo - { uiUsername = username - , uiPassword = password - } - + pure $ + UserInfo + { uiUsername = username, + uiPassword = password + } genAuthority :: Gen Authority genAuthority = do userInfo <- Gen.maybe genUserInfo host <- genHost port <- Gen.maybe genPort - pure $ Authority - { authorityUserInfo = userInfo - , authorityHost = host - , authorityPort = port - } - + pure $ + Authority + { authorityUserInfo = userInfo, + authorityHost = host, + authorityPort = port + } genHost :: Gen Host genHost = Host <$> Gen.utf8 (Range.linear 0 100) Gen.ascii - genPort :: Gen Port genPort = Port <$> genPositiveInt - genRelativeURIRef :: Gen (URIRef Relative) genRelativeURIRef = do authority <- Gen.maybe genAuthority path <- Gen.utf8 (Range.linear 0 100) Gen.ascii query <- genQuery fragment <- Gen.maybe genAlphaNumBS - pure $ RelativeRef - { rrAuthority = authority - , rrPath = path - , rrQuery = query - , rrFragment = fragment - } - + pure $ + RelativeRef + { rrAuthority = authority, + rrPath = path, + rrQuery = query, + rrFragment = fragment + } genAbsoluteURIRef :: Gen (URIRef Absolute) genAbsoluteURIRef = do @@ -72,34 +70,33 @@ path <- Gen.utf8 (Range.linear 0 100) Gen.ascii query <- genQuery fragment <- Gen.maybe genAlphaNumBS - pure $ URI - { uriScheme = scheme - , uriAuthority = authority - , uriPath = path - , uriQuery = query - , uriFragment = fragment - } - + pure $ + URI + { uriScheme = scheme, + uriAuthority = authority, + uriPath = path, + uriQuery = query, + uriFragment = fragment + } genScheme :: Gen Scheme genScheme = Scheme <$> genAlphaNumBS - genQuery :: Gen Query genQuery = do pairs <- Gen.list (Range.linear 0 10) ((,) <$> genAlphaNumBS <*> genAlphaNumBS) - pure $ Query - { queryPairs = pairs - } - + pure $ + Query + { queryPairs = pairs + } genURIParserOptions :: Gen URIParserOptions genURIParserOptions = do cointoss <- Gen.bool - pure $ URIParserOptions - { upoValidQueryChar = const cointoss - } - + pure $ + URIParserOptions + { upoLaxQueryParsing = cointoss + } genURINormalizationOptions :: Gen URINormalizationOptions genURINormalizationOptions = do @@ -111,46 +108,42 @@ dSort <- Gen.bool dSegments <- Gen.bool ports <- Gen.map (Range.linear 0 10) ((,) <$> genScheme <*> genPort) - pure $ URINormalizationOptions - { unoDowncaseScheme = dScheme - , unoDowncaseHost = dHost - , unoDropDefPort = dPort - , unoSlashEmptyPath = slashPath - , unoDropExtraSlashes = dSlashes - , unoSortParameters = dSort - , unoRemoveDotSegments = dSegments - , unoDefaultPorts = ports - } - + pure $ + URINormalizationOptions + { unoDowncaseScheme = dScheme, + unoDowncaseHost = dHost, + unoDropDefPort = dPort, + unoSlashEmptyPath = slashPath, + unoDropExtraSlashes = dSlashes, + unoSortParameters = dSort, + unoRemoveDotSegments = dSegments, + unoDefaultPorts = ports + } genSchemaError :: Gen SchemaError genSchemaError = Gen.enumBounded - genURIParseError :: Gen URIParseError -genURIParseError = Gen.choice - [ MalformedScheme <$> genSchemaError - , pure MalformedUserInfo - , pure MalformedQuery - , pure MalformedFragment - , pure MalformedHost - , pure MalformedPort - , pure MalformedPath - , OtherError <$> genString - ] - +genURIParseError = + Gen.choice + [ MalformedScheme <$> genSchemaError, + pure MalformedUserInfo, + pure MalformedQuery, + pure MalformedFragment, + pure MalformedHost, + pure MalformedPort, + pure MalformedPath, + OtherError <$> genString + ] genString :: Gen String genString = Gen.string (Range.linear 0 100) Gen.unicode - genAlphaNumBS :: Gen ByteString genAlphaNumBS = Gen.utf8 (Range.linear 0 100) Gen.alphaNum - genBS :: Gen ByteString genBS = Gen.utf8 (Range.linear 0 100) Gen.unicode - genPositiveInt :: Gen Int genPositiveInt = Gen.int (Range.linear 0 maxBound) diff --git a/test/URI/ByteStringQQTests.hs b/test/URI/ByteStringQQTests.hs --- a/test/URI/ByteStringQQTests.hs +++ b/test/URI/ByteStringQQTests.hs @@ -1,28 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module URI.ByteStringQQTests (tests) where +{-# LANGUAGE QuasiQuotes #-} +module URI.ByteStringQQTests (tests) where ------------------------------------------------------------------------------- -import Test.Tasty -import Test.Tasty.HUnit -------------------------------------------------------------------------------- -import URI.ByteString -import URI.ByteString.QQ +import Test.Tasty +import Test.Tasty.HUnit ------------------------------------------------------------------------------- +import URI.ByteString +import URI.ByteString.QQ +------------------------------------------------------------------------------- quasiTest :: URI quasiTest = [uri|https://stackage.org/foo?bar=baz#quux|] - quasiRelTest :: RelativeRef quasiRelTest = [relativeRef|/foo?bar=baz#quux|] tests :: TestTree -tests = testGroup "URI.ByteString.QQ" - [ testCase "uri quasi quoter produces expected RelativeRef" $ do - quasiTest @?= URI (Scheme "https") (Just (Authority Nothing (Host "stackage.org") Nothing)) "/foo" (Query [("bar", "baz")]) (Just "quux") - , testCase "relativeRef quasi quoter produces expected RelativeRef" $ do - quasiRelTest @?= RelativeRef Nothing "/foo" (Query [("bar", "baz")]) (Just "quux") - ] +tests = + testGroup + "URI.ByteString.QQ" + [ testCase "uri quasi quoter produces expected RelativeRef" $ do + quasiTest @?= URI (Scheme "https") (Just (Authority Nothing (Host "stackage.org") Nothing)) "/foo" (Query [("bar", "baz")]) (Just "quux"), + testCase "relativeRef quasi quoter produces expected RelativeRef" $ do + quasiRelTest @?= RelativeRef Nothing "/foo" (Query [("bar", "baz")]) (Just "quux") + ] diff --git a/test/URI/ByteStringTests.hs b/test/URI/ByteStringTests.hs --- a/test/URI/ByteStringTests.hs +++ b/test/URI/ByteStringTests.hs @@ -1,482 +1,557 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} + module URI.ByteStringTests (tests) where ------------------------------------------------------------------------------- -import qualified Blaze.ByteString.Builder as BB -import Control.Applicative (Const (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import Data.Either -import Data.Function.Compat ((&)) -import Data.Functor.Identity (Identity (..)) -import qualified Data.Map.Strict as M -import Data.Monoid -import Hedgehog -import qualified Hedgehog.Gen as Gen -import Safe (readMay) -import Test.Tasty -import Test.Tasty.Hedgehog -import Test.Tasty.HUnit +import qualified Blaze.ByteString.Builder as BB +import Control.Applicative (Const (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import Data.Either +import Data.Function.Compat ((&)) +import Data.Functor.Identity (Identity (..)) +import qualified Data.Map.Strict as M +import Data.Monoid +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Safe (readMay) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog ------------------------------------------------------------------------------- -import Prelude + ------------------------------------------------------------------------------- -import URI.ByteString -import URI.ByteString.Generators +import URI.ByteString +import URI.ByteString.Generators ------------------------------------------------------------------------------- -import URI.ByteStringQQTests () +import URI.ByteStringQQTests () +import Prelude infixr 4 .~ + (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t (.~) l b s = runIdentity (l (const (Identity b)) s) -infixl ^. +infixl 9 ^. + (^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a s ^. l = getConst (l Const s) - tests :: TestTree -tests = testGroup "URI.Bytestring" - [ - parseUriTests - , uriParseErrorInstancesTests - , lensTests - , serializeURITests - , normalizeURITests - ] - +tests = + testGroup + "URI.Bytestring" + [ parseUriTests, + uriParseErrorInstancesTests, + lensTests, + serializeURITests, + normalizeURITests + ] ------------------------------------------------------------------------------- parseUriTests :: TestTree -parseUriTests = testGroup "parseUri" - [ - testParses "http://www.example.org/" $ - URI (Scheme "http") +parseUriTests = + testGroup + "parseUri" + [ testParses "http://www.example.org/" $ + URI + (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/" mempty - Nothing - , testParseHost "http://www.example.org" "www.example.org" - -- IPV4 - , testParseHost "http://192.168.1.1" "192.168.1.1" - -- IPV6 - , testParseHost "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210" - , testParseHost "http://[1080:0:0:0:8:800:200C:417A]" "1080:0:0:0:8:800:200C:417A" - , testParseHost "http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1" - , testParseHost "http://[::192.9.5.5]" "::192.9.5.5" - , testParseHost "http://[::FFFF:129.144.52.38]" "::FFFF:129.144.52.38" - , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" - , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" - -- IPVFuture - , testParseHost "http://[v1.fe80::a+en1]" "v1.fe80::a+en1" - , testParses "https://user:pass:wo%20rd@www.example.org?foo=bar&foo=baz+quux#frag" $ - URI (Scheme "https") + Nothing, + testParseHost "http://www.example.org" "www.example.org", + -- IPV4 + testParseHost "http://192.168.1.1" "192.168.1.1", + -- IPV6 + testParseHost "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210", + testParseHost "http://[1080:0:0:0:8:800:200C:417A]" "1080:0:0:0:8:800:200C:417A", + testParseHost "http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1", + testParseHost "http://[::192.9.5.5]" "::192.9.5.5", + testParseHost "http://[::FFFF:129.144.52.38]" "::FFFF:129.144.52.38", + testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179", + testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179", + -- IPVFuture + testParseHost "http://[v1.fe80::a+en1]" "v1.fe80::a+en1", + testParses "https://user:pass:wo%20rd@www.example.org?foo=bar&foo=baz+quux#frag" $ + URI + (Scheme "https") (Just (Authority (Just (UserInfo "user" "pass:wo rd")) (Host "www.example.org") Nothing)) "" - (Query [("foo", "bar"), ("foo", "baz quux")]) - (Just "frag") - -- trailing & - , testParses "http://www.example.org?foo=bar&" $ - URI (Scheme "http") + (Query [("foo", "bar"), ("foo", "baz+quux")]) + (Just "frag"), + testParses "https://user@www.example.org" $ + URI + (Scheme "https") + (Just (Authority (Just (UserInfo "user" "")) (Host "www.example.org") Nothing)) + "" + (Query []) + Nothing, + testParses "https://@www.example.org" $ + URI + (Scheme "https") + (Just (Authority (Just (UserInfo "" "")) (Host "www.example.org") Nothing)) + "" + (Query []) + Nothing, + testParses "https://::@www.example.org" $ + URI + (Scheme "https") + (Just (Authority (Just (UserInfo "" ":")) (Host "www.example.org") Nothing)) + "" + (Query []) + Nothing, + -- trailing & + testParses "http://www.example.org?foo=bar&" $ + URI + (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("foo", "bar")]) - Nothing - , testParses "http://www.google.com:80/aclk?sa=l&ai=CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw&sig=AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ&rct=j&q=&ved=0CCUQ0Qw&adurl=http://www.aruba.com/where-to-stay/hotels-and-resorts%3Ftid%3D122" - URI { uriScheme = Scheme {schemeBS = "http"} - , uriAuthority = Just Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.google.com"}, authorityPort = Just (Port 80)} - , uriPath = "/aclk" - , uriQuery = Query {queryPairs = - [("sa", "l") - ,("ai", "CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw") - ,("sig", "AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ") - ,("rct", "j") - ,("q", "") - ,("ved", "0CCUQ0Qw") - ,("adurl", "http://www.aruba.com/where-to-stay/hotels-and-resorts?tid=122") - ]} - , uriFragment = Nothing - } - - , testParseFailure "$$$$://www.example.org/" (MalformedScheme NonAlphaLeading) - , testParses "http://www.example.org/foo#bar" $ - URI (Scheme "http") + Nothing, + testParses + "http://www.google.com:80/aclk?sa=l&ai=CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw&sig=AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ&rct=j&q=&ved=0CCUQ0Qw&adurl=http://www.aruba.com/where-to-stay/hotels-and-resorts%3Ftid%3D122" + URI + { uriScheme = Scheme {schemeBS = "http"}, + uriAuthority = Just Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.google.com"}, authorityPort = Just (Port 80)}, + uriPath = "/aclk", + uriQuery = + Query + { queryPairs = + [ ("sa", "l"), + ("ai", "CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw"), + ("sig", "AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ"), + ("rct", "j"), + ("q", ""), + ("ved", "0CCUQ0Qw"), + ("adurl", "http://www.aruba.com/where-to-stay/hotels-and-resorts?tid=122") + ] + }, + uriFragment = Nothing + }, + testParseFailure "$$$$://www.example.org/" (MalformedScheme NonAlphaLeading), + testParses "http://www.example.org/foo#bar" $ + URI + (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/foo" mempty - (Just "bar") - , testParses "http://www.example.org/foo#" $ - URI (Scheme "http") + (Just "bar"), + testParses "http://www.example.org/foo#" $ + URI + (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/foo" mempty - (Just "") - , testParseFailure "http://www.example.org/foo#bar#baz" MalformedFragment - , testParseFailure "https://www.example.org?listParam[]=foo,bar" MalformedQuery - , testParsesLax "https://www.example.org?listParam[]=foo,bar" $ - URI (Scheme "https") + (Just ""), + testParseFailure "http://www.example.org/foo#bar#baz" MalformedFragment, + testParseFailure "https://www.example.org?listParam[]=foo,bar" MalformedQuery, + testParsesLax "https://www.example.org?listParam[]=foo,bar" $ + URI + (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")]) - Nothing - - , testParses "https://www.example.org?listParam%5B%5D=foo,bar" $ - URI (Scheme "https") + Nothing, + testParses "https://www.example.org?listParam%5B%5D=foo,bar" $ + URI + (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")]) - Nothing - - , testParses "https://www.example.org#only-fragment" $ - URI (Scheme "https") + Nothing, + testParses "https://www.example.org#only-fragment" $ + URI + (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query []) - (Just "only-fragment") - , testParses "https://www.example.org/weird%20path" $ - URI (Scheme "https") - (Just (Authority Nothing (Host "www.example.org") Nothing)) - "/weird path" - (Query []) - Nothing - - , parseTestURI strictURIParserOptions "http://www.example.org/." $ - Right $ URI - (Scheme "http") + (Just "only-fragment"), + testParses "https://www.example.org/weird%20path" $ + URI + (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) - "/." - (Query []) - Nothing - , parseTestURI strictURIParserOptions "http:/." $ - Right $ URI - (Scheme "http") - Nothing - "/." - (Query []) - Nothing - - , roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt" - , roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt" - , roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com" - , roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix" - , roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212" - , roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/" - - -- RFC 3986, Section 4.2 - , parseTestRelativeRef strictURIParserOptions "verysimple" $ - Right $ RelativeRef - Nothing - "verysimple" + "/weird path" (Query []) - Nothing - , parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $ - Left $ MalformedPath - , parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $ - Right $ RelativeRef - Nothing - "./this:that/thap/sub" - (Query [("1", "2")]) - Nothing - ] - + Nothing, + parseTestURI strictURIParserOptions "http://www.example.org/." $ + Right $ + URI + (Scheme "http") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "/." + (Query []) + Nothing, + parseTestURI strictURIParserOptions "http:/." $ + Right $ + URI + (Scheme "http") + Nothing + "/." + (Query []) + Nothing, + parseTestURI strictURIParserOptions "file:c:/foo" $ + Right $ + URI + (Scheme "file") + Nothing + "c:/foo" + (Query []) + Nothing, + parseTestURI strictURIParserOptions "file:///foo/%F" $ + Left MalformedPath, + parseTestURI strictURIParserOptions "file:///foo/?foo=%F" $ + Left MalformedQuery, + roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt", + roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt", + roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com", + roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix", + roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212", + roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/", + -- percent encoding in queries and fragments + roundtripTestURI strictURIParserOptions "http://example.com/foo#bar%20baz", + roundtripTestURI strictURIParserOptions "http://example.com/foo?bar%20baz=quux", + roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux", + roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux#bar%20baz", + -- RFC 3986, Section 4.2 + parseTestRelativeRef strictURIParserOptions "verysimple" $ + Right $ + RelativeRef + Nothing + "verysimple" + (Query []) + Nothing, + parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $ + Left $ + MalformedPath, + parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $ + Right $ + RelativeRef + Nothing + "./this:that/thap/sub" + (Query [("1", "2")]) + Nothing + ] ------------------------------------------------------------------------------- uriParseErrorInstancesTests :: TestTree -uriParseErrorInstancesTests = testGroup "URIParseError instances" - [ - testProperty "roundtrips between Show and Read" $ property $ do - parseError <- forAll genURIParseError - trippingShow parseError - ] - +uriParseErrorInstancesTests = + testGroup + "URIParseError instances" + [ testProperty "roundtrips between Show and Read" $ + property $ do + parseError <- forAll genURIParseError + trippingShow parseError + ] ------------------------------------------------------------------------------- lensTests :: TestTree -lensTests = testGroup "lenses" - [ - testProperty "schemeBSL Lens" $ property $ do - wrapped <- forAll genScheme - Scheme bs' <- forAll genScheme - (wrapped ^. schemeBSL) === schemeBS wrapped - (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'} - , testProperty "hostBSL Lens" $ property $ do - wrapped <- forAll genHost - Host bs' <- forAll genHost - (wrapped ^. hostBSL) === hostBS wrapped - (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'} - , testProperty "portNumberL Lens" $ property $ do - wrapped <- forAll genPort - Port n' <- forAll genPort - (wrapped ^. portNumberL) === portNumber wrapped - (wrapped & portNumberL .~ n') === wrapped { portNumber = n'} - , testProperty "queryPairsL Lens" $ property $ do - wrapped <- forAll genQuery - Query ps' <- forAll genQuery - wrapped ^. queryPairsL === queryPairs wrapped - (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'} - , testProperty "authorityUserInfoL Lens" $ property $ do - authority <- forAll genAuthority - userInfo <- forAll (Gen.maybe genUserInfo) - (authority ^. authorityUserInfoL === authorityUserInfo authority) - (authority & authorityUserInfoL .~ userInfo) === authority { authorityUserInfo = userInfo } - , testProperty "authorityHostL Lens" $ property $ do - authority <- forAll genAuthority - host <- forAll genHost - (authority ^. authorityHostL === authorityHost authority) - (authority & authorityHostL .~ host) === authority { authorityHost = host } - , testProperty "authorityPortL Lens" $ property $ do - authority <- forAll genAuthority - port <- forAll (Gen.maybe genPort) - (authority ^. authorityPortL === authorityPort authority) - (authority & authorityPortL .~ port) === authority { authorityPort = port } - , testProperty "uiUsernameL Lens" $ property $ do - ui <- forAll genUserInfo - bs <- forAll genBS - (ui ^. uiUsernameL === uiUsername ui) - (ui & uiUsernameL .~ bs) === ui { uiUsername = bs } - , testProperty "uiPasswordL Lens" $ property $ do - ui <- forAll genUserInfo - bs <- forAll genBS - (ui ^. uiPasswordL === uiPassword ui) - (ui & uiPasswordL .~ bs) === ui { uiPassword = bs } - , testProperty "uriSchemeL Lens" $ property $ do - uri <- forAll genAbsoluteURIRef - x <- forAll genScheme - uri ^. uriSchemeL === uriScheme uri - (uri & uriSchemeL .~ x) === uri { uriScheme = x } - , testProperty "authorityL Lens on URI" $ property $ do - uri <- forAll genAbsoluteURIRef - x <- forAll (Gen.maybe genAuthority) - uri ^. authorityL === uriAuthority uri - (uri & authorityL .~ x) === uri { uriAuthority = x } - , testProperty "pathL Lens on URI" $ property $ do - uri <- forAll genAbsoluteURIRef - x <- forAll genBS - uri ^. pathL === uriPath uri - (uri & pathL .~ x) === uri { uriPath = x } - , testProperty "queryL Lens on URI" $ property $ do - uri <- forAll genAbsoluteURIRef - x <- forAll genQuery - uri ^. queryL === uriQuery uri - (uri & queryL .~ x) === uri { uriQuery = x } - , testProperty "fragmentL Lens on URI" $ property $ do - uri <- forAll genAbsoluteURIRef - x <- forAll (Gen.maybe genBS) - uri ^. fragmentL === uriFragment uri - (uri & fragmentL .~ x) === uri { uriFragment = x } - , testProperty "authorityL Lens on relative ref" $ property $ do - rr <- forAll genRelativeURIRef - x <- forAll (Gen.maybe genAuthority) - (rr ^. authorityL === rrAuthority rr) - (rr & authorityL .~ x) === rr { rrAuthority = x } - , testProperty "pathL Lens on relative ref" $ property $ do - rr <- forAll genRelativeURIRef - x <- forAll genBS - rr ^. pathL === rrPath rr - (rr & pathL .~ x) === rr { rrPath = x } - , testProperty "queryL Lens on relative ref" $ property $ do - rr <- forAll genRelativeURIRef - x <- forAll genQuery - rr ^. queryL === rrQuery rr - (rr & queryL .~ x) === rr { rrQuery = x } - , testProperty "fragmentL Lens on relative ref" $ property $ do - rr <- forAll genRelativeURIRef - x <- forAll (Gen.maybe genBS) - rr ^. fragmentL === rrFragment rr - (rr & fragmentL .~ x) === rr { rrFragment = x } - ] - +lensTests = + testGroup + "lenses" + [ testProperty "schemeBSL Lens" $ + property $ do + wrapped <- forAll genScheme + Scheme bs' <- forAll genScheme + (wrapped ^. schemeBSL) === schemeBS wrapped + (wrapped & schemeBSL .~ bs') === wrapped {schemeBS = bs'}, + testProperty "hostBSL Lens" $ + property $ do + wrapped <- forAll genHost + Host bs' <- forAll genHost + (wrapped ^. hostBSL) === hostBS wrapped + (wrapped & hostBSL .~ bs') === wrapped {hostBS = bs'}, + testProperty "portNumberL Lens" $ + property $ do + wrapped <- forAll genPort + Port n' <- forAll genPort + (wrapped ^. portNumberL) === portNumber wrapped + (wrapped & portNumberL .~ n') === wrapped {portNumber = n'}, + testProperty "queryPairsL Lens" $ + property $ do + wrapped <- forAll genQuery + Query ps' <- forAll genQuery + wrapped ^. queryPairsL === queryPairs wrapped + (wrapped & queryPairsL .~ ps') === wrapped {queryPairs = ps'}, + testProperty "authorityUserInfoL Lens" $ + property $ do + authority <- forAll genAuthority + userInfo <- forAll (Gen.maybe genUserInfo) + (authority ^. authorityUserInfoL === authorityUserInfo authority) + (authority & authorityUserInfoL .~ userInfo) === authority {authorityUserInfo = userInfo}, + testProperty "authorityHostL Lens" $ + property $ do + authority <- forAll genAuthority + host <- forAll genHost + (authority ^. authorityHostL === authorityHost authority) + (authority & authorityHostL .~ host) === authority {authorityHost = host}, + testProperty "authorityPortL Lens" $ + property $ do + authority <- forAll genAuthority + port <- forAll (Gen.maybe genPort) + (authority ^. authorityPortL === authorityPort authority) + (authority & authorityPortL .~ port) === authority {authorityPort = port}, + testProperty "uiUsernameL Lens" $ + property $ do + ui <- forAll genUserInfo + bs <- forAll genBS + (ui ^. uiUsernameL === uiUsername ui) + (ui & uiUsernameL .~ bs) === ui {uiUsername = bs}, + testProperty "uiPasswordL Lens" $ + property $ do + ui <- forAll genUserInfo + bs <- forAll genBS + (ui ^. uiPasswordL === uiPassword ui) + (ui & uiPasswordL .~ bs) === ui {uiPassword = bs}, + testProperty "uriSchemeL Lens" $ + property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genScheme + uri ^. uriSchemeL === uriScheme uri + (uri & uriSchemeL .~ x) === uri {uriScheme = x}, + testProperty "authorityL Lens on URI" $ + property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll (Gen.maybe genAuthority) + uri ^. authorityL === uriAuthority uri + (uri & authorityL .~ x) === uri {uriAuthority = x}, + testProperty "pathL Lens on URI" $ + property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genBS + uri ^. pathL === uriPath uri + (uri & pathL .~ x) === uri {uriPath = x}, + testProperty "queryL Lens on URI" $ + property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll genQuery + uri ^. queryL === uriQuery uri + (uri & queryL .~ x) === uri {uriQuery = x}, + testProperty "fragmentL Lens on URI" $ + property $ do + uri <- forAll genAbsoluteURIRef + x <- forAll (Gen.maybe genBS) + uri ^. fragmentL === uriFragment uri + (uri & fragmentL .~ x) === uri {uriFragment = x}, + testProperty "authorityL Lens on relative ref" $ + property $ do + rr <- forAll genRelativeURIRef + x <- forAll (Gen.maybe genAuthority) + (rr ^. authorityL === rrAuthority rr) + (rr & authorityL .~ x) === rr {rrAuthority = x}, + testProperty "pathL Lens on relative ref" $ + property $ do + rr <- forAll genRelativeURIRef + x <- forAll genBS + rr ^. pathL === rrPath rr + (rr & pathL .~ x) === rr {rrPath = x}, + testProperty "queryL Lens on relative ref" $ + property $ do + rr <- forAll genRelativeURIRef + x <- forAll genQuery + rr ^. queryL === rrQuery rr + (rr & queryL .~ x) === rr {rrQuery = x}, + testProperty "fragmentL Lens on relative ref" $ + property $ do + rr <- forAll genRelativeURIRef + x <- forAll (Gen.maybe genBS) + rr ^. fragmentL === rrFragment rr + (rr & fragmentL .~ x) === rr {rrFragment = x} + ] ------------------------------------------------------------------------------- testParses :: ByteString -> URI -> TestTree testParses = testParses' strictURIParserOptions - ------------------------------------------------------------------------------- testParseHost :: ByteString -> ByteString -> TestTree testParseHost uri expectedHost = testParses uri $ - URI (Scheme "http") - (Just (Authority Nothing (Host expectedHost) Nothing)) - mempty - mempty - Nothing - - + URI + (Scheme "http") + (Just (Authority Nothing (Host expectedHost) Nothing)) + mempty + mempty + Nothing ------------------------------------------------------------------------------- testParsesLax :: ByteString -> URI -> TestTree testParsesLax = testParses' laxURIParserOptions - ------------------------------------------------------------------------------- testParses' :: URIParserOptions -> ByteString -> URI -> TestTree -testParses' opts s u = testGroup "testParses'" - [ parseTestURI opts s $ Right u - , parseTestRelativeRef opts (makeRelativeRefBS s) $ Right (makeRelativeRefTyped u) +testParses' opts s u = + testGroup + "testParses'" + [ parseTestURI opts s $ Right u, + parseTestRelativeRef opts (makeRelativeRefBS s) $ Right (makeRelativeRefTyped u) ] - ------------------------------------------------------------------------------- makeRelativeRefTyped :: URI -> RelativeRef makeRelativeRefTyped (URI _ a p q f) = RelativeRef a p q f - ------------------------------------------------------------------------------- makeRelativeRefBS :: ByteString -> ByteString makeRelativeRefBS s = B8.tail x where - (_, x) = B8.break (==':') s - + (_, x) = B8.break (== ':') s ------------------------------------------------------------------------------- testParseFailure :: ByteString -> URIParseError -> TestTree testParseFailure s = parseTestURI strictURIParserOptions s . Left - ------------------------------------------------------------------------------- -parseTestURI - :: URIParserOptions - -> ByteString - -> Either URIParseError URI - -> TestTree +parseTestURI :: + URIParserOptions -> + ByteString -> + Either URIParseError URI -> + TestTree parseTestURI opts s r = testCase (B8.unpack s) $ parseURI opts s @?= r - ------------------------------------------------------------------------------- -roundtripTestURI - :: URIParserOptions - -> ByteString - -> TestTree +roundtripTestURI :: + URIParserOptions -> + ByteString -> + TestTree roundtripTestURI opts s = - testCase (B8.unpack s) $ (parseURI opts s >>= return . serializeURIRef') @?= Right s - + testCase (B8.unpack s) $ (parseURI opts s >>= return . serializeURIRef') @?= Right s ------------------------------------------------------------------------------- -parseTestRelativeRef - :: URIParserOptions - -> ByteString - -> Either URIParseError RelativeRef - -> TestTree +parseTestRelativeRef :: + URIParserOptions -> + ByteString -> + Either URIParseError RelativeRef -> + TestTree parseTestRelativeRef opts s r = testCase (B8.unpack s) $ parseRelativeRef opts s @?= r - ------------------------------------------------------------------------------- serializeURITests :: TestTree -serializeURITests = testGroup "serializeURIRef" - [ - testCase "renders userinfo correctly" $ do - let ui = UserInfo "user" "pass" - let uri = URI (Scheme "http") - (Just (Authority (Just ui) (Host "www.example.org") (Just port))) - "/" - (Query [("foo", "bar")]) - (Just "somefragment") - let res = BB.toLazyByteString (serializeURIRef uri) - res @?= "http://user:pass@www.example.org:123/?foo=bar#somefragment" - , testCase "encodes decoded paths" $ do - let uri = URI (Scheme "http") - (Just (Authority Nothing (Host "www.example.org") (Just port))) - "/weird path" - (Query []) - Nothing - let res = BB.toLazyByteString (serializeURIRef uri) - res @?= "http://www.example.org:123/weird%20path" - , testCase "encodes relative refs" $ do - let ui = UserInfo "user" "pass" - let uri = RelativeRef (Just (Authority (Just ui) (Host "www.example.org") (Just port))) +serializeURITests = + testGroup + "serializeURIRef" + [ testCase "renders userinfo correctly" $ do + let ui = UserInfo "user" "pass" + let uri = + URI + (Scheme "http") + (Just (Authority (Just ui) (Host "www.example.org") (Just port))) "/" (Query [("foo", "bar")]) (Just "somefragment") - let res = BB.toLazyByteString (serializeURIRef uri) - res @?= "//user:pass@www.example.org:123/?foo=bar#somefragment" - ] + let res = BB.toLazyByteString (serializeURIRef uri) + res @?= "http://user:pass@www.example.org:123/?foo=bar#somefragment", + testCase "encodes decoded paths" $ do + let uri = + URI + (Scheme "http") + (Just (Authority Nothing (Host "www.example.org") (Just port))) + "/weird path" + (Query []) + Nothing + let res = BB.toLazyByteString (serializeURIRef uri) + res @?= "http://www.example.org:123/weird%20path", + testCase "encodes relative refs" $ do + let ui = UserInfo "user" "pass" + let uri = + RelativeRef + (Just (Authority (Just ui) (Host "www.example.org") (Just port))) + "/" + (Query [("foo", "bar")]) + (Just "somefragment") + let res = BB.toLazyByteString (serializeURIRef uri) + res @?= "//user:pass@www.example.org:123/?foo=bar#somefragment" + ] where port = Port 123 - ------------------------------------------------------------------------------- normalizeURITests :: TestTree -normalizeURITests = testGroup "normalization" - [ - testCase "downcase schema" $ do - normalizeURIBS o { unoDowncaseScheme = True } "hTtP://example.org" @?= - "http://example.org" - - , testCase "downcase host" $ do - normalizeURIBS o { unoDowncaseHost = True } "http://ExAmPlE.org" @?= - "http://example.org" - - , testCase "drop default port http" $ do - normalizeURIBS o { unoDropDefPort = True } "http://example.org:80" @?= - "http://example.org" - , testCase "drop default port https" $ do - normalizeURIBS o { unoDropDefPort = True } "https://example.org:443" @?= - "https://example.org" - , testCase "drop default port no port" $ do - normalizeURIBS o { unoDropDefPort = True } "http://example.org" @?= - "http://example.org" - , testCase "drop default port nondefault" $ do - normalizeURIBS o { unoDropDefPort = True } "http://example.org:8000" @?= - "http://example.org:8000" - , testCase "drop default unknown schema" $ do - normalizeURIBS o { unoDropDefPort = True } "bogus://example.org:9999" @?= - "bogus://example.org:9999" - , testCase "user-extensable port defaulting hit" $ do - normalizeURIBS o { unoDropDefPort = True - , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } - "ftp://example.org:21" @?= - "ftp://example.org" - , testCase "user-extensable port defaulting off" $ do - normalizeURIBS o { unoDropDefPort = False - , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } - "ftp://example.org:21" @?= - "ftp://example.org:21" - , testCase "user-extensable port defaulting miss" $ do - normalizeURIBS o { unoDropDefPort = True - , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } - "http://example.org:80" @?= - "http://example.org:80" - - , testCase "slash empty path" $ do - normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org" @?= - "http://example.org/" - , testCase "slash empty path with nonempty path" $ do - normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org/foo/bar" @?= - "http://example.org/foo/bar" - - , testCase "drop redundant slashes" $ do - normalizeURIBS o { unoDropExtraSlashes = True } "http://example.org/foo//bar///baz" @?= - "http://example.org/foo/bar/baz" - - , testCase "sort params" $ do - normalizeURIBS o { unoSortParameters = True } "http://example.org/foo?zulu=1&charlie=&alpha=1" @?= - "http://example.org/foo?alpha=1&charlie=&zulu=1" - - , testCase "remove dot segments" $ do - normalizeURIBS o { unoRemoveDotSegments = True } "http://example.org/a/b/c/./../../g" @?= - "http://example.org/a/g" - - , testCase "percent encoding is upcased automatically" $ do - normalizeURIBS o "http://example.org/a?foo%3abar=baz" @?= - "http://example.org/a?foo%3Abar=baz" - , testCase "aggressive normalization retains slashes (issue 41)" $ do - normalizeURIBS aggressiveNormalization "http://example.org/" @?= - "http://example.org/" - ] +normalizeURITests = + testGroup + "normalization" + [ testCase "downcase schema" $ do + normalizeURIBS o {unoDowncaseScheme = True} "hTtP://example.org" + @?= "http://example.org", + testCase "downcase host" $ do + normalizeURIBS o {unoDowncaseHost = True} "http://ExAmPlE.org" + @?= "http://example.org", + testCase "drop default port http" $ do + normalizeURIBS o {unoDropDefPort = True} "http://example.org:80" + @?= "http://example.org", + testCase "drop default port https" $ do + normalizeURIBS o {unoDropDefPort = True} "https://example.org:443" + @?= "https://example.org", + testCase "drop default port no port" $ do + normalizeURIBS o {unoDropDefPort = True} "http://example.org" + @?= "http://example.org", + testCase "drop default port nondefault" $ do + normalizeURIBS o {unoDropDefPort = True} "http://example.org:8000" + @?= "http://example.org:8000", + testCase "drop default unknown schema" $ do + normalizeURIBS o {unoDropDefPort = True} "bogus://example.org:9999" + @?= "bogus://example.org:9999", + testCase "user-extensable port defaulting hit" $ do + normalizeURIBS + o + { unoDropDefPort = True, + unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) + } + "ftp://example.org:21" + @?= "ftp://example.org", + testCase "user-extensable port defaulting off" $ do + normalizeURIBS + o + { unoDropDefPort = False, + unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) + } + "ftp://example.org:21" + @?= "ftp://example.org:21", + testCase "user-extensable port defaulting miss" $ do + normalizeURIBS + o + { unoDropDefPort = True, + unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) + } + "http://example.org:80" + @?= "http://example.org:80", + testCase "slash empty path" $ do + normalizeURIBS o {unoSlashEmptyPath = True} "http://example.org" + @?= "http://example.org/", + testCase "slash empty path with nonempty path" $ do + normalizeURIBS o {unoSlashEmptyPath = True} "http://example.org/foo/bar" + @?= "http://example.org/foo/bar", + testCase "drop redundant slashes" $ do + normalizeURIBS o {unoDropExtraSlashes = True} "http://example.org/foo//bar///baz" + @?= "http://example.org/foo/bar/baz", + testCase "sort params" $ do + normalizeURIBS o {unoSortParameters = True} "http://example.org/foo?zulu=1&charlie=&alpha=1" + @?= "http://example.org/foo?alpha=1&charlie=&zulu=1", + testCase "remove dot segments" $ do + normalizeURIBS o {unoRemoveDotSegments = True} "http://example.org/a/b/c/./../../g" + @?= "http://example.org/a/g", + testCase "percent encoding is upcased automatically" $ do + normalizeURIBS o "http://example.org/a?foo%3abar=baz" + @?= "http://example.org/a?foo%3Abar=baz", + testCase "aggressive normalization retains slashes (issue 41)" $ do + normalizeURIBS aggressiveNormalization "http://example.org/" + @?= "http://example.org/" + ] where o = noNormalization - normalizeURIBS opts bs = let Right x = parseURI laxURIParserOptions bs - in normalizeURIRef' opts x + normalizeURIBS opts bs = case parseURI laxURIParserOptions bs of + Right x -> normalizeURIRef' opts x + Left e -> error ("Test error, " <> show bs <> " did not parse: " <> show e) -trippingShow - :: ( Show a - , Read a - , Eq a - , MonadTest m - ) - => a - -> m () +trippingShow :: + ( Show a, + Read a, + Eq a, + MonadTest m + ) => + a -> + m () trippingShow a = tripping a show readMay 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.3.3.1 +version: 0.4.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