modern-uri 0.3.2.0 → 0.3.3.0
raw patch · 15 files changed
+1155/−1015 lines, 15 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−0
- README.md +40/−28
- Text/URI.hs +96/−88
- Text/URI/Lens.hs +51/−60
- Text/URI/Parser/ByteString.hs +104/−76
- Text/URI/Parser/Text.hs +44/−41
- Text/URI/Parser/Text/Utils.hs +58/−55
- Text/URI/QQ.hs +28/−36
- Text/URI/Render.hs +124/−114
- Text/URI/Types.hs +217/−177
- bench/memory/Main.hs +5/−12
- bench/speed/Main.hs +8/−13
- modern-uri.cabal +120/−101
- tests/Text/QQSpec.hs +10/−9
- tests/Text/URISpec.hs +246/−205
CHANGELOG.md view
@@ -1,3 +1,7 @@+## Modern URI 0.3.3.0++* Added `mkURIBs` for parsing `ByteString` as a `URI`.+ ## Modern URI 0.3.2.0 * Quasi-quoters from `Text.URI.QQ` now can be used in pattern context when
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/modern-uri) [](http://stackage.org/nightly/package/modern-uri) [](http://stackage.org/lts/package/modern-uri)-[](https://travis-ci.org/mrkkrp/modern-uri)+ This is a modern library for working with URIs in Haskell as per RFC 3986: @@ -68,15 +68,19 @@ λ> let uri = URI.URI (Just scheme) (Right (URI.Authority Nothing host Nothing)) Nothing [] Nothing λ> uri URI- { uriScheme = Just "https"- , uriAuthority = Right- (Authority- { authUserInfo = Nothing- , authHost = "markkarpov.com"- , authPort = Nothing })- , uriPath = Nothing- , uriQuery = []- , uriFragment = Nothing }+ { uriScheme = Just "https",+ uriAuthority =+ Right+ ( Authority+ { authUserInfo = Nothing,+ authHost = "markkarpov.com",+ authPort = Nothing+ }+ ),+ uriPath = Nothing,+ uriQuery = [],+ uriFragment = Nothing+ } ``` In this library we use quite a few refined text values. They only can be@@ -93,15 +97,19 @@ λ> uri <- URI.mkURI "https://markkarpov.com" λ> uri URI- { uriScheme = Just "https"- , uriAuthority = Right- (Authority- { authUserInfo = Nothing- , authHost = "markkarpov.com"- , authPort = Nothing })- , uriPath = Nothing- , uriQuery = []- , uriFragment = Nothing }+ { uriScheme = Just "https",+ uriAuthority =+ Right+ ( Authority+ { authUserInfo = Nothing,+ authHost = "markkarpov.com",+ authPort = Nothing+ }+ ),+ uriPath = Nothing,+ uriQuery = [],+ uriFragment = Nothing+ } ``` If the argument of `mkURI` is not a valid URI, then an exception will be@@ -118,15 +126,19 @@ λ> let uri = [QQ.uri|https://markkarpov.com|] λ> uri URI- { uriScheme = Just "https"- , uriAuthority = Right- (Authority- { authUserInfo = Nothing- , authHost = "markkarpov.com"- , authPort = Nothing })- , uriPath = Nothing- , uriQuery = []- , uriFragment = Nothing }+ { uriScheme = Just "https",+ uriAuthority =+ Right+ ( Authority+ { authUserInfo = Nothing,+ authHost = "markkarpov.com",+ authPort = Nothing+ }+ ),+ uriPath = Nothing,+ uriQuery = [],+ uriFragment = Nothing+ } ``` Note how the value returned by the `url` quasi quote is pure, its
Text/URI.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+ -- | -- Module : Text.URI -- Copyright : © 2017–present Mark Karpov@@ -19,60 +24,60 @@ -- 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.--{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}- module Text.URI ( -- * Data types- URI (..)- , mkURI- , emptyURI- , makeAbsolute- , isPathAbsolute- , relativeTo- , Authority (..)- , UserInfo (..)- , QueryParam (..)- , ParseException (..)+ URI (..),+ mkURI,+ mkURIBs,+ emptyURI,+ makeAbsolute,+ isPathAbsolute,+ relativeTo,+ Authority (..),+ UserInfo (..),+ QueryParam (..),+ ParseException (..),+ ParseExceptionBs (..),+ -- * Refined text -- $rtext- , RText- , RTextLabel (..)- , mkScheme- , mkHost- , mkUsername- , mkPassword- , mkPathPiece- , mkQueryKey- , mkQueryValue- , mkFragment- , unRText- , RTextException (..)+ RText,+ RTextLabel (..),+ mkScheme,+ mkHost,+ mkUsername,+ mkPassword,+ mkPathPiece,+ mkQueryKey,+ mkQueryValue,+ mkFragment,+ unRText,+ RTextException (..),+ -- * Parsing -- $parsing- , parser- , parserBs+ parser,+ parserBs,+ -- * Rendering -- $rendering- , render- , render'- , renderBs- , renderBs'- , renderStr- , renderStr' )+ render,+ render',+ renderBs,+ renderBs',+ renderStr,+ renderStr',+ ) where import Data.Either (isLeft) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust, isNothing) import Text.URI.Parser.ByteString import Text.URI.Parser.Text import Text.URI.Render import Text.URI.Types-import qualified Data.List.NonEmpty as NE #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -81,15 +86,15 @@ -- | The empty 'URI'. -- -- @since 0.2.1.0- emptyURI :: URI-emptyURI = URI- { uriScheme = Nothing- , uriAuthority = Left False- , uriPath = Nothing- , uriQuery = []- , uriFragment = Nothing- }+emptyURI =+ URI+ { uriScheme = Nothing,+ uriAuthority = Left False,+ uriPath = Nothing,+ uriQuery = [],+ uriFragment = Nothing+ } -- $rtext --@@ -126,57 +131,60 @@ -- See also: <https://tools.ietf.org/html/rfc3986#section-5.2>. -- -- @since 0.2.0.0--relativeTo- :: URI -- ^ Reference 'URI' to make absolute- -> URI -- ^ Base 'URI'- -> Maybe URI -- ^ The target 'URI'+relativeTo ::+ -- | Reference 'URI' to make absolute+ URI ->+ -- | Base 'URI'+ URI ->+ -- | The target 'URI'+ Maybe URI relativeTo r base = case uriScheme base of Nothing -> Nothing- Just bscheme -> Just $- if isJust (uriScheme r)- then r { uriPath = uriPath r >>= removeDotSegments }- else r- { uriScheme = Just bscheme- , uriAuthority =- case uriAuthority r of- Right auth -> Right auth- Left rabs ->- case uriAuthority base of- Right auth -> Right auth- Left babs -> Left (babs || rabs)- , uriPath = (>>= removeDotSegments) $- if isPathAbsolute r- then uriPath r- else case (uriPath base, uriPath r) of- (Nothing, Nothing) -> Nothing- (Just b', Nothing) -> Just b'- (Nothing, Just r') -> Just r'- (Just (bt, bps), Just (rt, rps)) ->- fmap (rt,) . NE.nonEmpty $- (if bt then NE.toList bps else NE.init bps) <>- NE.toList rps- , uriQuery =- if isLeft (uriAuthority r) &&- isNothing (uriPath r) &&- null (uriQuery r)- then uriQuery base- else uriQuery r- }+ Just bscheme ->+ Just $+ if isJust (uriScheme r)+ then r {uriPath = uriPath r >>= removeDotSegments}+ else+ r+ { uriScheme = Just bscheme,+ uriAuthority = case uriAuthority r of+ Right auth -> Right auth+ Left rabs ->+ case uriAuthority base of+ Right auth -> Right auth+ Left babs -> Left (babs || rabs),+ uriPath =+ (>>= removeDotSegments) $+ if isPathAbsolute r+ then uriPath r+ else case (uriPath base, uriPath r) of+ (Nothing, Nothing) -> Nothing+ (Just b', Nothing) -> Just b'+ (Nothing, Just r') -> Just r'+ (Just (bt, bps), Just (rt, rps)) ->+ fmap (rt,) . NE.nonEmpty $+ (if bt then NE.toList bps else NE.init bps)+ <> NE.toList rps,+ uriQuery =+ if isLeft (uriAuthority r)+ && isNothing (uriPath r)+ && null (uriQuery r)+ then uriQuery base+ else uriQuery r+ } ---------------------------------------------------------------------------- -- Helpers -- | Remove dot segments from a path.--removeDotSegments- :: (Bool, NonEmpty (RText 'PathPiece))- -> Maybe (Bool, NonEmpty (RText 'PathPiece))+removeDotSegments ::+ (Bool, NonEmpty (RText 'PathPiece)) ->+ Maybe (Bool, NonEmpty (RText 'PathPiece)) removeDotSegments (trailSlash, path) = go [] (NE.toList path) trailSlash where- go out [] ts = (fmap (ts,) . NE.nonEmpty . reverse) out- go out (x:xs) ts- | unRText x == "." = go out xs (null xs || ts)+ go out [] ts = (fmap (ts,) . NE.nonEmpty . reverse) out+ go out (x : xs) ts+ | unRText x == "." = go out xs (null xs || ts) | unRText x == ".." = go (drop 1 out) xs (null xs || ts)- | otherwise = go (x:out) xs ts+ | otherwise = go (x : out) xs ts
Text/URI/Lens.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+ -- | -- Module : Text.URI.Lens -- Copyright : © 2017–present Mark Karpov@@ -8,59 +13,58 @@ -- Portability : portable -- -- Lenses for working with the 'URI' data type and its internals.--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}- module Text.URI.Lens- ( uriScheme- , uriAuthority- , uriPath- , isPathAbsolute- , uriTrailingSlash- , uriQuery- , uriFragment- , authUserInfo- , authHost- , authPort- , uiUsername- , uiPassword- , _QueryFlag- , _QueryParam- , queryFlag- , queryParam- , unRText )+ ( uriScheme,+ uriAuthority,+ uriPath,+ isPathAbsolute,+ uriTrailingSlash,+ uriQuery,+ uriFragment,+ authUserInfo,+ authHost,+ authPort,+ uiUsername,+ uiPassword,+ _QueryFlag,+ _QueryParam,+ queryFlag,+ queryParam,+ unRText,+ ) where import Control.Applicative (liftA2) import Data.Foldable (find) import Data.Functor.Contravariant+import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import Data.Profunctor import Data.Text (Text)-import Text.URI.Types (URI, Authority, UserInfo, QueryParam (..), RText, RTextLabel (..))-import qualified Data.List.NonEmpty as NE-import qualified Text.URI.Types as URI+import Text.URI.Types+ ( Authority,+ QueryParam (..),+ RText,+ RTextLabel (..),+ URI,+ UserInfo,+ )+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)+uriScheme f s = (\x -> s {URI.uriScheme = x}) <$> f (URI.uriScheme s) -- | 'URI' authority lens. -- -- __Note__: before version /0.1.0.0/ this lens allowed to focus on @'Maybe' -- 'URI.Authority'@.- uriAuthority :: Lens' URI (Either Bool URI.Authority)-uriAuthority f s = (\x -> s { URI.uriAuthority = x }) <$> f (URI.uriAuthority s)+uriAuthority f s = (\x -> s {URI.uriAuthority = x}) <$> f (URI.uriAuthority s) -- | 'URI' path lens.- uriPath :: Lens' URI [RText 'PathPiece]-uriPath f s = (\x -> s { URI.uriPath = (ts,) <$> NE.nonEmpty x }) <$> f ps+uriPath f s = (\x -> s {URI.uriPath = (ts,) <$> NE.nonEmpty x}) <$> f ps where ts = maybe False fst path ps = maybe [] (NE.toList . snd) path@@ -69,87 +73,74 @@ -- | A getter that can tell if path component of a 'URI' is absolute. -- -- @since 0.1.0.0- isPathAbsolute :: Getter URI Bool isPathAbsolute = to URI.isPathAbsolute -- | A 0-1 traversal allowing to view and manipulate trailing slash. -- -- @since 0.2.0.0- uriTrailingSlash :: Traversal' URI Bool uriTrailingSlash f s =- (\x -> s { URI.uriPath = liftA2 (,) x ps }) <$> traverse f ts+ (\x -> s {URI.uriPath = liftA2 (,) x ps}) <$> traverse f ts where ts = fst <$> path ps = snd <$> path path = URI.uriPath s -- | 'URI' query params lens.- uriQuery :: Lens' URI [URI.QueryParam]-uriQuery f s = (\x -> s { URI.uriQuery = x }) <$> f (URI.uriQuery s)+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)+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)+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)+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)+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)+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)+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+ _ -> 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+ _ -> 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+ g _ = False -- | Manipulate a query parameter by its key. Note that since there may be -- several query parameters with the same key this is a traversal that can -- return\/modify several items at once.- queryParam :: RText 'QueryKey -> Traversal' [URI.QueryParam] (RText 'QueryValue) queryParam k f = traverse g where@@ -160,7 +151,6 @@ g p = pure p -- | A getter that can project 'Text' from refined text values.- unRText :: Getter (RText l) Text unRText = to URI.unRText @@ -169,25 +159,26 @@ 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/ByteString.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+ -- | -- Module : Text.URI.Parser.ByteString -- Copyright : © 2017–present Mark Karpov@@ -8,49 +14,58 @@ -- Portability : portable -- -- URI parser for string 'ByteString', an internal module.--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}- module Text.URI.Parser.ByteString- ( parserBs )+ ( mkURIBs,+ parserBs,+ ) where import Control.Monad import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.State.Strict import Data.ByteString (ByteString)+import qualified Data.ByteString as B import Data.Char import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (isJust, catMaybes, maybeToList)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes, isJust, maybeToList)+import qualified Data.Set as E import Data.Text (Text)+import qualified Data.Text.Encoding as TE import Data.Void 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+import Text.URI.Types hiding (pHost) +-- | Construct a 'URI' from 'ByteString'. The input you pass to 'mkURIBs'+-- must be a valid URI as per RFC 3986, that is, its components should be+-- percent-encoded where necessary. In case of parse failure+-- 'ParseExceptionBs' is thrown.+--+-- This function uses the 'parserBs' parser under the hood, which you can also+-- use directly in a Megaparsec parser.+--+-- @since 0.3.3.0+mkURIBs :: MonadThrow m => ByteString -> m URI+mkURIBs input =+ case runParser (parserBs <* eof :: Parsec Void ByteString URI) "" input of+ Left b -> throwM (ParseExceptionBs b)+ Right x -> return x+ -- | This parser can be used to parse 'URI' from strict 'ByteString'. -- Remember to use a concrete non-polymorphic parser type for efficiency. -- -- @since 0.0.2.0- parserBs :: MonadParsec e ByteString m => m URI parserBs = do- uriScheme <- optional (try pScheme)- mauth <- optional pAuthority+ uriScheme <- optional (try pScheme)+ mauth <- optional pAuthority (absPath, uriPath) <- pPath (isJust mauth)- uriQuery <- option [] pQuery- uriFragment <- optional pFragment+ uriQuery <- option [] pQuery+ uriFragment <- optional pFragment let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parserBs #-}@@ -58,10 +73,10 @@ pScheme :: MonadParsec e ByteString m => m (RText 'Scheme) pScheme = do- x <- asciiAlphaChar+ x <- asciiAlphaChar xs <- many (asciiAlphaNumChar <|> char 43 <|> char 45 <|> char 46) void (char 58)- liftR mkScheme (x:xs)+ liftR mkScheme (x : xs) {-# INLINE pScheme #-} pAuthority :: MonadParsec e ByteString m => m Authority@@ -74,17 +89,19 @@ {-# INLINE pAuthority #-} -- | Parser that can parse host names.- pHost :: MonadParsec e ByteString m => m [Word8]-pHost = choice- [ try (asConsumed ipLiteral)- , try (asConsumed ipv4Address)- , regName ]+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+ ipLiteral =+ between (char 91) (char 93) $+ try ipv6Address <|> ipvFuture octet = do o <- getOffset (toks, x) <- match L.decimal@@ -99,17 +116,17 @@ o <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::")- xs <- flip sepBy1 (char 58) $ do+ xs <- flip sepBy1 (char 58) $ do (skip, hasMore) <- lookAhead . hidden $ do- skip <- option False (True <$ char 58)+ 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+ (True, True) -> return []+ (True, False) -> [] <$ char 58+ (False, _) -> count' 1 4 hexDigitChar return (xs' ++ xs)- let nskips = length (filter null xs)+ let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do setOffset o@@ -127,16 +144,19 @@ case mx of Nothing -> return [] Just x -> do- let r = ch <|> try- (char 45 <* (lookAhead . try) (ch <|> char 45))+ let r =+ ch+ <|> try+ (char 45 <* (lookAhead . try) (ch <|> char 45)) xs <- many r- return (x:xs)+ return (x : xs) pUserInfo :: MonadParsec e ByteString m => m UserInfo pUserInfo = try $ do- uiUsername <- label "username" $- many (unreservedChar <|> percentEncChar <|> subDelimChar)- >>= liftR mkUsername+ uiUsername <-+ label "username" $+ many (unreservedChar <|> percentEncChar <|> subDelimChar)+ >>= liftR mkUsername uiPassword <- optional $ do void (char 58) many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char 58)@@ -145,13 +165,14 @@ return UserInfo {..} {-# INLINE pUserInfo #-} -pPath :: MonadParsec e ByteString m- => Bool- -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))+pPath ::+ MonadParsec e ByteString m =>+ Bool ->+ m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do doubleSlash <- lookAhead (option False (True <$ string "//")) when (doubleSlash && not hasAuth) $- (unexpected . Tokens . NE.fromList) [47,47]+ (unexpected . Tokens . NE.fromList) [47, 47] absPath <- option False (True <$ char 47) (rawPieces, trailingSlash) <- flip runStateT False $ flip sepBy (char 47) . label "path piece" $ do@@ -160,8 +181,8 @@ return x pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces) return- ( absPath- , case NE.nonEmpty pieces of+ ( absPath,+ case NE.nonEmpty pieces of Nothing -> Nothing Just ps -> Just (trailingSlash, ps) )@@ -175,29 +196,32 @@ let p = many (pchar' <|> char 47 <|> char 63) k' <- p mv <- optional (char 61 *> p)- k <- liftR mkQueryKey k'+ 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+ 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+ 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 ::+ 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 #-} @@ -229,41 +253,45 @@ {-# INLINE subDelimChar #-} pchar :: MonadParsec e ByteString m => m Word8-pchar = choice- [ unreservedChar- , percentEncChar- , subDelimChar- , char 58- , char 64 ]+pchar =+ choice+ [ unreservedChar,+ percentEncChar,+ subDelimChar,+ char 58,+ char 64+ ] {-# INLINE pchar #-} pchar' :: MonadParsec e ByteString m => m Word8-pchar' = choice- [ unreservedChar- , percentEncChar- , char 43 >> pure 32- , oneOf s <?> "sub-delimiter"- , char 58- , char 64 ]+pchar' =+ choice+ [ unreservedChar,+ percentEncChar,+ char 43 >> pure 32,+ oneOf s <?> "sub-delimiter",+ char 58,+ char 64+ ] where s = E.fromList (fromIntegral . ord <$> "!$'()*,;") {-# INLINE pchar' #-} isAsciiAlpha :: Word8 -> Bool isAsciiAlpha x- | 65 <= x && x <= 90 = True+ | 65 <= x && x <= 90 = True | 97 <= x && x <= 122 = True- | otherwise = False+ | otherwise = False isAsciiAlphaNum :: Word8 -> Bool isAsciiAlphaNum x- | isAsciiAlpha x = True+ | isAsciiAlpha x = True | 48 <= x && x <= 57 = True- | otherwise = False+ | otherwise = False restoreDigit :: Word8 -> Word8 restoreDigit x- | 48 <= x && x <= 57 = x - 48- | 65 <= x && x <= 70 = x - 55+ | 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"+ | otherwise = error "Text.URI.Parser.restoreDigit: bad input"
Text/URI/Parser/Text.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+ -- | -- Module : Text.URI.Parser.Text -- Copyright : © 2017–present Mark Karpov@@ -8,33 +14,27 @@ -- Portability : portable -- -- URI parser for strict 'Text', an internal module.--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}- module Text.URI.Parser.Text- ( mkURI- , parser )+ ( mkURI,+ parser,+ ) where import Control.Monad import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.State.Strict+import qualified Data.ByteString.Char8 as B8 import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (isJust, catMaybes)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes, isJust) import Data.Text (Text)+import qualified Data.Text.Encoding as TE import Data.Void import Text.Megaparsec import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L import Text.URI.Parser.Text.Utils import Text.URI.Types-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'. The input you pass to 'mkURI' must be a -- valid URI as per RFC 3986, that is, its components should be@@ -43,23 +43,21 @@ -- -- This function uses the 'parser' parser under the hood, which you can also -- use directly in a Megaparsec parser.- mkURI :: MonadThrow m => Text -> m URI mkURI input = case runParser (parser <* eof :: Parsec Void Text URI) "" input of- Left b -> throwM (ParseException b)+ Left b -> throwM (ParseException b) Right x -> return x -- | This parser can be used to parse 'URI' from strict 'Text'. Remember to -- use a concrete non-polymorphic parser type for efficiency.- parser :: MonadParsec e Text m => m URI parser = do- uriScheme <- optional (try pScheme)- mauth <- optional pAuthority+ uriScheme <- optional (try pScheme)+ mauth <- optional pAuthority (absPath, uriPath) <- pPath (isJust mauth)- uriQuery <- option [] pQuery- uriFragment <- optional pFragment+ uriQuery <- option [] pQuery+ uriFragment <- optional pFragment let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parser #-}@@ -67,10 +65,10 @@ pScheme :: MonadParsec e Text m => m (RText 'Scheme) pScheme = do- x <- asciiAlphaChar+ x <- asciiAlphaChar xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.') void (char ':')- liftR mkScheme (x:xs)+ liftR mkScheme (x : xs) {-# INLINE pScheme #-} pAuthority :: MonadParsec e Text m => m Authority@@ -84,9 +82,10 @@ pUserInfo :: MonadParsec e Text m => m UserInfo pUserInfo = try $ do- uiUsername <- label "username" $- many (unreservedChar <|> percentEncChar <|> subDelimChar)- >>= liftR mkUsername+ uiUsername <-+ label "username" $+ many (unreservedChar <|> percentEncChar <|> subDelimChar)+ >>= liftR mkUsername uiPassword <- optional $ do void (char ':') many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':')@@ -95,9 +94,10 @@ return UserInfo {..} {-# INLINE pUserInfo #-} -pPath :: MonadParsec e Text m- => Bool- -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))+pPath ::+ MonadParsec e Text m =>+ Bool ->+ m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece))) pPath hasAuth = do doubleSlash <- lookAhead (option False (True <$ string "//")) when (doubleSlash && not hasAuth) $@@ -110,8 +110,8 @@ return x pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces) return- ( absPath- , case NE.nonEmpty pieces of+ ( absPath,+ case NE.nonEmpty pieces of Nothing -> Nothing Just ps -> Just (trailingSlash, ps) )@@ -125,28 +125,31 @@ let p = many (pchar' <|> char '/' <|> char '?') k' <- p mv <- optional (char '=' *> p)- k <- liftR mkQueryKey k'+ 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+ 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 '?'+ 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 ::+ 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
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | -- Module : Text.URI.Parser.Text.Utils -- Copyright : © 2017–present Mark Karpov@@ -8,47 +11,48 @@ -- 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' )+ ( pHost,+ asciiAlphaChar,+ asciiAlphaNumChar,+ unreservedChar,+ percentEncChar,+ subDelimChar,+ pchar,+ pchar',+ ) where import Control.Monad import Data.Char import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE import Data.Maybe (maybeToList)+import qualified Data.Set as E import Data.Text (Text)+import qualified Data.Text as T import Text.Megaparsec import Text.Megaparsec.Char-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 ]+pHost ::+ MonadParsec e Text m =>+ -- | Demand percent-encoding in reg names+ Bool ->+ 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+ ipLiteral =+ between (char '[') (char ']') $+ try ipv6Address <|> ipvFuture octet = do o <- getOffset (toks, x) <- match L.decimal@@ -60,20 +64,20 @@ ipv4Address = count 3 (octet <* char '.') *> octet ipv6Address = do- pos <- getOffset+ pos <- getOffset (toks, xs) <- match $ do xs' <- maybeToList <$> optional ([] <$ string "::")- xs <- flip sepBy1 (char ':') $ do+ xs <- flip sepBy1 (char ':') $ do (skip, hasMore) <- lookAhead . hidden $ do- skip <- option False (True <$ char ':')+ 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+ (True, True) -> return []+ (True, False) -> [] <$ char ':'+ (False, _) -> count' 1 4 hexDigitChar return (xs' ++ xs)- let nskips = length (filter null xs)+ let nskips = length (filter null xs) npieces = length xs unless (nskips < 2 && (npieces == 8 || (nskips == 1 && npieces < 8))) $ do setOffset pos@@ -94,33 +98,31 @@ case mx of Nothing -> return "" Just x -> do- let r = ch <|> try- (char '-' <* (lookAhead . try) (ch <|> char '-'))+ let r =+ ch+ <|> try+ (char '-' <* (lookAhead . try) (ch <|> char '-')) xs <- many r- return (x:xs)+ 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 '%')@@ -130,7 +132,6 @@ {-# INLINE percentEncChar #-} -- | Parse a sub-delimiter character.- subDelimChar :: MonadParsec e Text m => m Char subDelimChar = oneOf s <?> "sub-delimiter" where@@ -138,26 +139,28 @@ {-# INLINE subDelimChar #-} -- | PCHAR thing from the spec.- pchar :: MonadParsec e Text m => m Char-pchar = choice- [ unreservedChar- , percentEncChar- , subDelimChar- , char ':'- , char '@' ]+pchar =+ choice+ [ unreservedChar,+ percentEncChar,+ subDelimChar,+ char ':',+ char '@'+ ] {-# INLINE pchar #-} -- | 'pchar' adjusted for query parsing.- pchar' :: MonadParsec e Text m => m Char-pchar' = choice- [ unreservedChar- , percentEncChar- , char '+' >> pure ' '- , oneOf s <?> "sub-delimiter"- , char ':'- , char '@' ]+pchar' =+ choice+ [ unreservedChar,+ percentEncChar,+ char '+' >> pure ' ',+ oneOf s <?> "sub-delimiter",+ char ':',+ char '@'+ ] where s = E.fromList "!$'()*,;" {-# INLINE pchar' #-}
Text/URI/QQ.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+ -- | -- Module : Text.URI.QQ -- Copyright : © 2017–present Mark Karpov@@ -13,73 +16,61 @@ -- All of the quasi-quoters in this module can be used in an expression -- context. With the @ViewPatterns@ language extension enabled, they may -- also be used in a pattern context (since /0.3.2.0/).--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}- module Text.URI.QQ- ( uri- , scheme- , host- , username- , password- , pathPiece- , queryKey- , queryValue- , fragment )+ ( uri,+ scheme,+ host,+ username,+ password,+ pathPiece,+ queryKey,+ queryValue,+ fragment,+ ) where -import Control.Exception (SomeException, Exception (..))+import Control.Exception (Exception (..), SomeException) import Data.Text (Text)+import qualified Data.Text as T import Language.Haskell.TH.Lib (appE, viewP) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (Lift (..)) import Text.URI.Parser.Text import Text.URI.Types-import qualified Data.Text as T -- | 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 @@ -90,16 +81,17 @@ -- -- The 'Eq' constraint is technically unnecessary here, but the pattern -- generated by 'quotePat' will only work if the type has an 'Eq' instance.- liftToQQ :: (Eq a, Lift a) => (Text -> Either SomeException a) -> QuasiQuoter-liftToQQ f = QuasiQuoter- { quoteExp = \str ->- case f (T.pack str) of- Left err -> fail (displayException err)- Right x -> lift x- , quotePat = \str ->- case f (T.pack str) of- Left err -> fail (displayException err)- Right x -> appE [|(==)|] (lift x) `viewP` [p|True|]- , quoteType = error "This usage is not supported"- , quoteDec = error "This usage is not supported" }+liftToQQ f =+ QuasiQuoter+ { quoteExp = \str ->+ case f (T.pack str) of+ Left err -> fail (displayException err)+ Right x -> lift x,+ quotePat = \str ->+ case f (T.pack str) of+ Left err -> fail (displayException err)+ Right x -> appE [|(==)|] (lift x) `viewP` [p|True|],+ quoteType = error "This usage is not supported",+ quoteDec = error "This usage is not supported"+ }
Text/URI/Render.hs view
@@ -1,3 +1,14 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- Module : Text.URI.Render -- Copyright : © 2017–present Mark Karpov@@ -8,138 +19,133 @@ -- Portability : portable -- -- URI renders, an internal module.--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Text.URI.Render- ( render- , render'- , renderBs- , renderBs'- , renderStr- , renderStr' )+ ( render,+ render',+ renderBs,+ renderBs',+ renderStr,+ renderStr',+ ) where import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Builder as BLB import Data.Char (chr, intToDigit) import Data.Kind (Type) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Reflection+import qualified Data.Semigroup as S import Data.String (IsString (..)) import Data.Tagged import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as TLB import Data.Word (Word8) import Numeric (showInt) import Text.URI.Types-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Builder as BLB-import qualified Data.List.NonEmpty as NE-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-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' x = equip- TLB.decimal- (TLB.fromText . percentEncode)- (genericRender x)+render' x =+ equip+ TLB.decimal+ (TLB.fromText . percentEncode)+ (genericRender x) -- | Render a given 'URI' 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' x = equip- BLB.wordDec- (BLB.byteString . TE.encodeUtf8 . percentEncode)- (genericRender x)+renderBs' x =+ equip+ BLB.wordDec+ (BLB.byteString . TE.encodeUtf8 . percentEncode)+ (genericRender x) -- | Render a given 'URI' value as a 'String'. -- -- @since 0.0.2.0- renderStr :: URI -> String renderStr = ($ []) . renderStr' -- | Render a given 'URI' value as 'ShowS'. -- -- @since 0.0.2.0- renderStr' :: URI -> ShowS-renderStr' x = toShowS $ equip- (DString . showInt)- (fromString . T.unpack . percentEncode)- (genericRender x)+renderStr' x =+ toShowS $+ equip+ (DString . showInt)+ (fromString . T.unpack . percentEncode)+ (genericRender x) ---------------------------------------------------------------------------- -- Reflection stuff data Renders b = Renders- { rWord :: Word -> b- , rText :: forall l. RLabel l => RText l -> b+ { rWord :: Word -> b,+ rText :: forall l. RLabel l => RText l -> b } -equip- :: forall b. (Word -> b)- -> (forall l. RLabel l => RText l -> b)- -> (forall (s :: Type). Reifies s (Renders b) => Tagged s b)- -> b+equip ::+ forall b.+ (Word -> b) ->+ (forall l. RLabel l => RText l -> b) ->+ (forall (s :: Type). Reifies s (Renders b) => Tagged s b) ->+ b equip rWord rText f = reify Renders {..} $ \(Proxy :: Proxy s') -> unTagged (f :: Tagged s' b) -renderWord :: forall s b. Reifies s (Renders b)- => Word- -> Tagged s b+renderWord ::+ forall s b.+ Reifies s (Renders b) =>+ Word ->+ Tagged s b renderWord = Tagged . rWord (reflect (Proxy :: Proxy s)) -renderText :: forall s b l. (Reifies s (Renders b), RLabel l)- => RText l- -> Tagged s b+renderText ::+ forall s b l.+ (Reifies s (Renders b), RLabel l) =>+ RText l ->+ Tagged s b renderText = Tagged . rText (reflect (Proxy :: Proxy s)) ---------------------------------------------------------------------------- -- Generic render -type Render a b = forall (s :: Type).- (Semigroup b, Monoid b, IsString b, Reifies s (Renders b))- => a- -> Tagged s b+type Render a b =+ forall (s :: Type).+ (Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>+ a ->+ Tagged s b genericRender :: Render URI b-genericRender uri@URI {..} = mconcat- [ rJust rScheme uriScheme- , rJust rAuthority (either (const Nothing) Just uriAuthority)- , rPath (isPathAbsolute uri) uriPath- , rQuery uriQuery- , rJust rFragment uriFragment ]+genericRender uri@URI {..} =+ mconcat+ [ rJust rScheme uriScheme,+ rJust rAuthority (either (const Nothing) Just uriAuthority),+ rPath (isPathAbsolute uri) uriPath,+ rQuery uriQuery,+ rJust rFragment uriFragment+ ] {-# INLINE genericRender #-} rJust :: Monoid m => (a -> m) -> Maybe a -> m@@ -150,18 +156,22 @@ {-# INLINE rScheme #-} rAuthority :: Render Authority b-rAuthority Authority {..} = mconcat- [ "//"- , rJust rUserInfo authUserInfo- , renderText authHost- , rJust ((":" <>) . renderWord) authPort ]+rAuthority Authority {..} =+ mconcat+ [ "//",+ rJust rUserInfo authUserInfo,+ renderText authHost,+ rJust ((":" <>) . renderWord) authPort+ ] {-# INLINE rAuthority #-} rUserInfo :: Render UserInfo b-rUserInfo UserInfo {..} = mconcat- [ renderText uiUsername- , rJust ((":" <>) . renderText) uiPassword- , "@" ]+rUserInfo UserInfo {..} =+ mconcat+ [ renderText uiUsername,+ rJust ((":" <>) . renderText) uiPassword,+ "@"+ ] {-# INLINE rUserInfo #-} rPath :: Bool -> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b@@ -173,7 +183,7 @@ Nothing -> mempty Just (trailingSlash, ps) -> (mconcat . intersperse "/" . fmap renderText . NE.toList) ps- <> if trailingSlash then "/" else mempty+ <> if trailingSlash then "/" else mempty {-# INLINE rPath #-} rQuery :: Render [QueryParam] b@@ -195,7 +205,7 @@ ---------------------------------------------------------------------------- -- DString -newtype DString = DString { toShowS :: ShowS }+newtype DString = DString {toShowS :: ShowS} instance S.Semigroup DString where DString a <> DString b = DString (a . b)@@ -211,10 +221,13 @@ -- Percent-encoding -- | Percent-encode a 'Text' value.--percentEncode :: forall l. RLabel l- => RText l -- ^ Input text to encode- -> Text -- ^ Percent-encoded text+percentEncode ::+ forall l.+ RLabel l =>+ -- | Input text to encode+ RText l ->+ -- | Percent-encoded text+ Text percentEncode rtxt = if skipEscaping (Proxy :: Proxy l) txt then txt@@ -223,38 +236,35 @@ f (bs', []) = case B.uncons bs' of Nothing -> Nothing- Just (w, bs'') -> Just $- if | sap && w == 32 -> ('+', (bs'', []))- | nne w -> (chr (fromIntegral w), (bs'', []))- | otherwise ->- let c:|cs = encodeByte w- in (c, (bs'', cs))- f (bs', x:xs) = Just (x, (bs', xs))+ Just (w, bs'') ->+ Just $+ if+ | sap && w == 32 -> ('+', (bs'', []))+ | nne w -> (chr (fromIntegral w), (bs'', []))+ | otherwise ->+ let c :| cs = encodeByte w+ in (c, (bs'', cs))+ f (bs', x : xs) = Just (x, (bs', xs)) encodeByte x = '%' :| [intToDigit h, intToDigit l] where (h, l) = fromIntegral x `quotRem` 16 nne = needsNoEscaping (Proxy :: Proxy l)- sap = spaceAsPlus (Proxy :: Proxy l)+ sap = spaceAsPlus (Proxy :: Proxy l) txt = unRText rtxt {-# INLINE percentEncode #-} -- | This type class attaches some predicates that control serialization to -- the type level label of kind 'RTextLabel'.- class RLabel (l :: RTextLabel) where- -- | The predicate selects bytes that are not to be percent-escaped in -- rendered URI.- needsNoEscaping :: Proxy l -> Word8 -> Bool -- | Whether to serialize space as the plus sign.- spaceAsPlus :: Proxy l -> Bool spaceAsPlus Proxy = False -- | Whether to skip percent-escaping altogether for this value.- skipEscaping :: Proxy l -> Text -> Bool skipEscaping Proxy _ = False @@ -296,33 +306,33 @@ isUnreserved x = isAlphaNum x || other where other = case x of- 45 -> True- 46 -> True- 95 -> True+ 45 -> True+ 46 -> True+ 95 -> True 126 -> True- _ -> False+ _ -> False isAlphaNum :: Word8 -> Bool isAlphaNum x- | x >= 65 && x <= 90 = True -- 'A'..'Z'+ | x >= 65 && x <= 90 = True -- 'A'..'Z' | x >= 97 && x <= 122 = True -- 'a'..'z'- | x >= 48 && x <= 57 = True -- '0'..'9'- | otherwise = False+ | x >= 48 && x <= 57 = True -- '0'..'9'+ | otherwise = False isDelim :: Word8 -> Bool isDelim x- | x == 33 = True- | x == 36 = True+ | x == 33 = True+ | x == 36 = True | x >= 38 && x <= 44 = True- | x == 59 = True- | x == 61 = True- | otherwise = False+ | x == 59 = True+ | x == 61 = True+ | otherwise = False isDelim' :: Word8 -> Bool isDelim' x- | x == 33 = True- | x == 36 = True+ | x == 33 = True+ | x == 36 = True | x >= 39 && x <= 42 = True- | x == 44 = True- | x == 59 = True- | otherwise = False+ | x == 44 = True+ | x == 59 = True+ | otherwise = False
Text/URI/Types.hs view
@@ -1,3 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+ -- | -- Module : Text.URI.Types -- Copyright : © 2017–present Mark Karpov@@ -8,66 +21,58 @@ -- 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 #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}- module Text.URI.Types ( -- * Data types- URI (..)- , makeAbsolute- , isPathAbsolute- , Authority (..)- , UserInfo (..)- , QueryParam (..)- , ParseException (..)+ URI (..),+ makeAbsolute,+ isPathAbsolute,+ Authority (..),+ UserInfo (..),+ QueryParam (..),+ ParseException (..),+ ParseExceptionBs (..),+ -- * Refined text- , RText- , RTextLabel (..)- , mkScheme- , mkHost- , mkUsername- , mkPassword- , mkPathPiece- , mkQueryKey- , mkQueryValue- , mkFragment- , unRText- , RTextException (..)+ RText,+ RTextLabel (..),+ mkScheme,+ mkHost,+ mkUsername,+ mkPassword,+ mkPathPiece,+ mkQueryKey,+ mkQueryValue,+ mkFragment,+ unRText,+ RTextException (..),+ -- * Utils- , pHost )+ pHost,+ ) where import Control.DeepSeq import Control.Monad import Control.Monad.Catch (Exception (..), MonadThrow (..))+import Data.ByteString (ByteString) import Data.Char import Data.Data (Data) import Data.List (intercalate)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (fromMaybe, isJust, fromJust)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Proxy import Data.Text (Text)+import qualified Data.Text as T import Data.Typeable (Typeable, cast) import Data.Void-import Data.Word (Word8, Word16)+import Data.Word (Word16, Word8) import GHC.Generics-import Numeric (showInt, showHex)+import qualified Language.Haskell.TH.Syntax as TH+import Numeric (showHex, showInt) import Test.QuickCheck import Text.Megaparsec import Text.URI.Parser.Text.Utils (pHost)-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Language.Haskell.TH.Syntax as TH ---------------------------------------------------------------------------- -- Data types@@ -75,137 +80,155 @@ -- | 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 :: Either Bool Authority- -- ^ 'Authority' component in 'Right' or a 'Bool' value in 'Left'+ { -- | URI scheme, if 'Nothing', then the URI reference is relative+ uriScheme :: Maybe (RText 'Scheme),+ -- | 'Authority' component in 'Right' or a 'Bool' value in 'Left' -- indicating if 'uriPath' path is absolute ('True') or relative -- ('False'); if we have an 'Authority' component, then the path is -- necessarily absolute, see 'isPathAbsolute' -- -- __Note__: before version /0.1.0.0/ type of 'uriAuthority' was -- @'Maybe' 'Authority'@- , uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))- -- ^ 'Nothing' represents the empty path, while 'Just' contains an+ uriAuthority :: Either Bool Authority,+ -- | 'Nothing' represents the empty path, while 'Just' contains an -- indication 'Bool' whether the path component has a trailing slash, -- and the collection of path pieces @'NonEmpty' ('RText' 'PathPiece')@. -- -- __Note__: before version /0.2.0.0/ type of 'uriPath' was @['RText' -- 'PathPiece']@.- , uriQuery :: [QueryParam]- -- ^ Query parameters, RFC 3986 does not define the inner organization+ uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece)),+ -- | Query parameters, RFC 3986 does not define the inner organization -- of query string, so we deconstruct it following RFC 1866 here- , uriFragment :: Maybe (RText 'Fragment)- -- ^ Fragment, without @#@- } deriving (Show, Eq, Ord, Data, Typeable, Generic)+ uriQuery :: [QueryParam],+ -- | Fragment, without @#@+ uriFragment :: Maybe (RText 'Fragment)+ }+ deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Arbitrary URI where- arbitrary = URI- <$> arbitrary- <*> arbitrary- <*> (do mpieces <- NE.nonEmpty <$> arbitrary- trailingSlash <- arbitrary- return ((trailingSlash,) <$> mpieces))- <*> arbitrary- <*> arbitrary+ arbitrary =+ URI+ <$> arbitrary+ <*> arbitrary+ <*> ( do+ mpieces <- NE.nonEmpty <$> arbitrary+ trailingSlash <- arbitrary+ return ((trailingSlash,) <$> mpieces)+ )+ <*> arbitrary+ <*> arbitrary instance NFData URI -- | @since 0.3.1.0- instance TH.Lift URI where lift = liftData +#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif+ -- | 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)- , .. }+makeAbsolute scheme URI {..} =+ URI+ { uriScheme = pure (fromMaybe scheme uriScheme),+ ..+ } -- | Return 'True' if path in a given 'URI' is absolute. -- -- @since 0.1.0.0- isPathAbsolute :: URI -> Bool isPathAbsolute = either id (const True) . uriAuthority -- | 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)+ { -- | User information+ authUserInfo :: Maybe UserInfo,+ -- | Host+ authHost :: RText 'Host,+ -- | Port number+ authPort :: Maybe Word+ }+ deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Arbitrary Authority where- arbitrary = Authority- <$> arbitrary- <*> arbitrary- <*> arbitrary+ arbitrary =+ Authority+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary instance NFData Authority -- | @since 0.3.1.0- instance TH.Lift Authority where lift = liftData --- | User info as a combination of username and password.+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif +-- | 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+ { -- | Username+ uiUsername :: RText 'Username,+ -- | Password, 'Nothing' means that there was no @:@ character in the -- user info string- } deriving (Show, Eq, Ord, Data, Typeable, Generic)+ uiPassword :: Maybe (RText 'Password)+ }+ deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Arbitrary UserInfo where- arbitrary = UserInfo- <$> arbitrary- <*> arbitrary+ arbitrary =+ UserInfo+ <$> arbitrary+ <*> arbitrary instance NFData UserInfo -- | @since 0.3.1.0- instance TH.Lift UserInfo where lift = liftData +#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif+ -- | 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+ = -- | Flag parameter+ QueryFlag (RText 'QueryKey)+ | -- | Key–value pair+ QueryParam (RText 'QueryKey) (RText 'QueryValue) deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Arbitrary QueryParam where- arbitrary = oneof- [ QueryFlag <$> arbitrary- , QueryParam <$> arbitrary <*> arbitrary ]+ arbitrary =+ oneof+ [ QueryFlag <$> arbitrary,+ QueryParam <$> arbitrary <*> arbitrary+ ] instance NFData QueryParam -- | @since 0.3.1.0- instance TH.Lift QueryParam where lift = liftData +#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif+ -- | Parse exception thrown by 'mkURI' when a given 'Text' value cannot be -- parsed as a 'URI'.--newtype ParseException = ParseException (ParseErrorBundle Text Void)- -- ^ Arguments are: original input and parse error+newtype ParseException+ = -- | Arguments are: original input and parse error+ ParseException (ParseErrorBundle Text Void) deriving (Show, Eq, Data, Typeable, Generic) instance Exception ParseException where@@ -213,35 +236,58 @@ instance NFData ParseException +-- | Parse exception thrown by 'mkURIBs' when a given 'ByteString' value cannot be+-- parsed as a 'URI'.+--+-- @since 0.3.3.0+newtype ParseExceptionBs+ = -- | Arguments are: original input and parse error+ ParseExceptionBs (ParseErrorBundle ByteString Void)+ deriving (Show, Eq, Data, Typeable, Generic)++instance Exception ParseExceptionBs where+ displayException (ParseExceptionBs b) = errorBundlePretty b++instance NFData ParseExceptionBs+ ---------------------------------------------------------------------------- -- Refined text -- | Refined text labelled at the type level.- newtype RText (l :: RTextLabel) = RText Text deriving (Eq, Ord, Data, Typeable, Generic) instance Show (RText l) where show (RText txt) = show txt -instance NFData (RText l) where+instance NFData (RText l) -- | @since 0.3.1.0- instance Typeable l => TH.Lift (RText l) where lift = liftData --- | Refined text labels.+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif +-- | 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'+ = -- | See 'mkScheme'+ Scheme+ | -- | See 'mkHost'+ Host+ | -- | See 'mkUsername'+ Username+ | -- | See 'mkPassword'+ Password+ | -- | See 'mkPathPiece'+ PathPiece+ | -- | See 'mkQueryKey'+ QueryKey+ | -- | See 'mkQueryValue'+ QueryValue+ | -- | See 'mkFragment'+ Fragment deriving (Show, Eq, Ord, Data, Typeable, Generic) -- | This type class associates checking, normalization, and a term level@@ -250,14 +296,12 @@ -- 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+ rcheck :: Proxy l -> Text -> Bool rnormalize :: Proxy l -> Text -> Text- rlabel :: Proxy l -> RTextLabel+ 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@@ -276,18 +320,17 @@ -- 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+ 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+ rlabel Proxy = Scheme instance Arbitrary (RText 'Scheme) where arbitrary = arbScheme@@ -302,14 +345,13 @@ -- 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+ rcheck Proxy = (ifMatches . void . pHost) False rnormalize Proxy = T.toLower- rlabel Proxy = Host+ rlabel Proxy = Host instance Arbitrary (RText 'Host) where arbitrary = arbHost@@ -319,14 +361,13 @@ -- 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+ rcheck Proxy = not . T.null rnormalize Proxy = id- rlabel Proxy = Username+ rlabel Proxy = Username instance Arbitrary (RText 'Username) where arbitrary = arbText' mkUsername@@ -336,14 +377,13 @@ -- 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+ rcheck Proxy = const True rnormalize Proxy = id- rlabel Proxy = Password+ rlabel Proxy = Password instance Arbitrary (RText 'Password) where arbitrary = arbText mkPassword@@ -353,14 +393,13 @@ -- 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+ rcheck Proxy = not . T.null rnormalize Proxy = id- rlabel Proxy = PathPiece+ rlabel Proxy = PathPiece instance Arbitrary (RText 'PathPiece) where arbitrary = arbText' mkPathPiece@@ -370,14 +409,13 @@ -- 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+ rcheck Proxy = not . T.null rnormalize Proxy = id- rlabel Proxy = QueryKey+ rlabel Proxy = QueryKey instance Arbitrary (RText 'QueryKey) where arbitrary = arbText' mkQueryKey@@ -387,14 +425,13 @@ -- 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+ rcheck Proxy = const True rnormalize Proxy = id- rlabel Proxy = QueryValue+ rlabel Proxy = QueryValue instance Arbitrary (RText 'QueryValue) where arbitrary = arbText mkQueryValue@@ -404,40 +441,40 @@ -- 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+ rcheck Proxy = const True rnormalize Proxy = id- rlabel Proxy = Fragment+ 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+data RTextException+ = -- | 'RTextLabel' identifying what sort of refined text value could not be+ -- constructed and the input that was supplied, as a 'Text' value+ RTextException RTextLabel Text deriving (Show, Eq, Ord, Data, Typeable, Generic) instance Exception RTextException where- displayException (RTextException lbl txt) = "The value \"" ++- T.unpack txt ++ "\" could not be lifted into a " ++ show lbl+ 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 @@ -445,24 +482,25 @@ -- 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+ let g = oneof [choose ('a', 'z'), choose ('A', 'Z')]+ x <- g+ xs <-+ listOf $+ frequency [(3, g), (1, choose ('0', '9'))]+ return . fromJust . mkScheme . T.pack $ x : xs -- | Generator of 'Arbitrary' hosts.- arbHost :: Gen (RText 'Host)-arbHost = fromJust . mkHost . T.pack <$> frequency- [ (1, ipLiteral)- , (2, ipv4Address)- , (4, regName)- , (1, return "")- ]+arbHost =+ fromJust . mkHost . T.pack+ <$> frequency+ [ (1, ipLiteral),+ (2, ipv4Address),+ (4, regName),+ (1, return "")+ ] where ipLiteral = do xs <- oneof [ipv6Address, ipvFuture]@@ -470,37 +508,39 @@ 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)+ intercalate ":" . fmap (`showHex` "")+ <$> vectorOf 8 (arbitrary :: Gen Word16) ipv4Address =- intercalate "." . fmap (`showInt` "") <$>- vectorOf 4 (arbitrary :: Gen Word8)+ 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 "-._~!$&'()*+,;=:") ]+ 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+ 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
@@ -9,56 +9,49 @@ import Data.Void import Text.Megaparsec import Text.URI (URI)-import Weigh import qualified Text.URI as URI+import Weigh main :: IO () main = mainWith $ do setColumns [Case, Allocated, GCs, Max]- bparser turiStr- bparserBs turiStr- brender turi- brenderBs turi+ bparser turiStr+ bparserBs turiStr+ brender turi+ brenderBs turi brenderStr turi ---------------------------------------------------------------------------- -- Helpers -- | Test 'URI' as a polymorphic string.- turiStr :: IsString a => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form.- turi :: URI turi = fromJust (URI.mkURI turiStr) -- | Benchmark memory usage of the 'URI' parser with given input.- bparser :: Text -> Weigh () bparser = func "text parser" (parse p "") where p = URI.parser <* eof :: Parsec Void Text URI -- | Like 'bparser' but accepts a 'ByteString'.- bparserBs :: ByteString -> Weigh () bparserBs = func "bs parser" (parse p "") where p = URI.parserBs <* eof :: Parsec Void ByteString URI -- | Benchmark memory usage of the 'URI' render with given input.- brender :: URI -> Weigh () brender = func "text render" URI.render -- | The same as 'brender' but for the 'URI.renderBs' render.- brenderBs :: URI -> Weigh () brenderBs = func "bs render" URI.renderBs -- | The same as 'brender' but for the 'URI.renderString' render.- brenderStr :: URI -> Weigh () brenderStr = func "str render" URI.renderStr
bench/speed/Main.hs view
@@ -13,51 +13,46 @@ import qualified Text.URI as URI main :: IO ()-main = defaultMain- [ bparser turiStr- , bparserBs turiStr- , brender turi- , brenderBs turi- , brenderStr turi ]+main =+ defaultMain+ [ bparser turiStr,+ bparserBs turiStr,+ brender turi,+ brenderBs turi,+ brenderStr turi+ ] ---------------------------------------------------------------------------- -- Helpers -- | Test 'URI' as a polymorphic string.- turiStr :: IsString a => a turiStr = "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" -- | Test 'URI' in parsed form.- turi :: URI turi = fromJust (URI.mkURI turiStr) -- | Benchmark speed of the 'URI' parser with given input.- bparser :: Text -> Benchmark bparser txt = env (return txt) (bench "text parser" . nf p) where p = parse (URI.parser <* eof :: Parsec Void Text URI) "" -- | Like 'bparser' but accepts a 'ByteString'.- bparserBs :: ByteString -> Benchmark bparserBs bs = env (return bs) (bench "bs parser" . nf p) where p = parse (URI.parserBs <* eof :: Parsec Void ByteString URI) "" -- | Benchmark speed of the 'URI' render with given input.- brender :: URI -> Benchmark brender uri = env (return uri) (bench "text render" . nf URI.render) -- | The same as 'brender' but for the 'URI.renderBs' render.- brenderBs :: URI -> Benchmark brenderBs uri = env (return uri) (bench "bs render" . nf URI.renderBs) -- | The same as 'brender' but for the 'URI.renderString' render.- brenderStr :: URI -> Benchmark brenderStr uri = env (return uri) (bench "str render" . nf URI.renderStr)
modern-uri.cabal view
@@ -1,113 +1,132 @@-name: modern-uri-version: 0.3.2.0-cabal-version: 1.18-tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3-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+cabal-version: 1.18+name: modern-uri+version: 0.3.3.0+license: BSD3+license-file: LICENSE.md+maintainer: Mark Karpov <markkarpov92@gmail.com>+author: Mark Karpov <markkarpov92@gmail.com>+tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.2+homepage: https://github.com/mrkkrp/modern-uri+bug-reports: https://github.com/mrkkrp/modern-uri/issues+synopsis: Modern library for working with URIs+description: Modern library for working with URIs.+category: Text+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md source-repository head- type: git- location: https://github.com/mrkkrp/modern-uri.git+ type: git+ location: https://github.com/mrkkrp/modern-uri.git flag dev- description: Turn on development settings.- manual: True- default: False+ description: Turn on development settings.+ default: False+ manual: True library- build-depends: QuickCheck >= 2.4 && < 3.0- , base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , containers >= 0.5 && < 0.7- , contravariant >= 1.3 && < 2.0- , deepseq >= 1.3 && < 1.5- , exceptions >= 0.6 && < 0.11- , megaparsec >= 7.0 && < 9.0- , mtl >= 2.0 && < 3.0- , profunctors >= 5.2.1 && < 6.0- , reflection >= 2.0 && < 3.0- , tagged >= 0.8 && < 0.9- , template-haskell >= 2.10 && < 2.16- , text >= 0.2 && < 1.3- exposed-modules: Text.URI- , Text.URI.Lens- , Text.URI.QQ- other-modules: Text.URI.Parser.ByteString- , Text.URI.Parser.Text- , Text.URI.Parser.Text.Utils- , Text.URI.Render- , Text.URI.Types- if flag(dev)- ghc-options: -Wall -Werror- else- ghc-options: -O2 -Wall- if flag(dev)- ghc-options: -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances- default-language: Haskell2010+ exposed-modules:+ Text.URI+ Text.URI.Lens+ Text.URI.QQ + other-modules:+ Text.URI.Parser.ByteString+ Text.URI.Parser.Text+ Text.URI.Parser.Text.Utils+ Text.URI.Render+ Text.URI.Types++ default-language: Haskell2010+ build-depends:+ QuickCheck >=2.4 && <3.0,+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ containers >=0.5 && <0.7,+ contravariant >=1.3 && <2.0,+ deepseq >=1.3 && <1.5,+ exceptions >=0.6 && <0.11,+ megaparsec >=7.0 && <10.0,+ mtl >=2.0 && <3.0,+ profunctors >=5.2.1 && <6.0,+ reflection >=2.0 && <3.0,+ tagged >=0.8 && <0.9,+ template-haskell >=2.10 && <2.17,+ text >=0.2 && <1.3++ if flag(dev)+ ghc-options: -Wall -Werror++ else+ ghc-options: -O2 -Wall++ if flag(dev)+ ghc-options:+ -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Wnoncanonical-monad-instances+ 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.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , hspec >= 2.0 && < 3.0- , hspec-megaparsec >= 2.0 && < 3.0- , megaparsec >= 7.0 && < 9.0- , modern-uri- , text >= 0.2 && < 1.3- build-tools: hspec-discover >= 2.0 && < 3.0- other-modules: Text.QQSpec- , Text.URISpec- if flag(dev)- ghc-options: -Wall -Werror- else- ghc-options: -O2 -Wall- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tools: hspec-discover >=2.0 && <3.0+ hs-source-dirs: tests+ other-modules:+ Text.QQSpec+ Text.URISpec + default-language: Haskell2010+ build-depends:+ QuickCheck >=2.4 && <3.0,+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ hspec >=2.0 && <3.0,+ hspec-megaparsec >=2.0 && <3.0,+ megaparsec >=7.0 && <10.0,+ modern-uri -any,+ text >=0.2 && <1.3++ if flag(dev)+ ghc-options: -Wall -Werror++ else+ ghc-options: -O2 -Wall+ benchmark bench-speed- main-is: Main.hs- hs-source-dirs: bench/speed- type: exitcode-stdio-1.0- build-depends: base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , criterion >= 0.6.2.1 && < 1.6- , megaparsec >= 7.0 && < 9.0- , modern-uri- , text >= 0.2 && < 1.3- if flag(dev)- ghc-options: -O2 -Wall -Werror- else- ghc-options: -O2 -Wall- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/speed+ default-language: Haskell2010+ build-depends:+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ criterion >=0.6.2.1 && <1.6,+ megaparsec >=7.0 && <10.0,+ modern-uri -any,+ text >=0.2 && <1.3 + if flag(dev)+ ghc-options: -O2 -Wall -Werror++ else+ ghc-options: -O2 -Wall+ benchmark bench-memory- main-is: Main.hs- hs-source-dirs: bench/memory- type: exitcode-stdio-1.0- build-depends: base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , deepseq >= 1.3 && < 1.5- , megaparsec >= 7.0 && < 9.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+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/memory+ default-language: Haskell2010+ build-depends:+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ deepseq >=1.3 && <1.5,+ megaparsec >=7.0 && <10.0,+ modern-uri -any,+ text >=0.2 && <1.3,+ weigh >=0.0.4++ if flag(dev)+ ghc-options: -O2 -Wall -Werror++ else+ ghc-options: -O2 -Wall
tests/Text/QQSpec.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} module Text.QQSpec (spec) where @@ -12,7 +12,6 @@ spec :: Spec spec = do- describe "uri" $ do it "works as an expression" $ do let uriQQ = [QQ.uri|https://markkarpov.com|]@@ -113,9 +112,11 @@ _ -> shouldHaveMatchedAlready shouldNotMatch :: Expectation-shouldNotMatch = expectationFailure- "First case should not have matched, but did"+shouldNotMatch =+ expectationFailure+ "First case should not have matched, but did" shouldHaveMatchedAlready :: Expectation-shouldHaveMatchedAlready = expectationFailure- "Second case should have matched, but didn't"+shouldHaveMatchedAlready =+ expectationFailure+ "Second case should have matched, but didn't"
tests/Text/URISpec.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Text.URISpec (spec) where@@ -7,18 +7,18 @@ import Control.Monad import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (isNothing, isJust)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust, isNothing) import Data.String (IsString (..)) import Data.Text (Text)+import qualified Data.Text as T 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.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Text.URI as URI+import Text.URI (RTextException (..), RTextLabel (..), URI (..))+import qualified Text.URI as URI #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -34,21 +34,28 @@ uri <- mkTestURI URI.mkURI testURI `shouldReturn` uri it "rejects invalid URIs" $ do- let e = err 0 . mconcat $- [ utok 'ч'- , etok '#'- , etok '/'- , etoks "//"- , etok '?'- , elabel "ASCII alpha character"- , elabel "path piece"- , eeof ]- b = ParseErrorBundle- { bundleErrors = e :| []- , bundlePosState = initialPosState s- }+ let e =+ err 0 . mconcat $+ [ utok 'ч',+ etok '#',+ etok '/',+ etoks "//",+ etok '?',+ elabel "ASCII alpha character",+ elabel "path piece",+ eeof+ ]+ b =+ ParseErrorBundle+ { bundleErrors = e :| [],+ bundlePosState = initialPosState s+ } s = "что-то" URI.mkURI s `shouldThrow` (== URI.ParseException b)+ describe "mkURIBs" $ do+ it "accepts valid URIs" $ do+ uri <- mkTestURI+ URI.mkURIBs testURI `shouldReturn` uri describe "emptyURI" $ do it "parsing of empty input produces emptyURI" $ URI.mkURI "" `shouldReturn` URI.emptyURI@@ -62,71 +69,74 @@ 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+ 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+ property $ \scheme uri ->+ isNothing (uriScheme uri)+ ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` Just scheme describe "isPathAbsolute" $ do context "when URI has authority component" $ it "returns True" $ property $ \uri auth ->- URI.isPathAbsolute (uri { uriAuthority = Right auth }) `shouldBe` True+ URI.isPathAbsolute (uri {uriAuthority = Right auth}) `shouldBe` True context "when URI has no authority component" $ it "return what is inside of Left in uriAuthority" $ property $ \uri b ->- URI.isPathAbsolute (uri { uriAuthority = Left b }) `shouldBe` b+ URI.isPathAbsolute (uri {uriAuthority = Left b}) `shouldBe` b describe "mkScheme" $ do it "accepts valid schemes" $ do- URI.mkScheme "http" `shouldRText` "http"- URI.mkScheme "HTTPS" `shouldRText` "https"+ URI.mkScheme "http" `shouldRText` "http"+ URI.mkScheme "HTTPS" `shouldRText` "https" URI.mkScheme "mailto" `shouldRText` "mailto"- URI.mkScheme "a+-." `shouldRText` "a+-."+ URI.mkScheme "a+-." `shouldRText` "a+-." it "rejects invalid schemes" $ do- URI.mkScheme "123" `shouldThrow` (== RTextException Scheme "123")+ URI.mkScheme "123" `shouldThrow` (== RTextException Scheme "123") URI.mkScheme "схема" `shouldThrow` (== RTextException Scheme "схема")- 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 "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::]"+ 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::]")+ 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]"+ URI.mkHost "[v1.123-456]" `shouldRText` "[v1.123-456]" it "rejects invalid IP future literals" $- URI.mkHost "[vv.something]" `shouldThrow`- (== RTextException Host "[vv.something]")+ 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 "LOCALHOST" `shouldRText` "localhost"+ URI.mkHost "github.com" `shouldRText` "github.com" URI.mkHost "foo.example.com" `shouldRText` "foo.example.com"- URI.mkHost "юникод.рф" `shouldRText` "юникод.рф"- URI.mkHost "" `shouldRText` ""+ URI.mkHost "юникод.рф" `shouldRText` "юникод.рф"+ URI.mkHost "" `shouldRText` "" it "rejects invalid hosts" $ do- URI.mkHost "_something" `shouldThrow`- (== RTextException Host "_something")- URI.mkHost "some@thing" `shouldThrow`- (== RTextException Host "some@thing")+ 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+ 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" $@@ -136,16 +146,18 @@ 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+ 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+ 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" $@@ -168,58 +180,75 @@ shouldParseBs (URI.renderBs uri) uri describe "parse" $ do it "rejects Unicode in scheme" $- parse urip "" "что:something" `shouldFailWith` err 0 (mconcat- [ utok 'ч'- , etok '#'- , etok '/'- , etoks "//"- , etok '?'- , elabel "ASCII alpha character"- , elabel "path piece"- , eeof ] )+ parse urip "" "что:something"+ `shouldFailWith` err+ 0+ ( mconcat+ [ utok 'ч',+ etok '#',+ etok '/',+ etoks "//",+ etok '?',+ elabel "ASCII alpha character",+ elabel "path piece",+ eeof+ ]+ ) it "rejects Unicode in host" $ do let s = "https://юникод.рф"- parse urip "" s `shouldFailWith` err 8 (mconcat- [ utok 'ю'- , etok '#'- , etok '%'- , etok '.'- , etok '/'- , etok ':'- , etok '?'- , etok '['- , elabel "ASCII alpha-numeric character"- , elabel "integer"- , elabel "username"- , elabel "path piece"- , eeof- ] )+ parse urip "" s+ `shouldFailWith` err+ 8+ ( mconcat+ [ utok 'ю',+ etok '#',+ etok '%',+ etok '.',+ etok '/',+ etok ':',+ etok '?',+ etok '[',+ elabel "ASCII alpha-numeric character",+ elabel "integer",+ elabel "username",+ elabel "path piece",+ eeof+ ]+ ) it "rejects Unicode in path" $ do let s = "https://github.com/марк"- parse urip "" s `shouldFailWith` err 19 (mconcat- [ utok 'м'- , etok '#'- , etok '/'- , etok '?'- , elabel "path piece"- , eeof ] )+ parse urip "" s+ `shouldFailWith` err+ 19+ ( mconcat+ [ utok 'м',+ etok '#',+ etok '/',+ etok '?',+ elabel "path piece",+ eeof+ ]+ ) it "parses URIs with empty authority" $ do scheme <- URI.mkScheme "file" ppetc <- URI.mkPathPiece "etc" pphosts <- URI.mkPathPiece "hosts" host <- URI.mkHost "" let s = "file:///etc/hosts"- parse urip "" s `shouldParse` URI- { uriScheme = Just scheme- , uriAuthority = Right URI.Authority- { URI.authUserInfo = Nothing- , URI.authHost = host- , URI.authPort = Nothing+ parse urip "" s+ `shouldParse` URI+ { uriScheme = Just scheme,+ uriAuthority =+ Right+ URI.Authority+ { URI.authUserInfo = Nothing,+ URI.authHost = host,+ URI.authPort = Nothing+ },+ uriPath = Just (False, ppetc :| [pphosts]),+ uriQuery = [],+ uriFragment = Nothing }- , uriPath = Just (False, ppetc :| [pphosts])- , uriQuery = []- , uriFragment = Nothing- } it "parses URIs with superfluous '&' before query parameters" $ do uri <- mkTestURI let s = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri+%3a@?&foo:@=bar+:@#fragment:@"@@ -236,13 +265,15 @@ (URI.render <$> URI.mkURI "//host/fir:st/se:cond") `shouldReturn` "//host/fir%3ast/se%3acond" context "when URI is a relative-path reference" $- it "escapes colon but only in the first path segment" $ do- firstSeg <- URI.mkPathPiece "fir:st"- secondSeg <- URI.mkPathPiece "se:cond"- let uri = URI.emptyURI- { uriPath = Just (False, firstSeg :| [secondSeg])- }- URI.render uri `shouldBe` "fir%3ast/se%3acond"+ it "escapes colon but only in the first path segment" $+ do+ firstSeg <- URI.mkPathPiece "fir:st"+ secondSeg <- URI.mkPathPiece "se:cond"+ let uri =+ URI.emptyURI+ { uriPath = Just (False, firstSeg :| [secondSeg])+ }+ URI.render uri `shouldBe` "fir%3ast/se%3acond" describe "renderBs" $ it "sort of works" $ fmap URI.renderBs mkTestURI `shouldReturn` testURI@@ -251,14 +282,15 @@ fmap URI.renderStr mkTestURI `shouldReturn` testURI describe "relativeTo" $ do let testResolution r e = do- base <- URI.mkURI "http://a/b/c/d;p?q"+ base <- URI.mkURI "http://a/b/c/d;p?q" reference <- URI.mkURI r- expected <- URI.mkURI e+ expected <- URI.mkURI e URI.relativeTo reference base `shouldBe` Just expected context "when reference URI has no scheme" $- forM_ resolutionTests $ \(r, e) ->- it ("resolves reference path \"" <> T.unpack r <> "\"") $- testResolution r e+ forM_ resolutionTests $+ \(r, e) ->+ it ("resolves reference path \"" <> T.unpack r <> "\"") $+ testResolution r e context "when reference URI has scheme" $ do context "when the scheme is the same as the scheme of base URI" $ it "reference URI is preserved intact" $@@ -268,142 +300,151 @@ testResolution "ftp:g" "ftp:g" context "when base URI has no scheme" $ it "returns Nothing" $- property $ \reference base -> isNothing (uriScheme base) ==>- URI.relativeTo reference base `shouldBe` Nothing+ property $ \reference base ->+ isNothing (uriScheme base)+ ==> URI.relativeTo reference base `shouldBe` Nothing context "when base URI has scheme" $ it "the resulting URI always has scheme" $- property $ \reference base -> isJust (uriScheme base) ==> do- let scheme = URI.relativeTo reference base >>= uriScheme- scheme `shouldSatisfy` isJust+ property $ \reference base ->+ isJust (uriScheme base) ==> do+ let scheme = URI.relativeTo reference base >>= uriScheme+ scheme `shouldSatisfy` isJust ---------------------------------------------------------------------------- -- Helpers -- | Construct a test URI.- mkTestURI :: IO URI mkTestURI = do- scheme <- URI.mkScheme "https"+ 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 :@"+ host <- URI.mkHost "github.com"+ path <- mapM URI.mkPathPiece ["mrkkrp", "modern-uri+:@"]+ k <- URI.mkQueryKey "foo:@"+ v <- URI.mkQueryValue "bar :@" fragment <- URI.mkFragment "fragment:@"- return URI- { uriScheme = Just scheme- , uriAuthority = Right URI.Authority- { URI.authUserInfo = Just URI.UserInfo- { URI.uiUsername = username- , URI.uiPassword = Just password }- , URI.authHost = host- , URI.authPort = Just 443+ return+ URI+ { uriScheme = Just scheme,+ uriAuthority =+ Right+ URI.Authority+ { URI.authUserInfo =+ Just+ URI.UserInfo+ { URI.uiUsername = username,+ URI.uiPassword = Just password+ },+ URI.authHost = host,+ URI.authPort = Just 443+ },+ uriPath = Just (False, NE.fromList path),+ uriQuery = [URI.QueryParam k v],+ uriFragment = Just fragment }- , uriPath = Just (False, NE.fromList path)- , uriQuery = [URI.QueryParam k v]- , uriFragment = Just fragment- } -- | Polymorphic textual rendering of the 'URI' generated by 'mkTestURI'.- testURI :: IsString a => a testURI = "https://mark%3a%40:secret:%40@github.com:443/mrkkrp/modern-uri+%3a@?foo:@=bar+:@#fragment:@" -- | A utility wrapper around 'URI.parser'.- urip :: Parsec Void Text URI urip = URI.parser <* eof -- | Expect that the given action constructs 'URI.RText' with certain text -- inside.--shouldRText- :: IO (URI.RText l) -- ^ Action that produces refined text- -> Text -- ^ Inner text to compare with- -> Expectation+shouldRText ::+ -- | Action that produces refined text+ IO (URI.RText l) ->+ -- | Inner text to compare with+ Text ->+ Expectation shouldRText rtext txt = do txt' <- rtext URI.unRText txt' `shouldBe` txt -- | Expect that the specified input for parser will produce 'URI' equal to -- a given one.--shouldParse'- :: Text -- ^ Parser input- -> URI -- ^ 'URI' to compare with- -> Expectation+shouldParse' ::+ -- | Parser input+ Text ->+ -- | 'URI' to compare with+ URI ->+ Expectation shouldParse' s a = case runParser urip "" s of- Left e -> expectationFailure $- "the parser is expected to succeed, but it failed with:\n" ++- errorBundlePretty e+ Left e ->+ expectationFailure $+ "the parser is expected to succeed, but it failed with:\n"+ ++ errorBundlePretty e Right a' -> a' `shouldBe` a -- | Similar to 'shouldParse'' but uses 'URI.parserBs' under the hood.--shouldParseBs- :: ByteString -- ^ Parser input- -> URI -- ^ 'URI' to compare with- -> Expectation+shouldParseBs ::+ -- | Parser input+ ByteString ->+ -- | 'URI' to compare with+ URI ->+ Expectation shouldParseBs s a = case runParser (URI.parserBs <* eof :: Parsec Void ByteString URI) "" s of- Left e -> expectationFailure $- "the parser is expected to succeed, but it failed with:\n" ++- errorBundlePretty e+ Left e ->+ expectationFailure $+ "the parser is expected to succeed, but it failed with:\n"+ ++ errorBundlePretty e Right a' -> a' `shouldBe` a -- | Test cases from section 5.4.1 from RFC 3986. -- -- First item in the tuple is the relative path, the second is the expected -- result. The base path is always @http://a/b/c/d;p?q@.- resolutionTests :: [(Text, Text)] resolutionTests = [ -- Normal examples- ("g:h", "g:h")- , ("g", "http://a/b/c/g")- , ("./g", "http://a/b/c/g")- , ("g/", "http://a/b/c/g/")- , ("/g", "http://a/g")- , ("//g", "http://g")- , ("?y", "http://a/b/c/d;p?y")- , ("g?y", "http://a/b/c/g?y")- , ("#s", "http://a/b/c/d;p?q#s")- , ("g#s", "http://a/b/c/g#s")- , ("g?y#s", "http://a/b/c/g?y#s")- , (";x", "http://a/b/c/;x")- , ("g;x", "http://a/b/c/g;x")- , ("g;x?y#s", "http://a/b/c/g;x?y#s")- , ("", "http://a/b/c/d;p?q")- , (".", "http://a/b/c/")- , ("./", "http://a/b/c/")- , ("..", "http://a/b/")- , ("../", "http://a/b/")- , ("../g", "http://a/b/g")- , ("../..", "http://a/")- , ("../../", "http://a/")- , ("../../g", "http://a/g")+ ("g:h", "g:h"),+ ("g", "http://a/b/c/g"),+ ("./g", "http://a/b/c/g"),+ ("g/", "http://a/b/c/g/"),+ ("/g", "http://a/g"),+ ("//g", "http://g"),+ ("?y", "http://a/b/c/d;p?y"),+ ("g?y", "http://a/b/c/g?y"),+ ("#s", "http://a/b/c/d;p?q#s"),+ ("g#s", "http://a/b/c/g#s"),+ ("g?y#s", "http://a/b/c/g?y#s"),+ (";x", "http://a/b/c/;x"),+ ("g;x", "http://a/b/c/g;x"),+ ("g;x?y#s", "http://a/b/c/g;x?y#s"),+ ("", "http://a/b/c/d;p?q"),+ (".", "http://a/b/c/"),+ ("./", "http://a/b/c/"),+ ("..", "http://a/b/"),+ ("../", "http://a/b/"),+ ("../g", "http://a/b/g"),+ ("../..", "http://a/"),+ ("../../", "http://a/"),+ ("../../g", "http://a/g"), -- Abnormal cases- , ("../../../g", "http://a/g")- , ("../../../../g", "http://a/g")+ ("../../../g", "http://a/g"),+ ("../../../../g", "http://a/g"), -- Dot segments- , ("/./g", "http://a/g")- , ("/../g", "http://a/g")- , ("g.", "http://a/b/c/g.")- , (".g", "http://a/b/c/.g")- , ("g..", "http://a/b/c/g..")- , ("..g", "http://a/b/c/..g")+ ("/./g", "http://a/g"),+ ("/../g", "http://a/g"),+ ("g.", "http://a/b/c/g."),+ (".g", "http://a/b/c/.g"),+ ("g..", "http://a/b/c/g.."),+ ("..g", "http://a/b/c/..g"), -- Nonsensical forms of the "." and ".."- , ("./../g", "http://a/b/g")- , ("./g/.", "http://a/b/c/g/")- , ("g/./h", "http://a/b/c/g/h")- , ("g/../h", "http://a/b/c/h")- , ("g;x=1/./y", "http://a/b/c/g;x=1/y")- , ("g;x=1/../y", "http://a/b/c/y")+ ("./../g", "http://a/b/g"),+ ("./g/.", "http://a/b/c/g/"),+ ("g/./h", "http://a/b/c/g/h"),+ ("g/../h", "http://a/b/c/h"),+ ("g;x=1/./y", "http://a/b/c/g;x=1/y"),+ ("g;x=1/../y", "http://a/b/c/y"), -- Query and/or fragment components- , ("g?y/./x", "http://a/b/c/g?y/./x")- , ("g?y/../x", "http://a/b/c/g?y/../x")- , ("g#s/./x", "http://a/b/c/g#s/./x")- , ("g#s/../x", "http://a/b/c/g#s/../x")+ ("g?y/./x", "http://a/b/c/g?y/./x"),+ ("g?y/../x", "http://a/b/c/g?y/../x"),+ ("g#s/./x", "http://a/b/c/g#s/./x"),+ ("g#s/../x", "http://a/b/c/g#s/../x") ]