diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Modern URI 0.0.1.0 + +* Initial release. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2017 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# 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) +[![Build Status](https://travis-ci.org/mrkkrp/modern-uri.svg?branch=master)](https://travis-ci.org/mrkkrp/modern-uri) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/modern-uri/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/modern-uri?branch=master) + +This is a modern library for working with URIs in Haskell as per RFC 3986: + +https://tools.ietf.org/html/rfc3986 + +## Motivation + +There are already at least two libraries for working with URIs: +[`uri`](https://hackage.haskell.org/package/uri) and +[`uri-bytestring`](https://hackage.haskell.org/package/uri-bytestring). Why +write one more? + +Let's see first about the `uri` package: + +* It uses `String` instead of `Text` or `ByteString`, it is thus + inefficient. +* The types are not very precise. Query string is represented as `Maybe + String` for example. +* Uses Parsec under the hood, however does not allow us to use its URI + parser in a bigger Parsec parser. + +Now what about `uri-bytestring`? + +* Works with `ByteString`, which totally makes sense because a URI can have + only ASCII characters in it. However sometimes a URI is a part of a bigger + document that can contain Unicode characters and so we may need to parse a + URI from `Text` or render it to `Text`. Ideally, we would like to be able + to parse from both `Text` and `ByteString` as well to render to both + `Text` and `ByteString`. +* Does not allow to use its URI parser as part of a bigger parser. +* Provides `newtype` wrappers for different components of URI, but we could + still put something incorrect inside. +* Absolute and relative URI references have different types, which may or + may not be handy. +* Provides lenses, but does not provide e.g. traversal for working with + query parameters selected by their names. + +## Features + +The `modern-uri` package features: + +* Correct by construction `URI` data type. Correctness is ensured by + guaranteeing that every sub-component of the `URI` record is by itself + cannot be invalid. This boils down to careful use of types and a set of + smart constructors for things like scheme, host, etc. +* Absolute and relative URIs differ only by the scheme component: if it's + `Nothing`, then URI is relative, otherwise it's absolute. +* Megaparsec parser that can be used as a standalone smart constructor for + the `URI` data type (see `mkURI`) as well as be seamlessly integrated into + a bigger Megaparsec parser. +* Fast rendering to strict `Text` and `ByteString` as well as to their + respective `Builder` types. +* 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`). + +TODO: + +* Provide parser that can parse URIs from `ByteString`s. + +## 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 and will be reviewed quickly. + +## License + +Copyright © 2017 Mark Karpov + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Text/URI.hs b/Text/URI.hs new file mode 100644 --- /dev/null +++ b/Text/URI.hs @@ -0,0 +1,72 @@ +-- | +-- Module : Text.URI +-- Copyright : © 2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- This is 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 + , makeAbsolute + , Authority (..) + , UserInfo (..) + , QueryParam (..) + , ParseException (..) + -- * Refined text + -- $rtext + , RText + , RTextLabel (..) + , mkScheme + , mkHost + , mkUsername + , mkPassword + , mkPathPiece + , mkQueryKey + , mkQueryValue + , mkFragment + , unRText + , RTextException (..) + -- * Parsing + , parser + -- * Rendering + , render + , render' + , renderBs + , renderBs' ) +where + +import Text.URI.Parser +import Text.URI.Render +import Text.URI.Types + +-- $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. diff --git a/Text/URI/Lens.hs b/Text/URI/Lens.hs new file mode 100644 --- /dev/null +++ b/Text/URI/Lens.hs @@ -0,0 +1,162 @@ +-- | +-- Module : Text.URI.Lens +-- Copyright : © 2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Lenses for working with the 'URI' data type and its internals. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module Text.URI.Lens + ( uriScheme + , uriAuthority + , uriPath + , uriQuery + , uriFragment + , authUserInfo + , authHost + , authPort + , uiUsername + , uiPassword + , _QueryFlag + , _QueryParam + , queryFlag + , queryParam + , unRText ) +where + +import Data.Foldable (find) +import Data.Functor.Contravariant +import Data.Maybe (isJust) +import Data.Profunctor +import Data.Text (Text) +import Text.URI.Types (URI, Authority, UserInfo, QueryParam (..), RText, RTextLabel (..)) +import qualified Text.URI.Types as URI + +-- | 'URI' scheme lens. + +uriScheme :: Lens' URI (Maybe (RText 'Scheme)) +uriScheme f s = (\x -> s { URI.uriScheme = x }) <$> f (URI.uriScheme s) + +-- | 'URI' authority lens. + +uriAuthority :: Lens' URI (Maybe 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 = x }) <$> f (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 s = go s + where + go [] = pure s + go (x:xs) = + case x of + QueryParam k' v -> if k == k' then f v *> go xs else go xs + _ -> go xs + +-- | 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) diff --git a/Text/URI/Parser.hs b/Text/URI/Parser.hs new file mode 100644 --- /dev/null +++ b/Text/URI/Parser.hs @@ -0,0 +1,203 @@ +-- | +-- Module : Text.URI.Parser +-- Copyright : © 2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- URI parsers, an internal module. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Text.URI.Parser + ( mkURI + , parser + , ParseException (..) ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Catch (Exception (..), MonadThrow (..)) +import Data.Char +import Data.Data (Data) +import Data.Maybe (isNothing, catMaybes) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Void +import GHC.Generics +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.URI.Types +import qualified Data.ByteString.Char8 as B8 +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E +import qualified Data.Text.Encoding as TE +import qualified Text.Megaparsec.Char.Lexer as L + +-- | Construct a 'URI' from 'Text'. In case of 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 err -> throwM (ParseException input err) + Right x -> return x + +-- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be +-- parsed as a 'URI'. + +data ParseException = ParseException Text (ParseError Char Void) + -- ^ Arguments are: original input and parse error + deriving (Show, Eq, Data, Typeable, Generic) + +instance Exception ParseException where + displayException (ParseException s e) = parseErrorPretty' s e + +-- | This parser can be used to parse 'URI' from strict 'Text'. + +parser :: MonadParsec e Text m => m URI +parser = do + uriScheme <- optional (try pScheme) + uriAuthority <- optional pAuthority + uriPath <- pPath (isNothing uriAuthority) + uriQuery <- option [] pQuery + uriFragment <- optional pFragment + return URI {..} +{-# INLINEABLE parser #-} + +pScheme :: MonadParsec e Text m => m (RText 'Scheme) +pScheme = do + x <- asciiAlphaChar + xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') + void (char ':') + liftR mkScheme (x:xs) +{-# INLINE pScheme #-} + +pAuthority :: MonadParsec e Text m => m Authority +pAuthority = do + void (string "//") + authUserInfo <- optional pUserInfo + authHost <- pHost True >>= liftR mkHost + authPort <- optional (char ':' *> L.decimal) + return Authority {..} +{-# INLINE pAuthority #-} + +pUserInfo :: MonadParsec e Text m => m UserInfo +pUserInfo = try $ do + uiUsername <- label "username" $ + many (unreservedChar <|> percentEncChar <|> subDelimChar) + >>= liftR mkUsername + uiPassword <- optional $ do + void (char ':') + many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':') + >>= liftR mkPassword + void (char '@') + return UserInfo {..} +{-# INLINE pUserInfo #-} + +pPath :: MonadParsec e Text m => Bool -> m [RText 'PathPiece] +pPath hadNoAuth = do + doubleSlash <- lookAhead (True <$ string "//" <|> pure False) + when (doubleSlash && hadNoAuth) $ + (unexpected . Tokens . NE.fromList) "//" + path <- flip sepBy (char '/') . label "path piece" $ + many pchar + mapM (liftR mkPathPiece) (filter (not . null) path) +{-# INLINE pPath #-} + +pQuery :: MonadParsec e Text m => m [QueryParam] +pQuery = do + void (char '?') + fmap catMaybes . flip sepBy (char '&') . label "query parameter" $ do + let p = many (pchar' <|> char '/' <|> char '?') + k' <- p + mv <- optional (char '=' *> p) + k <- liftR mkQueryKey k' + if null k' + then return Nothing + else Just <$> case mv of + Nothing -> return (QueryFlag k) + Just v -> QueryParam k <$> liftR mkQueryValue v +{-# INLINE pQuery #-} + +pFragment :: MonadParsec e Text m => m (RText 'Fragment) +pFragment = do + void (char '#') + xs <- many . label "fragment character" $ + pchar <|> char '/' <|> char '?' + liftR mkFragment xs +{-# INLINE pFragment #-} + +---------------------------------------------------------------------------- +-- Helpers + +liftR :: MonadParsec e s m + => (forall n. MonadThrow n => Text -> n r) + -> String + -> m r +liftR f = maybe empty return . f . TE.decodeUtf8 . B8.pack +{-# INLINE liftR #-} + +asciiAlphaChar :: MonadParsec e Text m => m Char +asciiAlphaChar = satisfy isAsciiAlpha "ASCII alpha character" +{-# INLINE asciiAlphaChar #-} + +asciiAlphaNumChar :: MonadParsec e Text m => m Char +asciiAlphaNumChar = satisfy isAsciiAlphaNum "ASCII alpha-numeric character" +{-# INLINE asciiAlphaNumChar #-} + +unreservedChar :: MonadParsec e Text m => m Char +unreservedChar = label "unreserved character" . satisfy $ \x -> + isAsciiAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' +{-# INLINE unreservedChar #-} + +percentEncChar :: MonadParsec e Text m => m Char +percentEncChar = do + void (char '%') + h <- digitToInt <$> hexDigitChar + l <- digitToInt <$> hexDigitChar + return . chr $ h * 16 + l +{-# INLINE percentEncChar #-} + +subDelimChar :: MonadParsec e Text m => m Char +subDelimChar = oneOf s "sub-delimiter" + where + s = E.fromList "!$&'()*+,;=" +{-# INLINE subDelimChar #-} + +pchar :: MonadParsec e Text m => m Char +pchar = choice + [ unreservedChar + , percentEncChar + , subDelimChar + , char ':' + , char '@' ] +{-# INLINE pchar #-} + +pchar' :: MonadParsec e Text m => m Char +pchar' = choice + [ unreservedChar + , percentEncChar + , 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 diff --git a/Text/URI/QQ.hs b/Text/URI/QQ.hs new file mode 100644 --- /dev/null +++ b/Text/URI/QQ.hs @@ -0,0 +1,110 @@ +-- | +-- Module : Text.URI.QQ +-- Copyright : © 2017 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Text.URI.QQ + ( uri + , scheme + , host + , username + , password + , pathPiece + , queryKey + , queryValue + , fragment ) +where + +import Control.Exception (SomeException, Exception (..)) +import Data.Data (Data) +import Data.Text (Text) +import Data.Typeable (cast) +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax (lift) +import Text.URI.Parser +import Text.URI.Types +import qualified Data.Text as T + +#if MIN_VERSION_template_haskell(2,11,0) +import Language.Haskell.TH.Syntax (dataToExpQ) +#else +dataToExpQ :: Data a => (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp +dataToExpQ _ _ = fail "The feature requires at least GHC 8 to work" +#endif + +-- | 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'. + +liftToQQ :: Data a => (Text -> Either SomeException a) -> QuasiQuoter +liftToQQ f = QuasiQuoter + { quoteExp = \str -> + case f (T.pack str) of + Left err -> fail (displayException err) + Right x -> dataToExpQ (fmap liftText . cast) x + , quotePat = error "This usage is not supported" + , quoteType = error "This usage is not supported" + , quoteDec = error "This usage is not supported" } + +-- | Lift strict 'T.Text' to @'Q' 'Exp'@. + +liftText :: T.Text -> Q Exp +liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) diff --git a/Text/URI/Render.hs b/Text/URI/Render.hs new file mode 100644 --- /dev/null +++ b/Text/URI/Render.hs @@ -0,0 +1,171 @@ +-- | +-- Module : Text.URI.Render +-- Copyright : © 2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- URI renders, an internal module. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Text.URI.Render + ( render + , render' + , renderBs + , renderBs' ) +where + +import Data.ByteString (ByteString) +import Data.Char (chr, intToDigit) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Word (Word8) +import Text.URI.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Builder as BLB +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 + +---------------------------------------------------------------------------- +-- 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' = genericRender TLB.decimal $ \e -> + TLB.fromText . percentEncode e . unRText + +-- | Render a given 'URI.Normalized' value as a strict 'ByteString'. + +renderBs :: URI -> ByteString +renderBs = BL.toStrict . BLB.toLazyByteString . renderBs' + +-- | Render a given 'URI' value as a 'BLB.Builder'. + +renderBs' :: URI -> BLB.Builder +renderBs' = genericRender BLB.wordDec $ \e -> + BLB.byteString . TE.encodeUtf8 . percentEncode e . unRText + +---------------------------------------------------------------------------- +-- Generic render + +data Escaping = N | P | Q deriving (Eq) + +type Render a b = (forall l. Escaping -> RText l -> b) -> a -> b +type R b = (Monoid b, IsString b) + +genericRender :: R b => (Word -> b) -> Render URI b +genericRender d r URI {..} = mconcat + [ rJust (rScheme r) uriScheme + , rJust (rAuthority d r) uriAuthority + , rPath r uriPath + , rQuery r uriQuery + , rJust (rFragment r) uriFragment ] +{-# INLINE genericRender #-} + +rJust :: Monoid m => (a -> m) -> Maybe a -> m +rJust = maybe mempty + +rScheme :: R b => Render (RText 'Scheme) b +rScheme r = (<> ":") . r Q +{-# INLINE rScheme #-} + +rAuthority :: R b => (Word -> b) -> Render Authority b +rAuthority d r Authority {..} = mconcat + [ "//" + , rJust (rUserInfo r) authUserInfo + , if T.head (unRText authHost) == '[' + then r N authHost + else r Q authHost + , rJust ((":" <>) . d) authPort ] +{-# INLINE rAuthority #-} + +rUserInfo :: R b => Render UserInfo b +rUserInfo r UserInfo {..} = mconcat + [ r Q uiUsername + , rJust ((":" <>) . r Q) uiPassword + , "@" ] +{-# INLINE rUserInfo #-} + +rPath :: R b => Render [RText 'PathPiece] b +rPath r ps = "/" <> mconcat (intersperse "/" (r P <$> ps)) +{-# INLINE rPath #-} + +rQuery :: R b => Render [QueryParam] b +rQuery r = \case + [] -> mempty + qs -> "?" <> mconcat (intersperse "&" (rQueryParam r <$> qs)) +{-# INLINE rQuery #-} + +rQueryParam :: R b => Render QueryParam b +rQueryParam r = \case + QueryFlag flag -> r P flag + QueryParam k v -> r P k <> "=" <> r P v +{-# INLINE rQueryParam #-} + +rFragment :: R b => Render (RText 'Fragment) b +rFragment r = ("#" <>) . r P +{-# INLINE rFragment #-} + +---------------------------------------------------------------------------- +-- Percent-encoding + +-- | Percent-encode a 'Text' value. + +percentEncode + :: Escaping -- ^ Whether to leave @':'@ and @'@'@ unescaped + -> Text -- ^ Input text to encode + -> Text -- ^ Percent-encoded text +percentEncode N txt = txt +percentEncode e txt = T.unfoldrN n f (bs, []) + where + f (bs', []) = + case B.uncons bs' of + Nothing -> Nothing + Just (w, bs'') -> Just $ + if isUnreserved (e == P) w + then (chr (fromIntegral w), (bs'', [])) + else let c:|cs = encodeByte w + in (c, (bs'', cs)) + f (bs', x:xs) = Just (x, (bs', xs)) + bs = TE.encodeUtf8 txt + n = B.foldl' (\n' w -> g w + n') 0 bs + g x = if isUnreserved (e == P) x then 1 else 3 + encodeByte x = '%' :| [intToDigit h, intToDigit l] + where + (h, l) = fromIntegral x `quotRem` 16 + +-- | The predicate selects unreserved bytes. + +isUnreserved :: Bool -> Word8 -> Bool +isUnreserved t x + | x >= 65 && x <= 90 = True -- 'A'..'Z' + | x >= 97 && x <= 122 = True -- 'a'..'z' + | x >= 48 && x <= 57 = True -- '0'..'9' + | x == 45 = True -- '-' + | x == 95 = True -- '_' + | x == 46 = True -- '.' + | x == 126 = True -- '~' + | t && x == 58 = True -- ':' + | t && x == 64 = True -- '@' + | otherwise = False diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs new file mode 100644 --- /dev/null +++ b/Text/URI/Types.hs @@ -0,0 +1,528 @@ +-- | +-- Module : Text.URI.Types +-- Copyright : © 2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- 'URI' types, an internal module. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.URI.Types + ( -- * Data types + URI (..) + , makeAbsolute + , Authority (..) + , UserInfo (..) + , QueryParam (..) + -- * Refined text + , RText + , RTextLabel (..) + , mkScheme + , mkHost + , mkUsername + , mkPassword + , mkPathPiece + , mkQueryKey + , mkQueryValue + , mkFragment + , unRText + , RTextException (..) + -- * Utils + , pHost ) +where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.Catch (Exception (..), MonadThrow (..)) +import Data.Char +import Data.Data (Data) +import Data.List (intercalate) +import Data.Maybe (fromMaybe, isJust, fromJust, maybeToList) +import Data.Proxy +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Void +import Data.Word (Word8, Word16) +import GHC.Generics +import Numeric (showInt, showHex) +import Test.QuickCheck hiding (label) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E +import qualified Data.Text as T +import qualified Text.Megaparsec.Char.Lexer as L + +---------------------------------------------------------------------------- +-- 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 + { uriScheme :: Maybe (RText 'Scheme) + -- ^ URI scheme, if 'Nothing', then the URI reference is relative + , uriAuthority :: Maybe Authority + -- ^ 'Authority' component + , uriPath :: [RText 'PathPiece] + -- ^ Path + , uriQuery :: [QueryParam] + -- ^ Query parameters + , uriFragment :: Maybe (RText 'Fragment) + -- ^ Fragment, without @#@ + } deriving (Show, Eq, Ord, Data, Typeable, Generic) + +instance Arbitrary URI where + arbitrary = URI + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance NFData URI + +-- | 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) + , .. } + +-- | Authority component of 'URI'. + +data Authority = Authority + { authUserInfo :: Maybe UserInfo + -- ^ User information + , authHost :: RText 'Host + -- ^ Host + , authPort :: Maybe Word + -- ^ Port number + } deriving (Show, Eq, Ord, Data, Typeable, Generic) + +instance Arbitrary Authority where + arbitrary = Authority + <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance NFData Authority + +-- | User info as a combination of username and password. + +data UserInfo = UserInfo + { uiUsername :: RText 'Username + -- ^ Username + , uiPassword :: Maybe (RText 'Password) + -- ^ Password, 'Nothing' means that there was no @:@ character in the + -- user info string + } deriving (Show, Eq, Ord, Data, Typeable, Generic) + +instance Arbitrary UserInfo where + arbitrary = UserInfo + <$> arbitrary + <*> arbitrary + +instance NFData UserInfo + +-- | 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 + = QueryFlag (RText 'QueryKey) + -- ^ Flag parameter + | QueryParam (RText 'QueryKey) (RText 'QueryValue) + -- ^ Key–value pair + deriving (Show, Eq, Ord, Data, Typeable, Generic) + +instance Arbitrary QueryParam where + arbitrary = oneof + [ QueryFlag <$> arbitrary + , QueryParam <$> arbitrary <*> arbitrary ] + +instance NFData QueryParam + +---------------------------------------------------------------------------- +-- Refined text + +-- | Refined text labelled at the type level. + +newtype RText (l :: RTextLabel) = RText Text + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show (RText l) where + show (RText txt) = show txt + +instance NFData (RText l) where + +-- | Refined text labels. + +data RTextLabel + = Scheme -- ^ See 'mkScheme' + | Host -- ^ See 'mkHost' + | Username -- ^ See 'mkUsername' + | Password -- ^ See 'mkPassword' + | PathPiece -- ^ See 'mkPathPiece' + | QueryKey -- ^ See 'mkQueryKey' + | QueryValue -- ^ See 'mkQueryValue' + | Fragment -- ^ See 'mkFragment' + 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 = RTextException RTextLabel Text + -- ^ 'RTextLabel' identifying what sort of refined text value could not be + -- constructed and the input that was supplied, as a 'Text' value + 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 + +-- | Parser for unreserved characters as per RFC3986. + +unreserved :: MonadParsec e Text m => m Char +unreserved = label "unreserved character" . satisfy $ \x -> + isAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~' + +-- | Match a sub-delimiter. + +subDelim :: MonadParsec e Text m => m Char +subDelim = oneOf s "sub-delimiter" + where + s = E.fromList "!$&'()*+,;=" + +-- | Parser that can parse host names. + +pHost :: MonadParsec e Text m + => Bool -- ^ Demand percent-encoding in reg names + -> m String +pHost pe = choice + [ try (asConsumed ipLiteral) + , try (asConsumed ipv4Address) + , 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 + octet = do + pos <- getNextTokenPosition + (toks, x) <- match L.decimal + when (x >= (256 :: Integer)) $ do + mapM_ setPosition pos + failure + (fmap Tokens . NE.nonEmpty . T.unpack $ toks) + (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255") + ipv4Address = + count 3 (octet <* char '.') *> octet + ipv6Address = do + pos <- getNextTokenPosition + (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 + mapM_ setPosition 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 (unreserved <|> subDelim <|> char ':') + regName = fmap (intercalate ".") . flip sepBy1 (char '.') $ do + let ch = + if pe + then percentEncChar <|> asciiAlphaNumChar + else alphaNumChar + x <- ch + let r = ch <|> try + (char '-' <* (lookAhead . try) (ch <|> char '-')) + xs <- many r + return (x:xs) + +asciiAlphaNumChar :: MonadParsec e Text m => m Char +asciiAlphaNumChar = satisfy f "ASCII alpha-numeric character" + where + f x = isAscii x && isAlphaNum x + +percentEncChar :: MonadParsec e Text m => m Char +percentEncChar = do + void (char '%') + h <- digitToInt <$> hexDigitChar + l <- digitToInt <$> hexDigitChar + return . chr $ h * 16 + l + +---------------------------------------------------------------------------- +-- 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) ] + 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` isAlphaNum + x <- g + xs <- listOf $ + frequency [(3, g), (1, return '-')] + x' <- g + return ([x] ++ xs ++ [x']) + regName = intercalate "." <$> resize 5 (listOf1 domainLabel) + +-- | 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 diff --git a/bench/memory/Main.hs b/bench/memory/Main.hs new file mode 100644 --- /dev/null +++ b/bench/memory/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Void +import Text.Megaparsec +import Text.URI (URI) +import Weigh +import qualified Data.Text as T +import qualified Text.URI as URI + +main :: IO () +main = mainWith $ do + setColumns [Case, Allocated, GCs, Max] + bparser turiText + brender turi + brenderBs turi + +---------------------------------------------------------------------------- +-- Helpers + +-- | Test 'URI' as 'Text'. + +turiText :: Text +turiText = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + +-- | Test 'URI' in parsed form. + +turi :: URI +turi = fromJust (URI.mkURI turiText) + +-- | Benchmark memory usage of the 'URI' parser with given input. + +bparser :: Text -> Weigh () +bparser txt = func name (parse p "") txt + where + name = "parser: " ++ T.unpack txt + p = URI.parser <* eof :: Parsec Void Text URI + +-- | Benchmark memory usage of the 'URI' render with given input. + +brender :: URI -> Weigh () +brender uri = func name URI.render uri + where + name = "text render: " ++ T.unpack (URI.render uri) + +-- | The same as 'brender' but for the 'ByteString' render. + +brenderBs :: URI -> Weigh () +brenderBs uri = func name URI.renderBs uri + where + name = "bs render: " ++ T.unpack (URI.render uri) diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs new file mode 100644 --- /dev/null +++ b/bench/speed/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Criterion.Main +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Void +import Text.Megaparsec +import Text.URI (URI) +import qualified Data.Text as T +import qualified Text.URI as URI + +main :: IO () +main = defaultMain + [ bparser turiText + , brender turi + , brenderBs turi ] + +---------------------------------------------------------------------------- +-- Helpers + +-- | Test 'URI' as 'Text'. + +turiText :: Text +turiText = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + +-- | Test 'URI' in parsed form. + +turi :: URI +turi = fromJust (URI.mkURI turiText) + +-- | Benchmark speed of the 'URI' parser with given input. + +bparser :: Text -> Benchmark +bparser txt = env (return txt) (bench name . nf p) + where + name = "parser: " ++ T.unpack txt + p = parse (URI.parser <* eof :: Parsec Void Text URI) "" + +-- | Benchmark speed of the 'URI' render with given input. + +brender :: URI -> Benchmark +brender uri = env (return uri) (bench name . nf URI.render) + where + name = "text render: " ++ T.unpack (URI.render uri) + +-- | The same as 'brender' but for the 'ByteString' render. + +brenderBs :: URI -> Benchmark +brenderBs uri = env (return uri) (bench name . nf URI.renderBs) + where + name = "bs render: " ++ T.unpack (URI.render uri) diff --git a/modern-uri.cabal b/modern-uri.cabal new file mode 100644 --- /dev/null +++ b/modern-uri.cabal @@ -0,0 +1,101 @@ +name: modern-uri +version: 0.0.1.0 +cabal-version: >= 1.18 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 +license: BSD3 +license-file: LICENSE.md +author: Mark Karpov +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/modern-uri +bug-reports: https://github.com/mrkkrp/modern-uri/issues +category: Text +synopsis: Modern library for working with URIs +build-type: Simple +description: Modern library for working with URIs. +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. + manual: True + default: False + +library + build-depends: QuickCheck >= 2.4 && < 3.0 + , base >= 4.7 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , containers >= 0.5 && < 0.6 + , contravariant >= 1.3 && < 2.0 + , deepseq >= 1.3 && < 1.5 + , exceptions >= 0.6 && < 0.9 + , megaparsec >= 6.0 && < 7.0 + , profunctors >=5.2.1 && < 6.0 + , template-haskell >= 2.10 && < 2.13 + , text >= 0.2 && < 1.3 + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* + exposed-modules: Text.URI + , Text.URI.Lens + , Text.URI.QQ + other-modules: Text.URI.Parser + , Text.URI.Render + , Text.URI.Types + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Spec.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + build-depends: QuickCheck >= 2.4 && < 3.0 + , base >= 4.7 && < 5.0 + , hspec >= 2.0 && < 3.0 + , hspec-megaparsec >= 1.0 && < 2.0 + , megaparsec >= 6.0 && < 7.0 + , modern-uri + , text >= 0.2 && < 1.3 + other-modules: Text.URISpec + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +benchmark bench-speed + main-is: Main.hs + hs-source-dirs: bench/speed + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0 + , criterion >= 0.6.2.1 && < 1.3 + , megaparsec >= 6.0 && < 7.0 + , modern-uri + , text >= 0.2 && < 1.3 + if flag(dev) + ghc-options: -O2 -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +benchmark bench-memory + main-is: Main.hs + hs-source-dirs: bench/memory + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , deepseq >= 1.3 && < 1.5 + , megaparsec >= 6.0 && < 7.0 + , modern-uri + , text >= 0.2 && < 1.3 + , weigh >= 0.0.4 + if flag(dev) + ghc-options: -O2 -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/URISpec.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.URISpec (spec) where + +import Data.Maybe (isNothing, isJust) +import Data.Text (Text) +import Data.Void +import Test.Hspec +import Test.Hspec.Megaparsec +import Test.QuickCheck +import Text.Megaparsec +import Text.URI (URI (..), RTextException (..), RTextLabel (..)) +import qualified Data.Text as T +import qualified Text.URI 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 "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + `shouldReturn` uri + it "rejects invalid URIs" $ do + let e = err posI . mconcat $ + [ utok 'ч' + , etok '#' + , etok '/' + , etoks "//" + , etok '?' + , elabel "ASCII alpha character" + , elabel "path piece" + , eeof ] + URI.mkURI "что-то" `shouldThrow` (== URI.ParseException "что-то" e) + 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 "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 "юникод.рф" `shouldRText` "юникод.рф" + 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 "parse" $ do + it "rejects Unicode in scheme" $ + parse urip "" "что:something" `shouldFailWith` err posI (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 (posN 8 s) (mconcat + [ utok 'ю' + , etok '%' + , etok '[' + , elabel "ASCII alpha-numeric character" + , elabel "integer" + , elabel "username" ] ) + it "rejects Unicode in path" $ do + let s = "https://github.com/марк" + parse urip "" s `shouldFailWith` err (posN 19 s) (mconcat + [ utok 'м' + , etok '#' + , etok '/' + , etok '?' + , elabel "path piece" + , eeof ] ) + describe "render" $ + it "sort of works" $ + fmap URI.render mkTestURI `shouldReturn` + "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + describe "renderBs" $ + it "sort of works" $ + fmap URI.renderBs mkTestURI `shouldReturn` + "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + +---------------------------------------------------------------------------- +-- 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 = Just URI.Authority + { URI.authUserInfo = Just URI.UserInfo + { URI.uiUsername = username + , URI.uiPassword = Just password } + , URI.authHost = host + , URI.authPort = Just 443 } + , uriPath = path + , uriQuery = [URI.QueryParam k v] + , uriFragment = Just 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 + :: IO (URI.RText l) -- ^ Action that produces refined text + -> Text -- ^ Inner text to compare with + -> 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' + :: Text -- ^ Parser input + -> URI -- ^ 'URI' to compare with + -> Expectation +shouldParse' s a = + case runParser urip "" s of + Left e -> expectationFailure $ + "the parser is expected to succeed, but it failed with:\n" ++ + parseErrorPretty' s e + Right a' -> a' `shouldBe` a