--- /dev/null
+# Contribution Guidelines
+
+1. Configure your project with `--enable-tests -flib-Werror`. This
+ will make sure tests get built and will treat all warnings as
+ errors. We are shooting for 0 warnings in this project.
+2. If you are considering some major functionality, please run it by
+ us in an issue first so you don't have to do a bunch of work that
+ will get rejected. This project is shooting for very minimal
+ dependencies and compliance with the RFC3986 spec, so we can't
+ include every feature under the sun.
+3. Please try to write a test if applicable.
+4. Please try to write a benchmark if applicable.
+5. If we forget to add you to the Contributors section of the README,
+ please let us know!
--- /dev/null
+Copyright (c) 2014, Soostone Inc
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+* Neither the name of the {organization} nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
--- /dev/null
+# uri-bytestring
+[](https://travis-ci.org/Soostone/uri-bytestring)
+[](https://hackage.haskell.org/package/uri-bytestring)
+
+Haskell URI parsing as ByteStrings
+
+
+## Contributors
+* [Michael Xavier](http://github.com/MichaelXavier)
+* [Doug Beardsley](http://github.com/mightybyte)
+* [Ozgun Ataman](http://github.com/ozataman)
+* [fisx](http://github.com/fisx)
+* [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)
--- /dev/null
+import Distribution.Simple
+main = defaultMain
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Main (main) where
+
+-------------------------------------------------------------------------------
+import Blaze.ByteString.Builder
+import Control.DeepSeq
+import Criterion.Main
+import Data.String
+import qualified Network.URI as NU
+-------------------------------------------------------------------------------
+import URI.ByteString
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+instance NFData Authority
+instance NFData Host
+instance NFData UserInfo
+instance NFData SchemaError
+instance NFData URIParseError
+instance NFData Scheme
+instance NFData Port
+instance NFData Query
+
+instance NFData (URIRef a) where
+ rnf (URI a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e
+ rnf (RelativeRef b c d e) = rnf b `seq` rnf c `seq` rnf d `seq` rnf e
+
+
+-------------------------------------------------------------------------------
+main :: IO ()
+main = defaultMain
+ [
+ bgroup "parsing"
+ [
+ bench "Network.URI.parseURI" $ nf NU.parseURI exampleURIS
+ , bench "URI.ByteString.parseURI strict" $ nf (parseURI strictURIParserOptions) exampleURIS
+ , bench "URI.ByteString.parseURI lax" $ nf (parseURI laxURIParserOptions) exampleURIS
+ , bench "URI.ByteString.parseRelativeRef strict" $ nf (parseRelativeRef strictURIParserOptions) exampleRelativeRefS
+ , bench "URI.ByteString.parseRelativeRef lax" $ nf (parseRelativeRef laxURIParserOptions) exampleRelativeRefS
+ ]
+ , bgroup "serializing"
+ [
+ bench "URI.ByteString.serializeURIRef on URI" $ nf (toLazyByteString . serializeURIRef) exampleURI
+ , bench "URI.ByteString.serializeURIRef on relative ref" $ nf (toLazyByteString . serializeURIRef) exampleRelativeRef
+ ]
+ ]
+
+
+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
+ }
+
+
+exampleRelativeRef :: RelativeRef
+exampleRelativeRef = RelativeRef {
+ rrAuthority = Just Authority {
+ authorityUserInfo = Nothing
+ , authorityHost = Host "google.com"
+ , authorityPort = Nothing
+ }
+ , rrPath = "/example"
+ , rrQuery = Query [("params", "youbetcha")]
+ , rrFragment = Nothing
+ }
--- /dev/null
+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.
+
+0.1.9
+* Fix type bug in serializeRelativeRef'
+
+0.1.8
+* Fix bug where uri-encoded paths would not decode when parsed.
+
+0.1.7
+* Add bytestring serialization functions. This is a common use case
+ and exporting these prevents the user from directly depending on
+ blaze-builder and re-implementing these functions in every application.
+
+0.1.6
+* Add Ord instances
+
+0.1.5
+* Fix serialization bug where userinfo was not including the @ separator.
+
+0.1.4
+* Bump attoparsec bounds
+
+0.1.3
+* Include test modules in distribution
+
+0.1.2
+* Add support for GHC 7.10
+
+0.1.1
+* Switch to blaze-bytestring for less contentious dependencies
+
+0.1
+* Add generic lenses (breaking field name changes).
+* Add support for relative refs.
+* Make Query instance of Generic, Typeable.
+
+0.0.1
+
+* Initial release.
--- /dev/null
+Copyright (c) 2011, Aristid Breitkreuz
+Copyright (c) 2011, Michael Snoyman
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Aristid Breitkreuz nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+{-|
+
+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
+ -- * Operations
+ , toAbsolute
+ -- * Parsing
+ , parseURI
+ , parseRelativeRef
+ , uriParser
+ , relativeRefParser
+ -- * Serializing
+ , serializeURIRef
+ , serializeURIRef'
+ , serializeQuery
+ , serializeQuery'
+ , serializeFragment
+ , serializeFragment'
+ , serializeAuthority
+ , serializeAuthority'
+ , serializeUserInfo
+ , serializeUserInfo'
+ -- ** Normalized Serialization
+ , normalizeURIRef
+ , normalizeURIRef'
+ -- * Low level utility functions
+ , urlDecode
+ , urlDecodeQuery
+ , urlEncodeQuery
+ , urlEncodePath
+ , urlEncode
+ -- * Lenses
+ -- ** Lenses over 'Scheme'
+ , schemeBSL
+ -- ** Lenses over 'Host'
+ , hostBSL
+ -- ** Lenses over 'Port'
+ , portNumberL
+ -- ** Lenses over 'Authority'
+ , authorityUserInfoL
+ , authorityHostL
+ , authorityPortL
+ -- ** Lenses over 'UserInfo'
+ , uiUsernameL
+ , uiPasswordL
+ -- ** Lenses over 'Query'
+ , queryPairsL
+ -- ** Lenses over 'URIRef'
+ , uriSchemeL
+ , authorityL
+ , pathL
+ , queryL
+ , fragmentL
+ -- ** Lenses over 'URIParserOptions'
+ , 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
+-------------------------------------------------------------------------------
--- /dev/null
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+module URI.ByteString.Internal where
+
+-------------------------------------------------------------------------------
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
+import Control.Applicative
+import Control.Monad
+import qualified Control.Monad.Fail as F
+import Data.Attoparsec.ByteString
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.Attoparsec.ByteString.Char8 as A (decimal)
+import Data.Bits
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.Char (ord, toLower)
+import Data.Ix
+import Data.List (delete, intersperse,
+ sortBy, stripPrefix, (\\))
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.Monoid as Monoid (mempty)
+import Data.Ord (comparing)
+import Data.Semigroup as Semigroup
+import Data.Word
+import Text.Read (readMaybe)
+-------------------------------------------------------------------------------
+import URI.ByteString.Types
+-------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+-- | Strict URI Parser config. Follows RFC3986 as-specified. Use this
+-- if you can be certain that your URIs are properly encoded or if you
+-- want parsing to fail if they deviate from the spec at all.
+strictURIParserOptions :: URIParserOptions
+strictURIParserOptions = URIParserOptions {
+ upoValidQueryChar = validForQuery
+ }
+
+
+-------------------------------------------------------------------------------
+-- | Lax URI Parser config. Use this if you you want to handle common
+-- deviations from the spec gracefully.
+--
+-- * Allows non-encoded [ and ] in query string
+laxURIParserOptions :: URIParserOptions
+laxURIParserOptions = URIParserOptions {
+ upoValidQueryChar = validForQueryLax
+ }
+
+
+-------------------------------------------------------------------------------
+-- | All normalization options disabled
+noNormalization :: URINormalizationOptions
+noNormalization = URINormalizationOptions False False False False False False False httpDefaultPorts
+
+
+-------------------------------------------------------------------------------
+-- | The set of known default ports to schemes. Currently only
+-- contains http\/80 and https\/443. Feel free to extend it if needed
+-- with 'unoDefaultPorts'.
+httpDefaultPorts :: M.Map Scheme Port
+httpDefaultPorts = M.fromList [ (Scheme "http", Port 80)
+ , (Scheme "https", Port 443)
+ ]
+
+
+-------------------------------------------------------------------------------
+-- | 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 True True True True True True True httpDefaultPorts
+
+
+-------------------------------------------------------------------------------
+-- | @toAbsolute scheme ref@ converts @ref@ to an absolute URI.
+-- If @ref@ is already absolute, then it is unchanged.
+toAbsolute :: Scheme -> URIRef a -> URIRef Absolute
+toAbsolute scheme (RelativeRef {..}) = URI scheme rrAuthority rrPath rrQuery rrFragment
+toAbsolute _ uri@(URI {..}) = uri
+
+
+-------------------------------------------------------------------------------
+-- | URI Serializer
+-------------------------------------------------------------------------------
+
+-- | Serialize a URI reference into a 'Builder'.
+--
+-- Example of serializing + converting to a lazy "Data.ByteString.Lazy.ByteString":
+--
+-- >>> 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"
+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 (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' :: URIRef Absolute -> ByteString
+serializeURI' = BB.toByteString . serializeURI
+{-# DEPRECATED serializeURI' "Use 'serializeURIRef'' instead" #-}
+
+
+-------------------------------------------------------------------------------
+-- | Like 'serializeURI', but do not render scheme.
+serializeRelativeRef :: URIRef Relative -> Builder
+serializeRelativeRef = normalizeRelativeRef noNormalization Nothing
+{-# DEPRECATED serializeRelativeRef "Use 'serializeURIRef' instead" #-}
+
+
+-------------------------------------------------------------------------------
+-- | Like 'serializeRelativeRef', with conversion into a strict 'ByteString'.
+serializeRelativeRef' :: URIRef Relative -> ByteString
+serializeRelativeRef' = BB.toByteString . serializeRelativeRef
+{-# DEPRECATED serializeRelativeRef' "Use 'serializeURIRef'' instead" #-}
+
+
+-------------------------------------------------------------------------------
+-- | Serialize the query part of a url
+-- @serializeQuery opts mempty = ""@
+-- @serializeQuery opts (Query [("a","b"),("c","d")]) = "?a=b&c=d"@
+serializeQuery :: URINormalizationOptions -> Query -> Builder
+serializeQuery _ (Query []) = mempty
+serializeQuery URINormalizationOptions {..} (Query ps) =
+ c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps'))
+ where
+ serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v
+ ps'
+ | unoSortParameters = sortBy (comparing fst) ps
+ | otherwise = ps
+
+
+serializeQuery' :: URINormalizationOptions -> Query -> ByteString
+serializeQuery' opts = BB.toByteString . serializeQuery opts
+
+
+-------------------------------------------------------------------------------
+serializeFragment :: Maybe ByteString -> Builder
+serializeFragment = maybe mempty (\s -> c8 '#' <> bs s)
+
+
+serializeFragment' :: Maybe ByteString -> ByteString
+serializeFragment' = BB.toByteString . serializeFragment
+
+
+-------------------------------------------------------------------------------
+serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder
+serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port
+ where
+ userinfo = maybe mempty serializeUserInfo authorityUserInfo
+ 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:
+--
+-- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar=baz#quux"
+-- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"})
+--
+-- >>> parseURI strictURIParserOptions "$$$$://badurl.example.org"
+-- Left (MalformedScheme NonAlphaLeading)
+--
+-- There are some urls that you'll encounter which defy the spec, such
+-- as those with square brackets in the query string. If you must be
+-- able to parse those, you can use "laxURIParserOptions" or specify your own
+--
+-- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar[]=baz"
+-- Left MalformedQuery
+--
+-- >>> parseURI laxURIParserOptions "http://www.example.org/foo?bar[]=baz"
+-- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar[]","baz")]}, uriFragment = Nothing})
+--
+-- >>> let myLaxOptions = URIParserOptions { upoValidQueryChar = liftA2 (||) (upoValidQueryChar strictURIParserOptions) (inClass "[]")}
+-- >>> parseURI myLaxOptions "http://www.example.org/foo?bar[]=baz"
+-- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar[]","baz")]}, uriFragment = Nothing})
+parseURI :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Absolute)
+parseURI opts = parseOnly' OtherError (uriParser' opts)
+
+-- | Like 'parseURI', but do not parse scheme.
+parseRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Relative)
+parseRelativeRef opts = parseOnly' OtherError (relativeRefParser' opts)
+
+
+-------------------------------------------------------------------------------
+-- | Convenience alias for a parser that can return URIParseError
+type URIParser = Parser' URIParseError
+
+
+-------------------------------------------------------------------------------
+-- | Underlying attoparsec parser. Useful for composing with your own parsers.
+uriParser :: URIParserOptions -> Parser (URIRef Absolute)
+uriParser = unParser' . uriParser'
+
+
+-------------------------------------------------------------------------------
+-- | Toplevel parser for URIs
+uriParser' :: URIParserOptions -> URIParser (URIRef Absolute)
+uriParser' opts = do
+ scheme <- schemeParser
+ void $ word8 colon `orFailWith` MalformedScheme MissingColon
+ RelativeRef authority path query fragment <- relativeRefParser' opts
+ return $ URI scheme authority path query fragment
+
+
+-------------------------------------------------------------------------------
+-- | Underlying attoparsec parser. Useful for composing with your own parsers.
+relativeRefParser :: URIParserOptions -> Parser (URIRef Relative)
+relativeRefParser = unParser' . relativeRefParser'
+
+
+-------------------------------------------------------------------------------
+-- | Toplevel parser for relative refs
+relativeRefParser' :: URIParserOptions -> URIParser (URIRef Relative)
+relativeRefParser' opts = do
+ (authority, path) <- hierPartParser <|> rrPathParser
+ query <- queryParser opts
+ frag <- mFragmentParser
+ case frag of
+ Just _ -> endOfInput `orFailWith` MalformedFragment
+ Nothing -> endOfInput `orFailWith` MalformedQuery
+ return $ RelativeRef authority path query frag
+
+
+-------------------------------------------------------------------------------
+-- | Parser for scheme, e.g. "http", "https", etc.
+schemeParser :: URIParser Scheme
+schemeParser = do
+ c <- satisfy isAlpha `orFailWith` MalformedScheme NonAlphaLeading
+ rest <- A.takeWhile isSchemeValid `orFailWith` MalformedScheme InvalidChars
+ return $ Scheme $ c `BS.cons` rest
+ where
+ isSchemeValid = inClass $ "-+." ++ alphaNum
+
+
+-------------------------------------------------------------------------------
+-- | Hier part immediately follows the schema and encompasses the
+-- authority and path sections.
+hierPartParser :: URIParser (Maybe Authority, ByteString)
+hierPartParser = authWithPathParser <|>
+ pathAbsoluteParser <|>
+ pathRootlessParser <|>
+ pathEmptyParser
+
+
+-------------------------------------------------------------------------------
+-- | Relative references have awkward corner cases. See
+-- 'firstRelRefSegmentParser'.
+rrPathParser :: URIParser (Maybe Authority, ByteString)
+rrPathParser = (Nothing,) <$>
+ ((<>) <$> firstRelRefSegmentParser <*> pathParser)
+
+
+-------------------------------------------------------------------------------
+-- | See the "authority path-abempty" grammar in the RFC
+authWithPathParser :: URIParser (Maybe Authority, ByteString)
+authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> pathParser)
+
+
+-------------------------------------------------------------------------------
+-- | See the "path-absolute" grammar in the RFC. Essentially a special
+-- case of rootless.
+pathAbsoluteParser :: URIParser (Maybe Authority, ByteString)
+pathAbsoluteParser = string' "/" *> pathRootlessParser
+
+
+-------------------------------------------------------------------------------
+-- | See the "path-rootless" grammar in the RFC.
+pathRootlessParser :: URIParser (Maybe Authority, ByteString)
+pathRootlessParser = (,) <$> pure Nothing <*> pathParser1
+
+
+-------------------------------------------------------------------------------
+-- | See the "path-empty" grammar in the RFC. Must not be followed
+-- with a path-valid char.
+pathEmptyParser :: URIParser (Maybe Authority, ByteString)
+pathEmptyParser = do
+ nextChar <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error"
+ case nextChar of
+ Just c -> guard (notInClass pchar c) >> return emptyCase
+ _ -> return emptyCase
+ where
+ emptyCase = (Nothing, mempty)
+
+
+-------------------------------------------------------------------------------
+-- | Parser whe
+mAuthorityParser :: URIParser (Maybe Authority)
+mAuthorityParser = mParse authorityParser
+
+
+-------------------------------------------------------------------------------
+-- | Parses the user info section of a URL (i.e. for HTTP Basic
+-- Authentication). Note that this will decode any percent-encoded
+-- data.
+userInfoParser :: URIParser UserInfo
+userInfoParser = (uiTokenParser <* word8 atSym) `orFailWith` MalformedUserInfo
+ where
+ atSym = 64
+ uiTokenParser = do
+ ui <- A.takeWhile1 validForUserInfo
+ let (user, passWithColon) = BS.break (== colon) $ urlDecode' ui
+ let pass = BS.drop 1 passWithColon
+ return $ UserInfo user pass
+ validForUserInfo = inClass $ pctEncoded ++ subDelims ++ (':' : unreserved)
+
+
+-------------------------------------------------------------------------------
+-- | Authority consists of host and port
+authorityParser :: URIParser Authority
+authorityParser = Authority <$> mParse userInfoParser <*> hostParser <*> mPortParser
+
+
+-------------------------------------------------------------------------------
+-- | Parser that can handle IPV6/Future literals, IPV4, and domain names.
+hostParser :: URIParser Host
+hostParser = (Host <$> parsers) `orFailWith` MalformedHost
+ where
+ parsers = ipLiteralParser <|> ipV4Parser <|> regNameParser
+ ipLiteralParser = word8 oBracket *> (ipVFutureParser <|> ipV6Parser) <* word8 cBracket
+
+
+-------------------------------------------------------------------------------
+-- | Parses IPV6 addresses. See relevant section in RFC.
+ipV6Parser :: Parser ByteString
+ipV6Parser = do
+ leading <- h16s
+ elided <- maybe [] (const [""]) <$> optional (string "::")
+ trailing <- many (A.takeWhile (/= colon) <* word8 colon)
+ (finalChunkLen, final) <- finalChunk
+ let len = length (leading ++ trailing) + finalChunkLen
+ when (len > 8) $ fail "Too many digits in IPv6 address"
+ return $ rejoin $ [rejoin leading] ++ elided ++ trailing ++ maybeToList final
+ where
+ finalChunk = fromMaybe (0, Nothing) <$> optional (finalIpV4 <|> finalH16)
+ finalH16 = (1, ) . Just <$> h16
+ finalIpV4 = (2, ) . Just <$> ipV4Parser
+ rejoin = BS.intercalate ":"
+ h16s = h16 `sepBy` word8 colon
+ h16 = mconcat <$> parseBetween 1 4 (A.takeWhile1 hexDigit)
+
+
+-------------------------------------------------------------------------------
+-- | Parses IPVFuture addresses. See relevant section in RFC.
+ipVFutureParser :: Parser ByteString
+ipVFutureParser = do
+ _ <- word8 lowercaseV
+ ds <- A.takeWhile1 hexDigit
+ _ <- word8 period
+ rest <- A.takeWhile1 $ inClass $ subDelims ++ ":" ++ unreserved
+ return $ "v" <> ds <> "." <> rest
+ where
+ lowercaseV = 118
+
+
+-------------------------------------------------------------------------------
+-- | Parses a valid IPV4 address
+ipV4Parser :: Parser ByteString
+ipV4Parser = mconcat <$> sequence [ decOctet
+ , dot
+ , decOctet
+ , dot
+ , decOctet
+ , dot
+ , decOctet]
+ where
+ decOctet :: Parser ByteString
+ decOctet = do
+ (s,num) <- A.match A.decimal
+ let len = BS.length s
+ guard $ len <= 3
+ guard $ num >= (1 :: Int) && num <= 255
+ return s
+ dot = string "."
+
+
+-------------------------------------------------------------------------------
+-- | This corresponds to the hostname, e.g. www.example.org
+regNameParser :: Parser ByteString
+regNameParser = urlDecode' <$> A.takeWhile1 (inClass validForRegName)
+ where
+ validForRegName = pctEncoded ++ subDelims ++ unreserved
+
+
+-------------------------------------------------------------------------------
+-- | 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 <$> 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'
+
+
+-------------------------------------------------------------------------------
+-- | 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)]
+
+
+-------------------------------------------------------------------------------
+-- | Parses the first segment of a path section of a relative-path
+-- reference. See RFC 3986, Section 4.2.
+-- firstRelRefSegmentParser :: URIParser ByteString
+firstRelRefSegmentParser :: URIParser ByteString
+firstRelRefSegmentParser = A.takeWhile (inClass (pchar \\ ":")) `orFailWith` MalformedPath
+
+
+-------------------------------------------------------------------------------
+-- | This parser is being a bit pragmatic. The query section in the
+-- spec does not identify the key/value format used in URIs, but that
+-- is what most users are expecting to see. One alternative could be
+-- to just expose the query string as a string and offer functions on
+-- URI to parse a query string to a Query.
+queryParser :: URIParserOptions -> URIParser Query
+queryParser opts = do
+ mc <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error"
+ case mc of
+ Just c
+ | c == question -> skip' 1 *> itemsParser
+ | c == hash -> pure mempty
+ | otherwise -> fail' MalformedPath
+ _ -> pure mempty
+ where
+ itemsParser = Query . 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)
+
+
+-------------------------------------------------------------------------------
+validForQuery :: Word8 -> Bool
+validForQuery = inClass ('?':'/':delete '&' pchar)
+
+
+-------------------------------------------------------------------------------
+validForQueryLax :: Word8 -> Bool
+validForQueryLax = notInClass "&#"
+
+
+-------------------------------------------------------------------------------
+-- | Only parses a fragment if the # signifiier is there
+mFragmentParser :: URIParser (Maybe ByteString)
+mFragmentParser = mParse $ word8' hash *> fragmentParser
+
+
+-------------------------------------------------------------------------------
+-- | The final piece of a uri, e.g. #fragment, minus the #.
+fragmentParser :: URIParser ByteString
+fragmentParser = Parser' $ A.takeWhile validFragmentWord
+ where
+ validFragmentWord = inClass ('?':'/':pchar)
+
+
+-------------------------------------------------------------------------------
+-- | Grammar Components
+-------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+hexDigit :: Word8 -> Bool
+hexDigit = inClass "0-9a-fA-F"
+
+
+-------------------------------------------------------------------------------
+isAlpha :: Word8 -> Bool
+isAlpha = inClass alpha
+
+
+-------------------------------------------------------------------------------
+isDigit :: Word8 -> Bool
+isDigit = inClass digit
+
+
+-------------------------------------------------------------------------------
+pchar :: String
+pchar = pctEncoded ++ subDelims ++ ":@" ++ unreserved
+
+
+-------------------------------------------------------------------------------
+-- Very important! When concatenating this to other strings to make larger
+-- character classes, you must put this at the end because the '-' character
+-- is treated as a range unless it's at the beginning or end.
+unreserved :: String
+unreserved = alphaNum ++ "~._-"
+
+
+-------------------------------------------------------------------------------
+unreserved8 :: [Word8]
+unreserved8 = map ord8 unreserved
+
+
+-------------------------------------------------------------------------------
+unreservedPath8 :: [Word8]
+unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$,"
+
+-------------------------------------------------------------------------------
+ord8 :: Char -> Word8
+ord8 = fromIntegral . ord
+
+
+-------------------------------------------------------------------------------
+-- | pc-encoded technically is % HEXDIG HEXDIG but that's handled by
+-- the previous alphaNum constraint. May need to double back with a
+-- parser to ensure pct-encoded never exceeds 2 hexdigs after
+pctEncoded :: String
+pctEncoded = "%"
+
+
+-------------------------------------------------------------------------------
+subDelims :: String
+subDelims = "!$&'()*+,;="
+
+
+-------------------------------------------------------------------------------
+alphaNum :: String
+alphaNum = alpha ++ digit
+
+
+-------------------------------------------------------------------------------
+alpha :: String
+alpha = "a-zA-Z"
+
+
+-------------------------------------------------------------------------------
+digit :: String
+digit = "0-9"
+
+
+-------------------------------------------------------------------------------
+colon :: Word8
+colon = 58
+
+
+-------------------------------------------------------------------------------
+oBracket :: Word8
+oBracket = 91
+
+
+-------------------------------------------------------------------------------
+cBracket :: Word8
+cBracket = 93
+
+
+-------------------------------------------------------------------------------
+equals :: Word8
+equals = 61
+
+
+-------------------------------------------------------------------------------
+question :: Word8
+question = 63
+
+
+-------------------------------------------------------------------------------
+ampersand :: Word8
+ampersand = 38
+
+
+-------------------------------------------------------------------------------
+hash :: Word8
+hash = 35
+
+
+-------------------------------------------------------------------------------
+period :: Word8
+period = 46
+
+
+-------------------------------------------------------------------------------
+slash :: Word8
+slash = 47
+
+
+-------------------------------------------------------------------------------
+-- | ByteString Utilities
+-------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+-- | Decoding specifically for the query string, which decodes + as
+-- space. Shorthand for @urlDecode True@
+urlDecodeQuery :: ByteString -> ByteString
+urlDecodeQuery = urlDecode plusToSpace
+ where
+ plusToSpace = True
+
+
+-------------------------------------------------------------------------------
+-- | Decode any part of the URL besides the query, which decodes + as
+-- space.
+urlDecode' :: ByteString -> ByteString
+urlDecode' = urlDecode plusToSpace
+ where
+ plusToSpace = False
+
+
+-------------------------------------------------------------------------------
+-- | Parsing with Strongly-Typed Errors
+-------------------------------------------------------------------------------
+
+
+-- | A parser with a specific error type. Attoparsec unfortunately
+-- throws all errors into strings, which cannot be handled well
+-- programmatically without doing something silly like parsing error
+-- messages. This wrapper attempts to concentrate these errors into
+-- one type.
+newtype Parser' e a = Parser' { unParser' :: Parser a}
+ deriving ( Functor
+ , Applicative
+ , Alternative
+ , Monad
+ , MonadPlus
+ , Semigroup.Semigroup
+ , Monoid)
+
+
+instance F.MonadFail (Parser' e) where
+#if MIN_VERSION_attoparsec(0,13,1)
+ fail e = Parser' (F.fail e)
+#else
+ fail e = Parser' (fail e)
+#endif
+
+
+-------------------------------------------------------------------------------
+-- | Use with caution. Catch a parser failing and return Nothing.
+mParse :: Parser' e a -> Parser' e (Maybe a)
+mParse p = A.option Nothing (Just <$> p)
+
+
+-------------------------------------------------------------------------------
+-- | If the first parser succeeds, discard the result and use the
+-- second parser (which may fail). If the first parser fails, return
+-- Nothing. This is used to check a benign precondition that indicates
+-- 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) => Parser a -> e -> Parser' e a
+orFailWith p e = Parser' p <|> fail' e
+
+
+-------------------------------------------------------------------------------
+-- | Should be preferred to fail'
+fail' :: (Show e) => e -> Parser' e a
+fail' = fail . show
+
+
+-------------------------------------------------------------------------------
+parseBetween :: (Alternative m, Monad m) => Int -> Int -> m a -> m [a]
+parseBetween a b f = choice parsers
+ where
+ parsers = map (`count` f) $ reverse $ range (a, b)
+
+
+-------------------------------------------------------------------------------
+-- | Stronger-typed variation of parseOnly'. Consumes all input.
+parseOnly' :: (Read e)
+ => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality.
+ -> Parser' e a
+ -> ByteString
+ -> Either e a
+parseOnly' noParse (Parser' p) = fmapL readWithFallback . parseOnly p
+ where
+ readWithFallback s = fromMaybe (noParse s) (readMaybe . stripAttoparsecGarbage $ s)
+
+-------------------------------------------------------------------------------
+-- | Our pal Control.Monad.fail is how attoparsec propagates
+-- errors. If you throw an error string with fail (your only choice),
+-- it will *always* prepend it with "Failed reading: ". At least in
+-- this version. That may change to something else and break this workaround.
+stripAttoparsecGarbage :: String -> String
+stripAttoparsecGarbage = stripPrefix' "Failed reading: "
+
+
+-------------------------------------------------------------------------------
+-- | stripPrefix where it is a noop if the prefix doesn't exist.
+stripPrefix' :: Eq a => [a] -> [a] -> [a]
+stripPrefix' pfx s = fromMaybe s $ stripPrefix pfx s
+
+
+-------------------------------------------------------------------------------
+fmapL :: (a -> b) -> Either a r -> Either b r
+fmapL f = either (Left . f) Right
+
+
+-------------------------------------------------------------------------------
+-- | This function was 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
+
+ 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
--- /dev/null
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module URI.ByteString.Lens where
+
+
+-------------------------------------------------------------------------------
+import Control.Applicative
+import Data.ByteString (ByteString)
+import Data.Word
+-------------------------------------------------------------------------------
+import Prelude
+-------------------------------------------------------------------------------
+import URI.ByteString.Types
+-------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+schemeBSL
+ :: Lens' Scheme ByteString
+schemeBSL =
+ lens schemeBS (\a b -> a { schemeBS = b})
+{-# INLINE schemeBSL #-}
+
+-------------------------------------------------------------------------------
+hostBSL
+ :: Lens' Host ByteString
+hostBSL =
+ lens hostBS (\a b -> a { hostBS = b})
+{-# INLINE hostBSL #-}
+
+
+-------------------------------------------------------------------------------
+portNumberL
+ :: Lens' Port Int
+portNumberL =
+ lens portNumber (\a b -> a { portNumber = b})
+{-# INLINE portNumberL #-}
+
+
+-------------------------------------------------------------------------------
+authorityUserInfoL
+ :: Lens' Authority (Maybe UserInfo)
+authorityUserInfoL =
+ lens authorityUserInfo (\a b -> a { authorityUserInfo = b})
+{-# INLINE authorityUserInfoL #-}
+
+-------------------------------------------------------------------------------
+authorityHostL
+ :: Lens' Authority Host
+authorityHostL =
+ lens authorityHost (\a b -> a { authorityHost = b})
+{-# INLINE authorityHostL #-}
+
+-------------------------------------------------------------------------------
+authorityPortL
+ :: Lens' Authority (Maybe Port)
+authorityPortL =
+ lens authorityPort (\a b -> a { authorityPort = b})
+{-# INLINE authorityPortL #-}
+
+-------------------------------------------------------------------------------
+uiUsernameL
+ :: Lens' UserInfo ByteString
+uiUsernameL =
+ lens uiUsername (\a b -> a { uiUsername = b})
+{-# INLINE uiUsernameL #-}
+
+
+-------------------------------------------------------------------------------
+uiPasswordL
+ :: Lens' UserInfo ByteString
+uiPasswordL =
+ lens uiPassword (\a b -> a { uiPassword = b})
+{-# INLINE uiPasswordL #-}
+
+
+-------------------------------------------------------------------------------
+queryPairsL
+ :: Lens' Query [(ByteString, ByteString)]
+queryPairsL =
+ lens queryPairs (\a b -> a { queryPairs = b})
+{-# INLINE queryPairsL #-}
+
+
+-------------------------------------------------------------------------------
+uriAuthorityL :: Lens' URI (Maybe Authority)
+uriAuthorityL =
+ 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})
+{-# INLINE uriPathL #-}
+{-# DEPRECATED uriPathL "Use 'pathL' instead" #-}
+
+
+-------------------------------------------------------------------------------
+uriQueryL :: Lens' URI Query
+uriQueryL =
+ 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})
+{-# INLINE uriFragmentL #-}
+{-# DEPRECATED uriFragmentL "Use 'fragmentL' instead" #-}
+
+
+-------------------------------------------------------------------------------
+rrAuthorityL :: Lens' RelativeRef (Maybe Authority)
+rrAuthorityL =
+ 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})
+{-# INLINE rrPathL #-}
+{-# DEPRECATED rrPathL "Use 'pathL' instead" #-}
+
+
+-------------------------------------------------------------------------------
+rrQueryL :: Lens' RelativeRef Query
+rrQueryL =
+ 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})
+{-# 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 #-}
+
+
+-------------------------------------------------------------------------------
+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 (Word8 -> Bool)
+upoValidQueryCharL =
+ lens upoValidQueryChar (\a b -> a { upoValidQueryChar = b})
+{-# INLINE upoValidQueryCharL #-}
+
+
+-------------------------------------------------------------------------------
+-- Lens machinery
+-------------------------------------------------------------------------------
+-- Unexported type aliases to clean up the documentation
+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
+lens sa sbt afb s = sbt s <$> afb (sa s)
+{-# INLINE lens #-}
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+
+module URI.ByteString.QQ
+ ( uri
+ , relativeRef
+ ) where
+
+import Language.Haskell.TH.Quote
+import URI.ByteString
+import Data.ByteString.Char8
+import Instances.TH.Lift()
+
+-- | Allows uri literals via QuasiQuotes language extension.
+--
+-- >>> {-# LANGUAGE QuasiQuotes #-}
+-- >>> stackage :: URI
+-- >>> stackage = [uri|http://stackage.org|]
+uri :: QuasiQuoter
+uri = QuasiQuoter { quoteExp = \s ->
+ let
+ parsedURI = either (\err -> error $ show err) id (parseURI laxURIParserOptions (pack s))
+ in
+ [| parsedURI |],
+ quotePat = error "Not implemented.",
+ quoteType = error "Not implemented.",
+ quoteDec = error "Not implemented."
+ }
+
+
+-------------------------------------------------------------------------------
+-- | Allows relative ref literals via QuasiQuotes language extension.
+--
+-- >>> {-# LANGUAGE QuasiQuotes #-}
+-- >>> ref :: RelativeRef
+-- >>> ref = [relativeRef|/foo?bar=baz#quux|]
+relativeRef :: QuasiQuoter
+relativeRef = QuasiQuoter { quoteExp = \s ->
+ let
+ parsedURI = either (\err -> error $ show err) id (parseRelativeRef laxURIParserOptions (pack s))
+ in
+ [| parsedURI |],
+ quotePat = error "Not implemented.",
+ quoteType = error "Not implemented.",
+ quoteDec = error "Not implemented."
+ }
--- /dev/null
+{-# 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 qualified Data.Map.Strict as M
+import Data.Monoid
+import Data.Semigroup as Semigroup
+import Data.Typeable
+import Data.Word
+import GHC.Generics
+import Instances.TH.Lift ()
+-------------------------------------------------------------------------------
+import 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 }
+ deriving (Show, Eq, Generic, Typeable, Ord)
+
+#ifdef LIFT_COMPAT
+deriveLift ''Scheme
+#else
+deriving instance Lift Scheme
+#endif
+
+-------------------------------------------------------------------------------
+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 }
+ deriving (Show, Eq, Generic, Typeable, Ord)
+
+#ifdef LIFT_COMPAT
+deriveLift ''Port
+#else
+deriving instance Lift Port
+#endif
+
+-------------------------------------------------------------------------------
+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 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, Semigroup.Semigroup, Monoid, Generic, Typeable, Ord)
+
+#ifdef LIFT_COMPAT
+deriveLift ''Query
+#else
+deriving instance Lift Query
+#endif
+
+-------------------------------------------------------------------------------
+data Absolute deriving(Typeable)
+
+#ifdef LIFT_COMPAT
+deriveLift ''Absolute
+#else
+deriving instance Lift Absolute
+#endif
+
+-------------------------------------------------------------------------------
+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 URINormalizationOptions = URINormalizationOptions {
+ unoDowncaseScheme :: Bool
+ -- ^ hTtP -> http
+ , unoDowncaseHost :: Bool
+ -- ^ eXaMpLe.org -> example.org
+ , unoDropDefPort :: Bool
+ -- ^ If the scheme is known and the port is the default (e.g. 80 for http) it is removed.
+ , unoSlashEmptyPath :: Bool
+ -- ^ If the path is empty, set it to \/
+ , unoDropExtraSlashes :: Bool
+ -- ^ Rewrite path from \/foo\/\/bar\/\/\/baz to \/foo\/bar\/baz
+ , unoSortParameters :: Bool
+ -- ^ Sorts parameters by parameter name
+ , unoRemoveDotSegments :: Bool
+ -- ^ Remove dot segments as per <https://tools.ietf.org/html/rfc3986#section-5.2.4 RFC3986 Section 5.2.4>
+ , unoDefaultPorts :: M.Map Scheme Port
+ -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled.
+ } deriving (Show, Eq)
+
+
+-------------------------------------------------------------------------------
+-- | URI Parser Types
+-------------------------------------------------------------------------------
+
+
+data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character
+ | InvalidChars -- ^ Subsequent characters in the schema were invalid
+ | MissingColon -- ^ Schemas must be followed by a colon
+ deriving (Show, Eq, Read, Generic, Typeable, Enum, Bounded)
+
+
+-------------------------------------------------------------------------------
+data URIParseError = MalformedScheme SchemaError
+ | MalformedUserInfo
+ | MalformedQuery
+ | MalformedFragment
+ | MalformedHost
+ | MalformedPort
+ | MalformedPath
+ | OtherError String -- ^ Catchall for unpredictable errors
+ deriving (Show, Eq, Generic, Read, Typeable)
--- /dev/null
+module Main (main) where
+
+-------------------------------------------------------------------------------
+import Test.Tasty
+-------------------------------------------------------------------------------
+import qualified URI.ByteStringTests
+import qualified URI.ByteStringQQTests
+-------------------------------------------------------------------------------
+
+
+main :: IO ()
+main = defaultMain testSuite
+
+testSuite :: TestTree
+testSuite = testGroup "uri-bytestring"
+ [
+ URI.ByteStringTests.tests
+ , URI.ByteStringQQTests.tests
+ ]
--- /dev/null
+{-# 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 Prelude
+-------------------------------------------------------------------------------
+import URI.ByteString
+-------------------------------------------------------------------------------
+
+
+
+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
+ { upoValidQueryChar = const 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)
--- /dev/null
+{-# 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")
+ ]
--- /dev/null
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module URI.ByteStringTests (tests) where
+
+-------------------------------------------------------------------------------
+import qualified Blaze.ByteString.Builder as BB
+import Control.Applicative (Const (..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8
+import Data.Either
+import Data.Function.Compat ((&))
+import Data.Functor.Identity (Identity (..))
+import qualified Data.Map.Strict as M
+import Data.Monoid
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import Safe (readMay)
+import Test.Tasty
+import Test.Tasty.Hedgehog
+import Test.Tasty.HUnit
+-------------------------------------------------------------------------------
+import Prelude
+-------------------------------------------------------------------------------
+import URI.ByteString
+import URI.ByteString.Generators
+-------------------------------------------------------------------------------
+import URI.ByteStringQQTests ()
+
+infixr 4 .~
+(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
+(.~) l b s = runIdentity (l (const (Identity b)) s)
+
+infixl ^.
+(^.) :: 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")
+ (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")
+ (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")
+ (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")
+ (Just (Authority Nothing (Host "www.example.org") Nothing))
+ "/foo"
+ mempty
+ (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")
+ (Just (Authority Nothing (Host "www.example.org") Nothing))
+ ""
+ (Query [("listParam[]", "foo,bar")])
+ 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 (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"
+ (Query [])
+ Nothing
+ , parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $
+ Left $ MalformedPath
+ , parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $
+ Right $ RelativeRef
+ Nothing
+ "./this:that/thap/sub"
+ (Query [("1", "2")])
+ Nothing
+ ]
+
+
+-------------------------------------------------------------------------------
+uriParseErrorInstancesTests :: TestTree
+uriParseErrorInstancesTests = testGroup "URIParseError instances"
+ [
+ testProperty "roundtrips between Show and Read" $ property $ do
+ parseError <- forAll genURIParseError
+ trippingShow parseError
+ ]
+
+
+-------------------------------------------------------------------------------
+lensTests :: TestTree
+lensTests = testGroup "lenses"
+ [
+ testProperty "schemeBSL Lens" $ property $ do
+ wrapped <- forAll genScheme
+ Scheme bs' <- forAll genScheme
+ (wrapped ^. schemeBSL) === schemeBS wrapped
+ (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'}
+ , testProperty "hostBSL Lens" $ property $ do
+ wrapped <- forAll genHost
+ Host bs' <- forAll genHost
+ (wrapped ^. hostBSL) === hostBS wrapped
+ (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'}
+ , testProperty "portNumberL Lens" $ property $ do
+ wrapped <- forAll genPort
+ Port n' <- forAll genPort
+ (wrapped ^. portNumberL) === portNumber wrapped
+ (wrapped & portNumberL .~ n') === wrapped { portNumber = n'}
+ , testProperty "queryPairsL Lens" $ property $ do
+ wrapped <- forAll genQuery
+ Query ps' <- forAll genQuery
+ wrapped ^. queryPairsL === queryPairs wrapped
+ (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'}
+ , testProperty "authorityUserInfoL Lens" $ property $ do
+ authority <- forAll genAuthority
+ userInfo <- forAll (Gen.maybe genUserInfo)
+ (authority ^. authorityUserInfoL === authorityUserInfo authority)
+ (authority & authorityUserInfoL .~ userInfo) === authority { authorityUserInfo = userInfo }
+ , testProperty "authorityHostL Lens" $ property $ do
+ authority <- forAll genAuthority
+ host <- forAll genHost
+ (authority ^. authorityHostL === authorityHost authority)
+ (authority & authorityHostL .~ host) === authority { authorityHost = host }
+ , testProperty "authorityPortL Lens" $ property $ do
+ authority <- forAll genAuthority
+ port <- forAll (Gen.maybe genPort)
+ (authority ^. authorityPortL === authorityPort authority)
+ (authority & authorityPortL .~ port) === authority { authorityPort = port }
+ , testProperty "uiUsernameL Lens" $ property $ do
+ ui <- forAll genUserInfo
+ bs <- forAll genBS
+ (ui ^. uiUsernameL === uiUsername ui)
+ (ui & uiUsernameL .~ bs) === ui { uiUsername = bs }
+ , testProperty "uiPasswordL Lens" $ property $ do
+ ui <- forAll genUserInfo
+ bs <- forAll genBS
+ (ui ^. uiPasswordL === uiPassword ui)
+ (ui & uiPasswordL .~ bs) === ui { uiPassword = bs }
+ , testProperty "uriSchemeL Lens" $ property $ do
+ uri <- forAll genAbsoluteURIRef
+ x <- forAll genScheme
+ uri ^. uriSchemeL === uriScheme uri
+ (uri & uriSchemeL .~ x) === uri { uriScheme = x }
+ , testProperty "authorityL Lens on URI" $ property $ do
+ uri <- forAll genAbsoluteURIRef
+ x <- forAll (Gen.maybe genAuthority)
+ uri ^. authorityL === uriAuthority uri
+ (uri & authorityL .~ x) === uri { uriAuthority = x }
+ , testProperty "pathL Lens on URI" $ property $ do
+ uri <- forAll genAbsoluteURIRef
+ x <- forAll genBS
+ uri ^. pathL === uriPath uri
+ (uri & pathL .~ x) === uri { uriPath = x }
+ , testProperty "queryL Lens on URI" $ property $ do
+ uri <- forAll genAbsoluteURIRef
+ x <- forAll genQuery
+ uri ^. queryL === uriQuery uri
+ (uri & queryL .~ x) === uri { uriQuery = x }
+ , testProperty "fragmentL Lens on URI" $ property $ do
+ uri <- forAll genAbsoluteURIRef
+ x <- forAll (Gen.maybe genBS)
+ uri ^. fragmentL === uriFragment uri
+ (uri & fragmentL .~ x) === uri { uriFragment = x }
+ , testProperty "authorityL Lens on relative ref" $ property $ do
+ rr <- forAll genRelativeURIRef
+ x <- forAll (Gen.maybe genAuthority)
+ (rr ^. authorityL === rrAuthority rr)
+ (rr & authorityL .~ x) === rr { rrAuthority = x }
+ , testProperty "pathL Lens on relative ref" $ property $ do
+ rr <- forAll genRelativeURIRef
+ x <- forAll genBS
+ rr ^. pathL === rrPath rr
+ (rr & pathL .~ x) === rr { rrPath = x }
+ , testProperty "queryL Lens on relative ref" $ property $ do
+ rr <- forAll genRelativeURIRef
+ x <- forAll genQuery
+ rr ^. queryL === rrQuery rr
+ (rr & queryL .~ x) === rr { rrQuery = x }
+ , testProperty "fragmentL Lens on relative ref" $ property $ do
+ rr <- forAll genRelativeURIRef
+ x <- forAll (Gen.maybe genBS)
+ rr ^. fragmentL === rrFragment rr
+ (rr & fragmentL .~ x) === rr { rrFragment = x }
+ ]
+
+
+-------------------------------------------------------------------------------
+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
+
+
+
+-------------------------------------------------------------------------------
+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)
+ ]
+
+
+-------------------------------------------------------------------------------
+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
+
+
+-------------------------------------------------------------------------------
+testParseFailure :: ByteString -> URIParseError -> TestTree
+testParseFailure s = parseTestURI strictURIParserOptions s . Left
+
+
+-------------------------------------------------------------------------------
+parseTestURI
+ :: URIParserOptions
+ -> ByteString
+ -> Either URIParseError URI
+ -> TestTree
+parseTestURI opts s r = testCase (B8.unpack s) $ parseURI opts s @?= r
+
+
+-------------------------------------------------------------------------------
+roundtripTestURI
+ :: URIParserOptions
+ -> ByteString
+ -> TestTree
+roundtripTestURI opts s =
+ testCase (B8.unpack s) $ (parseURI opts s >>= return . serializeURIRef') @?= Right s
+
+
+-------------------------------------------------------------------------------
+parseTestRelativeRef
+ :: URIParserOptions
+ -> ByteString
+ -> Either URIParseError RelativeRef
+ -> TestTree
+parseTestRelativeRef opts s r =
+ testCase (B8.unpack s) $ parseRelativeRef opts s @?= r
+
+
+-------------------------------------------------------------------------------
+serializeURITests :: TestTree
+serializeURITests = testGroup "serializeURIRef"
+ [
+ testCase "renders userinfo correctly" $ do
+ let ui = UserInfo "user" "pass"
+ let uri = URI (Scheme "http")
+ (Just (Authority (Just ui) (Host "www.example.org") (Just port)))
+ "/"
+ (Query [("foo", "bar")])
+ (Just "somefragment")
+ let res = BB.toLazyByteString (serializeURIRef uri)
+ res @?= "http://user:pass@www.example.org:123/?foo=bar#somefragment"
+ , testCase "encodes decoded paths" $ do
+ let uri = URI (Scheme "http")
+ (Just (Authority Nothing (Host "www.example.org") (Just port)))
+ "/weird path"
+ (Query [])
+ Nothing
+ let res = BB.toLazyByteString (serializeURIRef uri)
+ res @?= "http://www.example.org:123/weird%20path"
+ , testCase "encodes relative refs" $ do
+ let ui = UserInfo "user" "pass"
+ let uri = RelativeRef (Just (Authority (Just ui) (Host "www.example.org") (Just port)))
+ "/"
+ (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 = let Right x = parseURI laxURIParserOptions bs
+ in normalizeURIRef' opts x
+
+trippingShow
+ :: ( Show a
+ , Read a
+ , Eq a
+ , MonadTest m
+ )
+ => a
+ -> m ()
+trippingShow a = tripping a show readMay
--- /dev/null
+name: uri-bytestring
+version: 0.3.3.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
+license-files: LICENSE
+ , licenses/http-types/LICENSE
+author: Doug Beardsley, Michael Xavier
+maintainer: Michael Xavier <michael.xavier@soostone.com>
+copyright: Soostone Inc.
+category: Web
+build-type: Simple
+cabal-version: 1.16
+homepage: https://github.com/Soostone/uri-bytestring
+bug-reports: https://github.com/Soostone/uri-bytestring/issues
+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
+ changelog.md
+ bench/*.hs
+
+flag lib-Werror
+ default: False
+ manual: True
+
+library
+ exposed-modules:
+ URI.ByteString
+ URI.ByteString.QQ
+ other-modules:
+ URI.ByteString.Lens
+ URI.ByteString.Types
+ URI.ByteString.Internal
+
+ build-depends:
+
+ 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
+
+ ghc-options: -Wall
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ other-modules:
+ URI.ByteString.Generators
+ URI.ByteStringTests
+ URI.ByteStringQQTests
+ hs-source-dirs: test
+ build-depends:
+ uri-bytestring
+ , HUnit
+ , tasty
+ , tasty-hunit
+ , hedgehog
+ , tasty-hedgehog
+ , attoparsec
+ , base
+ , base-compat >= 0.7.0
+ , blaze-builder
+ , bytestring
+ , transformers
+ , containers
+ , safe
+
+ if !impl(ghc >= 8)
+ build-depends: semigroups
+
+ default-language: Haskell2010
+
+ if flag(lib-Werror)
+ ghc-options: -Werror
+
+ ghc-options: -Wall
+
+
+benchmark bench
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: bench
+ default-language: Haskell2010
+ build-depends:
+ base
+ , uri-bytestring
+ , criterion
+ , deepseq
+ , deepseq-generics
+ , network-uri >= 2.6.0.3
+ , bytestring
+ , blaze-builder
+
+source-repository head
+ type: git
+ location: git://github.com/Soostone/uri-bytestring.git
projects / haskell-uri-bytestring.git / commitdiff