packages feed

modern-uri 0.0.1.0 → 0.0.2.0

raw patch · 14 files changed

+728/−339 lines, 14 files

Files

CHANGELOG.md view
@@ -1,3 +1,10 @@+## Modern URI 0.0.2.0++* Added the `renderStr` and `renderStr'` functions for efficient rendering+  to `String` and `ShowS`.++* Added the `parserBs` that can consume strict `ByteString` streams.+ ## Modern URI 0.0.1.0  * Initial release.
README.md view
@@ -13,19 +13,20 @@  ## Motivation -There are already at least two libraries for working with URIs:-[`uri`](https://hackage.haskell.org/package/uri) and+There are already at least three libraries for working with URIs:+[`uri`](https://hackage.haskell.org/package/uri),+[`network-uri`](https://hackage.haskell.org/package/network-uri), and [`uri-bytestring`](https://hackage.haskell.org/package/uri-bytestring). Why write one more? -Let's see first about the `uri` package:+Let's see first about the `uri` and `network-uri` packages (they are quite+similar): -* It uses `String` instead of `Text` or `ByteString`, it is thus-  inefficient.+* They use `String` instead of `Text` or `ByteString`, this is 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.+* The packages use Parsec under the hood, however they do not allow us to+  use its URI parser in a bigger Parsec parser.  Now what about `uri-bytestring`? @@ -51,21 +52,27 @@   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.+* Textual components in the `URI` data type represented as `Text` rather+  than `ByteString`, because they are percent-decoded and so they can+  contain characters outside of ASCII range (i.e. Unicode). This allows for+  easier manipulation of `URI`s, while encoding and decoding headaches are+  handled by the parsers and renders for you. * Absolute and relative URIs differ only by the scheme component: if it's   `Nothing`, then 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.+  a bigger Megaparsec parser that consumes strict `Text` (see `parser`) or+  strict `ByteString` (see `parserBs`).+* The parser performs some normalization, for example it collapses+  consecutive slashes. Some smart constructors such as `mkScheme` and+  `mkHost` also perform normalization. So in a sense URIs are also+  “normalized by construction” to some extent. * Fast rendering to strict `Text` and `ByteString` as well as to their-  respective `Builder` types.+  respective `Builder` types and to `String`/`ShowS`. * Extensive set of lensy helpers for easier manipulation of the nested data   types (see `Text.URI.Lens`). * Quasi-quoters for compile-time construction of the `URI` data type and   refined text types (see `Text.URI.QQ`).--TODO:--* Provide parser that can parse URIs from `ByteString`s.  ## Contribution
Text/URI.hs view
@@ -45,14 +45,18 @@   , RTextException (..)     -- * Parsing   , parser+  , parserBs     -- * Rendering   , render   , render'   , renderBs-  , renderBs' )+  , renderBs'+  , renderStr+  , renderStr' ) where -import Text.URI.Parser+import Text.URI.Parser.ByteString+import Text.URI.Parser.Text import Text.URI.Render import Text.URI.Types
− Text/URI/Parser.hs 
@@ -1,203 +0,0 @@--- |--- 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/Parser/ByteString.hs view
@@ -0,0 +1,248 @@+-- |+-- Module      :  Text.URI.Parser.ByteString+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- URI parsers for string 'ByteString', an internal module.++{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE RecordWildCards    #-}++module Text.URI.Parser.ByteString+  ( parserBs )+where++import Control.Applicative+import Control.Monad+import Control.Monad.Catch (MonadThrow (..))+import Data.ByteString (ByteString)+import Data.Char+import Data.List (intercalate)+import Data.Maybe (isNothing, catMaybes, maybeToList)+import Data.Text (Text)+import Data.Word (Word8)+import Text.Megaparsec+import Text.Megaparsec.Byte+import Text.URI.Types hiding (pHost)+import qualified Data.ByteString            as B+import qualified Data.List.NonEmpty         as NE+import qualified Data.Set                   as E+import qualified Data.Text.Encoding         as TE+import qualified Text.Megaparsec.Byte.Lexer as L++-- | This parser can be used to parse 'URI' from strict 'ByteString'.+-- Remember to use a concrete non-polymorphic parser type for efficiency.+--+-- @since 0.0.2.0++parserBs :: MonadParsec e ByteString m => m URI+parserBs = do+  uriScheme    <- optional (try pScheme)+  uriAuthority <- optional pAuthority+  uriPath      <- pPath (isNothing uriAuthority)+  uriQuery     <- option [] pQuery+  uriFragment  <- optional pFragment+  return URI {..}+{-# INLINEABLE parserBs #-}++pScheme :: MonadParsec e ByteString m => m (RText 'Scheme)+pScheme = do+  x  <- asciiAlphaChar+  xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46)+  void (char 58)+  liftR mkScheme (x:xs)+{-# INLINE pScheme #-}++pAuthority :: MonadParsec e ByteString m => m Authority+pAuthority = do+  void (string "//")+  authUserInfo <- optional pUserInfo+  authHost <- pHost >>= liftR mkHost+  authPort <- optional (char 58 *> L.decimal)+  return Authority {..}+{-# INLINE pAuthority #-}++-- | Parser that can parse host names.++pHost :: MonadParsec e ByteString m => m [Word8]+pHost = choice+  [ try (asConsumed ipLiteral)+  , try (asConsumed ipv4Address)+  , regName ]+  where+    asConsumed :: MonadParsec e ByteString m => m a -> m [Word8]+    asConsumed p = B.unpack . fst <$> match p+    ipLiteral = between (char 91) (char 93) $+      try ipv6Address <|> ipvFuture+    octet = do+      pos       <- getNextTokenPosition+      (toks, x) <- match L.decimal+      when (x >= (256 :: Integer)) $ do+        mapM_ setPosition pos+        failure+          (fmap Tokens . NE.nonEmpty . B.unpack $ toks)+          (E.singleton . Label . NE.fromList $ "decimal number from 0 to 255")+    ipv4Address =+      count 3 (octet <* char 46) *> octet+    ipv6Address = do+      pos        <- getNextTokenPosition+      (toks, xs) <- match $ do+        xs' <- maybeToList <$> optional ([] <$ string "::")+        xs  <- flip sepBy1 (char 58) $ do+          (skip, hasMore) <- lookAhead . hidden $ do+            skip    <- option False (True <$ char 58)+            hasMore <- option False (True <$ hexDigitChar)+            return (skip, hasMore)+          case (skip, hasMore) of+            (True,  True)  -> return []+            (True,  False) -> [] <$ char 58+            (False, _)     -> count' 1 4 hexDigitChar+        return (xs' ++ xs)+      let nskips  = length (filter null xs)+          npieces = length xs+      unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do+        mapM_ setPosition pos+        failure+          (fmap Tokens . NE.nonEmpty . B.unpack $ toks)+          (E.singleton . Label . NE.fromList $ "valid IPv6 address")+    ipvFuture = do+      void (char 118)+      void hexDigitChar+      void (char 46)+      skipSome (unreservedChar <|> subDelimChar <|> char 58)+    regName = fmap (intercalate [46]) . flip sepBy1 (char 46) $ do+      let ch = percentEncChar <|> asciiAlphaNumChar+      x <- ch+      let r = ch <|> try+            (char 45 <* (lookAhead . try) (ch <|> char 45))+      xs <- many r+      return (x:xs)++pUserInfo :: MonadParsec e ByteString m => m UserInfo+pUserInfo = try $ do+  uiUsername <- label "username" $+    many (unreservedChar <|> percentEncChar <|> subDelimChar)+      >>= liftR mkUsername+  uiPassword <- optional $ do+    void (char 58)+    many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58)+      >>= liftR mkPassword+  void (char 64)+  return UserInfo {..}+{-# INLINE pUserInfo #-}++pPath :: MonadParsec e ByteString m => Bool -> m [RText 'PathPiece]+pPath hadNoAuth = do+  doubleSlash <- lookAhead (True <$ string "//" <|> pure False)+  when (doubleSlash && hadNoAuth) $+    (unexpected . Tokens . NE.fromList) [47,47]+  path <- flip sepBy (char 47) . label "path piece" $+    many pchar+  mapM (liftR mkPathPiece) (filter (not . null) path)+{-# INLINE pPath #-}++pQuery :: MonadParsec e ByteString m => m [QueryParam]+pQuery = do+  void (char 63)+  fmap catMaybes . flip sepBy (char 38) . label "query parameter" $ do+    let p = many (pchar' <|> char 47 <|> char 63)+    k' <- p+    mv <- optional (char 61 *> 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 ByteString m => m (RText 'Fragment)+pFragment = do+  void (char 35)+  xs <- many . label "fragment character" $+    pchar <|> char 47 <|> char 63+  liftR mkFragment xs+{-# INLINE pFragment #-}++----------------------------------------------------------------------------+-- Helpers++liftR :: MonadParsec e s m+  => (forall n. MonadThrow n => Text -> n r)+  -> [Word8]+  -> m r+liftR f = maybe empty return . f . TE.decodeUtf8 . B.pack+{-# INLINE liftR #-}++asciiAlphaChar :: MonadParsec e ByteString m => m Word8+asciiAlphaChar = satisfy isAsciiAlpha <?> "ASCII alpha character"+{-# INLINE asciiAlphaChar #-}++asciiAlphaNumChar :: MonadParsec e ByteString m => m Word8+asciiAlphaNumChar = satisfy isAsciiAlphaNum <?> "ASCII alpha-numeric character"+{-# INLINE asciiAlphaNumChar #-}++unreservedChar :: MonadParsec e ByteString m => m Word8+unreservedChar = label "unreserved character" . satisfy $ \x ->+  isAsciiAlphaNum x || x == 45 || x == 46 || x == 95 || x == 126+{-# INLINE unreservedChar #-}++percentEncChar :: MonadParsec e ByteString m => m Word8+percentEncChar = do+  void (char 37)+  h <- restoreDigit <$> hexDigitChar+  l <- restoreDigit <$> hexDigitChar+  return (h * 16 + l)+{-# INLINE percentEncChar #-}++subDelimChar :: MonadParsec e ByteString m => m Word8+subDelimChar = oneOf s <?> "sub-delimiter"+  where+    s = E.fromList (fromIntegral . ord <$> "!$&'()*+,;=")+{-# INLINE subDelimChar #-}++pchar :: MonadParsec e ByteString m => m Word8+pchar = choice+  [ unreservedChar+  , percentEncChar+  , subDelimChar+  , char 58+  , char 64 ]+{-# INLINE pchar #-}++pchar' :: MonadParsec e ByteString m => m Word8+pchar' = choice+  [ unreservedChar+  , percentEncChar+  , oneOf s <?> "sub-delimiter"+  , char 58+  , char 64 ]+  where+    s = E.fromList (fromIntegral . ord <$> "!$'()*+,;")+{-# INLINE pchar' #-}++isAsciiAlpha :: Word8 -> Bool+isAsciiAlpha x+  | 65 <= x && x <= 90  = True+  | 97 <= x && x <= 122 = True+  | otherwise           = False++isAsciiAlphaNum :: Word8 -> Bool+isAsciiAlphaNum x+  | isAsciiAlpha x     = True+  | 48 <= x && x <= 57 = True+  | otherwise          = False++restoreDigit :: Word8 -> Word8+restoreDigit x+  | 48 <= x && x <= 57  = x - 48+  | 65 <= x && x <= 70  = x - 55+  | 97 <= x && x <= 102 = x - 87+  | otherwise           = error "Text.URI.Parser.restoreDigit: bad input"
+ Text/URI/Parser/Text.hs view
@@ -0,0 +1,150 @@+-- |+-- Module      :  Text.URI.Parser.Text+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- URI parser for strict 'Text', an internal module.++{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE RecordWildCards    #-}++module Text.URI.Parser.Text+  ( mkURI+  , parser+  , ParseException (..) )+where++import Control.Applicative+import Control.Monad+import Control.Monad.Catch (Exception (..), MonadThrow (..))+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.Parser.Text.Utils+import Text.URI.Types+import qualified Data.ByteString.Char8      as B8+import qualified Data.List.NonEmpty         as NE+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'. Remember to+-- use a concrete non-polymorphic parser type for efficiency.++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 #-}
+ Text/URI/Parser/Text/Utils.hs view
@@ -0,0 +1,165 @@+-- |+-- Module      :  Text.URI.Parser.Text.Utils+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Random utilities for our 'Text' parsers.++{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.URI.Parser.Text.Utils+  ( pHost+  , asciiAlphaChar+  , asciiAlphaNumChar+  , unreservedChar+  , percentEncChar+  , subDelimChar+  , pchar+  , pchar' )+where++import Control.Monad+import Data.Char+import Data.List (intercalate)+import Data.Maybe (maybeToList)+import Data.Text (Text)+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++-- | 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 (unreservedChar <|> subDelimChar <|> 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)+{-# INLINEABLE pHost #-}++-- | Parse an ASCII alpha character.++asciiAlphaChar :: MonadParsec e Text m => m Char+asciiAlphaChar = satisfy isAsciiAlpha <?> "ASCII alpha character"+{-# INLINE asciiAlphaChar #-}++-- | Parse an ASCII alpha-numeric character.++asciiAlphaNumChar :: MonadParsec e Text m => m Char+asciiAlphaNumChar = satisfy isAsciiAlphaNum <?> "ASCII alpha-numeric character"+{-# INLINE asciiAlphaNumChar #-}++-- | Parse an unreserved character.++unreservedChar :: MonadParsec e Text m => m Char+unreservedChar = label "unreserved character" . satisfy $ \x ->+  isAsciiAlphaNum x || x == '-' || x == '.' || x == '_' || x == '~'+{-# INLINE unreservedChar #-}++-- | Parse a percent-encoded character.++percentEncChar :: MonadParsec e Text m => m Char+percentEncChar = do+  void (char '%')+  h <- digitToInt <$> hexDigitChar+  l <- digitToInt <$> hexDigitChar+  return . chr $ h * 16 + l+{-# INLINE percentEncChar #-}++-- | Parse a sub-delimiter character.++subDelimChar :: MonadParsec e Text m => m Char+subDelimChar = oneOf s <?> "sub-delimiter"+  where+    s = E.fromList "!$&'()*+,;="+{-# INLINE subDelimChar #-}++-- | PCHAR thing from the spec.++pchar :: MonadParsec e Text m => m Char+pchar = choice+  [ unreservedChar+  , percentEncChar+  , subDelimChar+  , char ':'+  , char '@' ]+{-# INLINE pchar #-}++-- | 'pchar' adjusted for query parsing.++pchar' :: MonadParsec e Text m => m Char+pchar' = choice+  [ unreservedChar+  , percentEncChar+  , 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
@@ -33,7 +33,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (lift)-import Text.URI.Parser+import Text.URI.Parser.Text import Text.URI.Types import qualified Data.Text as T
Text/URI/Render.hs view
@@ -20,7 +20,9 @@   ( render   , render'   , renderBs-  , renderBs' )+  , renderBs'+  , renderStr+  , renderStr' ) where  import Data.ByteString (ByteString)@@ -31,10 +33,12 @@ import Data.String (IsString (..)) import Data.Text (Text) import Data.Word (Word8)+import Numeric (showInt) 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.Semigroup               as S import qualified Data.Text                    as T import qualified Data.Text.Encoding           as TE import qualified Data.Text.Lazy               as TL@@ -55,7 +59,7 @@ render' = genericRender TLB.decimal $ \e ->   TLB.fromText . percentEncode e . unRText --- | Render a given 'URI.Normalized' value as a strict 'ByteString'.+-- | Render a given 'URI' value as a strict 'ByteString'.  renderBs :: URI -> ByteString renderBs = BL.toStrict . BLB.toLazyByteString . renderBs'@@ -66,6 +70,21 @@ renderBs' = genericRender BLB.wordDec $ \e ->   BLB.byteString . TE.encodeUtf8 . percentEncode e . unRText +-- | Render a given 'URI' value as a 'String'.+--+-- @since 0.0.2.0++renderStr :: URI -> String+renderStr = ($ []) . renderStr'++-- | Render a given 'URI' value as 'ShowS'.+--+-- @since 0.0.2.0++renderStr' :: URI -> ShowS+renderStr' = toShowS . genericRender (DString . showInt) (\e ->+  fromString . T.unpack . percentEncode e . unRText)+ ---------------------------------------------------------------------------- -- Generic render @@ -126,6 +145,21 @@ rFragment :: R b => Render (RText 'Fragment) b rFragment r = ("#" <>) . r P {-# INLINE rFragment #-}++----------------------------------------------------------------------------+-- DString++newtype DString = DString { toShowS :: ShowS }++instance S.Semigroup DString where+  DString a <> DString b = DString (a . b)++instance Monoid DString where+  mempty = DString id+  mappend = (S.<>)++instance IsString DString where+  fromString str = DString (str ++)  ---------------------------------------------------------------------------- -- Percent-encoding
Text/URI/Types.hs view
@@ -43,14 +43,13 @@   , 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.Maybe (fromMaybe, isJust, fromJust) import Data.Proxy import Data.Text (Text) import Data.Typeable (Typeable)@@ -61,10 +60,8 @@ 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+import Text.URI.Parser.Text.Utils (pHost)+import qualified Data.Text as T  ---------------------------------------------------------------------------- -- Data types@@ -379,92 +376,6 @@  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
bench/memory/Main.hs view
@@ -2,43 +2,56 @@  module Main (main) where +import Data.ByteString (ByteString) import Data.Maybe (fromJust)+import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.URI (URI) import Weigh-import qualified Data.Text as T-import qualified Text.URI  as URI+import qualified Data.ByteString.Char8 as B8+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+  bparser    turiStr+  bparserBs  turiStr+  brender    turi+  brenderBs  turi+  brenderStr turi  ---------------------------------------------------------------------------- -- Helpers --- | Test 'URI' as 'Text'.+-- | Test 'URI' as a polymorphic string. -turiText :: Text-turiText = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"+turiStr :: IsString a => a+turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"  -- | Test 'URI' in parsed form.  turi :: URI-turi = fromJust (URI.mkURI turiText)+turi = fromJust (URI.mkURI turiStr)  -- | 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+    name = "text parser: " ++ T.unpack txt     p    = URI.parser <* eof :: Parsec Void Text URI +-- | Like 'bparser' but accepts a 'ByteString'.++bparserBs :: ByteString -> Weigh ()+bparserBs bs = func name (parse p "") bs+  where+    name = "bs   parser: " ++ B8.unpack bs+    p    = URI.parserBs <* eof :: Parsec Void ByteString URI+ -- | Benchmark memory usage of the 'URI' render with given input.  brender :: URI -> Weigh ()@@ -46,9 +59,16 @@   where     name = "text render: " ++ T.unpack (URI.render uri) --- | The same as 'brender' but for the 'ByteString' render.+-- | The same as 'brender' but for the 'URI.renderBs' render.  brenderBs :: URI -> Weigh () brenderBs uri = func name URI.renderBs uri   where-    name = "bs render: " ++ T.unpack (URI.render uri)+    name = "bs   render: " ++ T.unpack (URI.render uri)++-- | The same as 'brender' but for the 'URI.renderString' render.++brenderStr :: URI -> Weigh ()+brenderStr uri = func name URI.renderStr uri+  where+    name = "str  render: " ++ T.unpack (URI.render uri)
bench/speed/Main.hs view
@@ -3,41 +3,54 @@ module Main (main) where  import Criterion.Main+import Data.ByteString (ByteString) import Data.Maybe (fromJust)+import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.URI (URI)-import qualified Data.Text as T-import qualified Text.URI  as URI+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text             as T+import qualified Text.URI              as URI  main :: IO () main = defaultMain-  [ bparser   turiText-  , brender   turi-  , brenderBs turi ]+  [ bparser    turiStr+  , bparserBs  turiStr+  , brender    turi+  , brenderBs  turi+  , brenderStr turi ]  ---------------------------------------------------------------------------- -- Helpers --- | Test 'URI' as 'Text'.+-- | Test 'URI' as a polymorphic string. -turiText :: Text-turiText = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"+turiStr :: IsString a => a+turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"  -- | Test 'URI' in parsed form.  turi :: URI-turi = fromJust (URI.mkURI turiText)+turi = fromJust (URI.mkURI turiStr)  -- | 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+    name = "text parser: " ++ T.unpack txt     p    = parse (URI.parser <* eof :: Parsec Void Text URI) "" +-- | Like 'bparser' but accepts a 'ByteString'.++bparserBs :: ByteString -> Benchmark+bparserBs bs = env (return bs) (bench name . nf p)+  where+    name = "bs   parser: " ++ B8.unpack bs+    p    = parse (URI.parserBs <* eof :: Parsec Void ByteString URI) ""+ -- | Benchmark speed of the 'URI' render with given input.  brender :: URI -> Benchmark@@ -45,9 +58,16 @@   where     name = "text render: " ++ T.unpack (URI.render uri) --- | The same as 'brender' but for the 'ByteString' render.+-- | The same as 'brender' but for the 'URI.renderBs' render.  brenderBs :: URI -> Benchmark brenderBs uri = env (return uri) (bench name . nf URI.renderBs)   where-    name = "bs render: " ++ T.unpack (URI.render uri)+    name = "bs   render: " ++ T.unpack (URI.render uri)++-- | The same as 'brender' but for the 'URI.renderString' render.++brenderStr :: URI -> Benchmark+brenderStr uri = env (return uri) (bench name . nf URI.renderStr)+  where+    name = "str  render: " ++ T.unpack (URI.render uri)
modern-uri.cabal view
@@ -1,5 +1,5 @@ name:                 modern-uri-version:              0.0.1.0+version:              0.0.2.0 cabal-version:        >= 1.18 tested-with:          GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license:              BSD3@@ -41,7 +41,9 @@   exposed-modules:    Text.URI                     , Text.URI.Lens                     , Text.URI.QQ-  other-modules:      Text.URI.Parser+  other-modules:      Text.URI.Parser.ByteString+                    , Text.URI.Parser.Text+                    , Text.URI.Parser.Text.Utils                     , Text.URI.Render                     , Text.URI.Types   if flag(dev)@@ -56,6 +58,7 @@   type:               exitcode-stdio-1.0   build-depends:      QuickCheck       >= 2.4 && < 3.0                     , base             >= 4.7 && < 5.0+                    , bytestring       >= 0.2 && < 0.11                     , hspec            >= 2.0 && < 3.0                     , hspec-megaparsec >= 1.0 && < 2.0                     , megaparsec       >= 6.0 && < 7.0@@ -73,6 +76,7 @@   hs-source-dirs:     bench/speed   type:               exitcode-stdio-1.0   build-depends:      base             >= 4.7 && < 5.0+                    , bytestring       >= 0.2 && < 0.11                     , criterion        >= 0.6.2.1 && < 1.3                     , megaparsec       >= 6.0 && < 7.0                     , modern-uri
tests/Text/URISpec.hs view
@@ -3,6 +3,7 @@  module Text.URISpec (spec) where +import Data.ByteString (ByteString) import Data.Maybe (isNothing, isJust) import Data.Text (Text) import Data.Void@@ -128,6 +129,10 @@     it "parser and render are consistent" $       property $ \uri ->         shouldParse' (URI.render uri) uri+  describe "parseBs and renderBs" $+    it "parser and render are consistent" $+      property $ \uri ->+        shouldParseBs (URI.renderBs uri) uri   describe "parse" $ do     it "rejects Unicode in scheme" $       parse urip "" "что:something" `shouldFailWith` err posI (mconcat@@ -165,6 +170,10 @@     it "sort of works" $       fmap URI.renderBs mkTestURI `shouldReturn`         "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"+  describe "renderStr" $+    it "sort of works" $+      fmap URI.renderStr mkTestURI `shouldReturn`+        "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment"  ---------------------------------------------------------------------------- -- Helpers@@ -218,6 +227,19 @@   -> 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++-- | Similar to 'shouldParse'' but uses 'URI.parserBs' under the hood.++shouldParseBs+  :: ByteString        -- ^ Parser input+  -> URI               -- ^ 'URI' to compare with+  -> Expectation+shouldParseBs s a =+  case runParser (URI.parserBs <* eof :: Parsec Void ByteString URI) "" s of     Left e -> expectationFailure $       "the parser is expected to succeed, but it failed with:\n" ++       parseErrorPretty' s e