uri-bytestring 0.1.9.2 → 0.4.0.1
raw patch · 15 files changed
Files
- README.md +6/−0
- Setup.hs +1/−0
- bench/Main.hs +60/−46
- changelog.md +63/−0
- src/URI/ByteString.hs +116/−75
- src/URI/ByteString/Internal.hs +537/−312
- src/URI/ByteString/Lens.hs +109/−65
- src/URI/ByteString/QQ.hs +48/−0
- src/URI/ByteString/Types.hs +173/−56
- test/Main.hs +10/−6
- test/URI/ByteString/Arbitrary.hs +0/−66
- test/URI/ByteString/Generators.hs +149/−0
- test/URI/ByteStringQQTests.hs +29/−0
- test/URI/ByteStringTests.hs +473/−249
- uri-bytestring.cabal +36/−15
README.md view
@@ -12,3 +12,9 @@ * [fisx](http://github.com/fisx) * [Timo von Holtz](http://github.com/tvh) * [Brendan Hay](http://github.com/brendanhay)+* [k0ral](https://github.com/k0ral)+* [Michael Hatfield](https://github.com/mikehat)+* [reactormonk](https://github.com/reactormonk)+* [Oleg Grenrus](https://github.com/phadej)+* [Edward Betts](https://github.com/EdwardBetts)+* [clinty](https://github.com/clinty)
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Main.hs view
@@ -1,80 +1,94 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Main (main) where --------------------------------------------------------------------------------import Control.DeepSeq.Generics-import Criterion.Main-import Blaze.ByteString.Builder-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 URI-instance NFData RelativeRef+ 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.serializeURI" $ nf (toLazyByteString . serializeURI) exampleURI- , bench "URI.ByteString.serializeRelativeRef" $ nf (toLazyByteString . serializeRelativeRef) 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,66 @@+0.4.0.1+* [Fix fragment serilization bug](https://github.com/Soostone/uri-bytestring/pull/65). 0.4.0.0 percent-decoded fragments on parse but did not percent-encode them on serialization, which made it possible for some URLs to not roundtrip.++0.4.0.0+* [Improve spec compliance ](https://github.com/Soostone/uri-bytestring/pull/64). Thanks to [hasufell](https://github.com/hasufell).++0.3.3.1+* Remove >= from cabal version. Thanks to [felixonmars](https://github.com/felixonmars).+* Conditionally drop dependency on semigroups library. Thanks to [felixonmars](https://github.com/felixonmars).++0.3.3.0+* Export more granular serializtion functions for things like the query string.++0.3.2.2+* Loosen dependencies++0.3.2.1+* Loosen upper bounds on template-haskell++0.3.2.0+* Only depend on the fail package when it is needed due to GHC version.++0.3.0.2+* Avoid using OverloadedStrings for Builder.++0.3.0.1+* Fix normalization bug where certain combination of options would fail to add a trailing slash.++0.3.0.0+* Add MonadFail instance.+* Correct haddock spelling mistake.++0.2.3.3+* Make buildable on GHC 8.2.1.++0.2.3.2+* Broaden dep on base.++0.2.3.1+* Add `relativeRef` quasi-quoter.++0.2.3.0+* Add `URI.ByteString.QQ` and the `uri` quasiquoter to be able to express statically known to be valid URIs, e.g. `example = [uri|http://www.example.com|]`. Thanks to [reactormonk](https://github.com/reactormonk).++0.2.2.1+* Drop dependency on derive in tests.++0.2.2.0+* Internally use attoparsec's numeric parser. Raise lower bounds on attoparsec.+* Allow blank fragments.++0.2.1.2+* Fixed bug introduced at 0.2.1.1 where RelativeRefs would fail to serialize their port numbers.++0.2.1.1+* Add URI normalization features.++0.2.1.0+* Widen dependency on base.++0.2.0.0+* Introduce URIRef, a GADT representation of absolute and relative URIs.+ 0.1.9.2 * Fix bug wher trailing ampersand in the query section would not parse.
src/URI/ByteString.hs view
@@ -1,92 +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+ ( -- * URI-related types+ Scheme (..),+ Host (..),+ Port (..),+ Authority (..),+ UserInfo (..),+ Query (..),+ URIRef (..),+ Absolute,+ Relative,+ SchemaError (..),+ URIParseError (..),+ URIParserOptions (..),+ strictURIParserOptions,+ laxURIParserOptions,+ URINormalizationOptions (..),+ noNormalization,+ rfc3986Normalization,+ httpNormalization,+ aggressiveNormalization,+ httpDefaultPorts, -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+ -- * Operations+ toAbsolute, -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.+ -- * Parsing+ parseURI,+ parseRelativeRef,+ uriParser,+ relativeRefParser, -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.+ -- * Serializing+ serializeURIRef,+ serializeURIRef',+ serializeQuery,+ serializeQuery',+ serializeFragment,+ serializeFragment',+ serializeAuthority,+ serializeAuthority',+ serializeUserInfo,+ serializeUserInfo', -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.+ -- ** Normalized Serialization+ normalizeURIRef,+ normalizeURIRef', --}-module URI.ByteString- (-- * URI-related types- Scheme(..)- , Host(..)- , Port(..)- , Authority(..)- , UserInfo(..)- , Query(..)- , URI(..)- , RelativeRef(..)- , SchemaError(..)- , URIParseError(..)- , URIParserOptions(..)- , strictURIParserOptions- , laxURIParserOptions- -- * Parsing- , parseURI- , parseRelativeRef- , uriParser- , relativeRefParser- -- * Serializing- , serializeURI- , serializeURI'- , serializeRelativeRef- , serializeRelativeRef' -- * 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- -- ** Lenses over 'URI'- , uriSchemeL- , uriAuthorityL- , uriPathL- , uriQueryL- , uriFragmentL- -- ** Lenses over 'RelativeRef'- , rrAuthorityL- , rrPathL- , rrQueryL- , rrFragmentL+ queryPairsL,++ -- ** Lenses over 'URIRef'+ uriSchemeL,+ authorityL,+ pathL,+ queryL,+ fragmentL,+ -- ** Lenses over 'URIParserOptions'- , upoValidQueryCharL- ) where+ upoValidQueryCharL, + -- ** Deprecated+ 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,123 +1,355 @@+{-# 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 Data.Attoparsec.ByteString-import qualified Data.Attoparsec.ByteString as A-import Data.Bits-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Char (ord)-import Data.Ix-import Data.List (delete, intersperse,- stripPrefix, (\\))-import Data.Maybe-import Data.Monoid-import Data.Word-import Text.Read (readMaybe)---------------------------------------------------------------------------------import URI.ByteString.Types+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+ { unoDowncaseScheme = False,+ unoDowncaseHost = False,+ unoDropDefPort = False,+ unoSlashEmptyPath = False,+ unoDropExtraSlashes = False,+ unoSortParameters = False,+ unoRemoveDotSegments = False,+ unoDefaultPorts = httpDefaultPorts+ }++-------------------------------------------------------------------------------++-- | The set of known default ports to schemes. Currently only+-- contains http\/80 and https\/443. Feel free to extend it if needed+-- with 'unoDefaultPorts'.+httpDefaultPorts :: M.Map Scheme Port+httpDefaultPorts =+ M.fromList+ [ (Scheme "http", Port 80),+ (Scheme "https", Port 443)+ ]++-------------------------------------------------------------------------------++-- | Only normalizations deemed appropriate for all protocols by+-- RFC3986 enabled, namely:+--+-- * Downcase Scheme+-- * Downcase Host+-- * Remove Dot Segments+rfc3986Normalization :: URINormalizationOptions+rfc3986Normalization =+ noNormalization+ { unoDowncaseScheme = True,+ unoDowncaseHost = True,+ unoRemoveDotSegments = True+ }++-------------------------------------------------------------------------------++-- | The same as 'rfc3986Normalization' but with additional enabled+-- features if you're working with HTTP URIs:+--+-- * Drop Default Port (with 'httpDefaultPorts')+-- * Drop Extra Slashes+httpNormalization :: URINormalizationOptions+httpNormalization =+ rfc3986Normalization+ { unoDropDefPort = True,+ unoSlashEmptyPath = True+ }++-------------------------------------------------------------------------------++-- | All options enabled+aggressiveNormalization :: URINormalizationOptions+aggressiveNormalization = URINormalizationOptions+ { unoDowncaseScheme = True,+ unoDowncaseHost = True,+ unoDropDefPort = True,+ unoSlashEmptyPath = True,+ unoDropExtraSlashes = True,+ unoSortParameters = True,+ unoRemoveDotSegments = True,+ unoDefaultPorts = httpDefaultPorts+ }++-------------------------------------------------------------------------------++-- | @toAbsolute scheme ref@ converts @ref@ to an absolute URI.+-- If @ref@ is already absolute, then it is unchanged.+toAbsolute :: Scheme -> URIRef a -> URIRef Absolute+toAbsolute scheme RelativeRef {..} = URI scheme rrAuthority rrPath rrQuery rrFragment+toAbsolute _ uri@URI {} = uri++-------------------------------------------------------------------------------+ -- | URI Serializer+ ------------------------------------------------------------------------------- --- | Serialize a URI into a Builder.+-- | Serialize a URI reference into a 'Builder'. -- -- Example of serializing + converting to a lazy "Data.ByteString.Lazy.ByteString": ----- >>> BB.toLazyByteString $ serializeURI $ URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"}+-- >>> BB.toLazyByteString $ serializeURIRef $ URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"} -- "http://www.example.org/foo?bar=baz#quux"-serializeURI :: URI -> Builder-serializeURI URI {..} = scheme <> BB.fromString ":" <>- serializeRelativeRef rr+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' :: URINormalizationOptions -> URIRef a -> ByteString+normalizeURIRef' o = BB.toByteString . normalizeURIRef o++-------------------------------------------------------------------------------+normalizeURI :: URINormalizationOptions -> URIRef Absolute -> Builder+normalizeURI o@URINormalizationOptions {..} URI {..} =+ scheme <> BB.fromString ":" <> normalizeRelativeRef o (Just uriScheme) rr where- scheme = bs $ schemeBS uriScheme+ scheme = bs (sCase (schemeBS uriScheme))+ sCase+ | unoDowncaseScheme = downcaseBS+ | otherwise = id rr = RelativeRef uriAuthority uriPath uriQuery uriFragment +-------------------------------------------------------------------------------+normalizeRelativeRef :: URINormalizationOptions -> Maybe Scheme -> URIRef Relative -> Builder+normalizeRelativeRef o@URINormalizationOptions {..} mScheme RelativeRef {..} =+ authority <> path <> query <> fragment+ where+ path+ | unoSlashEmptyPath && BS.null rrPath = BB.fromByteString "/"+ | segs == [""] = BB.fromByteString "/"+ | otherwise = mconcat (intersperse (c8 '/') (map urlEncodePath segs))+ segs = dropSegs (BS.split slash (pathRewrite rrPath))+ pathRewrite+ | unoRemoveDotSegments = removeDotSegments+ | otherwise = id+ dropSegs [] = []+ dropSegs (h : t)+ | unoDropExtraSlashes = h : (filter (not . BS.null) t)+ | otherwise = h : t+ authority = maybe 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.+removeDotSegments :: ByteString -> ByteString+removeDotSegments path = mconcat (rl2L (go path (RL [])))+ where+ go inBuf outBuf+ -- A. If the input buffer begins with prefix of ../ or ./ then+ -- remove the prefix from the input buffer+ | BS8.isPrefixOf "../" inBuf = go (BS8.drop 3 inBuf) outBuf+ | BS8.isPrefixOf "./" inBuf = go (BS8.drop 2 inBuf) outBuf+ -- B. If the input buffer begins with a prefix of "/./" or "/.",+ -- where "." is a complete path segment, then replace that+ -- prefix with "/" in the input buffer. TODO: I think "a+ -- complete path segment" means its the whole thing?+ | BS.isPrefixOf "/./" inBuf = go (BS8.drop 2 inBuf) outBuf+ | inBuf == "/." = go "/" outBuf+ -- C. If the input buffer begins with a prefix of "/../" or+ -- "/..", where ".." is a complete path segment, then replace+ -- that prefix with "/" in the input buffer and remove the last+ -- segment and its preceding "/" (if any) from the output buffer+ | BS.isPrefixOf "/../" inBuf = go (BS8.drop 3 inBuf) (unsnoc (unsnoc outBuf))+ | inBuf == "/.." = go "/" (unsnoc (unsnoc outBuf))+ -- D. If the input buffer consists only of "." or "..", then+ -- remove that from the input buffer+ | inBuf == "." = go mempty outBuf+ | inBuf == ".." = go mempty outBuf+ -- E. Move the first path segment in the input buffer to the end+ -- of the output buffer, including the initial "/" character (if+ -- any) and any subsequent characters up to, but not including,+ -- the next "/" character or the end of the input buffer.+ | otherwise = case BS8.uncons inBuf of+ Just ('/', rest) ->+ let (thisSeg, inBuf') = BS8.span (/= '/') rest+ in go inBuf' (outBuf |> "/" |> thisSeg)+ Just (_, _) ->+ let (thisSeg, inBuf') = BS8.span (/= '/') inBuf+ in go inBuf' (outBuf |> thisSeg)+ Nothing -> outBuf++-------------------------------------------------------------------------------+ -- | Like 'serializeURI', with conversion into a strict 'ByteString'.-serializeURI' :: URI -> ByteString+serializeURI' :: URIRef Absolute -> ByteString serializeURI' = BB.toByteString . serializeURI+{-# DEPRECATED serializeURI' "Use 'serializeURIRef'' instead" #-} +-------------------------------------------------------------------------------+ -- | Like 'serializeURI', but do not render scheme.-serializeRelativeRef :: RelativeRef -> Builder-serializeRelativeRef RelativeRef {..} = authority <> path <> query <> fragment- where- path = mconcat $ intersperse (c8 '/') $ map urlEncodePath segs- segs = BS.split slash rrPath- authority = maybe mempty serializeAuthority rrAuthority- query = serializeQuery rrQuery- fragment = maybe mempty (\s -> c8 '#' <> bs s) rrFragment+serializeRelativeRef :: URIRef Relative -> Builder+serializeRelativeRef = normalizeRelativeRef noNormalization Nothing+{-# DEPRECATED serializeRelativeRef "Use 'serializeURIRef' instead" #-} +-------------------------------------------------------------------------------+ -- | Like 'serializeRelativeRef', with conversion into a strict 'ByteString'.-serializeRelativeRef' :: RelativeRef -> ByteString+serializeRelativeRef' :: URIRef Relative -> ByteString serializeRelativeRef' = BB.toByteString . serializeRelativeRef+{-# DEPRECATED serializeRelativeRef' "Use 'serializeURIRef'' instead" #-} --------------------------------------------------------------------------------serializeQuery :: Query -> Builder-serializeQuery (Query []) = mempty-serializeQuery (Query ps) =- c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps))++-- | 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')) 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 --------------------------------------------------------------------------------serializeAuthority :: Authority -> Builder-serializeAuthority Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port+serializeFragment :: Maybe ByteString -> Builder+serializeFragment = maybe mempty (\s -> c8 '#' <> urlEncodeQuery s)++serializeFragment' :: Maybe ByteString -> ByteString+serializeFragment' = BB.toByteString . serializeFragment++-------------------------------------------------------------------------------+serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder+serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port where userinfo = maybe mempty serializeUserInfo authorityUserInfo- host = hostBS authorityHost- port = maybe mempty packPort authorityPort+ host = hCase (hostBS authorityHost)+ hCase+ | unoDowncaseHost = downcaseBS+ | otherwise = id+ port = maybe mempty packPort effectivePort+ effectivePort = do+ p <- authorityPort+ dropPort mScheme p packPort (Port p) = c8 ':' <> BB.fromString (show p)+ dropPort Nothing = Just+ dropPort (Just scheme)+ | unoDropDefPort = dropPort' scheme+ | otherwise = Just+ dropPort' s p+ | M.lookup s unoDefaultPorts == Just p = Nothing+ | otherwise = Just p +serializeAuthority' :: URINormalizationOptions -> Maybe Scheme -> Authority -> ByteString+serializeAuthority' opts mScheme = BB.toByteString . serializeAuthority opts mScheme ------------------------------------------------------------------------------- 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:@@ -141,144 +373,158 @@ -- >>> let myLaxOptions = URIParserOptions { upoValidQueryChar = liftA2 (||) (upoValidQueryChar strictURIParserOptions) (inClass "[]")} -- >>> parseURI myLaxOptions "http://www.example.org/foo?bar[]=baz" -- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar[]","baz")]}, uriFragment = Nothing})-parseURI :: URIParserOptions -> ByteString -> Either URIParseError URI+parseURI :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Absolute) parseURI opts = parseOnly' OtherError (uriParser' opts) -- | Like 'parseURI', but do not parse scheme.-parseRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError RelativeRef+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 URI+uriParser :: URIParserOptions -> Parser (URIRef Absolute) uriParser = unParser' . uriParser' - -------------------------------------------------------------------------------+ -- | Toplevel parser for URIs-uriParser' :: URIParserOptions -> URIParser URI+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 RelativeRef+relativeRefParser :: URIParserOptions -> Parser (URIRef Relative) relativeRefParser = unParser' . relativeRefParser' - -------------------------------------------------------------------------------+ -- | Toplevel parser for relative refs-relativeRefParser' :: URIParserOptions -> URIParser RelativeRef+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 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@@ -286,112 +532,99 @@ 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 <- A.takeWhile1 isDigit+ (s, num) <- A.match A.decimal let len = BS.length s- guard $ len > 0 && len <= 3- let num = bsToNum s- guard $ num >= 1 && num <= 255+ 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-portParser = (Port . bsToNum <$> A.takeWhile1 isDigit) `orFailWith` MalformedPort+portParser = (Port <$> A.decimal) `orFailWith` MalformedPort ---------------------------------------------------------------------------------- | Path with any number of segments-pathParser :: URIParser ByteString-pathParser = pathParser' A.many' ----------------------------------------------------------------------------------- | Path with at least 1 segment-pathParser1 :: URIParser ByteString-pathParser1 = pathParser' A.many1'+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@@ -403,78 +636,84 @@ case mc of Just c | c == question -> skip' 1 *> itemsParser- | c == hash -> pure mempty- | otherwise -> fail' MalformedPath- _ -> pure mempty+ | c == hash -> pure mempty+ | otherwise -> fail' MalformedPath+ _ -> pure mempty where itemsParser = Query . filter neQuery <$> A.sepBy' (queryItemParser opts) (word8' ampersand) neQuery (k, _) = not (BS.null k) - -------------------------------------------------------------------------------+ -- | When parsing a single query item string like "foo=bar", turns it -- into a key/value pair as per convention, with the value being -- optional. & separators need to be handled further up. queryItemParser :: URIParserOptions -> URIParser (ByteString, ByteString)-queryItemParser opts = do- s <- A.takeWhile (upoValidQueryChar opts) `orFailWith` MalformedQuery- if BS.null s- then return (mempty, mempty)- else do- let (k, vWithEquals) = BS.break (== equals) s- let v = BS.drop 1 vWithEquals- return (urlDecodeQuery k, urlDecodeQuery v)-+queryItemParser opts = (`orFailWith` MalformedQuery) $ do+ let parser = if upoLaxQueryParsing opts then queryLaxItemParser else queryItemParser'+ k <- manyC parser+ if BS.null k+ then return (mempty, mempty)+ else do+ A.peekWord8 >>= \case+ Just 61 -> do+ _ <- string "="+ v <- manyC parser+ return (k, v)+ _ -> return (k, mempty) --------------------------------------------------------------------------------validForQuery :: Word8 -> Bool-validForQuery = inClass ('?':'/':delete '&' pchar)-+queryItemParser' :: Parser ByteString+queryItemParser' = pctEncodedParser <|> satisfyClass ('?' : '/' : (delete '=' $ delete '&' (subDelims ++ ":@" ++ unreserved))) --------------------------------------------------------------------------------validForQueryLax :: Word8 -> Bool-validForQueryLax = notInClass "&#"-+queryLaxItemParser :: Parser ByteString+queryLaxItemParser = pctEncodedParser <|> satisfyNotClass "&#=" -------------------------------------------------------------------------------+ -- | Only parses a fragment if the # signifiier is there mFragmentParser :: URIParser (Maybe ByteString)-mFragmentParser = word8' hash `thenJust` fragmentParser-+mFragmentParser = mParse $ word8' hash *> fragmentParser -------------------------------------------------------------------------------+ -- | The final piece of a uri, e.g. #fragment, minus the #. fragmentParser :: URIParser ByteString-fragmentParser = A.takeWhile1 validFragmentWord `orFailWith` MalformedFragment- where- validFragmentWord = inClass ('?':'/':pchar)-+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@@ -482,12 +721,10 @@ unreserved :: String unreserved = alphaNum ++ "~._-" - ------------------------------------------------------------------------------- unreserved8 :: [Word8] unreserved8 = map ord8 unreserved - ------------------------------------------------------------------------------- unreservedPath8 :: [Word8] unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$,"@@ -496,202 +733,180 @@ 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-------------------------------------------------------------------------------- --- FIXME: theres probably a much better way to do this------------------------------------------------------------------------------------ | Convert a bytestring into an int representation. Assumes the--- entire string is comprised of 0-9 digits.-bsToNum :: ByteString -> Int-bsToNum s = sum $ zipWith (*) (reverse ints) [10 ^ x | x <- [0..] :: [Int]]- where- w2i w = fromEnum $ w - 48- ints = map w2i . BS.unpack $ s------------------------------------------------------------------------------------- | Decoding specifically for the query string, which decodes + as--- space. 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- , Monoid)+newtype Parser' e a = Parser' {unParser' :: Parser a}+ deriving+ ( Functor,+ Applicative,+ Alternative,+ Monad,+ MonadPlus,+ Semigroup.Semigroup,+ Monoid+ ) +#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 = option Nothing (Just <$> p)-+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--- the presence of a parsible token, i.e. ? preceeding a query.+-- the presence of a parsible token, i.e. ? preceding a query. thenJust :: Parser' e a -> Parser' e b -> Parser' e (Maybe b) thenJust p1 p2 = p1 *> (Just <$> p2) <|> pure Nothing - -------------------------------------------------------------------------------+ -- | Lift a word8 Parser into a strongly error typed parser. This will -- generate a "stringy" error message if it fails, so you should -- probably be prepared to exit with a nicer error further up. word8' :: Word8 -> Parser' e Word8 word8' = Parser' . word8 - -------------------------------------------------------------------------------+ -- | Skip exactly 1 character. Fails if the character isn't -- there. Generates a "stringy" error. skip' :: Int -> Parser' e () skip' = Parser' . void . A.take - -------------------------------------------------------------------------------+ -- | Lifted version of the string token parser. Same caveats about -- "stringy" errors apply. string' :: ByteString -> Parser' e ByteString string' = Parser' . string - -------------------------------------------------------------------------------+ -- | Combinator for tunnelling more specific error types through the -- attoparsec machinery using read/show.-orFailWith :: (Show e, Read e) => Parser a -> e -> Parser' e a+orFailWith :: (Show e) => Parser a -> e -> Parser' e a orFailWith p e = Parser' p <|> fail' e - -------------------------------------------------------------------------------+ -- | Should be preferred to fail'-fail' :: (Show e, Read e) => e -> Parser' e a+fail' :: (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, Show e)- => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality.- -> Parser' e a- -> ByteString- -> Either e a+parseOnly' ::+ (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@@ -699,76 +914,86 @@ stripAttoparsecGarbage :: String -> String stripAttoparsecGarbage = stripPrefix' "Failed reading: " - -------------------------------------------------------------------------------+ -- | stripPrefix where it is a noop if the prefix doesn't exist. stripPrefix' :: Eq a => [a] -> [a] -> [a] stripPrefix' pfx s = fromMaybe s $ stripPrefix pfx s - ------------------------------------------------------------------------------- fmapL :: (a -> b) -> Either a r -> Either b r fmapL f = either (Left . f) Right - ---------------------------------------------------------------------------------- | This function was extracted from the @http-types@ package. The--- license can be found in licenses/http-types/LICENSE-urlDecode- :: Bool- -- ^ Whether to decode '+' to ' '- -> BS.ByteString- -> BS.ByteString-urlDecode replacePlus z = fst $ BS.unfoldrN (BS.length z) go z- where- go bs' =- case BS.uncons bs' of- Nothing -> Nothing- Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space- Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent- (x, xs) <- BS.uncons ws- x' <- hexVal x- (y, ys) <- BS.uncons xs- y' <- hexVal y- Just (combine x' y', ys)- Just (w, ws) -> Just (w, ws)- hexVal w- | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9- | 65 <= w && w <= 70 = Just $ w - 55 -- A - F- | 97 <= w && w <= 102 = Just $ w - 87 -- a - f- | otherwise = Nothing- combine :: Word8 -> Word8 -> Word8- combine a b = shiftL a 4 .|. b---------------------------------------------------------------------------------- --TODO: keep an eye on perf here. seems like a good use case for a DList. the word8 list could be a set/hashset -- | Percent-encoding for URLs. Specify a list of additional -- unreserved characters to permit. urlEncode :: [Word8] -> ByteString -> Builder urlEncode extraUnreserved = mconcat . map encodeChar . BS.unpack- where- encodeChar ch | unreserved' ch = BB.fromWord8 ch- | otherwise = h2 ch-- unreserved' ch | ch >= 65 && ch <= 90 = True -- A-Z- | ch >= 97 && ch <= 122 = True -- a-z- | ch >= 48 && ch <= 57 = True -- 0-9- unreserved' c = c `elem` extraUnreserved+ where+ encodeChar ch+ | unreserved' ch = BB.fromWord8 ch+ | otherwise = h2 ch - h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b] -- percent (%)- h i | i < 10 = 48 + i -- zero (0)- | otherwise = 65 + i - 10 -- 65: A+ unreserved' ch+ | ch >= 65 && ch <= 90 = True -- A-Z+ | ch >= 97 && ch <= 122 = True -- a-z+ | ch >= 48 && ch <= 57 = True -- 0-9+ unreserved' c = c `elem` extraUnreserved + h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b] -- percent (%)+ h i+ | i < 10 = 48 + i -- zero (0)+ | otherwise = 65 + i - 10 -- 65: A -------------------------------------------------------------------------------+ -- | Encode a ByteString for use in the query section of a URL urlEncodeQuery :: ByteString -> Builder urlEncodeQuery = urlEncode unreserved8 - -------------------------------------------------------------------------------+ -- | Encode a ByteString for use in the path section of a URL urlEncodePath :: ByteString -> Builder urlEncodePath = urlEncode unreservedPath8++-------------------------------------------------------------------------------+downcaseBS :: ByteString -> ByteString+downcaseBS = BS8.map toLower++-------------------------------------------------------------------------------++-- | Simple data structure to get O(1) prepends on a list and defers the O(n)+newtype RL a = RL [a] deriving (Show)++(|>) :: RL a -> a -> RL a+RL as |> a = RL (a : as)++rl2L :: RL a -> [a]+rl2L (RL as) = reverse as++unsnoc :: RL a -> RL a+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,158 +1,203 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}-module URI.ByteString.Lens where+{-# LANGUAGE RecordWildCards #-} +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 #-} - --------------------------------------------------------------------------------uriSchemeL :: Lens' URI Scheme-uriSchemeL =- lens uriScheme (\a b -> a { uriScheme = b})-{-# INLINE uriSchemeL #-}---------------------------------------------------------------------------------- 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+{-# INLINE uriSchemeL #-} --------------------------------------------------------------------------------upoValidQueryCharL :: Lens' URIParserOptions (Word8 -> Bool)+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+{-# 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+{-# 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+{-# 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'+{-# INLINE fragmentL #-}++-------------------------------------------------------------------------------+upoValidQueryCharL :: Lens' URIParserOptions Bool upoValidQueryCharL =- lens upoValidQueryChar (\a b -> a { upoValidQueryChar = b})+ lens upoLaxQueryParsing (\a b -> a {upoLaxQueryParsing = b}) {-# INLINE upoValidQueryCharL #-} - ------------------------------------------------------------------------------- -- Lens machinery -------------------------------------------------------------------------------@@ -160,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
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module URI.ByteString.QQ+ ( uri,+ relativeRef,+ )+where++import Data.ByteString.Char8+import Instances.TH.Lift ()+import Language.Haskell.TH.Quote+import URI.ByteString++-- $setup+-- >>> :set -XQuasiQuotes++-- | Allows uri literals via QuasiQuotes language extension.+--+-- >>> 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."+ }++-------------------------------------------------------------------------------++-- | Allows relative ref literals via QuasiQuotes language extension.+--+-- >>> 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."+ }
src/URI/ByteString/Types.hs view
@@ -1,104 +1,221 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++#ifdef LIFT_COMPAT+{-# LANGUAGE TemplateHaskell #-}+#else+{-# LANGUAGE DeriveLift #-}+#endif module URI.ByteString.Types where --------------------------------------------------------------------------------import Data.ByteString (ByteString)-import Data.Monoid-import Data.Typeable-import Data.Word-import GHC.Generics---------------------------------------------------------------------------------import Prelude+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 +-------------------------------------------------------------------------------+#ifdef LIFT_COMPAT+import Language.Haskell.TH.Lift+import Language.Haskell.TH.Syntax ()+#else+import Language.Haskell.TH.Syntax+#endif -- | 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+deriveLift ''Scheme+#else+deriving instance Lift Scheme+#endif --------------------------------------------------------------------------------newtype Host = Host { hostBS :: ByteString }+newtype Host = Host {hostBS :: ByteString} deriving (Show, Eq, Generic, Typeable, Ord) +#ifdef LIFT_COMPAT+deriveLift ''Host+#else+deriving instance Lift Host+#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+deriveLift ''Port+#else+deriving instance Lift Port+#endif --------------------------------------------------------------------------------data Authority = Authority {- authorityUserInfo :: Maybe UserInfo- , authorityHost :: Host- , authorityPort :: Maybe Port- } deriving (Show, Eq, Generic, Typeable, Ord)+data UserInfo = UserInfo+ { uiUsername :: ByteString,+ uiPassword :: ByteString+ }+ deriving (Show, Eq, Generic, Typeable, Ord) +#ifdef LIFT_COMPAT+deriveLift ''UserInfo+#else+deriving instance Lift UserInfo+#endif --------------------------------------------------------------------------------data UserInfo = UserInfo {- uiUsername :: ByteString- , uiPassword :: ByteString- } 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+#else+deriving instance Lift Authority+#endif --------------------------------------------------------------------------------newtype Query = Query { queryPairs :: [(ByteString, ByteString)] }- deriving (Show, Eq, Monoid, Generic, Typeable, Ord)+newtype Query = Query {queryPairs :: [(ByteString, ByteString)]}+ deriving (Show, Eq, Semigroup.Semigroup, Monoid, Generic, Typeable, Ord) +#ifdef LIFT_COMPAT+deriveLift ''Query+#else+deriving instance Lift Query+#endif --------------------------------------------------------------------------------data URI = URI {- uriScheme :: Scheme- , uriAuthority :: Maybe Authority- , uriPath :: ByteString- , uriQuery :: Query- , uriFragment :: Maybe ByteString- -- ^ URI fragment. Does not include the #- } deriving (Show, Eq, Generic, Typeable, Ord)+data Absolute deriving (Typeable) +#ifdef LIFT_COMPAT+deriveLift ''Absolute+#else+deriving instance Lift Absolute+#endif --------------------------------------------------------------------------------data RelativeRef = RelativeRef {- rrAuthority :: Maybe Authority- , rrPath :: ByteString- , rrQuery :: Query- , rrFragment :: Maybe ByteString- -- ^ URI fragment. Does not include the #- } deriving (Show, Eq, Generic, Typeable, Ord)+data Relative deriving (Typeable) +#ifdef LIFT_COMPAT+deriveLift ''Relative+#else+deriving instance Lift Relative+#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++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+deriving instance Lift (URIRef a)+#endif++#ifdef WITH_TYPEABLE+deriving instance Typeable URIRef+#endif++-------------------------------------------------------------------------------+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+ } ---------------------------------------------------------------------------------- | URI Parser Types+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 -data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character- | InvalidChars -- ^ Subsequent characters in the schema were invalid- | MissingColon -- ^ Schemas must be followed by a colon- deriving (Show, Eq, Read, Generic, Typeable)+------------------------------------------------------------------------------- +data 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
@@ -3,15 +3,19 @@ ------------------------------------------------------------------------------- import Test.Tasty --------------------------------------------------------------------------------import URI.ByteStringTests-------------------------------------------------------------------------------- +import qualified URI.ByteStringQQTests+import qualified URI.ByteStringTests +-------------------------------------------------------------------------------+ main :: IO () main = defaultMain testSuite testSuite :: TestTree-testSuite = testGroup "uri-bytestring"- [- URI.ByteStringTests.tests- ]+testSuite =+ testGroup+ "uri-bytestring"+ [ URI.ByteStringTests.tests,+ URI.ByteStringQQTests.tests+ ]
− test/URI/ByteString/Arbitrary.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module URI.ByteString.Arbitrary where-----------------------------------------------------------------------------------import Control.Applicative-import Data.Derive.Arbitrary (makeArbitrary)-import Data.DeriveTH (derive)-import Test.QuickCheck-import Test.QuickCheck.Instances ()---------------------------------------------------------------------------------import Prelude---------------------------------------------------------------------------------import URI.ByteString-----------------------------------------------------------------------------------instance Arbitrary UserInfo where- arbitrary = UserInfo <$> arbitrary- <*> arbitrary---instance Arbitrary Authority where- arbitrary = Authority <$> arbitrary- <*> arbitrary- <*> arbitrary---instance Arbitrary Host where- arbitrary = Host <$> arbitrary---instance Arbitrary Port where- arbitrary = Port <$> arbitrary---instance Arbitrary URI where- arbitrary = URI <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary---instance Arbitrary RelativeRef where- arbitrary = RelativeRef <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary---instance Arbitrary Scheme where- arbitrary = Scheme <$> arbitrary---instance Arbitrary Query where- arbitrary = Query <$> arbitrary---instance Arbitrary URIParserOptions where- arbitrary = URIParserOptions <$> arbitrary---$(derive makeArbitrary ''SchemaError)-$(derive makeArbitrary ''URIParseError)
+ test/URI/ByteString/Generators.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++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 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+ }++genAuthority :: Gen Authority+genAuthority = do+ userInfo <- Gen.maybe genUserInfo+ host <- genHost+ port <- Gen.maybe genPort+ 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+ }++genAbsoluteURIRef :: Gen (URIRef Absolute)+genAbsoluteURIRef = do+ scheme <- genScheme+ authority <- Gen.maybe genAuthority+ 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+ }++genScheme :: Gen Scheme+genScheme = Scheme <$> genAlphaNumBS++genQuery :: Gen Query+genQuery = do+ pairs <- Gen.list (Range.linear 0 10) ((,) <$> genAlphaNumBS <*> genAlphaNumBS)+ pure $+ Query+ { queryPairs = pairs+ }++genURIParserOptions :: Gen URIParserOptions+genURIParserOptions = do+ cointoss <- Gen.bool+ pure $+ URIParserOptions+ { upoLaxQueryParsing = cointoss+ }++genURINormalizationOptions :: Gen URINormalizationOptions+genURINormalizationOptions = do+ dScheme <- Gen.bool+ dHost <- Gen.bool+ dPort <- Gen.bool+ slashPath <- Gen.bool+ dSlashes <- Gen.bool+ 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+ }++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+ ]++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
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module URI.ByteStringQQTests (tests) where++-------------------------------------------------------------------------------+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")+ ]
test/URI/ByteStringTests.hs view
@@ -1,333 +1,557 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+ module URI.ByteStringTests (tests) where --------------------------------------------------------------------------------import Control.Lens import qualified Blaze.ByteString.Builder as BB-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B8-import Data.Monoid-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck+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.Arbitrary ()+import URI.ByteString+import URI.ByteString.Generators -------------------------------------------------------------------------------+import URI.ByteStringQQTests ()+import Prelude -tests :: TestTree-tests = testGroup "URI.Bytestring"- [- parseUriTests- , uriParseErrorInstancesTests- , lensTests- , serializeURITests- ]+infixr 4 .~ +(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t+(.~) l b s = runIdentity (l (const (Identity b)) s) +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+ ]+ ------------------------------------------------------------------------------- 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")- , 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 "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 (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")])- Nothing-- , testParses "https://www.example.org?listParam%5B%5D=foo,bar" $- URI (Scheme "https")+ Nothing,+ testParses "https://www.example.org?listParam%5B%5D=foo,bar" $+ URI+ (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")])- Nothing-- , testParses "https://www.example.org#only-fragment" $- URI (Scheme "https")+ Nothing,+ testParses "https://www.example.org#only-fragment" $+ URI+ (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [])- (Just "only-fragment")- , testParses "https://www.example.org/weird%20path" $- URI (Scheme "https")- (Just (Authority Nothing (Host "www.example.org") Nothing))- "/weird path"- (Query [])- Nothing-- , parseTestURI strictURIParserOptions "http://www.example.org/." $- Right $ URI- (Scheme "http")+ (Just "only-fragment"),+ testParses "https://www.example.org/weird%20path" $+ URI+ (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing))- "/."- (Query [])- Nothing- , parseTestURI strictURIParserOptions "http:/." $- Right $ URI- (Scheme "http")- Nothing- "/."- (Query [])- Nothing-- , roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt"- , roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt"- , roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com"- , roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix"- , roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212"- , roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/"-- -- RFC 3986, Section 4.2- , parseTestRelativeRef strictURIParserOptions "verysimple" $- Right $ RelativeRef- Nothing- "verysimple"+ "/weird path" (Query [])- Nothing- , parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $- Left $ MalformedPath- , parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $- Right $ RelativeRef- Nothing- "./this:that/thap/sub"- (Query [("1", "2")])- Nothing- ]-+ Nothing,+ parseTestURI strictURIParserOptions "http://www.example.org/." $+ Right $+ URI+ (Scheme "http")+ (Just (Authority Nothing (Host "www.example.org") Nothing))+ "/."+ (Query [])+ Nothing,+ parseTestURI strictURIParserOptions "http:/." $+ Right $+ URI+ (Scheme "http")+ Nothing+ "/."+ (Query [])+ Nothing,+ parseTestURI strictURIParserOptions "file:c:/foo" $+ Right $+ URI+ (Scheme "file")+ Nothing+ "c:/foo"+ (Query [])+ Nothing,+ parseTestURI strictURIParserOptions "file:///foo/%F" $+ Left MalformedPath,+ parseTestURI strictURIParserOptions "file:///foo/?foo=%F" $+ Left MalformedQuery,+ roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt",+ roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt",+ roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com",+ roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix",+ roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212",+ roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/",+ -- percent encoding in queries and fragments+ roundtripTestURI strictURIParserOptions "http://example.com/foo#bar%20baz",+ roundtripTestURI strictURIParserOptions "http://example.com/foo?bar%20baz=quux",+ roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux",+ roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux#bar%20baz",+ -- RFC 3986, Section 4.2+ parseTestRelativeRef strictURIParserOptions "verysimple" $+ Right $+ RelativeRef+ Nothing+ "verysimple"+ (Query [])+ Nothing,+ parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $+ Left $+ MalformedPath,+ parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $+ Right $+ RelativeRef+ Nothing+ "./this:that/thap/sub"+ (Query [("1", "2")])+ Nothing+ ] ------------------------------------------------------------------------------- uriParseErrorInstancesTests :: TestTree-uriParseErrorInstancesTests = testGroup "URIParseError instances"- [- testProperty "roundtrips between Show and Read" $ \(e :: URIParseError) ->- read (show e) == e- ]-+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" $ \bs bs' ->- let wrapped = Scheme bs- in (wrapped ^. schemeBSL) === schemeBS wrapped .&&.- (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'}- , testProperty "hostBSL Lens" $ \bs bs' ->- let wrapped = Host bs- in (wrapped ^. hostBSL) === hostBS wrapped .&&.- (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'}- , testProperty "portNumberL Lens" $ \n n' ->- let wrapped = Port n- in (wrapped ^. portNumberL) === portNumber wrapped .&&.- (wrapped & portNumberL .~ n') === wrapped { portNumber = n'}- , testProperty "queryPairsL Lens" $ \ps ps' ->- let wrapped = Query ps- in wrapped ^. queryPairsL === queryPairs wrapped .&&.- (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'}-- , testProperty "authorityUserInfoL Lens" $ \a ui ->- (a ^. authorityUserInfoL === authorityUserInfo a) .&&.- ((a & authorityUserInfoL .~ ui) === a { authorityUserInfo = ui })- , testProperty "authorityHostL Lens" $ \a host ->- (a ^. authorityHostL === authorityHost a) .&&.- ((a & authorityHostL .~ host) === a { authorityHost = host })- , testProperty "authorityPortL Lens" $ \a port ->- (a ^. authorityPortL === authorityPort a) .&&.- ((a & authorityPortL .~ port) === a { authorityPort = port })-- , testProperty "uiUsernameL Lens" $ \ui bs ->- (ui ^. uiUsernameL === uiUsername ui) .&&.- ((ui & uiUsernameL .~ bs) === ui { uiUsername = bs })- , testProperty "uiPasswordL Lens" $ \ui bs ->- (ui ^. uiPasswordL === uiPassword ui) .&&.- ((ui & uiPasswordL .~ bs) === ui { uiPassword = bs })-- , testProperty "uriSchemeL Lens" $ \uri x ->- (uri ^. uriSchemeL === uriScheme uri) .&&.- ((uri & uriSchemeL .~ x) === uri { uriScheme = x })- , testProperty "uriAuthorityL Lens" $ \uri x ->- (uri ^. uriAuthorityL === uriAuthority uri) .&&.- ((uri & uriAuthorityL .~ x) === uri { uriAuthority = x })- , testProperty "uriPathL Lens" $ \uri x ->- (uri ^. uriPathL === uriPath uri) .&&.- ((uri & uriPathL .~ x) === uri { uriPath = x })- , testProperty "uriQueryL Lens" $ \uri x ->- (uri ^. uriQueryL === uriQuery uri) .&&.- ((uri & uriQueryL .~ x) === uri { uriQuery = x })- , testProperty "uriFragmentL Lens" $ \uri x ->- (uri ^. uriFragmentL === uriFragment uri) .&&.- ((uri & uriFragmentL .~ x) === uri { uriFragment = x })-- , testProperty "rrAuthorityL Lens" $ \rr x ->- (rr ^. rrAuthorityL === rrAuthority rr) .&&.- ((rr & rrAuthorityL .~ x) === rr { rrAuthority = x })- , testProperty "rrPathL Lens" $ \rr x ->- (rr ^. rrPathL === rrPath rr) .&&.- ((rr & rrPathL .~ x) === rr { rrPath = x })- , testProperty "rrQueryL Lens" $ \rr x ->- (rr ^. rrQueryL === rrQuery rr) .&&.- ((rr & rrQueryL .~ x) === rr { rrQuery = x })- , testProperty "rrFragmentL Lens" $ \rr x ->- (rr ^. rrFragmentL === rrFragment rr) .&&.- ((rr & rrFragmentL .~ 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 . BB.toByteString . serializeURI) @?= 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 "serializeURI"- [- testCase "renders userinfo correctly" $ do- let ui = UserInfo "user" "pass"- let uri = URI (Scheme "http")- (Just (Authority (Just ui) (Host "www.example.org") Nothing))- "/"- (Query [("foo", "bar")])- (Just "somefragment")- let res = BB.toLazyByteString (serializeURI uri)- res @?= "http://user:pass@www.example.org/?foo=bar#somefragment"- , testCase "encodes decoded paths" $ do- let uri = URI (Scheme "http")- (Just (Authority Nothing (Host "www.example.org") Nothing))- "/weird path"- (Query [])- Nothing- let res = BB.toLazyByteString (serializeURI uri)- res @?= "http://www.example.org/weird%20path"- ]+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)))+ "/"+ (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/"+ ]+ where+ o = noNormalization+ 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 a = tripping a show readMay
uri-bytestring.cabal view
@@ -1,5 +1,5 @@ name: uri-bytestring-version: 0.1.9.2+version: 0.4.0.1 synopsis: Haskell URI parsing as ByteStrings description: uri-bytestring aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the URI data. license: BSD3@@ -10,12 +10,14 @@ copyright: Soostone Inc. category: Web build-type: Simple-cabal-version: >=1.16+cabal-version: 1.16 homepage: https://github.com/Soostone/uri-bytestring bug-reports: https://github.com/Soostone/uri-bytestring/issues-Tested-With: GHC == 7.6.3- , GHC == 7.8.4+Tested-With: GHC == 7.8.4 , GHC == 7.10.1+ , GHC == 8.0.2+ , GHC == 8.2.1+ , GHC == 8.4.1 extra-source-files: README.md CONTRIBUTING.md@@ -29,6 +31,7 @@ library exposed-modules: URI.ByteString+ URI.ByteString.QQ other-modules: URI.ByteString.Lens URI.ByteString.Types@@ -36,14 +39,27 @@ build-depends: - attoparsec >= 0.10 && < 0.14- , base >= 4.6 && < 4.9- , bytestring >= 0.9.1 && < 0.11- , blaze-builder >= 0.3.0.0 && < 0.5+ attoparsec >= 0.13.1.0+ , base >= 4.6 && < 5+ , bytestring >= 0.9.1+ , blaze-builder >= 0.3.0.0+ , template-haskell >= 2.9+ , th-lift-instances >= 0.1.8+ , containers hs-source-dirs: src default-language: Haskell2010 + if impl(ghc >= 7.8)+ cpp-options: -DWITH_TYPEABLE++ if !impl(ghc >= 8)+ cpp-options: -DLIFT_COMPAT+ build-depends:+ fail >= 4.9 && < 5,+ th-lift >= 0.7.5 && < 0.8,+ semigroups >= 0.16.2.2 && <0.19+ if flag(lib-Werror) ghc-options: -Werror @@ -53,24 +69,29 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules:- URI.ByteString.Arbitrary+ URI.ByteString.Generators URI.ByteStringTests+ URI.ByteStringQQTests hs-source-dirs: test build-depends: uri-bytestring , HUnit- , QuickCheck , tasty , tasty-hunit- , tasty-quickcheck- , derive+ , hedgehog+ , tasty-hedgehog , attoparsec , base+ , base-compat >= 0.7.0 , blaze-builder , bytestring- , lens- , quickcheck-instances- , semigroups+ , transformers+ , containers+ , safe++ if !impl(ghc >= 8)+ build-depends: semigroups+ default-language: Haskell2010 if flag(lib-Werror)