diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## Modern URI 0.1.0.0 + +* Changed the type of `uriAuthority` from `Maybe Authority` to `Either Bool + Authority`. This allows to know if URI path is absolute or not without + duplication of information, i.e. when the `Authority` component is present + the path is necessarily absolute, otherwise the `Bool` value tells if it's + absolute (`True`) or relative (`False`). + +* Added `isPathAbsolute` in `Text.URI` and the corresponding getter in + `Text.URI.Lens`. + ## Modern URI 0.0.2.0 * Added the `renderStr` and `renderStr'` functions for efficient rendering diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,39 +11,6 @@ https://tools.ietf.org/html/rfc3986 -## Motivation - -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` and `network-uri` packages (they are quite -similar): - -* 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. -* 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`? - -* Works with `ByteString`, which totally makes sense because a URI can have - only ASCII characters in it. However sometimes a URI is a part of a bigger - document that can contain Unicode characters and so we may need to parse a - URI from `Text` or render it to `Text`. Ideally, we would like to be able - to parse from both `Text` and `ByteString` as well to render to both - `Text` and `ByteString`. -* Does not allow to use its URI parser as part of a bigger parser. -* Provides `newtype` wrappers for different components of URI, but we could - still put something incorrect inside. -* Absolute and relative URI references have different types, which may or - may not be handy. -* Provides lenses, but does not provide e.g. traversal for working with - query parameters selected by their names. - ## Features The `modern-uri` package features: diff --git a/Text/URI.hs b/Text/URI.hs --- a/Text/URI.hs +++ b/Text/URI.hs @@ -25,6 +25,7 @@ URI (..) , mkURI , makeAbsolute + , isPathAbsolute , Authority (..) , UserInfo (..) , QueryParam (..) diff --git a/Text/URI/Lens.hs b/Text/URI/Lens.hs --- a/Text/URI/Lens.hs +++ b/Text/URI/Lens.hs @@ -17,6 +17,7 @@ ( uriScheme , uriAuthority , uriPath + , isPathAbsolute , uriQuery , uriFragment , authUserInfo @@ -45,14 +46,24 @@ 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 (Maybe URI.Authority) +uriAuthority :: Lens' URI (Either Bool URI.Authority) uriAuthority f s = (\x -> s { URI.uriAuthority = x }) <$> f (URI.uriAuthority s) -- | 'URI' path lens. uriPath :: Lens' URI [RText 'PathPiece] uriPath f s = (\x -> s { URI.uriPath = x }) <$> f (URI.uriPath s) + +-- | A getter that can tell if path component of a 'URI' is absolute. +-- +-- @since 0.1.0.0 + +isPathAbsolute :: Getter URI Bool +isPathAbsolute = to URI.isPathAbsolute -- | 'URI' query params lens. diff --git a/Text/URI/Parser/ByteString.hs b/Text/URI/Parser/ByteString.hs --- a/Text/URI/Parser/ByteString.hs +++ b/Text/URI/Parser/ByteString.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : portable -- --- URI parsers for string 'ByteString', an internal module. +-- URI parser for string 'ByteString', an internal module. {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -25,8 +25,9 @@ import Data.ByteString (ByteString) import Data.Char import Data.List (intercalate) -import Data.Maybe (isNothing, catMaybes, maybeToList) +import Data.Maybe (isJust, catMaybes, maybeToList) import Data.Text (Text) +import Data.Void import Data.Word (Word8) import Text.Megaparsec import Text.Megaparsec.Byte @@ -44,13 +45,15 @@ 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 + uriScheme <- optional (try pScheme) + mauth <- optional pAuthority + (absPath, uriPath) <- pPath (isJust mauth) + uriQuery <- option [] pQuery + uriFragment <- optional pFragment + let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parserBs #-} +{-# SPECIALIZE parserBs :: Parsec Void ByteString URI #-} pScheme :: MonadParsec e ByteString m => m (RText 'Scheme) pScheme = do @@ -138,14 +141,16 @@ 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) $ +pPath :: MonadParsec e ByteString m => Bool -> m (Bool, [RText 'PathPiece]) +pPath hasAuth = do + doubleSlash <- lookAhead (option False (True <$ string "//")) + when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) [47,47] + absPath <- option False (True <$ char 47) path <- flip sepBy (char 47) . label "path piece" $ many pchar - mapM (liftR mkPathPiece) (filter (not . null) path) + pieces <- mapM (liftR mkPathPiece) (filter (not . null) path) + return (absPath, pieces) {-# INLINE pPath #-} pQuery :: MonadParsec e ByteString m => m [QueryParam] diff --git a/Text/URI/Parser/Text.hs b/Text/URI/Parser/Text.hs --- a/Text/URI/Parser/Text.hs +++ b/Text/URI/Parser/Text.hs @@ -27,7 +27,7 @@ import Control.Monad import Control.Monad.Catch (Exception (..), MonadThrow (..)) import Data.Data (Data) -import Data.Maybe (isNothing, catMaybes) +import Data.Maybe (isJust, catMaybes) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void @@ -68,13 +68,15 @@ 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 + uriScheme <- optional (try pScheme) + mauth <- optional pAuthority + (absPath, uriPath) <- pPath (isJust mauth) + uriQuery <- option [] pQuery + uriFragment <- optional pFragment + let uriAuthority = maybe (Left absPath) Right mauth return URI {..} {-# INLINEABLE parser #-} +{-# SPECIALIZE parser :: Parsec Void Text URI #-} pScheme :: MonadParsec e Text m => m (RText 'Scheme) pScheme = do @@ -106,14 +108,16 @@ 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) $ +pPath :: MonadParsec e Text m => Bool -> m (Bool, [RText 'PathPiece]) +pPath hasAuth = do + doubleSlash <- lookAhead (option False (True <$ string "//")) + when (doubleSlash && not hasAuth) $ (unexpected . Tokens . NE.fromList) "//" + absPath <- option False (True <$ char '/') path <- flip sepBy (char '/') . label "path piece" $ many pchar - mapM (liftR mkPathPiece) (filter (not . null) path) + pieces <- mapM (liftR mkPathPiece) (filter (not . null) path) + return (absPath, pieces) {-# INLINE pPath #-} pQuery :: MonadParsec e Text m => m [QueryParam] diff --git a/Text/URI/Render.hs b/Text/URI/Render.hs --- a/Text/URI/Render.hs +++ b/Text/URI/Render.hs @@ -88,16 +88,23 @@ ---------------------------------------------------------------------------- -- Generic render -data Escaping = N | P | Q deriving (Eq) +-- | Percent encoding options. +data Escaping + = N -- ^ No escaping + | P -- ^ Path-piece style, do not encode @:@ and @\@@ + | PQ -- ^ Mixed style, encode @:@ but not @\@@ + | Q -- ^ Query string style, encode @:@ and @\@@ + deriving (Eq) + type Render a b = (forall l. Escaping -> RText l -> b) -> a -> b type R b = (Monoid b, IsString b) genericRender :: R b => (Word -> b) -> Render URI b -genericRender d r URI {..} = mconcat +genericRender d r uri@URI {..} = mconcat [ rJust (rScheme r) uriScheme - , rJust (rAuthority d r) uriAuthority - , rPath r uriPath + , rJust (rAuthority d r) (either (const Nothing) Just uriAuthority) + , rPath (isPathAbsolute uri) r uriPath , rQuery r uriQuery , rJust (rFragment r) uriFragment ] {-# INLINE genericRender #-} @@ -126,8 +133,14 @@ , "@" ] {-# INLINE rUserInfo #-} -rPath :: R b => Render [RText 'PathPiece] b -rPath r ps = "/" <> mconcat (intersperse "/" (r P <$> ps)) +rPath :: R b => Bool -> Render [RText 'PathPiece] b +rPath isAbsolute r ps' = leading <> other + where + leading = if isAbsolute then "/" else mempty + other = mconcat . intersperse "/" $ + case (isAbsolute, ps') of + (False, p:ps) -> r PQ p : fmap (r P) ps + _ -> r P <$> ps' {-# INLINE rPath #-} rQuery :: R b => Render [QueryParam] b @@ -170,28 +183,28 @@ :: Escaping -- ^ Whether to leave @':'@ and @'@'@ unescaped -> Text -- ^ Input text to encode -> Text -- ^ Percent-encoded text -percentEncode N txt = txt percentEncode e txt = T.unfoldrN n f (bs, []) where f (bs', []) = case B.uncons bs' of Nothing -> Nothing Just (w, bs'') -> Just $ - if isUnreserved (e == P) w + if isUnreserved e w then (chr (fromIntegral w), (bs'', [])) else let c:|cs = encodeByte w in (c, (bs'', cs)) f (bs', x:xs) = Just (x, (bs', xs)) bs = TE.encodeUtf8 txt n = B.foldl' (\n' w -> g w + n') 0 bs - g x = if isUnreserved (e == P) x then 1 else 3 + g x = if isUnreserved e x then 1 else 3 encodeByte x = '%' :| [intToDigit h, intToDigit l] where (h, l) = fromIntegral x `quotRem` 16 -- | The predicate selects unreserved bytes. -isUnreserved :: Bool -> Word8 -> Bool +isUnreserved :: Escaping -> Word8 -> Bool +isUnreserved N _ = True isUnreserved t x | x >= 65 && x <= 90 = True -- 'A'..'Z' | x >= 97 && x <= 122 = True -- 'a'..'z' @@ -200,6 +213,9 @@ | x == 95 = True -- '_' | x == 46 = True -- '.' | x == 126 = True -- '~' - | t && x == 58 = True -- ':' - | t && x == 64 = True -- '@' + | colon && x == 58 = True -- ':' + | at && x == 64 = True -- '@' | otherwise = False + where + colon = t == P + at = t == P || t == PQ diff --git a/Text/URI/Types.hs b/Text/URI/Types.hs --- a/Text/URI/Types.hs +++ b/Text/URI/Types.hs @@ -23,6 +23,7 @@ ( -- * Data types URI (..) , makeAbsolute + , isPathAbsolute , Authority (..) , UserInfo (..) , QueryParam (..) @@ -73,8 +74,14 @@ data URI = URI { uriScheme :: Maybe (RText 'Scheme) -- ^ URI scheme, if 'Nothing', then the URI reference is relative - , uriAuthority :: Maybe Authority - -- ^ 'Authority' component + , uriAuthority :: Either Bool Authority + -- ^ '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 :: [RText 'PathPiece] -- ^ Path , uriQuery :: [QueryParam] @@ -100,6 +107,13 @@ 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'. diff --git a/modern-uri.cabal b/modern-uri.cabal --- a/modern-uri.cabal +++ b/modern-uri.cabal @@ -1,5 +1,5 @@ name: modern-uri -version: 0.0.2.0 +version: 0.1.0.0 cabal-version: >= 1.18 tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license: BSD3 diff --git a/tests/Text/URISpec.hs b/tests/Text/URISpec.hs --- a/tests/Text/URISpec.hs +++ b/tests/Text/URISpec.hs @@ -5,6 +5,7 @@ import Data.ByteString (ByteString) import Data.Maybe (isNothing, isJust) +import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Test.Hspec @@ -23,8 +24,7 @@ describe "mkURI" $ do it "accepts valid URIs" $ do uri <- mkTestURI - URI.mkURI "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" - `shouldReturn` uri + URI.mkURI testURI `shouldReturn` uri it "rejects invalid URIs" $ do let e = err posI . mconcat $ [ utok 'ч' @@ -45,6 +45,15 @@ it "sets the specified scheme" $ property $ \scheme uri -> isNothing (uriScheme uri) ==> uriScheme (URI.makeAbsolute scheme uri) `shouldBe` Just scheme + describe "isPathAbsolute" $ do + context "when URI has authority component" $ + it "returns True" $ + property $ \uri auth -> + URI.isPathAbsolute (uri { uriAuthority = Right auth }) `shouldBe` True + context "when URI has no authority component" $ + it "return what is inside of Left in uriAuthority" $ + property $ \uri b -> + URI.isPathAbsolute (uri { uriAuthority = Left b }) `shouldBe` b describe "mkScheme" $ do it "accepts valid schemes" $ do URI.mkScheme "http" `shouldRText` "http" @@ -162,18 +171,23 @@ , etok '?' , elabel "path piece" , eeof ] ) - describe "render" $ + describe "render" $ do it "sort of works" $ - fmap URI.render mkTestURI `shouldReturn` - "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + fmap URI.render mkTestURI `shouldReturn` testURI + context "when URI has absolute path" $ + it "escapes colon properly in first path piece" $ + (URI.render <$> URI.mkURI "/docu:ment.html") + `shouldReturn` "/docu:ment.html" + context "when URI has relative path" $ + it "escapes colon properly in first path piece" $ + (URI.render <$> URI.mkURI "docu%3ament.html") + `shouldReturn` "docu%3ament.html" describe "renderBs" $ it "sort of works" $ - fmap URI.renderBs mkTestURI `shouldReturn` - "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + fmap URI.renderBs mkTestURI `shouldReturn` testURI describe "renderStr" $ it "sort of works" $ - fmap URI.renderStr mkTestURI `shouldReturn` - "https://mark:secret@github.com:443/mrkkrp/modern-uri?foo=bar#fragment" + fmap URI.renderStr mkTestURI `shouldReturn` testURI ---------------------------------------------------------------------------- -- Helpers @@ -183,16 +197,16 @@ mkTestURI :: IO URI mkTestURI = do scheme <- URI.mkScheme "https" - username <- URI.mkUsername "mark" - password <- URI.mkPassword "secret" + username <- URI.mkUsername "mark:@" + password <- URI.mkPassword "secret:@" host <- URI.mkHost "github.com" - path <- mapM URI.mkPathPiece ["mrkkrp", "modern-uri"] - k <- URI.mkQueryKey "foo" - v <- URI.mkQueryValue "bar" - fragment <- URI.mkFragment "fragment" + path <- mapM URI.mkPathPiece ["mrkkrp", "modern-uri:@"] + k <- URI.mkQueryKey "foo:@" + v <- URI.mkQueryValue "bar:@" + fragment <- URI.mkFragment "fragment:@" return URI { uriScheme = Just scheme - , uriAuthority = Just URI.Authority + , uriAuthority = Right URI.Authority { URI.authUserInfo = Just URI.UserInfo { URI.uiUsername = username , URI.uiPassword = Just password } @@ -201,6 +215,11 @@ , uriPath = 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%3a%40@github.com:443/mrkkrp/modern-uri:@?foo:@=bar:@#fragment:@" -- | A utility wrapper around 'URI.parser'.