modern-uri 0.0.2.0 → 0.1.0.0
raw patch · 10 files changed
+136/−88 lines, 10 files
Files
- CHANGELOG.md +11/−0
- README.md +0/−33
- Text/URI.hs +1/−0
- Text/URI/Lens.hs +12/−1
- Text/URI/Parser/ByteString.hs +17/−12
- Text/URI/Parser/Text.hs +15/−11
- Text/URI/Render.hs +28/−12
- Text/URI/Types.hs +16/−2
- modern-uri.cabal +1/−1
- tests/Text/URISpec.hs +35/−16
CHANGELOG.md view
@@ -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
README.md view
@@ -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:
Text/URI.hs view
@@ -25,6 +25,7 @@ URI (..) , mkURI , makeAbsolute+ , isPathAbsolute , Authority (..) , UserInfo (..) , QueryParam (..)
Text/URI/Lens.hs view
@@ -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.
Text/URI/Parser/ByteString.hs view
@@ -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]
Text/URI/Parser/Text.hs view
@@ -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]
Text/URI/Render.hs view
@@ -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
Text/URI/Types.hs view
@@ -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'.
modern-uri.cabal view
@@ -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
tests/Text/URISpec.hs view
@@ -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'.