modern-uri (empty) → 0.0.1.0

raw patch · 15 files changed

+1797/−0 lines, 15 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, contravariant, criterion, deepseq, exceptions, hspec, hspec-megaparsec, megaparsec, modern-uri, profunctors, semigroups, template-haskell, text, weigh

Files

CHANGELOG.md +3/−0
LICENSE.md +28/−0
README.md +81/−0
Setup.hs +6/−0
Text/URI.hs +72/−0
Text/URI/Lens.hs +162/−0
Text/URI/Parser.hs +203/−0
Text/URI/QQ.hs +110/−0
Text/URI/Render.hs +171/−0
Text/URI/Types.hs +528/−0
bench/memory/Main.hs +54/−0
bench/speed/Main.hs +53/−0
modern-uri.cabal +101/−0
tests/Spec.hs +1/−0
tests/Text/URISpec.hs +224/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+## Modern URI 0.0.1.0++* Initial release.

+ LICENSE.md view

@@ -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.

+ README.md view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

+ Text/URI.hs view

@@ -0,0 +1,72 @@+-- |+-- Module      :  Text.URI+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- This is modern library for working with URIs as per RFC 3986:+--+-- <https://tools.ietf.org/html/rfc3986>+--+-- 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.

+ Text/URI/Lens.hs view

@@ -0,0 +1,162 @@+-- |+-- Module      :  Text.URI.Lens+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- 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)

+ Text/URI/Parser.hs view

@@ -0,0 +1,203 @@+-- |+-- Module      :  Text.URI.Parser+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- 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

+ Text/URI/QQ.hs view

@@ -0,0 +1,110 @@+-- |+-- Module      :  Text.URI.QQ+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- 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)

+ Text/URI/Render.hs view

@@ -0,0 +1,171 @@+-- |+-- Module      :  Text.URI.Render+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- 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

+ Text/URI/Types.hs view

@@ -0,0 +1,528 @@+-- |+-- Module      :  Text.URI.Types+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- 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: <https://tools.ietf.org/html/rfc3986#section-3.1>++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: <https://tools.ietf.org/html/rfc3986#section-3.2.2>++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: <https://tools.ietf.org/html/rfc3986#section-3.2.1>++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: <https://tools.ietf.org/html/rfc3986#section-3.2.1>++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: <https://tools.ietf.org/html/rfc3986#section-3.3>++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: <https://tools.ietf.org/html/rfc3986#section-3.4>++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: <https://tools.ietf.org/html/rfc3986#section-3.4>++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: <https://tools.ietf.org/html/rfc3986#section-3.5>++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

+ bench/memory/Main.hs view

@@ -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)

+ bench/speed/Main.hs view

@@ -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)

+ modern-uri.cabal view

@@ -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 <markkarpov92@gmail.com>+maintainer:           Mark Karpov <markkarpov92@gmail.com>+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

+ tests/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

+ tests/Text/URISpec.hs view

@@ -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