modern-uri-0.3.6.1/0000755000000000000000000000000007346545000012131 5ustar0000000000000000modern-uri-0.3.6.1/CHANGELOG.md0000644000000000000000000001017707346545000013750 0ustar0000000000000000## 0.3.6.1 * Host now can contain unreserved characters rather than simply alpha numeric ones, which was against RFC 3986. [Issue 73](https://github.com/mrkkrp/modern-uri/issues/73). ## 0.3.6.0 * Now colons are not escaped in paths, unless the `URI` in question is a URI-reference, in which case colons in the first path segment are escaped. See [RFC 3986, section 3.3](https://www.rfc-editor.org/rfc/rfc3986#section-3.3). [Issue 55](https://github.com/mrkkrp/modern-uri/issues/55). ## Modern URI 0.3.5.0 * Added `Hashable` instances for `URI`, `Authority`, `UserInfo`, `QueryParam`, `RText`. ## Modern URI 0.3.4.4 * The `mailto` scheme does not escape `@` in its paths (fixes the regression introduced in 0.3.4.3). ## Modern URI 0.3.4.3 * Percent encode delimiter characters and `@` that appear in a path component. [PR 47](https://github.com/mrkkrp/modern-uri/pull/47). * Sub-domains that look like IPv4 can now be parsed. [Issue 46](https://github.com/mrkkrp/modern-uri/issues/46). ## Modern URI 0.3.4.2 * Improved handling of percent-encoded sequences of bytes that cannot be decoded as UTF-8 text. Now friendly error messages are reported in these cases. ## Modern URI 0.3.4.1 * Works with GHC 9.0.1. ## Modern URI 0.3.4.0 * URIs with authority component and without path are now rendered without trailing slashes. ## Modern URI 0.3.3.1 * Works with `bytestring-0.11`. ## Modern URI 0.3.3.0 * Added `mkURIBs` for parsing `ByteString` as a `URI`. ## Modern URI 0.3.2.0 * Quasi-quoters from `Text.URI.QQ` now can be used in pattern context when the `ViewPatterns` extension is enabled. * Dropped support for GHC 8.2.x. ## Modern URI 0.3.1.0 * Dropped support for GHC 8.0 and 7.10. * Added Template Haskell `Lift` instance for the `URI` type and its sub-components. ## Modern URI 0.3.0.1 * Allow superfluous `&` right after question sign in query parameters. ## Modern URI 0.3.0.0 * Uses Megaparsec 7. Visible API changes amount to an adjustment in definition of the `ParseException` type. ## Modern URI 0.2.2.0 * Removed a potentially overlapping instance `Arbitrary (NonEmpty (RText 'PathPiece))`. * Fixed a bug that made it impossible to have empty host names. This allows us to parse URIs like `file:///etc/hosts`. ## Modern URI 0.2.1.0 * Added `emptyURI`—`URI` value representing the empty URI. ## Modern URI 0.2.0.0 * Changed the type of `uriPath` field of the `URI` record from `[RText 'PathPiece]` to `Maybe (Bool, NonEmpty (RText 'PathPiece))`. This allows us to store whether there is a trailing slash in the path or not. See the updated documentation for more information. * Added the `relativeTo` function. * Added the `uriTrailingSlash` 0-1 traversal in `Text.URI.Lens`. ## Modern URI 0.1.2.1 * Allow Megaparsec 6.4.0. ## Modern URI 0.1.2.0 * Fixed handling of `+` in query strings. Now `+` is parsed as space and serialized as `%2b` as per RFC 1866 (paragraph 8.2.1). White space in query parameters is serialized as `+`. ## Modern URI 0.1.1.1 * Fixed implementation of `Text.URI.Lens.queryParam` traversal. ## Modern URI 0.1.1.0 * Derived `NFData` for `ParseException`. * Adjusted percent-encoding in renders so it's only used when absolutely necessary. Previously we percent-escaped a bit too much, which, strictly speaking, did not make the renders incorrect, but that didn't look nice either. ## Modern URI 0.1.0.1 * Updated the readme to include “Quick start” instructions and some examples. ## Modern URI 0.1.0.0 * Changed the type of `uriAuthority` from `Maybe Authority` to `Either Bool Authority`. This allows to know if URI path is absolute or not without duplication of information, i.e. when the `Authority` component is present the path is necessarily absolute, otherwise the `Bool` value tells if it's absolute (`True`) or relative (`False`). * Added `isPathAbsolute` in `Text.URI` and the corresponding getter in `Text.URI.Lens`. ## Modern URI 0.0.2.0 * Added the `renderStr` and `renderStr'` functions for efficient rendering to `String` and `ShowS`. * Added the `parserBs` that can consume strict `ByteString` streams. ## Modern URI 0.0.1.0 * Initial release. modern-uri-0.3.6.1/LICENSE.md0000644000000000000000000000265607346545000013546 0ustar0000000000000000Copyright © 2017–present Mark Karpov 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 Mark Karpov nor the names of 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 “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 HOLDERS 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. modern-uri-0.3.6.1/README.md0000644000000000000000000001732607346545000013421 0ustar0000000000000000# Modern URI [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage](https://img.shields.io/hackage/v/modern-uri.svg?style=flat)](https://hackage.haskell.org/package/modern-uri) [![Stackage Nightly](http://stackage.org/package/modern-uri/badge/nightly)](http://stackage.org/nightly/package/modern-uri) [![Stackage LTS](http://stackage.org/package/modern-uri/badge/lts)](http://stackage.org/lts/package/modern-uri) ![CI](https://github.com/mrkkrp/modern-uri/workflows/CI/badge.svg?branch=master) This is a modern library for working with URIs in Haskell as per RFC 3986: https://tools.ietf.org/html/rfc3986 ## Features The `modern-uri` package features: * Correct by construction `URI` data type. The correctness is ensured by making sure that every sub-component of the `URI` record cannot be invalid. * Textual components in the `URI` data type are represented as `Text` rather than `ByteString`, because they are percent-decoded and so they can contain characters outside of ASCII range (i.e. Unicode). This allows for easier manipulation of `URI`s, while encoding and decoding headaches are handled by the parsers and renders for you. * Absolute and relative URIs differ only by the scheme component: if it's `Nothing`, then the URI is relative, otherwise it's absolute. * A Megaparsec parser that can be used as a standalone smart constructor for the `URI` data type (see `mkURI`) as well as seamlessly integrated into a bigger Megaparsec parser that consumes a strict `Text` (see `parser`) or strict `ByteString` (see `parserBs`). * The parser performs some normalization, for example it collapses consecutive slashes. Some smart constructors such as `mkScheme` and `mkHost` also perform normalization. So in a sense URIs are also “normalized by construction” to some extent. * Fast rendering to strict `Text` and `ByteString` as well as to their respective `Builder` types and to `String`/`ShowS`. * Extensive set of lensy helpers for easier manipulation of the nested data types (see `Text.URI.Lens`). * Quasi-quoters for compile-time construction of the `URI` data type and refined text types (see `Text.URI.QQ`). ## Quick start The `modern-uri` package serves three main purposes: * Construction of the `URI` data type. * Inspection and manipulation of the `URI` data type (in the sense of changing its parts). * Rendering of `URI`s. Let's walk through every operation quickly. ### Construction of `URI`s There are four ways to create a `URI` value. First off, one could assemble it manually like so: ```haskell λ> :set -XOverloadedStrings λ> import qualified Text.URI as URI λ> scheme <- URI.mkScheme "https" λ> scheme "https" λ> host <- URI.mkHost "markkarpov.com" λ> host "markkarpov.com" λ> let uri = URI.URI (Just scheme) (Right (URI.Authority Nothing host Nothing)) Nothing [] Nothing λ> uri URI { uriScheme = Just "https", uriAuthority = Right ( Authority { authUserInfo = Nothing, authHost = "markkarpov.com", authPort = Nothing } ), uriPath = Nothing, uriQuery = [], uriFragment = Nothing } ``` In this library we use quite a few refined text values. They only can be constructed by using smart constructors like `mkScheme :: MonadThrow m => Text -> m (RText 'Scheme)`. For example, if argument to `mkScheme` is not a valid scheme, an exception will be thrown. Note that monads such as `Maybe` are also instances of the `MonadThrow` type class, and so the smart constructors can be used in pure environment as well. There is a smart constructor that can make an entire `URI` too, it's called (unsurprisingly) `mkURI`: ```haskell λ> uri <- URI.mkURI "https://markkarpov.com" λ> uri URI { uriScheme = Just "https", uriAuthority = Right ( Authority { authUserInfo = Nothing, authHost = "markkarpov.com", authPort = Nothing } ), uriPath = Nothing, uriQuery = [], uriFragment = Nothing } ``` If the argument of `mkURI` is not a valid URI, then an exception will be thrown. The exception will contain full context and the actual parse error. If some refined text value or `URI` is known statically at compile time, we can use Template Haskell, namely the “quasi quotes” feature. To do so import the `Text.URI.QQ` module and enable the `QuasiQuotes` language extension, like so: ```haskell λ> :set -XQuasiQuotes λ> import qualified Text.URI.QQ as QQ λ> let uri = [QQ.uri|https://markkarpov.com|] λ> uri URI { uriScheme = Just "https", uriAuthority = Right ( Authority { authUserInfo = Nothing, authHost = "markkarpov.com", authPort = Nothing } ), uriPath = Nothing, uriQuery = [], uriFragment = Nothing } ``` Note how the value returned by the `url` quasi quote is pure, its construction cannot fail because when there is an invalid URI inside the quote it's a compilation error. The `Text.URI.QQ` module has quasi-quoters for scheme, host, and other components. Finally, the package provides two Megaparsec parsers: `parser` and `parserBs`. The first works on strict `Text`, while the other one works on strict `ByteString`s. You can use the parsers in a bigger Megaparsec parser to parse `URI`s. ### Inspection and manipulation Although one could use record syntax directly, possibly with language extensions like `RecordWildcards`, the best way to inspect and edit parts of `URI` is with lenses. The lenses can be found in the `Text.URI.Lens` module. If you have never used the [`lens`](https://hackage.haskell.org/package/lens) library, you could probably start by reading/watching materials suggested in the library description on Hackage. Here are some examples, just to show off what you can do: ```haskell λ> import Text.URI.Lens λ> uri <- URI.mkURI "https://example.com/some/path?foo=bar&baz=quux&foo=foo" λ> uri ^. uriScheme Just "https" λ> uri ^? uriAuthority . _Right . authHost Just "example.com" λ> uri ^. isPathAbsolute True λ> uri ^. uriPath ["some","path"] λ> k <- URI.mkQueryKey "foo" λ> uri ^.. uriQuery . queryParam k ["bar","foo"] -- etc. ``` ### Rendering Rendering turns a `URI` into a sequence of bytes or characters. Currently the following options are available: * `render` for rendering to strict `Text`. * `render'` for rendering to text `Builder`. It's possible to turn that into lazy `Text` by using the `toLazyText` function from `Data.Text.Lazy.Builder`. * `renderBs` for rendering to strict `ByteString`. * `renderBs'` for rendering to byte string `Builder`. Similarly it's possible to get a lazy `ByteString` from that by using the `toLazyByteString` function from `Data.ByteString.Builder`. * `renderStr` can be used to render to `String`. Sometimes it's handy. The render uses difference lists internally so it's not that slow, but in general I'd advise avoiding `String`s. * `renderStr'` returns `ShowS`, which is just a synonym for `String -> String`—a function that prepends the result of rendering to a given `String`. This is useful when the `URI` you want to render is a part of a bigger output, just like with the builders mentioned above. Examples: ```haskell λ> uri <- mkURI "https://markkarpov.com/posts.html" λ> render uri "https://markkarpov.com/posts.html" λ> renderBs uri "https://markkarpov.com/posts.html" λ> renderStr uri "https://markkarpov.com/posts.html" -- etc. ``` ## Contribution Issues, bugs, and questions may be reported in [the GitHub issue tracker for this project](https://github.com/mrkkrp/modern-uri/issues). Pull requests are also welcome. ## License Copyright © 2017–present Mark Karpov Distributed under BSD 3 clause license. modern-uri-0.3.6.1/Setup.hs0000644000000000000000000000012707346545000013565 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain modern-uri-0.3.6.1/Text/0000755000000000000000000000000007346545000013055 5ustar0000000000000000modern-uri-0.3.6.1/Text/URI.hs0000644000000000000000000001225007346545000014050 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | -- Module : Text.URI -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- This is a modern library for working with URIs as per RFC 3986: -- -- -- -- This module is intended to be imported qualified, e.g.: -- -- > import Text.URI (URI) -- > import qualified Text.URI as URI -- -- See also "Text.URI.Lens" for lens, prisms, and traversals; see -- "Text.URI.QQ" for quasi-quoters for compile-time validation of URIs and -- refined text components. module Text.URI ( -- * Data types URI (..), mkURI, mkURIBs, emptyURI, makeAbsolute, isPathAbsolute, relativeTo, Authority (..), UserInfo (..), QueryParam (..), ParseException (..), ParseExceptionBs (..), -- * Refined text -- $rtext RText, RTextLabel (..), mkScheme, mkHost, mkUsername, mkPassword, mkPathPiece, mkQueryKey, mkQueryValue, mkFragment, unRText, RTextException (..), -- * Parsing -- $parsing parser, parserBs, -- * Rendering -- $rendering render, render', renderBs, renderBs', renderStr, renderStr', ) where import Data.Either (isLeft) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust, isNothing) import Text.URI.Parser.ByteString import Text.URI.Parser.Text import Text.URI.Render import Text.URI.Types -- | The empty 'URI'. -- -- @since 0.2.1.0 emptyURI :: URI emptyURI = URI { uriScheme = Nothing, uriAuthority = Left False, uriPath = Nothing, uriQuery = [], uriFragment = Nothing } -- $rtext -- -- Refined text values can only be created by using the smart constructors -- listed below, such as 'mkScheme'. This eliminates the possibility of -- having an invalid component in 'URI' which could invalidate the whole -- 'URI'. -- -- Note that the refined text 'RText' type is labelled at the type level -- with 'RTextLabel's, which see. -- -- When an invalid 'Data.Text.Text' value is passed to a smart constructor, -- it rejects it by throwing the 'RTextException'. Remember that the 'Maybe' -- datatype is also an instance of 'Control.Monad.Catch.MonadThrow', and so -- one could as well use the smart constructors in the 'Maybe' monad. -- $parsing -- -- The input you feed into the parsers must be a valid URI as per RFC 3986, -- that is, its components should be percent-encoded where necessary. -- $rendering -- -- Rendering functions take care of constructing correct 'URI' -- representation as per RFC 3986, that is, percent-encoding will be applied -- when necessary automatically. -- | @'relativeTo' reference base@ makes the @reference@ 'URI' absolute -- resolving it against the @base@ 'URI'. -- -- If the base 'URI' is not absolute itself (that is, it has no scheme), -- this function returns 'Nothing'. -- -- See also: . -- -- @since 0.2.0.0 relativeTo :: -- | Reference 'URI' to make absolute URI -> -- | Base 'URI' URI -> -- | The target 'URI' Maybe URI relativeTo r base = case uriScheme base of Nothing -> Nothing Just bscheme -> Just $ if isJust (uriScheme r) then r {uriPath = uriPath r >>= removeDotSegments} else r { uriScheme = Just bscheme, uriAuthority = case uriAuthority r of Right auth -> Right auth Left rabs -> case uriAuthority base of Right auth -> Right auth Left babs -> Left (babs || rabs), uriPath = (>>= removeDotSegments) $ if isPathAbsolute r then uriPath r else case (uriPath base, uriPath r) of (Nothing, Nothing) -> Nothing (Just b', Nothing) -> Just b' (Nothing, Just r') -> Just r' (Just (bt, bps), Just (rt, rps)) -> fmap (rt,) . NE.nonEmpty $ (if bt then NE.toList bps else NE.init bps) <> NE.toList rps, uriQuery = if isLeft (uriAuthority r) && isNothing (uriPath r) && null (uriQuery r) then uriQuery base else uriQuery r } ---------------------------------------------------------------------------- -- Helpers -- | Remove dot segments from a path. removeDotSegments :: (Bool, NonEmpty (RText 'PathPiece)) -> Maybe (Bool, NonEmpty (RText 'PathPiece)) removeDotSegments (trailSlash, path) = go [] (NE.toList path) trailSlash where go out [] ts = (fmap (ts,) . NE.nonEmpty . reverse) out go out (x : xs) ts | unRText x == "." = go out xs (null xs || ts) | unRText x == ".." = go (drop 1 out) xs (null xs || ts) | otherwise = go (x : out) xs ts modern-uri-0.3.6.1/Text/URI/0000755000000000000000000000000007346545000013514 5ustar0000000000000000modern-uri-0.3.6.1/Text/URI/Lens.hs0000644000000000000000000001243407346545000014755 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -- | -- Module : Text.URI.Lens -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Lenses for working with the 'URI' data type and its internals. module Text.URI.Lens ( uriScheme, uriAuthority, uriPath, isPathAbsolute, uriTrailingSlash, uriQuery, uriFragment, authUserInfo, authHost, authPort, uiUsername, uiPassword, _QueryFlag, _QueryParam, queryFlag, queryParam, unRText, ) where import Data.Foldable (find) import Data.Functor.Contravariant import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import Data.Profunctor import Data.Text (Text) import Text.URI.Types ( Authority, QueryParam (..), RText, RTextLabel (..), URI, UserInfo, ) import qualified Text.URI.Types as URI #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -- | 'URI' scheme lens. uriScheme :: Lens' URI (Maybe (RText 'Scheme)) uriScheme f s = (\x -> s {URI.uriScheme = x}) <$> f (URI.uriScheme s) -- | 'URI' authority lens. -- -- __Note__: before version /0.1.0.0/ this lens allowed to focus on @'Maybe' -- 'URI.Authority'@. uriAuthority :: Lens' URI (Either Bool URI.Authority) uriAuthority f s = (\x -> s {URI.uriAuthority = x}) <$> f (URI.uriAuthority s) -- | 'URI' path lens. uriPath :: Lens' URI [RText 'PathPiece] uriPath f s = (\x -> s {URI.uriPath = (ts,) <$> NE.nonEmpty x}) <$> f ps where ts = maybe False fst path ps = maybe [] (NE.toList . snd) path path = URI.uriPath s -- | A getter that can tell if path component of a 'URI' is absolute. -- -- @since 0.1.0.0 isPathAbsolute :: Getter URI Bool isPathAbsolute = to URI.isPathAbsolute -- | A 0-1 traversal allowing to view and manipulate trailing slash. -- -- @since 0.2.0.0 uriTrailingSlash :: Traversal' URI Bool uriTrailingSlash f s = (\x -> s {URI.uriPath = liftA2 (,) x ps}) <$> traverse f ts where ts = fst <$> path ps = snd <$> path path = URI.uriPath s -- | 'URI' query params lens. uriQuery :: Lens' URI [URI.QueryParam] uriQuery f s = (\x -> s {URI.uriQuery = x}) <$> f (URI.uriQuery s) -- | 'URI' fragment lens. uriFragment :: Lens' URI (Maybe (RText 'Fragment)) uriFragment f s = (\x -> s {URI.uriFragment = x}) <$> f (URI.uriFragment s) -- | 'Authority' user info lens. authUserInfo :: Lens' Authority (Maybe URI.UserInfo) authUserInfo f s = (\x -> s {URI.authUserInfo = x}) <$> f (URI.authUserInfo s) -- | 'Authority' host lens. authHost :: Lens' Authority (RText 'Host) authHost f s = (\x -> s {URI.authHost = x}) <$> f (URI.authHost s) -- | 'Authority' port lens. authPort :: Lens' Authority (Maybe Word) authPort f s = (\x -> s {URI.authPort = x}) <$> f (URI.authPort s) -- | 'UserInfo' username lens. uiUsername :: Lens' UserInfo (RText 'Username) uiUsername f s = (\x -> s {URI.uiUsername = x}) <$> f (URI.uiUsername s) -- | 'UserInfo' password lens. uiPassword :: Lens' UserInfo (Maybe (RText 'Password)) uiPassword f s = (\x -> s {URI.uiPassword = x}) <$> f (URI.uiPassword s) -- | 'QueryParam' prism for query flags. _QueryFlag :: Prism' URI.QueryParam (RText 'QueryKey) _QueryFlag = prism' QueryFlag $ \case QueryFlag x -> Just x _ -> Nothing -- | 'QueryParam' prism for query parameters. _QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue) _QueryParam = prism' construct pick where construct (x, y) = QueryParam x y pick = \case QueryParam x y -> Just (x, y) _ -> Nothing -- | Check if the given query key is present in the collection of query -- parameters. queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool queryFlag k = to (isJust . find g) where g (QueryFlag k') = k' == k g _ = False -- | Manipulate a query parameter by its key. Note that since there may be -- several query parameters with the same key this is a traversal that can -- return\/modify several items at once. queryParam :: RText 'QueryKey -> Traversal' [URI.QueryParam] (RText 'QueryValue) queryParam k f = traverse g where g p@(QueryParam k' v) = if k == k' then QueryParam k' <$> f v else pure p g p = pure p -- | A getter that can project 'Text' from refined text values. unRText :: Getter (RText l) Text unRText = to URI.unRText ---------------------------------------------------------------------------- -- Helpers type Lens' s a = forall f. (Functor f) => (a -> f a) -> s -> f s type Traversal' s a = forall f. (Applicative f) => (a -> f a) -> s -> f s type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) type Prism' s a = Prism s s a a -- | Build a 'Prism'. prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt seta = dimap seta (either pure (fmap bt)) . right' -- | Another way to build a 'Prism'. prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) -- | Lift a function into optic. to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s)) to f = dimap f (contramap f) modern-uri-0.3.6.1/Text/URI/Parser/0000755000000000000000000000000007346545000014750 5ustar0000000000000000modern-uri-0.3.6.1/Text/URI/Parser/ByteString.hs0000644000000000000000000002347507346545000017411 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | -- Module : Text.URI.Parser.ByteString -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- URI parser for string 'ByteString', an internal module. module Text.URI.Parser.ByteString ( mkURIBs, parserBs, ) where import Control.Monad import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.State.Strict import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Char import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, isJust, maybeToList) import qualified Data.Set as E import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Void import Data.Word (Word8) import Text.Megaparsec import Text.Megaparsec.Byte import qualified Text.Megaparsec.Byte.Lexer as L import Text.URI.Types hiding (pHost) -- | Construct a 'URI' from 'ByteString'. The input you pass to 'mkURIBs' -- must be a valid URI as per RFC 3986, that is, its components should be -- percent-encoded where necessary. In case of parse failure -- 'ParseExceptionBs' is thrown. -- -- This function uses the 'parserBs' parser under the hood, which you can also -- use directly in a Megaparsec parser. -- -- @since 0.3.3.0 mkURIBs :: (MonadThrow m) => ByteString -> m URI mkURIBs input = case runParser (parserBs <* eof :: Parsec Void ByteString URI) "" input of Left b -> throwM (ParseExceptionBs b) Right x -> return x -- | This parser can be used to parse 'URI' from strict 'ByteString'. -- Remember to use a concrete non-polymorphic parser type for efficiency. -- -- @since 0.0.2.0 parserBs :: (MonadParsec e ByteString m) => m URI parserBs = do uriScheme <- optional (try pScheme) mauth <- optional pAuthority (absPath, uriPath) <- pPath (isJust mauth) uriQuery <- option [] pQuery uriFragment <- optional pFragment let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parserBs #-} {-# SPECIALIZE parserBs :: Parsec Void ByteString URI #-} pScheme :: (MonadParsec e ByteString m) => m (RText 'Scheme) pScheme = do r <- liftR "scheme" mkScheme $ do x <- asciiAlphaChar xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46) return (x : xs) void (char 58) return r {-# INLINE pScheme #-} pAuthority :: (MonadParsec e ByteString m) => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo authHost <- liftR "host" mkHost pHost authPort <- optional (char 58 *> L.decimal) return Authority {..} {-# INLINE pAuthority #-} -- | Parser that can parse host names. pHost :: (MonadParsec e ByteString m) => m [Word8] pHost = choice [ try (asConsumed ipLiteral), try (asConsumed ipv4Address), regName ] where asConsumed :: (MonadParsec e ByteString m) => m a -> m [Word8] asConsumed p = B.unpack . fst <$> match p ipLiteral = between (char 91) (char 93) $ try ipv6Address <|> ipvFuture octet = do o <- getOffset (toks, x) <- match L.decimal when (x >= (256 :: Integer)) $ do setOffset o failure (fmap Tokens . NE.nonEmpty . B.unpack $ toks) (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255") ipv4Address = count 3 (octet <* char 46) *> octet ipv6Address = do o <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::") xs <- flip sepBy1 (char 58) $ do (skip, hasMore) <- lookAhead . hidden $ do skip <- option False (True <$ char 58) hasMore <- option False (True <$ hexDigitChar) return (skip, hasMore) case (skip, hasMore) of (True, True) -> return [] (True, False) -> [] <$ char 58 (False, _) -> count' 1 4 hexDigitChar return (xs' ++ xs) let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do setOffset o failure (fmap Tokens . NE.nonEmpty . B.unpack $ toks) (E.singleton . Label . NE.fromList $ "valid IPv6 address") ipvFuture = do void (char 118) void hexDigitChar void (char 46) skipSome (unreservedChar <|> subDelimChar <|> char 58) regName = fmap (intercalate [46]) . flip sepBy1 (char 46) $ do let ch = percentEncChar <|> unreservedChar mx <- optional ch case mx of Nothing -> return [] Just x -> do let r = ch <|> try (char 45 <* (lookAhead . try) (ch <|> char 45)) xs <- many r return (x : xs) pUserInfo :: (MonadParsec e ByteString m) => m UserInfo pUserInfo = try $ do uiUsername <- liftR "username" mkUsername ( label "username" $ many (unreservedChar <|> percentEncChar <|> subDelimChar) ) uiPassword <- optional $ do void (char 58) liftR "password" mkPassword (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58)) void (char 64) return UserInfo {..} {-# INLINE pUserInfo #-} pPath :: (MonadParsec e ByteString m) => Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do doubleSlash <- lookAhead (option False (True <$ string "//")) when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) [47, 47] absPath <- option False (True <$ char 47) let mkPathPiece' x = if T.null x then Just Nothing else Just <$> mkPathPiece x (maybePieces, trailingSlash) <- flip runStateT False $ flip sepBy (char 47) $ liftR "path piece" mkPathPiece' $ label "path piece" $ do x <- many pchar put (null x) return x let pieces = catMaybes maybePieces return ( absPath, case NE.nonEmpty pieces of Nothing -> Nothing Just ps -> Just (trailingSlash, ps) ) {-# INLINE pPath #-} pQuery :: (MonadParsec e ByteString m) => m [QueryParam] pQuery = do void (char 63) void (optional (char 38)) fmap catMaybes . flip sepBy (char 38) . label "query parameter" $ do let p = many (pchar' <|> char 47 <|> char 63) k <- liftR "query key" mkQueryKey p mv <- optional (char 61 *> liftR "query value" mkQueryValue p) return $ if T.null (unRText k) then Nothing else Just ( case mv of Nothing -> QueryFlag k Just v -> QueryParam k v ) {-# INLINE pQuery #-} pFragment :: (MonadParsec e ByteString m) => m (RText 'Fragment) pFragment = do void (char 35) liftR "fragment" mkFragment ( many . label "fragment character" $ pchar <|> char 47 <|> char 63 ) {-# INLINE pFragment #-} ---------------------------------------------------------------------------- -- Helpers -- | Lift a smart constructor that consumes 'Text' into a parser. liftR :: (MonadParsec e ByteString m) => -- | What is being parsed String -> -- | The smart constructor that produces the result (Text -> Maybe r) -> -- | How to parse @['Word8']@ that will be converted to 'Text' and fed to -- the smart constructor m [Word8] -> m r liftR lbl f p = do o <- getOffset (toks, s) <- match p case TE.decodeUtf8' (B.pack s) of Left _ -> do let unexp = NE.fromList (B.unpack toks) expecting = NE.fromList (lbl ++ " that can be decoded as UTF-8") parseError ( TrivialError o (Just (Tokens unexp)) (S.singleton (Label expecting)) ) Right text -> maybe empty return (f text) {-# INLINE liftR #-} asciiAlphaChar :: (MonadParsec e ByteString m) => m Word8 asciiAlphaChar = satisfy isAsciiAlpha "ASCII alpha character" {-# INLINE asciiAlphaChar #-} asciiAlphaNumChar :: (MonadParsec e ByteString m) => m Word8 asciiAlphaNumChar = satisfy isAsciiAlphaNum "ASCII alpha-numeric character" {-# INLINE asciiAlphaNumChar #-} unreservedChar :: (MonadParsec e ByteString m) => m Word8 unreservedChar = label "unreserved character" . satisfy $ \x -> isAsciiAlphaNum x || x == 45 || x == 46 || x == 95 || x == 126 {-# INLINE unreservedChar #-} percentEncChar :: (MonadParsec e ByteString m) => m Word8 percentEncChar = do void (char 37) h <- restoreDigit <$> hexDigitChar l <- restoreDigit <$> hexDigitChar return (h * 16 + l) {-# INLINE percentEncChar #-} subDelimChar :: (MonadParsec e ByteString m) => m Word8 subDelimChar = oneOf s "sub-delimiter" where s = E.fromList (fromIntegral . ord <$> "!$&'()*+,;=") {-# INLINE subDelimChar #-} pchar :: (MonadParsec e ByteString m) => m Word8 pchar = choice [ unreservedChar, percentEncChar, subDelimChar, char 58, char 64 ] {-# INLINE pchar #-} pchar' :: (MonadParsec e ByteString m) => m Word8 pchar' = choice [ unreservedChar, percentEncChar, char 43 >> pure 32, oneOf s "sub-delimiter", char 58, char 64 ] where s = E.fromList (fromIntegral . ord <$> "!$'()*,;") {-# INLINE pchar' #-} isAsciiAlpha :: Word8 -> Bool isAsciiAlpha x | 65 <= x && x <= 90 = True | 97 <= x && x <= 122 = True | otherwise = False isAsciiAlphaNum :: Word8 -> Bool isAsciiAlphaNum x | isAsciiAlpha x = True | 48 <= x && x <= 57 = True | otherwise = False restoreDigit :: Word8 -> Word8 restoreDigit x | 48 <= x && x <= 57 = x - 48 | 65 <= x && x <= 70 = x - 55 | 97 <= x && x <= 102 = x - 87 | otherwise = error "Text.URI.Parser.restoreDigit: bad input" modern-uri-0.3.6.1/Text/URI/Parser/Text.hs0000644000000000000000000001310107346545000016224 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | -- Module : Text.URI.Parser.Text -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- URI parser for strict 'Text', an internal module. module Text.URI.Parser.Text ( mkURI, parser, ) where import Control.Monad import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.State.Strict import qualified Data.ByteString.Char8 as B8 import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, isJust) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Void import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Text.URI.Parser.Text.Utils import Text.URI.Types -- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a -- valid URI as per RFC 3986, that is, its components should be -- percent-encoded where necessary. In case of parse failure -- 'ParseException' is thrown. -- -- This function uses the 'parser' parser under the hood, which you can also -- use directly in a Megaparsec parser. mkURI :: (MonadThrow m) => Text -> m URI mkURI input = case runParser (parser <* eof :: Parsec Void Text URI) "" input of Left b -> throwM (ParseException b) Right x -> return x -- | This parser can be used to parse 'URI' from strict 'Text'. Remember to -- use a concrete non-polymorphic parser type for efficiency. parser :: (MonadParsec e Text m) => m URI parser = do uriScheme <- optional (try pScheme) mauth <- optional pAuthority (absPath, uriPath) <- pPath (isJust mauth) uriQuery <- option [] pQuery uriFragment <- optional pFragment let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parser #-} {-# SPECIALIZE parser :: Parsec Void Text URI #-} pScheme :: (MonadParsec e Text m) => m (RText 'Scheme) pScheme = do r <- liftR "scheme" mkScheme $ do x <- asciiAlphaChar xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') return (x : xs) void (char ':') return r {-# INLINE pScheme #-} pAuthority :: (MonadParsec e Text m) => m Authority pAuthority = do void (string "//") authUserInfo <- optional pUserInfo authHost <- liftR "host" mkHost (pHost True) authPort <- optional (char ':' *> L.decimal) return Authority {..} {-# INLINE pAuthority #-} pUserInfo :: (MonadParsec e Text m) => m UserInfo pUserInfo = try $ do uiUsername <- liftR "username" mkUsername ( label "username" $ many (unreservedChar <|> percentEncChar <|> subDelimChar) ) uiPassword <- optional $ do void (char ':') liftR "password" mkPassword (many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':')) void (char '@') return UserInfo {..} {-# INLINE pUserInfo #-} pPath :: (MonadParsec e Text m) => Bool -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do doubleSlash <- lookAhead (option False (True <$ string "//")) when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) "//" absPath <- option False (True <$ char '/') let mkPathPiece' x = if T.null x then Just Nothing else Just <$> mkPathPiece x (maybePieces, trailingSlash) <- flip runStateT False $ flip sepBy (char '/') $ liftR "path piece" mkPathPiece' $ label "path piece" $ do x <- many pchar put (null x) return x let pieces = catMaybes maybePieces return ( absPath, case NE.nonEmpty pieces of Nothing -> Nothing Just ps -> Just (trailingSlash, ps) ) {-# INLINE pPath #-} pQuery :: (MonadParsec e Text m) => m [QueryParam] pQuery = do void (char '?') void (optional (char '&')) fmap catMaybes . flip sepBy (char '&') . label "query parameter" $ do let p = many (pchar' <|> char '/' <|> char '?') k <- liftR "query key" mkQueryKey p mv <- optional (char '=' *> liftR "query value" mkQueryValue p) return $ if T.null (unRText k) then Nothing else Just ( case mv of Nothing -> QueryFlag k Just v -> QueryParam k v ) {-# INLINE pQuery #-} pFragment :: (MonadParsec e Text m) => m (RText 'Fragment) pFragment = do void (char '#') liftR "fragment" mkFragment ( many . label "fragment character" $ pchar <|> char '/' <|> char '?' ) {-# INLINE pFragment #-} ---------------------------------------------------------------------------- -- Helpers -- | Lift a smart constructor that consumes 'Text' into a parser. liftR :: (MonadParsec e Text m) => -- | What is being parsed String -> -- | The smart constructor that produces the result (Text -> Maybe r) -> -- | How to parse 'String' that will be converted to 'Text' and fed to -- the smart constructor m String -> m r liftR lbl f p = do o <- getOffset (toks, s) <- match p case TE.decodeUtf8' (B8.pack s) of Left _ -> do let unexp = NE.fromList (T.unpack toks) expecting = NE.fromList (lbl ++ " that can be decoded as UTF-8") parseError ( TrivialError o (Just (Tokens unexp)) (S.singleton (Label expecting)) ) Right text -> maybe empty return (f text) {-# INLINE liftR #-} modern-uri-0.3.6.1/Text/URI/Parser/Text/0000755000000000000000000000000007346545000015674 5ustar0000000000000000modern-uri-0.3.6.1/Text/URI/Parser/Text/Utils.hs0000644000000000000000000001070007346545000017326 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Text.URI.Parser.Text.Utils -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Random utilities for our 'Text' parsers. module Text.URI.Parser.Text.Utils ( pHost, asciiAlphaChar, asciiAlphaNumChar, unreservedChar, percentEncChar, subDelimChar, pchar, pchar', ) where import Control.Monad import Data.Char import Data.List (intercalate) import qualified Data.List.NonEmpty as NE import Data.Maybe (maybeToList) import qualified Data.Set as E import Data.Text (Text) import qualified Data.Text as T import Text.Megaparsec import Text.Megaparsec.Char -- | Parser that can parse host names. pHost :: (MonadParsec e Text m) => -- | Demand percent-encoding in reg names Bool -> m String pHost pe = choice [ try (asConsumed ipLiteral), regName ] where asConsumed :: (MonadParsec e Text m) => m a -> m String asConsumed p = T.unpack . fst <$> match p ipLiteral = between (char '[') (char ']') $ try ipv6Address <|> ipvFuture ipv6Address = do pos <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::") xs <- flip sepBy1 (char ':') $ do (skip, hasMore) <- lookAhead . hidden $ do skip <- option False (True <$ char ':') hasMore <- option False (True <$ hexDigitChar) return (skip, hasMore) case (skip, hasMore) of (True, True) -> return [] (True, False) -> [] <$ char ':' (False, _) -> count' 1 4 hexDigitChar return (xs' ++ xs) let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do setOffset pos failure (fmap Tokens . NE.nonEmpty . T.unpack $ toks) (E.singleton . Label . NE.fromList $ "valid IPv6 address") ipvFuture = do void (char 'v') void hexDigitChar void (char '.') skipSome (unreservedChar <|> subDelimChar <|> char ':') regName = fmap (intercalate ".") . flip sepBy1 (char '.') $ do many $ if pe then percentEncChar <|> unreservedChar else unreservedCharUnicode {-# INLINEABLE pHost #-} -- | Parse an ASCII alpha character. asciiAlphaChar :: (MonadParsec e Text m) => m Char asciiAlphaChar = satisfy isAsciiAlpha "ASCII alpha character" {-# INLINE asciiAlphaChar #-} -- | Parse an ASCII alpha-numeric character. asciiAlphaNumChar :: (MonadParsec e Text m) => m Char asciiAlphaNumChar = satisfy isAsciiAlphaNum "ASCII alpha-numeric character" {-# INLINE asciiAlphaNumChar #-} -- | Parse an unreserved character. unreservedChar :: (MonadParsec e Text m) => m Char unreservedChar = label "unreserved character" . satisfy $ \x -> isAsciiAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' {-# INLINE unreservedChar #-} -- | Parse an unreserved character allowing Unicode. unreservedCharUnicode :: (MonadParsec e Text m) => m Char unreservedCharUnicode = label "unreserved character" . satisfy $ \x -> isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' {-# INLINE unreservedCharUnicode #-} -- | Parse a percent-encoded character. percentEncChar :: (MonadParsec e Text m) => m Char percentEncChar = do void (char '%') h <- digitToInt <$> hexDigitChar l <- digitToInt <$> hexDigitChar return . chr $ h * 16 + l {-# INLINE percentEncChar #-} -- | Parse a sub-delimiter character. subDelimChar :: (MonadParsec e Text m) => m Char subDelimChar = oneOf s "sub-delimiter" where s = E.fromList "!$&'()*+,;=" {-# INLINE subDelimChar #-} -- | PCHAR thing from the spec. pchar :: (MonadParsec e Text m) => m Char pchar = choice [ unreservedChar, percentEncChar, subDelimChar, char ':', char '@' ] {-# INLINE pchar #-} -- | 'pchar' adjusted for query parsing. pchar' :: (MonadParsec e Text m) => m Char pchar' = choice [ unreservedChar, percentEncChar, char '+' >> pure ' ', oneOf s "sub-delimiter", char ':', char '@' ] where s = E.fromList "!$'()*,;" {-# INLINE pchar' #-} isAsciiAlpha :: Char -> Bool isAsciiAlpha x = isAscii x && isAlpha x isAsciiAlphaNum :: Char -> Bool isAsciiAlphaNum x = isAscii x && isAlphaNum x modern-uri-0.3.6.1/Text/URI/QQ.hs0000644000000000000000000000547707346545000014406 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Text.URI.QQ -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Quasi-quoters for compile-time construction of URIs and refined text -- values. -- -- All of the quasi-quoters in this module can be used in an expression -- context. With the @ViewPatterns@ language extension enabled, they may -- also be used in a pattern context (since /0.3.2.0/). module Text.URI.QQ ( uri, scheme, host, username, password, pathPiece, queryKey, queryValue, fragment, ) where import Control.Exception (Exception (..), SomeException) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH.Lib (appE, viewP) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (Lift (..)) import Text.URI.Parser.Text import Text.URI.Types -- | Construct a 'URI' value at compile time. uri :: QuasiQuoter uri = liftToQQ mkURI -- | Construct a @'RText' 'Scheme'@ value at compile time. scheme :: QuasiQuoter scheme = liftToQQ mkScheme -- | Construct a @'RText' 'Host'@ value at compile time. host :: QuasiQuoter host = liftToQQ mkHost -- | Construct a @'RText' 'Username'@ value at compile time. username :: QuasiQuoter username = liftToQQ mkUsername -- | Construct a @'RText' 'Password'@ value at compile time. password :: QuasiQuoter password = liftToQQ mkPassword -- | Construct a @'RText' 'PathPiece'@ value at compile time. pathPiece :: QuasiQuoter pathPiece = liftToQQ mkPathPiece -- | Construct a @'RText' 'QueryKey'@ value at compile time. queryKey :: QuasiQuoter queryKey = liftToQQ mkQueryKey -- | Construct a @'RText 'QueryValue'@ value at compile time. queryValue :: QuasiQuoter queryValue = liftToQQ mkQueryValue -- | Construct a @'RText' 'Fragment'@ value at compile time. fragment :: QuasiQuoter fragment = liftToQQ mkFragment ---------------------------------------------------------------------------- -- Helpers -- | Lift a smart constructor for refined text into a 'QuasiQuoter'. -- -- The 'Eq' constraint is technically unnecessary here, but the pattern -- generated by 'quotePat' will only work if the type has an 'Eq' instance. liftToQQ :: (Eq a, Lift a) => (Text -> Either SomeException a) -> QuasiQuoter liftToQQ f = QuasiQuoter { quoteExp = \str -> case f (T.pack str) of Left err -> fail (displayException err) Right x -> lift x, quotePat = \str -> case f (T.pack str) of Left err -> fail (displayException err) Right x -> appE [|(==)|] (lift x) `viewP` [p|True|], quoteType = error "This usage is not supported", quoteDec = error "This usage is not supported" } modern-uri-0.3.6.1/Text/URI/Render.hs0000644000000000000000000002460707346545000015300 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Text.URI.Render -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- URI renders, an internal module. module Text.URI.Render ( render, render', renderBs, renderBs', renderStr, renderStr', ) where import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import Data.Char (chr, intToDigit) import Data.Kind (Type) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Data.Reflection import qualified Data.Semigroup as S import Data.String (IsString (..)) import Data.Tagged import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder.Int as TLB import Data.Word (Word8) import Numeric (showInt) import Text.URI.Types ---------------------------------------------------------------------------- -- High-level wrappers -- | Render a given 'URI' value as strict 'Text'. render :: URI -> Text render = TL.toStrict . TLB.toLazyText . render' -- | Render a given 'URI' value as a 'TLB.Builder'. render' :: URI -> TLB.Builder render' x = equip TLB.decimal ( \mw r -> TLB.fromText ( percentEncode (uriScheme x) (mediateExtraEscaping x mw) r ) ) (genericRender x) -- | Render a given 'URI' value as a strict 'ByteString'. renderBs :: URI -> ByteString renderBs = BL.toStrict . BB.toLazyByteString . renderBs' -- | Render a given 'URI' value as a 'BB.Builder'. renderBs' :: URI -> BB.Builder renderBs' x = equip BB.wordDec ( \mw r -> BB.byteString ( TE.encodeUtf8 ( percentEncode (uriScheme x) (mediateExtraEscaping x mw) r ) ) ) (genericRender x) -- | Render a given 'URI' value as a 'String'. -- -- @since 0.0.2.0 renderStr :: URI -> String renderStr = ($ []) . renderStr' -- | Render a given 'URI' value as 'ShowS'. -- -- @since 0.0.2.0 renderStr' :: URI -> ShowS renderStr' x = toShowS $ equip (DString . showInt) ( \mw r -> fromString ( T.unpack ( percentEncode (uriScheme x) (mediateExtraEscaping x mw) r ) ) ) (genericRender x) -- | This is a (slightly hackish) way used to only escape ':' in the first -- path segment and only if there no scheme and no authority component. mediateExtraEscaping :: URI -> Maybe Word8 -> Maybe Word8 mediateExtraEscaping uri mw = case (uriScheme uri, uriAuthority uri) of (Nothing, Left _) -> mw _ -> Nothing ---------------------------------------------------------------------------- -- Reflection stuff data Renders b = Renders { rWord :: Word -> b, rText :: forall l. (RLabel l) => Maybe Word8 -> RText l -> b } equip :: forall b. (Word -> b) -> (forall l. (RLabel l) => Maybe Word8 -> RText l -> b) -> (forall (s :: Type). (Reifies s (Renders b)) => Tagged s b) -> b equip rWord rText f = reify Renders {..} $ \(Proxy :: Proxy s') -> unTagged (f :: Tagged s' b) renderWord :: forall s b. (Reifies s (Renders b)) => Word -> Tagged s b renderWord = Tagged . rWord (reflect (Proxy :: Proxy s)) renderText :: forall s b l. (Reifies s (Renders b), RLabel l) => RText l -> Tagged s b renderText = Tagged . rText (reflect (Proxy :: Proxy s)) Nothing renderTextEscaping :: forall s b l. (Reifies s (Renders b), RLabel l) => Word8 -> RText l -> Tagged s b renderTextEscaping w = Tagged . rText (reflect (Proxy :: Proxy s)) (Just w) ---------------------------------------------------------------------------- -- Generic render type Render a b = forall (s :: Type). (Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) => a -> Tagged s b genericRender :: Render URI b genericRender URI {..} = mconcat [ rJust rScheme uriScheme, rJust rAuthority (either (const Nothing) Just uriAuthority), rAbsPathSlash uriAuthority uriPath, rPath uriPath, rQuery uriQuery, rJust rFragment uriFragment ] {-# INLINE genericRender #-} rJust :: (Monoid m) => (a -> m) -> Maybe a -> m rJust = maybe mempty rScheme :: Render (RText 'Scheme) b rScheme = (<> ":") . renderText {-# INLINE rScheme #-} rAuthority :: Render Authority b rAuthority Authority {..} = mconcat [ "//", rJust rUserInfo authUserInfo, renderText authHost, rJust ((":" <>) . renderWord) authPort ] {-# INLINE rAuthority #-} rUserInfo :: Render UserInfo b rUserInfo UserInfo {..} = mconcat [ renderText uiUsername, rJust ((":" <>) . renderText) uiPassword, "@" ] {-# INLINE rUserInfo #-} rAbsPathSlash :: Either Bool a -> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b rAbsPathSlash (Left isAbsolute) _ = if isAbsolute then "/" else mempty rAbsPathSlash (Right _) Nothing = mempty rAbsPathSlash (Right _) (Just _) = "/" {-# INLINE rAbsPathSlash #-} rPath :: Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b rPath path = case path of Nothing -> mempty Just (trailingSlash, ps) -> ( mconcat . intersperse "/" $ case ps of (x :| xs) -> renderTextEscaping 58 x : fmap renderText xs ) <> if trailingSlash then "/" else mempty {-# INLINE rPath #-} rQuery :: Render [QueryParam] b rQuery = \case [] -> mempty qs -> "?" <> mconcat (intersperse "&" (rQueryParam <$> qs)) {-# INLINE rQuery #-} rQueryParam :: Render QueryParam b rQueryParam = \case QueryFlag flag -> renderText flag QueryParam k v -> renderText k <> "=" <> renderText v {-# INLINE rQueryParam #-} rFragment :: Render (RText 'Fragment) b rFragment = ("#" <>) . renderText {-# INLINE rFragment #-} ---------------------------------------------------------------------------- -- DString newtype DString = DString {toShowS :: ShowS} instance S.Semigroup DString where DString a <> DString b = DString (a . b) instance Monoid DString where mempty = DString id mappend = (S.<>) instance IsString DString where fromString str = DString (str ++) ---------------------------------------------------------------------------- -- Percent-encoding -- | Percent-encode a 'Text' value. percentEncode :: forall l. (RLabel l) => -- | Scheme of the URI Maybe (RText 'Scheme) -> -- | A byte to additionally escape Maybe Word8 -> -- | Input text to encode RText l -> -- | Percent-encoded text Text percentEncode mscheme alsoEscape rtxt = if skipEscaping (Proxy :: Proxy l) txt then txt else T.unfoldr f (TE.encodeUtf8 txt, []) where f (bs', []) = case B.uncons bs' of Nothing -> Nothing Just (w, bs'') -> Just $ if | sap && w == 32 -> ('+', (bs'', [])) | nne w -> (chr (fromIntegral w), (bs'', [])) | otherwise -> let c :| cs = encodeByte w in (c, (bs'', cs)) f (bs', x : xs) = Just (x, (bs', xs)) encodeByte x = '%' :| [intToDigit h, intToDigit l] where (h, l) = fromIntegral x `quotRem` 16 nne w = let normalCase = needsNoEscaping (Proxy :: Proxy l) mscheme w in case alsoEscape of Nothing -> normalCase Just w' -> if w == w' then False else normalCase sap = spaceAsPlus (Proxy :: Proxy l) txt = unRText rtxt {-# INLINE percentEncode #-} -- | This type class attaches some predicates that control serialization to -- the type level label of kind 'RTextLabel'. class RLabel (l :: RTextLabel) where -- | The predicate selects bytes that are not to be percent-escaped in -- rendered URI. needsNoEscaping :: Proxy l -> Maybe (RText 'Scheme) -> Word8 -> Bool -- | Whether to serialize space as the plus sign. spaceAsPlus :: Proxy l -> Bool spaceAsPlus Proxy = False -- | Whether to skip percent-escaping altogether for this value. skipEscaping :: Proxy l -> Text -> Bool skipEscaping Proxy _ = False instance RLabel 'Scheme where needsNoEscaping Proxy _ x = isAlphaNum x || x == 43 || x == 45 || x == 46 instance RLabel 'Host where needsNoEscaping Proxy _ x = isUnreserved x || isDelim x skipEscaping Proxy x = T.take 1 x == "[" instance RLabel 'Username where needsNoEscaping Proxy _ x = isUnreserved x || isDelim x instance RLabel 'Password where needsNoEscaping Proxy _ x = isUnreserved x || isDelim x || x == 58 instance RLabel 'PathPiece where needsNoEscaping Proxy mscheme x = case mscheme of Nothing -> commonCase Just scheme -> if unRText scheme == "mailto" then commonCase || x == 64 else commonCase where commonCase = isUnreserved x || x == 58 instance RLabel 'QueryKey where needsNoEscaping Proxy _ x = isPChar isDelim' x || x == 47 || x == 63 spaceAsPlus Proxy = True instance RLabel 'QueryValue where needsNoEscaping Proxy _ x = isPChar isDelim' x || x == 47 || x == 63 spaceAsPlus Proxy = True instance RLabel 'Fragment where needsNoEscaping Proxy _ x = isPChar isDelim x || x == 47 || x == 63 isPChar :: (Word8 -> Bool) -> Word8 -> Bool isPChar f x = isUnreserved x || f x || x == 58 || x == 64 isUnreserved :: Word8 -> Bool isUnreserved x = isAlphaNum x || other where other = case x of 45 -> True 46 -> True 95 -> True 126 -> True _ -> False isAlphaNum :: Word8 -> Bool isAlphaNum x | x >= 65 && x <= 90 = True -- 'A'..'Z' | x >= 97 && x <= 122 = True -- 'a'..'z' | x >= 48 && x <= 57 = True -- '0'..'9' | otherwise = False isDelim :: Word8 -> Bool isDelim x | x == 33 = True | x == 36 = True | x >= 38 && x <= 44 = True | x == 59 = True | x == 61 = True | otherwise = False isDelim' :: Word8 -> Bool isDelim' x | x == 33 = True | x == 36 = True | x >= 39 && x <= 42 = True | x == 44 = True | x == 59 = True | otherwise = False modern-uri-0.3.6.1/Text/URI/Types.hs0000644000000000000000000004024307346545000015157 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} -- | -- Module : Text.URI.Types -- Copyright : © 2017–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- 'URI' types, an internal module. module Text.URI.Types ( -- * Data types URI (..), makeAbsolute, isPathAbsolute, Authority (..), UserInfo (..), QueryParam (..), ParseException (..), ParseExceptionBs (..), -- * Refined text RText, RTextLabel (..), mkScheme, mkHost, mkUsername, mkPassword, mkPathPiece, mkQueryKey, mkQueryValue, mkFragment, unRText, RTextException (..), -- * Utils pHost, ) where import Control.DeepSeq import Control.Monad import Control.Monad.Catch (Exception (..), MonadThrow (..)) import Data.ByteString (ByteString) import Data.Char import Data.Data (Data) import Data.Either (fromLeft) import Data.Hashable (Hashable) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable, cast) import Data.Void import Data.Word (Word16, Word8) import GHC.Generics import qualified Language.Haskell.TH.Syntax as TH import Numeric (showHex, showInt) import Test.QuickCheck import Text.Megaparsec import Text.URI.Parser.Text.Utils (pHost) ---------------------------------------------------------------------------- -- Data types -- | Uniform resource identifier (URI) reference. We use refined 'Text' -- (@'RText' l@) here because information is presented in human-readable -- form, i.e. percent-decoded, and thus it may contain Unicode characters. data URI = URI { -- | URI scheme, if 'Nothing', then the URI reference is relative uriScheme :: Maybe (RText 'Scheme), -- | 'Authority' component in 'Right' or a 'Bool' value in 'Left' -- indicating if 'uriPath' path is absolute ('True') or relative -- ('False'); if we have an 'Authority' component, then the path is -- necessarily absolute, see 'isPathAbsolute' -- -- __Note__: before version /0.1.0.0/ type of 'uriAuthority' was -- @'Maybe' 'Authority'@ uriAuthority :: Either Bool Authority, -- | 'Nothing' represents the empty path, while 'Just' contains an -- indication 'Bool' whether the path component has a trailing slash, -- and the collection of path pieces @'NonEmpty' ('RText' 'PathPiece')@. -- -- __Note__: before version /0.2.0.0/ type of 'uriPath' was @['RText' -- 'PathPiece']@. uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece)), -- | Query parameters, RFC 3986 does not define the inner organization -- of query string, so we deconstruct it following RFC 1866 here uriQuery :: [QueryParam], -- | Fragment, without @#@ uriFragment :: Maybe (RText 'Fragment) } deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | @since 0.3.5.0 instance Hashable URI instance Arbitrary URI where arbitrary = URI <$> arbitrary <*> arbitrary <*> ( do mpieces <- NE.nonEmpty <$> arbitrary trailingSlash <- arbitrary return ((trailingSlash,) <$> mpieces) ) <*> arbitrary <*> arbitrary instance NFData URI -- | @since 0.3.1.0 instance TH.Lift URI where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | Make a given 'URI' reference absolute using the supplied @'RText' -- 'Scheme'@ if necessary. makeAbsolute :: RText 'Scheme -> URI -> URI makeAbsolute scheme URI {..} = URI { uriScheme = pure (fromMaybe scheme uriScheme), .. } -- | Return 'True' if path in a given 'URI' is absolute. -- -- @since 0.1.0.0 isPathAbsolute :: URI -> Bool isPathAbsolute = fromLeft True . uriAuthority -- | Authority component of 'URI'. data Authority = Authority { -- | User information authUserInfo :: Maybe UserInfo, -- | Host authHost :: RText 'Host, -- | Port number authPort :: Maybe Word } deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | @since 0.3.5.0 instance Hashable Authority instance Arbitrary Authority where arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary instance NFData Authority -- | @since 0.3.1.0 instance TH.Lift Authority where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | User info as a combination of username and password. data UserInfo = UserInfo { -- | Username uiUsername :: RText 'Username, -- | Password, 'Nothing' means that there was no @:@ character in the -- user info string uiPassword :: Maybe (RText 'Password) } deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | @since 0.3.5.0 instance Hashable UserInfo instance Arbitrary UserInfo where arbitrary = UserInfo <$> arbitrary <*> arbitrary instance NFData UserInfo -- | @since 0.3.1.0 instance TH.Lift UserInfo where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | Query parameter either in the form of flag or as a pair of key and -- value. A key cannot be empty, while a value can. data QueryParam = -- | Flag parameter QueryFlag (RText 'QueryKey) | -- | Key–value pair QueryParam (RText 'QueryKey) (RText 'QueryValue) deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | @since 0.3.5.0 instance Hashable QueryParam instance Arbitrary QueryParam where arbitrary = oneof [ QueryFlag <$> arbitrary, QueryParam <$> arbitrary <*> arbitrary ] instance NFData QueryParam -- | @since 0.3.1.0 instance TH.Lift QueryParam where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be -- parsed as a 'URI'. newtype ParseException = -- | Arguments are: original input and parse error ParseException (ParseErrorBundle Text Void) deriving (Show, Eq, Data, Typeable, Generic) instance Exception ParseException where displayException (ParseException b) = errorBundlePretty b instance NFData ParseException -- | Parse exception thrown by 'mkURIBs' when a given 'ByteString' value cannot be -- parsed as a 'URI'. -- -- @since 0.3.3.0 newtype ParseExceptionBs = -- | Arguments are: original input and parse error ParseExceptionBs (ParseErrorBundle ByteString Void) deriving (Show, Eq, Data, Typeable, Generic) instance Exception ParseExceptionBs where displayException (ParseExceptionBs b) = errorBundlePretty b instance NFData ParseExceptionBs ---------------------------------------------------------------------------- -- Refined text -- | Refined text labelled at the type level. newtype RText (l :: RTextLabel) = RText Text deriving (Eq, Ord, Data, Typeable, Generic) -- | @since 0.3.5.0 instance Hashable (RText l) instance Show (RText l) where show (RText txt) = show txt instance NFData (RText l) -- | @since 0.3.1.0 instance (Typeable l) => TH.Lift (RText l) where lift = liftData liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | Refined text labels. data RTextLabel = -- | See 'mkScheme' Scheme | -- | See 'mkHost' Host | -- | See 'mkUsername' Username | -- | See 'mkPassword' Password | -- | See 'mkPathPiece' PathPiece | -- | See 'mkQueryKey' QueryKey | -- | See 'mkQueryValue' QueryValue | -- | See 'mkFragment' Fragment deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | This type class associates checking, normalization, and a term level -- label with a label on the type level. -- -- We would like to have a closed type class here, and so we achieve almost -- that by not exporting 'RLabel' and 'mkRText' (only specialized helpers -- like 'mkScheme'). class RLabel (l :: RTextLabel) where rcheck :: Proxy l -> Text -> Bool rnormalize :: Proxy l -> Text -> Text rlabel :: Proxy l -> RTextLabel -- | Construct a refined text value. mkRText :: forall m l. (MonadThrow m, RLabel l) => Text -> m (RText l) mkRText txt = if rcheck lproxy txt then return . RText $ rnormalize lproxy txt else throwM (RTextException (rlabel lproxy) txt) where lproxy = Proxy :: Proxy l -- | Lift a 'Text' value into @'RText' 'Scheme'@. -- -- Scheme names consist of a sequence of characters beginning with a letter -- and followed by any combination of letters, digits, plus @\"+\"@, period -- @\".\"@, or hyphen @\"-\"@. -- -- This smart constructor performs normalization of valid schemes by -- converting them to lower case. -- -- See also: mkScheme :: (MonadThrow m) => Text -> m (RText 'Scheme) mkScheme = mkRText instance RLabel 'Scheme where rcheck Proxy = ifMatches $ do void . satisfy $ \x -> isAscii x && isAlpha x skipMany . satisfy $ \x -> isAscii x && isAlphaNum x || x == '+' || x == '-' || x == '.' rnormalize Proxy = T.toLower rlabel Proxy = Scheme instance Arbitrary (RText 'Scheme) where arbitrary = arbScheme -- | Lift a 'Text' value into @'RText' 'Host'@. -- -- The host sub-component of authority is identified by an IP literal -- encapsulated within square brackets, an IPv4 address in dotted-decimal -- form, or a registered name. -- -- This smart constructor performs normalization of valid hosts by -- converting them to lower case. -- -- See also: mkHost :: (MonadThrow m) => Text -> m (RText 'Host) mkHost = mkRText instance RLabel 'Host where rcheck Proxy = (ifMatches . void . pHost) False rnormalize Proxy = T.toLower rlabel Proxy = Host instance Arbitrary (RText 'Host) where arbitrary = arbHost -- | Lift a 'Text' value into @'RText' 'Username'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkUsername :: (MonadThrow m) => Text -> m (RText 'Username) mkUsername = mkRText instance RLabel 'Username where rcheck Proxy = not . T.null rnormalize Proxy = id rlabel Proxy = Username instance Arbitrary (RText 'Username) where arbitrary = arbText' mkUsername -- | Lift a 'Text' value into @'RText' 'Password'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkPassword :: (MonadThrow m) => Text -> m (RText 'Password) mkPassword = mkRText instance RLabel 'Password where rcheck Proxy = const True rnormalize Proxy = id rlabel Proxy = Password instance Arbitrary (RText 'Password) where arbitrary = arbText mkPassword -- | Lift a 'Text' value into @'RText' 'PathPiece'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkPathPiece :: (MonadThrow m) => Text -> m (RText 'PathPiece) mkPathPiece = mkRText instance RLabel 'PathPiece where rcheck Proxy = not . T.null rnormalize Proxy = id rlabel Proxy = PathPiece instance Arbitrary (RText 'PathPiece) where arbitrary = arbText' mkPathPiece -- | Lift a 'Text' value into @'RText 'QueryKey'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkQueryKey :: (MonadThrow m) => Text -> m (RText 'QueryKey) mkQueryKey = mkRText instance RLabel 'QueryKey where rcheck Proxy = not . T.null rnormalize Proxy = id rlabel Proxy = QueryKey instance Arbitrary (RText 'QueryKey) where arbitrary = arbText' mkQueryKey -- | Lift a 'Text' value into @'RText' 'QueryValue'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkQueryValue :: (MonadThrow m) => Text -> m (RText 'QueryValue) mkQueryValue = mkRText instance RLabel 'QueryValue where rcheck Proxy = const True rnormalize Proxy = id rlabel Proxy = QueryValue instance Arbitrary (RText 'QueryValue) where arbitrary = arbText mkQueryValue -- | Lift a 'Text' value into @'RText' 'Fragment'@. -- -- This smart constructor does not perform any sort of normalization. -- -- See also: mkFragment :: (MonadThrow m) => Text -> m (RText 'Fragment) mkFragment = mkRText instance RLabel 'Fragment where rcheck Proxy = const True rnormalize Proxy = id rlabel Proxy = Fragment instance Arbitrary (RText 'Fragment) where arbitrary = arbText mkFragment -- | Project a plain strict 'Text' value from a refined @'RText' l@ value. unRText :: RText l -> Text unRText (RText txt) = txt -- | The exception is thrown when a refined @'RText' l@ value cannot be -- constructed due to the fact that given 'Text' value is not correct. data RTextException = -- | 'RTextLabel' identifying what sort of refined text value could not be -- constructed and the input that was supplied, as a 'Text' value RTextException RTextLabel Text deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Exception RTextException where displayException (RTextException lbl txt) = "The value \"" ++ T.unpack txt ++ "\" could not be lifted into a " ++ show lbl ---------------------------------------------------------------------------- -- Parser helpers -- | Return 'True' if given parser can consume 'Text' in its entirety. ifMatches :: Parsec Void Text () -> Text -> Bool ifMatches p = isJust . parseMaybe p ---------------------------------------------------------------------------- -- Arbitrary helpers -- | Generator of 'Arbitrary' schemes. arbScheme :: Gen (RText 'Scheme) arbScheme = do let g = oneof [choose ('a', 'z'), choose ('A', 'Z')] x <- g xs <- listOf $ frequency [(3, g), (1, choose ('0', '9'))] return . fromJust . mkScheme . T.pack $ x : xs -- | Generator of 'Arbitrary' hosts. arbHost :: Gen (RText 'Host) arbHost = fromJust . mkHost . T.pack <$> frequency [ (1, ipLiteral), (2, ipv4Address), (4, regName), (1, return "") ] where ipLiteral = do xs <- oneof [ipv6Address, ipvFuture] return ("[" ++ xs ++ "]") ipv6Address = -- NOTE We do not mess with zeroes here, because it's a hairy stuff. -- We test how we handle :: thing manually in the test suite. intercalate ":" . fmap (`showHex` "") <$> vectorOf 8 (arbitrary :: Gen Word16) ipv4Address = intercalate "." . fmap (`showInt` "") <$> vectorOf 4 (arbitrary :: Gen Word8) ipvFuture = do v <- oneof [choose ('0', '9'), choose ('a', 'f')] xs <- listOf1 $ frequency [ (3, choose ('a', 'z')), (3, choose ('A', 'Z')), (2, choose ('0', '9')), (2, elements "-._~!$&'()*+,;=:") ] return ("v" ++ [v] ++ "." ++ xs) domainLabel = do let g = arbitrary `suchThat` isUnreservedChar x <- g xs <- listOf $ frequency [(3, g), (1, return '-')] x' <- g return ([x] ++ xs ++ [x']) regName = intercalate "." <$> resize 5 (listOf1 domainLabel) -- | Return 'True' if the given character is unreserved. isUnreservedChar :: Char -> Bool isUnreservedChar x = isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' -- | Make generator for refined text given how to lift a possibly empty -- arbitrary 'Text' value into a refined type. arbText :: (Text -> Maybe (RText l)) -> Gen (RText l) arbText f = fromJust . f . T.pack <$> listOf arbitrary -- | Like 'arbText'', but the lifting function will be given non-empty -- arbitrary 'Text' value. arbText' :: (Text -> Maybe (RText l)) -> Gen (RText l) arbText' f = fromJust . f . T.pack <$> listOf1 arbitrary ---------------------------------------------------------------------------- -- TH lifting helpers liftData :: (Data a, TH.Quote m) => a -> m TH.Exp liftData = TH.dataToExpQ (fmap liftText . cast) liftText :: (TH.Quote m) => Text -> m TH.Exp liftText t = TH.AppE (TH.VarE 'T.pack) <$> TH.lift (T.unpack t) modern-uri-0.3.6.1/bench/memory/0000755000000000000000000000000007346545000014520 5ustar0000000000000000modern-uri-0.3.6.1/bench/memory/Main.hs0000644000000000000000000000305407346545000015742 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Data.ByteString (ByteString) import Data.Maybe (fromJust) import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.URI (URI) import Text.URI qualified as URI import Weigh main :: IO () main = mainWith $ do setColumns [Case, Allocated, GCs, Max] bparser turiStr bparserBs turiStr brender turi brenderBs turi brenderStr turi ---------------------------------------------------------------------------- -- Helpers -- | Test 'URI' as a polymorphic string. turiStr :: (IsString a) => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form. turi :: URI turi = fromJust (URI.mkURI turiStr) -- | Benchmark memory usage of the 'URI' parser with given input. bparser :: Text -> Weigh () bparser = func "text parser" (parse p "") where p = URI.parser <* eof :: Parsec Void Text URI -- | Like 'bparser' but accepts a 'ByteString'. bparserBs :: ByteString -> Weigh () bparserBs = func "bs parser" (parse p "") where p = URI.parserBs <* eof :: Parsec Void ByteString URI -- | Benchmark memory usage of the 'URI' render with given input. brender :: URI -> Weigh () brender = func "text render" URI.render -- | The same as 'brender' but for the 'URI.renderBs' render. brenderBs :: URI -> Weigh () brenderBs = func "bs render" URI.renderBs -- | The same as 'brender' but for the 'URI.renderString' render. brenderStr :: URI -> Weigh () brenderStr = func "str render" URI.renderStr modern-uri-0.3.6.1/bench/speed/0000755000000000000000000000000007346545000014310 5ustar0000000000000000modern-uri-0.3.6.1/bench/speed/Main.hs0000644000000000000000000000326007346545000015531 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Criterion.Main import Data.ByteString (ByteString) import Data.Maybe (fromJust) import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.URI (URI) import Text.URI qualified as URI main :: IO () main = defaultMain [ bparser turiStr, bparserBs turiStr, brender turi, brenderBs turi, brenderStr turi ] ---------------------------------------------------------------------------- -- Helpers -- | Test 'URI' as a polymorphic string. turiStr :: (IsString a) => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form. turi :: URI turi = fromJust (URI.mkURI turiStr) -- | Benchmark speed of the 'URI' parser with given input. bparser :: Text -> Benchmark bparser txt = env (return txt) (bench "text parser" . nf p) where p = parse (URI.parser <* eof :: Parsec Void Text URI) "" -- | Like 'bparser' but accepts a 'ByteString'. bparserBs :: ByteString -> Benchmark bparserBs bs = env (return bs) (bench "bs parser" . nf p) where p = parse (URI.parserBs <* eof :: Parsec Void ByteString URI) "" -- | Benchmark speed of the 'URI' render with given input. brender :: URI -> Benchmark brender uri = env (return uri) (bench "text render" . nf URI.render) -- | The same as 'brender' but for the 'URI.renderBs' render. brenderBs :: URI -> Benchmark brenderBs uri = env (return uri) (bench "bs render" . nf URI.renderBs) -- | The same as 'brender' but for the 'URI.renderString' render. brenderStr :: URI -> Benchmark brenderStr uri = env (return uri) (bench "str render" . nf URI.renderStr) modern-uri-0.3.6.1/modern-uri.cabal0000644000000000000000000000665507346545000015212 0ustar0000000000000000cabal-version: 2.4 name: modern-uri version: 0.3.6.1 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov author: Mark Karpov tested-with: ghc ==9.2.8 ghc ==9.4.5 ghc ==9.6.2 homepage: https://github.com/mrkkrp/modern-uri bug-reports: https://github.com/mrkkrp/modern-uri/issues synopsis: Modern library for working with URIs description: Modern library for working with URIs. category: Text build-type: Simple extra-doc-files: CHANGELOG.md README.md source-repository head type: git location: https://github.com/mrkkrp/modern-uri.git flag dev description: Turn on development settings. default: False manual: True library exposed-modules: Text.URI Text.URI.Lens Text.URI.QQ other-modules: Text.URI.Parser.ByteString Text.URI.Parser.Text Text.URI.Parser.Text.Utils Text.URI.Render Text.URI.Types default-language: Haskell2010 build-depends: QuickCheck >=2.4 && <3.0, base >=4.15 && <5.0, bytestring >=0.2 && <0.12, containers >=0.5 && <0.7, deepseq >=1.3 && <1.5, exceptions >=0.6 && <0.11, hashable >=1.3 && <2.0, megaparsec >=7.0 && <10.0, mtl >=2.0 && <3.0, profunctors >=5.2.1 && <6.0, reflection >=2.0 && <3.0, tagged >=0.8 && <0.9, template-haskell >=2.10 && <2.21, text >=0.2 && <2.1 if flag(dev) ghc-options: -Wall -Werror -Wpartial-fields -Wunused-packages else ghc-options: -O2 -Wall test-suite tests type: exitcode-stdio-1.0 main-is: Spec.hs build-tool-depends: hspec-discover:hspec-discover >=2.0 && <3.0 hs-source-dirs: tests other-modules: Text.QQSpec Text.URISpec default-language: GHC2021 build-depends: QuickCheck >=2.4 && <3.0, base >=4.15 && <5.0, bytestring >=0.2 && <0.12, hspec >=2.0 && <3.0, hspec-megaparsec >=2.0 && <3.0, megaparsec >=8.0 && <10.0, modern-uri, text >=0.2 && <2.1 if flag(dev) ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields -Wunused-packages else ghc-options: -O2 -Wall benchmark bench-speed type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/speed default-language: GHC2021 build-depends: base >=4.15 && <5.0, bytestring >=0.2 && <0.12, criterion >=0.6.2.1 && <1.7, megaparsec >=8.0 && <10.0, modern-uri, text >=0.2 && <2.1 if flag(dev) ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields -Wunused-packages else ghc-options: -O2 -Wall benchmark bench-memory type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/memory default-language: GHC2021 build-depends: base >=4.15 && <5.0, bytestring >=0.2 && <0.12, megaparsec >=8.0 && <10.0, modern-uri, text >=0.2 && <2.1, weigh >=0.0.4 if flag(dev) ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields -Wunused-packages else ghc-options: -O2 -Wall modern-uri-0.3.6.1/tests/0000755000000000000000000000000007346545000013273 5ustar0000000000000000modern-uri-0.3.6.1/tests/Spec.hs0000644000000000000000000000005407346545000014520 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} modern-uri-0.3.6.1/tests/Text/0000755000000000000000000000000007346545000014217 5ustar0000000000000000modern-uri-0.3.6.1/tests/Text/QQSpec.hs0000644000000000000000000000752407346545000015717 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} module Text.QQSpec (spec) where import Test.Hspec import Text.URI import Text.URI.QQ qualified as QQ spec :: Spec spec = do describe "uri" $ do it "works as an expression" $ do let uriQQ = [QQ.uri|https://markkarpov.com|] uri <- mkURI "https://markkarpov.com" uriQQ `shouldBe` uri it "works as a pattern" $ mkURI "https://markkarpov.com" >>= \case [QQ.uri|https://haskell.org|] -> shouldNotMatch [QQ.uri|https://markkarpov.com|] -> return () _ -> shouldHaveMatchedAlready describe "scheme" $ do it "works as an expression" $ do let schemeQQ = [QQ.scheme|https|] scheme <- mkScheme "https" schemeQQ `shouldBe` scheme it "works as a pattern" $ mkScheme "https" >>= \case [QQ.scheme|ftp|] -> shouldNotMatch [QQ.scheme|https|] -> return () _ -> shouldHaveMatchedAlready describe "host" $ do it "works as an expression" $ do let hostQQ = [QQ.host|markkarpov.com|] host <- mkHost "markkarpov.com" hostQQ `shouldBe` host it "works as a pattern" $ do mkHost "markkarpov.com" >>= \case [QQ.host|haskell.org|] -> shouldNotMatch [QQ.host|markkarpov.com|] -> return () _ -> shouldHaveMatchedAlready describe "username" $ do it "works as an expression" $ do let usernameQQ = [QQ.username|mark|] username <- mkUsername "mark" usernameQQ `shouldBe` username it "works as a pattern" $ do mkUsername "mark" >>= \case [QQ.username|chris|] -> shouldNotMatch [QQ.username|mark|] -> return () _ -> shouldHaveMatchedAlready describe "password" $ do it "works as an expression" $ do let passwordQQ = [QQ.password|secret123|] password <- mkPassword "secret123" passwordQQ `shouldBe` password it "works as a pattern" $ do mkPassword "secret123" >>= \case [QQ.password|secretXYZ|] -> shouldNotMatch [QQ.password|secret123|] -> return () _ -> shouldHaveMatchedAlready describe "pathPiece" $ do it "works as an expression" $ do let pathPieceQQ = [QQ.pathPiece|foo|] pathPiece <- mkPathPiece "foo" pathPieceQQ `shouldBe` pathPiece it "works as a pattern" $ do mkPathPiece "foo" >>= \case [QQ.pathPiece|bar|] -> shouldNotMatch [QQ.pathPiece|foo|] -> return () _ -> shouldHaveMatchedAlready describe "queryKey" $ do it "works as an expression" $ do let queryKeyQQ = [QQ.queryKey|foo|] queryKey <- mkQueryKey "foo" queryKeyQQ `shouldBe` queryKey it "works as a pattern" $ do mkQueryKey "foo" >>= \case [QQ.queryKey|xyz|] -> shouldNotMatch [QQ.queryKey|foo|] -> return () _ -> shouldHaveMatchedAlready describe "queryValue" $ do it "works as an expression" $ do let queryValueQQ = [QQ.queryValue|bar|] queryValue <- mkQueryValue "bar" queryValueQQ `shouldBe` queryValue it "works as a pattern" $ do mkQueryValue "bar" >>= \case [QQ.queryValue|xyz|] -> shouldNotMatch [QQ.queryValue|bar|] -> return () _ -> shouldHaveMatchedAlready describe "fragment" $ do it "works as an expression" $ do let fragmentQQ = [QQ.fragment|frag|] fragment <- mkFragment "frag" fragmentQQ `shouldBe` fragment it "works as a pattern" $ do mkFragment "frag" >>= \case [QQ.fragment|xyz|] -> shouldNotMatch [QQ.fragment|frag|] -> return () _ -> shouldHaveMatchedAlready shouldNotMatch :: Expectation shouldNotMatch = expectationFailure "First case should not have matched, but did" shouldHaveMatchedAlready :: Expectation shouldHaveMatchedAlready = expectationFailure "Second case should have matched, but didn't" modern-uri-0.3.6.1/tests/Text/URISpec.hs0000644000000000000000000004331207346545000016030 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Text.URISpec (spec) where import Control.Monad import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, isNothing) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Void import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck import Text.Megaparsec import Text.URI (RTextException (..), RTextLabel (..), URI (..)) import Text.URI qualified as URI instance Arbitrary Text where arbitrary = T.pack <$> arbitrary spec :: Spec spec = do describe "mkURI" $ do it "accepts valid URIs" $ do uri <- mkTestURI URI.mkURI testURI `shouldReturn` uri it "accepts a URI with an underscore in host name" $ do scheme <- URI.mkScheme "http" host <- URI.mkHost "auth_service" path <- mapM URI.mkPathPiece ["api", "v1", "users", "validate"] URI.mkURI "http://auth_service:3000/api/v1/users/validate" `shouldReturn` URI { uriScheme = Just scheme, uriAuthority = Right URI.Authority { URI.authUserInfo = Nothing, URI.authHost = host, URI.authPort = Just 3000 }, uriPath = Just (False, NE.fromList path), uriQuery = [], uriFragment = Nothing } it "rejects invalid URIs" $ do let e = err 0 . mconcat $ [ utok 'ч', etok '#', etok '/', etoks "//", etok '?', elabel "ASCII alpha character", elabel "path piece", eeof ] b = ParseErrorBundle { bundleErrors = e :| [], bundlePosState = initialPosState s } s = "что-то" URI.mkURI s `shouldThrow` (== URI.ParseException b) describe "mkURIBs" $ do it "accepts valid URIs" $ do uri <- mkTestURI URI.mkURIBs testURI `shouldReturn` uri describe "emptyURI" $ do it "parsing of empty input produces emptyURI" $ URI.mkURI "" `shouldReturn` URI.emptyURI context "rendering of emptyURI produces empty output" $ do it "with render" $ URI.render URI.emptyURI `shouldBe` "" it "with renderBs" $ URI.renderBs URI.emptyURI `shouldBe` "" it "with renderStr" $ URI.renderStr URI.emptyURI `shouldBe` "" describe "makeAbsolute" $ do context "when given URI already has scheme" $ it "returns that URI unchanged" $ property $ \scheme uri -> isJust (uriScheme uri) ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` uriScheme uri context "when given URI has no scheme" $ it "sets the specified scheme" $ property $ \scheme uri -> isNothing (uriScheme uri) ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` Just scheme describe "isPathAbsolute" $ do context "when URI has authority component" $ it "returns True" $ property $ \uri auth -> URI.isPathAbsolute (uri {uriAuthority = Right auth}) `shouldBe` True context "when URI has no authority component" $ it "return what is inside of Left in uriAuthority" $ property $ \uri b -> URI.isPathAbsolute (uri {uriAuthority = Left b}) `shouldBe` b describe "mkScheme" $ do it "accepts valid schemes" $ do URI.mkScheme "http" `shouldRText` "http" URI.mkScheme "HTTPS" `shouldRText` "https" URI.mkScheme "mailto" `shouldRText` "mailto" URI.mkScheme "a+-." `shouldRText` "a+-." it "rejects invalid schemes" $ do URI.mkScheme "123" `shouldThrow` (== RTextException Scheme "123") URI.mkScheme "схема" `shouldThrow` (== RTextException Scheme "схема") URI.mkScheme "+-." `shouldThrow` (== RTextException Scheme "+-.") describe "mkHost" $ do it "accepts valid IPv4 literals" $ do URI.mkHost "127.0.0.1" `shouldRText` "127.0.0.1" URI.mkHost "198.98.43.23" `shouldRText` "198.98.43.23" it "accepts valid IPv6 literals" $ do URI.mkHost "[0123:4567:89ab:cdef:0:0:0:0]" `shouldRText` "[0123:4567:89ab:cdef:0:0:0:0]" URI.mkHost "[0123::4567:89ab]" `shouldRText` "[0123::4567:89ab]" URI.mkHost "[::0123:4567:89ab]" `shouldRText` "[::0123:4567:89ab]" URI.mkHost "[0123:4567:89ab::]" `shouldRText` "[0123:4567:89ab::]" it "rejects invalid IPv6 literals" $ do URI.mkHost "[0123:4567:89ab]" `shouldThrow` (== RTextException Host "[0123:4567:89ab]") URI.mkHost "[0123::4567:89ab::]" `shouldThrow` (== RTextException Host "[0123::4567:89ab::]") it "accepts valid IP future literals" $ do URI.mkHost "[va.something]" `shouldRText` "[va.something]" URI.mkHost "[v1.123-456]" `shouldRText` "[v1.123-456]" it "rejects invalid IP future literals" $ URI.mkHost "[vv.something]" `shouldThrow` (== RTextException Host "[vv.something]") it "accepts valid domain names" $ do URI.mkHost "LOCALHOST" `shouldRText` "localhost" URI.mkHost "github.com" `shouldRText` "github.com" URI.mkHost "foo.example.com" `shouldRText` "foo.example.com" URI.mkHost "104.155.144.4.sslip.io" `shouldRText` "104.155.144.4.sslip.io" URI.mkHost "юникод.рф" `shouldRText` "юникод.рф" URI.mkHost "" `shouldRText` "" URI.mkHost "." `shouldRText` "." URI.mkHost "my-host." `shouldRText` "my-host." URI.mkHost "auth_service" `shouldRText` "auth_service" it "rejects invalid hosts" $ do URI.mkHost ")something" `shouldThrow` (== RTextException Host ")something") URI.mkHost "some@thing" `shouldThrow` (== RTextException Host "some@thing") describe "mkUsername" $ do it "accepts valid usernames" $ property $ \txt -> not (T.null txt) ==> do username <- URI.mkUsername txt URI.unRText username `shouldBe` txt it "rejects invalid usernames" $ URI.mkUsername "" `shouldThrow` (== RTextException Username "") describe "mkPassword" $ it "lifts any text into password" $ property $ \txt -> do pass <- URI.mkPassword txt URI.unRText pass `shouldBe` txt describe "mkPathPiece" $ do it "accepts valid path pieces" $ property $ \txt -> not (T.null txt) ==> do pp <- URI.mkPathPiece txt URI.unRText pp `shouldBe` txt it "rejects invalid path pieces" $ URI.mkPathPiece "" `shouldThrow` (== RTextException PathPiece "") describe "mkQueryKey" $ do it "accepts valid query keys" $ property $ \txt -> not (T.null txt) ==> do k <- URI.mkQueryKey txt URI.unRText k `shouldBe` txt it "rejects invalid query keys" $ URI.mkQueryKey "" `shouldThrow` (== RTextException QueryKey "") describe "mkQueryValue" $ it "lifts any text into query value" $ property $ \txt -> do v <- URI.mkQueryValue txt URI.unRText v `shouldBe` txt describe "mkFragment" $ it "lifts any text into fragment" $ property $ \txt -> do fragment <- URI.mkFragment txt URI.unRText fragment `shouldBe` txt describe "parse and render" $ it "parser and render are consistent" $ property $ \uri -> shouldParse' (URI.render uri) uri describe "parseBs and renderBs" $ it "parser and render are consistent" $ property $ \uri -> shouldParseBs (URI.renderBs uri) uri describe "parse" $ do it "rejects Unicode in scheme" $ parse urip "" "что:something" `shouldFailWith` err 0 ( mconcat [ utok 'ч', etok '#', etok '/', etoks "//", etok '?', elabel "ASCII alpha character", elabel "path piece", eeof ] ) it "rejects Unicode in host" $ do let s = "https://юникод.рф" parse urip "" s `shouldFailWith` err 8 ( mconcat [ utok 'ю', etok '#', etok '%', etok '.', etok '/', etok ':', etok '?', etok '[', elabel "path piece", elabel "unreserved character", elabel "username", eeof ] ) it "rejects Unicode in path" $ do let s = "https://github.com/марк" parse urip "" s `shouldFailWith` err 19 ( mconcat [ utok 'м', etok '#', etok '/', etok '?', elabel "path piece", eeof ] ) it "parses URIs with sub-domains that look like IPv4" $ do scheme <- URI.mkScheme "https" host <- URI.mkHost "104.155.144.4.sslip.io" let s = "https://104.155.144.4.sslip.io:443/" parse urip "" s `shouldParse` URI { uriScheme = Just scheme, uriAuthority = Right URI.Authority { URI.authUserInfo = Nothing, URI.authHost = host, URI.authPort = Just 443 }, uriPath = Nothing, uriQuery = [], uriFragment = Nothing } it "parses URIs with empty authority" $ do scheme <- URI.mkScheme "file" ppetc <- URI.mkPathPiece "etc" pphosts <- URI.mkPathPiece "hosts" host <- URI.mkHost "" let s = "file:///etc/hosts" parse urip "" s `shouldParse` URI { uriScheme = Just scheme, uriAuthority = Right URI.Authority { URI.authUserInfo = Nothing, URI.authHost = host, URI.authPort = Nothing }, uriPath = Just (False, ppetc :| [pphosts]), uriQuery = [], uriFragment = Nothing } it "parses URIs with superfluous '&' before query parameters" $ do uri <- mkTestURI let s = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri+%3a@?&foo:@=bar+:@#fragment:@" parse urip "" s `shouldParse` uri it "treats gracefully percent-encoded sequences that are not UTF-8 encoded Text" $ do let s = "https://foo%f0bar" parse urip "" s `shouldFailWith` err 8 ( mconcat [ utoks "foo%f0bar", etok '%', etok '.', elabel "unreserved character", elabel "host that can be decoded as UTF-8" ] ) describe "render" $ do it "sort of works" $ fmap URI.render mkTestURI `shouldReturn` testURI context "when URI has scheme" $ it "does not escape colon in path components" $ (URI.render <$> URI.mkURI "https:/fir:st/se:cond") `shouldReturn` "https:/fir:st/se:cond" context "when URI is a network-path reference" $ it "does not escape colon in path components" $ (URI.render <$> URI.mkURI "//host/fir:st/se:cond") `shouldReturn` "//host/fir:st/se:cond" context "when URI is a relative-path reference" $ it "escapes colon but only in the first path segment" $ do firstSeg <- URI.mkPathPiece "fir:st" secondSeg <- URI.mkPathPiece "se:cond" let uri = URI.emptyURI { uriPath = Just (False, firstSeg :| [secondSeg]) } URI.render uri `shouldBe` "fir%3ast/se:cond" context "when URI has no path" $ it "is rendered without trailing slash" $ do let uriWithoutSlash = "https://example.com" uri <- URI.mkURI uriWithoutSlash URI.render uri `shouldBe` uriWithoutSlash context "when the scheme is mailto" $ it "does not escape @ in the path" $ do let mailtoUri = "mailto:john.smith@example.org" uri <- URI.mkURI mailtoUri URI.render uri `shouldBe` mailtoUri describe "renderBs" $ it "sort of works" $ fmap URI.renderBs mkTestURI `shouldReturn` testURI describe "renderStr" $ it "sort of works" $ fmap URI.renderStr mkTestURI `shouldReturn` testURI describe "relativeTo" $ do let testResolution r e = do base <- URI.mkURI "http://a/b/c/d;p?q" reference <- URI.mkURI r expected <- URI.mkURI e URI.relativeTo reference base `shouldBe` Just expected context "when reference URI has no scheme" $ forM_ resolutionTests $ \(r, e) -> it ("resolves reference path \"" <> T.unpack r <> "\"") $ testResolution r e context "when reference URI has scheme" $ do context "when the scheme is the same as the scheme of base URI" $ it "reference URI is preserved intact" $ testResolution "http:g" "http:g" context "when the scheme is different from the scheme of base URI" $ it "reference URI is preserved intact" $ testResolution "ftp:g" "ftp:g" context "when base URI has no scheme" $ it "returns Nothing" $ property $ \reference base -> isNothing (uriScheme base) ==> URI.relativeTo reference base `shouldBe` Nothing context "when base URI has scheme" $ it "the resulting URI always has scheme" $ property $ \reference base -> isJust (uriScheme base) ==> do let scheme = URI.relativeTo reference base >>= uriScheme scheme `shouldSatisfy` isJust ---------------------------------------------------------------------------- -- Helpers -- | Construct a test URI. mkTestURI :: IO URI mkTestURI = do scheme <- URI.mkScheme "https" username <- URI.mkUsername "mark:@" password <- URI.mkPassword "secret:@" host <- URI.mkHost "github.com" path <- mapM URI.mkPathPiece ["mrkkrp", "modern-uri+:@"] k <- URI.mkQueryKey "foo:@" v <- URI.mkQueryValue "bar :@" fragment <- URI.mkFragment "fragment:@" return URI { uriScheme = Just scheme, uriAuthority = Right URI.Authority { URI.authUserInfo = Just URI.UserInfo { URI.uiUsername = username, URI.uiPassword = Just password }, URI.authHost = host, URI.authPort = Just 443 }, uriPath = Just (False, NE.fromList path), uriQuery = [URI.QueryParam k v], uriFragment = Just fragment } -- | Polymorphic textual rendering of the 'URI' generated by 'mkTestURI'. testURI :: (IsString a) => a testURI = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri%2b:%40?foo:@=bar+:@#fragment:@" -- | A utility wrapper around 'URI.parser'. urip :: Parsec Void Text URI urip = URI.parser <* eof -- | Expect that the given action constructs 'URI.RText' with certain text -- inside. shouldRText :: -- | Action that produces refined text IO (URI.RText l) -> -- | Inner text to compare with Text -> Expectation shouldRText rtext txt = do txt' <- rtext URI.unRText txt' `shouldBe` txt -- | Expect that the specified input for parser will produce 'URI' equal to -- a given one. shouldParse' :: -- | Parser input Text -> -- | 'URI' to compare with URI -> Expectation shouldParse' s a = case runParser urip "" s of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ errorBundlePretty e Right a' -> a' `shouldBe` a -- | Similar to 'shouldParse'' but uses 'URI.parserBs' under the hood. shouldParseBs :: -- | Parser input ByteString -> -- | 'URI' to compare with URI -> Expectation shouldParseBs s a = case runParser (URI.parserBs <* eof :: Parsec Void ByteString URI) "" s of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ errorBundlePretty e Right a' -> a' `shouldBe` a -- | Test cases from section 5.4.1 from RFC 3986. -- -- First item in the tuple is the relative path, the second is the expected -- result. The base path is always @http://a/b/c/d;p?q@. resolutionTests :: [(Text, Text)] resolutionTests = [ -- Normal examples ("g:h", "g:h"), ("g", "http://a/b/c/g"), ("./g", "http://a/b/c/g"), ("g/", "http://a/b/c/g/"), ("/g", "http://a/g"), ("//g", "http://g"), ("?y", "http://a/b/c/d;p?y"), ("g?y", "http://a/b/c/g?y"), ("#s", "http://a/b/c/d;p?q#s"), ("g#s", "http://a/b/c/g#s"), ("g?y#s", "http://a/b/c/g?y#s"), (";x", "http://a/b/c/;x"), ("g;x", "http://a/b/c/g;x"), ("g;x?y#s", "http://a/b/c/g;x?y#s"), ("", "http://a/b/c/d;p?q"), (".", "http://a/b/c/"), ("./", "http://a/b/c/"), ("..", "http://a/b/"), ("../", "http://a/b/"), ("../g", "http://a/b/g"), ("../..", "http://a/"), ("../../", "http://a/"), ("../../g", "http://a/g"), -- Abnormal cases ("../../../g", "http://a/g"), ("../../../../g", "http://a/g"), -- Dot segments ("/./g", "http://a/g"), ("/../g", "http://a/g"), ("g.", "http://a/b/c/g."), (".g", "http://a/b/c/.g"), ("g..", "http://a/b/c/g.."), ("..g", "http://a/b/c/..g"), -- Nonsensical forms of the "." and ".." ("./../g", "http://a/b/g"), ("./g/.", "http://a/b/c/g/"), ("g/./h", "http://a/b/c/g/h"), ("g/../h", "http://a/b/c/h"), ("g;x=1/./y", "http://a/b/c/g;x=1/y"), ("g;x=1/../y", "http://a/b/c/y"), -- Query and/or fragment components ("g?y/./x", "http://a/b/c/g?y/./x"), ("g?y/../x", "http://a/b/c/g?y/../x"), ("g#s/./x", "http://a/b/c/g#s/./x"), ("g#s/../x", "http://a/b/c/g#s/../x") ]