uri-bytestring 0.3.3.1 → 0.4.0.0
raw patch · 13 files changed
+1240/−1169 lines, 13 filessetup-changed
Files
- Setup.hs +1/−0
- bench/Main.hs +56/−46
- changelog.md +3/−0
- src/URI/ByteString.hs +114/−101
- src/URI/ByteString/Internal.hs +313/−336
- src/URI/ByteString/Lens.hs +82/−97
- src/URI/ByteString/QQ.hs +31/−31
- src/URI/ByteString/Types.hs +97/−81
- test/Main.hs +10/−8
- test/URI/ByteString/Generators.hs +70/−77
- test/URI/ByteStringQQTests.hs +15/−14
- test/URI/ByteStringTests.hs +447/−377
- uri-bytestring.cabal +1/−1
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Main.hs view
@@ -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 }
changelog.md view
@@ -1,3 +1,6 @@+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).
src/URI/ByteString.hs view
@@ -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+ -------------------------------------------------------------------------------
src/URI/ByteString/Internal.hs view
@@ -1,79 +1,90 @@-{-# 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 - -------------------------------------------------------------------------------+ -- | 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 +92,45 @@ -- * 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 - -------------------------------------------------------------------------------+ -- | @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 +142,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 +180,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 -- <https://tools.ietf.org/html/rfc3986#section-5.2.4>, reproduced -- artlessly.@@ -200,7 +214,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 +236,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 ByteString -> ByteString serializeFragment' = BB.toByteString . serializeFragment - ------------------------------------------------------------------------------- serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port@@ -303,7 +312,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 +319,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 +362,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 +514,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 +593,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 +618,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 +703,10 @@ unreserved :: String unreserved = alphaNum ++ "~._-" - ------------------------------------------------------------------------------- unreserved8 :: [Word8] unreserved8 = map ord8 unreserved - ------------------------------------------------------------------------------- unreservedPath8 :: [Word8] unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$,"@@ -705,138 +715,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 +832,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 +896,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+
src/URI/ByteString/Lens.hs view
@@ -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
src/URI/ByteString/QQ.hs view
@@ -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."+ }
src/URI/ByteString/Types.hs view
@@ -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 <https://tools.ietf.org/html/rfc3986#section-5.2.4 RFC3986 Section 5.2.4>- , unoDefaultPorts :: M.Map Scheme Port- -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled.- } deriving (Show, Eq)-+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 <https://tools.ietf.org/html/rfc3986#section-5.2.4 RFC3986 Section 5.2.4>+ 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)
test/Main.hs view
@@ -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+ ]
test/URI/ByteString/Generators.hs view
@@ -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)
test/URI/ByteStringQQTests.hs view
@@ -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")+ ]
test/URI/ByteStringTests.hs view
@@ -1,482 +1,552 @@-{-# 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/",+ -- 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
uri-bytestring.cabal view
@@ -1,5 +1,5 @@ name: uri-bytestring-version: 0.3.3.1+version: 0.4.0.0 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