From 2c8dd1541b494b2b5236ea19bcd638381db00f0d Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Fri, 22 Jul 2022 15:20:35 +0100 Subject: [PATCH] Import haskell-uri-bytestring_0.3.3.1.orig.tar.gz [dgit import orig haskell-uri-bytestring_0.3.3.1.orig.tar.gz] --- CONTRIBUTING.md | 14 + LICENSE | 28 + README.md | 20 + Setup.hs | 2 + bench/Main.hs | 84 +++ changelog.md | 97 +++ licenses/http-types/LICENSE | 31 + src/URI/ByteString.hs | 120 ++++ src/URI/ByteString/Internal.hs | 1004 +++++++++++++++++++++++++++++ src/URI/ByteString/Lens.hs | 227 +++++++ src/URI/ByteString/QQ.hs | 48 ++ src/URI/ByteString/Types.hs | 205 ++++++ test/Main.hs | 19 + test/URI/ByteString/Generators.hs | 156 +++++ test/URI/ByteStringQQTests.hs | 28 + test/URI/ByteStringTests.hs | 482 ++++++++++++++ uri-bytestring.cabal | 120 ++++ 17 files changed, 2685 insertions(+) create mode 100644 CONTRIBUTING.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 bench/Main.hs create mode 100644 changelog.md create mode 100644 licenses/http-types/LICENSE create mode 100644 src/URI/ByteString.hs create mode 100644 src/URI/ByteString/Internal.hs create mode 100644 src/URI/ByteString/Lens.hs create mode 100644 src/URI/ByteString/QQ.hs create mode 100644 src/URI/ByteString/Types.hs create mode 100644 test/Main.hs create mode 100644 test/URI/ByteString/Generators.hs create mode 100644 test/URI/ByteStringQQTests.hs create mode 100644 test/URI/ByteStringTests.hs create mode 100644 uri-bytestring.cabal diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..18f3aa4 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,14 @@ +# Contribution Guidelines + +1. Configure your project with `--enable-tests -flib-Werror`. This + will make sure tests get built and will treat all warnings as + errors. We are shooting for 0 warnings in this project. +2. If you are considering some major functionality, please run it by + us in an issue first so you don't have to do a bunch of work that + will get rejected. This project is shooting for very minimal + dependencies and compliance with the RFC3986 spec, so we can't + include every feature under the sun. +3. Please try to write a test if applicable. +4. Please try to write a benchmark if applicable. +5. If we forget to add you to the Contributors section of the README, + please let us know! diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c78c856 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +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. + diff --git a/README.md b/README.md new file mode 100644 index 0000000..c30b695 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# uri-bytestring +[![Build Status](https://travis-ci.org/Soostone/uri-bytestring.svg?branch=master)](https://travis-ci.org/Soostone/uri-bytestring) +[![Hackage](https://img.shields.io/hackage/v/uri-bytestring.svg?style=flat)](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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 0000000..806bf1f --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,84 @@ +{-# 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 + } diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..272953b --- /dev/null +++ b/changelog.md @@ -0,0 +1,97 @@ +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. diff --git a/licenses/http-types/LICENSE b/licenses/http-types/LICENSE new file mode 100644 index 0000000..f77a7b2 --- /dev/null +++ b/licenses/http-types/LICENSE @@ -0,0 +1,31 @@ +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. diff --git a/src/URI/ByteString.hs b/src/URI/ByteString.hs new file mode 100644 index 0000000..3eafd3a --- /dev/null +++ b/src/URI/ByteString.hs @@ -0,0 +1,120 @@ +{-| + +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 +------------------------------------------------------------------------------- diff --git a/src/URI/ByteString/Internal.hs b/src/URI/ByteString/Internal.hs new file mode 100644 index 0000000..9421bad --- /dev/null +++ b/src/URI/ByteString/Internal.hs @@ -0,0 +1,1004 @@ +{-# 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 +-- , 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 diff --git a/src/URI/ByteString/Lens.hs b/src/URI/ByteString/Lens.hs new file mode 100644 index 0000000..9ddba4d --- /dev/null +++ b/src/URI/ByteString/Lens.hs @@ -0,0 +1,227 @@ +{-# 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 #-} diff --git a/src/URI/ByteString/QQ.hs b/src/URI/ByteString/QQ.hs new file mode 100644 index 0000000..240eda4 --- /dev/null +++ b/src/URI/ByteString/QQ.hs @@ -0,0 +1,48 @@ +{-# 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." + } diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs new file mode 100644 index 0000000..96c8309 --- /dev/null +++ b/src/URI/ByteString/Types.hs @@ -0,0 +1,205 @@ +{-# 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 + , 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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..4c82ae7 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,19 @@ +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 + ] diff --git a/test/URI/ByteString/Generators.hs b/test/URI/ByteString/Generators.hs new file mode 100644 index 0000000..af2511a --- /dev/null +++ b/test/URI/ByteString/Generators.hs @@ -0,0 +1,156 @@ +{-# 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) diff --git a/test/URI/ByteStringQQTests.hs b/test/URI/ByteStringQQTests.hs new file mode 100644 index 0000000..bb7ed80 --- /dev/null +++ b/test/URI/ByteStringQQTests.hs @@ -0,0 +1,28 @@ +{-# 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") + ] diff --git a/test/URI/ByteStringTests.hs b/test/URI/ByteStringTests.hs new file mode 100644 index 0000000..5c8ad1c --- /dev/null +++ b/test/URI/ByteStringTests.hs @@ -0,0 +1,482 @@ +{-# 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 diff --git a/uri-bytestring.cabal b/uri-bytestring.cabal new file mode 100644 index 0000000..c435116 --- /dev/null +++ b/uri-bytestring.cabal @@ -0,0 +1,120 @@ +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 +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 -- 2.30.2