modern-uri 0.1.2.1 → 0.2.0.0

raw patch · 13 files changed

+353/−78 lines, 13 filesdep +mtldep +reflectiondep +taggeddep ~exceptionsdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, reflection, tagged

Dependency ranges changed: exceptions, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• LICENSE.md +1/−1
• README.md +9/−9
• Text/URI.hs +75/−1
• Text/URI/Lens.hs +26/−6
• Text/URI/Parser/ByteString.hs +18/−6
• Text/URI/Parser/Text.hs +18/−6
• Text/URI/Parser/Text/Utils.hs +1/−1
• Text/URI/QQ.hs +1/−1
• Text/URI/Render.hs +82/−38
• Text/URI/Types.hs +19/−6
• modern-uri.cabal +7/−2
• tests/Text/URISpec.hs +85/−1

@@ -1,3 +1,14 @@+## Modern URI 0.2.0.0++* Changed the type of `uriPath` field of the `URI` record from `[RText+  'PathPiece]` to `Maybe (Bool, NonEmpty (RText 'PathPiece))`. This allows+  us to store whether there is a trailing slash in the path or not. See the+  updated documentation for more information.++* Added the `relativeTo` function.++* Added the `uriTrailingSlash` 0-1 traversal in `Text.URI.Lens`.+ ## Modern URI 0.1.2.1  * Allow Megaparsec 6.4.0.

@@ -1,4 +1,4 @@-Copyright © 2017 Mark Karpov+Copyright © 2017–2018 Mark Karpov  All rights reserved. 

@@ -66,7 +66,7 @@ λ> host <- URI.mkHost "markkarpov.com" λ> host "markkarpov.com"-λ> let uri = URI.URI (Just scheme) (Right (URI.Authority Nothing host Nothing)) [] [] Nothing+λ> let uri = URI.URI (Just scheme) (Right (URI.Authority Nothing host Nothing)) Nothing [] Nothing λ> uri URI   { uriScheme = Just "https"@@ -75,7 +75,7 @@         { authUserInfo = Nothing         , authHost = "markkarpov.com"         , authPort = Nothing })-  , uriPath = []+  , uriPath = Nothing   , uriQuery = []   , uriFragment = Nothing } ```@@ -101,7 +101,7 @@         { authUserInfo = Nothing         , authHost = "markkarpov.com"         , authPort = Nothing })-  , uriPath = []+  , uriPath = Nothing   , uriQuery = []   , uriFragment = Nothing } ```@@ -126,7 +126,7 @@         { authUserInfo = Nothing         , authHost = "markkarpov.com"         , authPort = Nothing })-  , uriPath = []+  , uriPath = Nothing   , uriQuery = []   , uriFragment = Nothing } ```@@ -189,10 +189,10 @@ * `renderStr` can be used to render to `String`. Sometimes it's handy. The   render uses difference lists internally so it's not that slow, but in   general I'd advise avoiding `String`s.-* `rederStr'` returns `ShowS`, which is just a synonym for `String ->-  String`—a function that prepends result of rendering to a given `String`.-  This is useful when the `URI` you want to render is a part of a bigger-  output, just like with the builders mentioned above.+* `renderStr'` returns `ShowS`, which is just a synonym for `String ->+  String`—a function that prepends the result of rendering to a given+  `String`. This is useful when the `URI` you want to render is a part of a+  bigger output, just like with the builders mentioned above.  Examples: @@ -216,6 +216,6 @@  ## License -Copyright © 2017 Mark Karpov+Copyright © 2017–2018 Mark Karpov  Distributed under BSD 3 clause license.

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -20,12 +20,17 @@ -- "Text.URI.QQ" for quasi-quoters for compile-time validation of URIs and -- refined text components. +{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}+ module Text.URI   ( -- * Data types     URI (..)   , mkURI   , makeAbsolute   , isPathAbsolute+  , relativeTo   , Authority (..)   , UserInfo (..)   , QueryParam (..)@@ -58,10 +63,15 @@   , renderStr' ) where +import Data.Either (isLeft)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isJust, isNothing)+import Data.Semigroup ((<>)) 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  -- $rtext --@@ -88,3 +98,67 @@ -- Rendering functions take care of constructing correct 'URI' -- representation as per RFC 3986, that is, percent-encoding will be applied -- when necessary automatically.++-- | @'relativeTo' reference base@ makes the @reference@ 'URI' absolute+-- resolving it against the @base@ 'URI'.+--+-- If the base 'URI' is not absolute itself (that is, it has no scheme),+-- this function returns 'Nothing'.+--+-- 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 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+          }++----------------------------------------------------------------------------+-- Helpers++-- | Remove dot segments from a path.++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)+      | unRText x == ".." = go (drop 1 out) xs (null xs || ts)+      | otherwise         = go (x:out)      xs ts

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Lens--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -9,15 +9,17 @@ -- -- Lenses for working with the 'URI' data type and its internals. -{-# LANGUAGE DataKinds  #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE TupleSections #-}  module Text.URI.Lens   ( uriScheme   , uriAuthority   , uriPath   , isPathAbsolute+  , uriTrailingSlash   , uriQuery   , uriFragment   , authUserInfo@@ -32,13 +34,15 @@   , unRText ) where +import Control.Applicative (liftA2) import Data.Foldable (find) import Data.Functor.Contravariant import Data.Maybe (isJust) import Data.Profunctor import Data.Text (Text) import Text.URI.Types (URI, Authority, UserInfo, QueryParam (..), RText, RTextLabel (..))-import qualified Text.URI.Types as URI+import qualified Data.List.NonEmpty as NE+import qualified Text.URI.Types     as URI  -- | 'URI' scheme lens. @@ -56,7 +60,11 @@ -- | 'URI' path lens.  uriPath :: Lens' URI [RText 'PathPiece]-uriPath f s = (\x -> s { URI.uriPath = x }) <$> f (URI.uriPath s)+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+    path = URI.uriPath s  -- | A getter that can tell if path component of a 'URI' is absolute. --@@ -64,6 +72,18 @@  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+  where+    ts = fst <$> path+    ps = snd <$> path+    path = URI.uriPath s  -- | 'URI' query params lens. 

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Parser.ByteString--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -22,9 +22,11 @@  import Control.Monad import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.State.Strict import Data.ByteString (ByteString) import Data.Char import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust, catMaybes, maybeToList) import Data.Text (Text) import Data.Void@@ -145,16 +147,26 @@   return UserInfo {..} {-# INLINE pUserInfo #-} -pPath :: MonadParsec e ByteString m => Bool -> m (Bool, [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]   absPath <- option False (True <$ char 47)-  path <- flip sepBy (char 47) . label "path piece" $-    many pchar-  pieces <- mapM (liftR mkPathPiece) (filter (not . null) path)-  return (absPath, pieces)+  (rawPieces, trailingSlash) <- flip runStateT False $+    flip sepBy (char 47) . label "path piece" $ do+      x <- many pchar+      put (null x)+      return x+  pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces)+  return+    ( absPath+    , case NE.nonEmpty pieces of+        Nothing -> Nothing+        Just ps -> Just (trailingSlash, ps)+    ) {-# INLINE pPath #-}  pQuery :: MonadParsec e ByteString m => m [QueryParam]

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Parser.Text--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -23,6 +23,8 @@  import Control.Monad import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.State.Strict+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust, catMaybes) import Data.Text (Text) import Data.Void@@ -98,16 +100,26 @@   return UserInfo {..} {-# INLINE pUserInfo #-} -pPath :: MonadParsec e Text m => Bool -> m (Bool, [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) $     (unexpected . Tokens . NE.fromList) "//"   absPath <- option False (True <$ char '/')-  path <- flip sepBy (char '/') . label "path piece" $-    many pchar-  pieces <- mapM (liftR mkPathPiece) (filter (not . null) path)-  return (absPath, pieces)+  (rawPieces, trailingSlash) <- flip runStateT False $+    flip sepBy (char '/') . label "path piece" $ do+      x <- many pchar+      put (null x)+      return x+  pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces)+  return+    ( absPath+    , case NE.nonEmpty pieces of+        Nothing -> Nothing+        Just ps -> Just (trailingSlash, ps)+    ) {-# INLINE pPath #-}  pQuery :: MonadParsec e Text m => m [QueryParam]

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Parser.Text.Utils--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.QQ--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Render--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -11,6 +11,7 @@  {-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE KindSignatures      #-} {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE MultiWayIf          #-}@@ -34,7 +35,10 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid import Data.Proxy+import Data.Reflection+import Data.Semigroup (Semigroup) import Data.String (IsString (..))+import Data.Tagged import Data.Text (Text) import Data.Word (Word8) import Numeric (showInt)@@ -42,6 +46,7 @@ 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@@ -60,8 +65,10 @@ -- | Render a given 'URI' value as a 'TLB.Builder'.  render' :: URI -> TLB.Builder-render' = genericRender TLB.decimal $-  TLB.fromText . percentEncode+render' x = equip+  TLB.decimal+  (TLB.fromText . percentEncode)+  (genericRender x)  -- | Render a given 'URI' value as a strict 'ByteString'. @@ -71,8 +78,10 @@ -- | Render a given 'URI' value as a 'BLB.Builder'.  renderBs' :: URI -> BLB.Builder-renderBs' = genericRender BLB.wordDec $-  BLB.byteString . TE.encodeUtf8 . percentEncode+renderBs' x = equip+  BLB.wordDec+  (BLB.byteString . TE.encodeUtf8 . percentEncode)+  (genericRender x)  -- | Render a given 'URI' value as a 'String'. --@@ -86,67 +95,102 @@ -- @since 0.0.2.0  renderStr' :: URI -> ShowS-renderStr' = toShowS . genericRender (DString . showInt)+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+  }++equip+  :: forall b. (Word -> b)+  -> (forall l. RLabel l => RText l -> b)+  -> (forall (s :: *). 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 = Tagged . rWord (reflect (Proxy :: Proxy s))++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 l. RLabel l => RText l -> b) -> a -> b-type R        b = (Monoid b, IsString b)+type Render a b = forall (s :: *).+  (Semigroup b, Monoid b, IsString b, Reifies s (Renders b))+  => a+  -> Tagged s b -genericRender :: R b => (Word -> b) -> Render URI b-genericRender d r uri@URI {..} = mconcat-  [ rJust (rScheme r) uriScheme-  , rJust (rAuthority d r) (either (const Nothing) Just uriAuthority)-  , rPath (isPathAbsolute uri) r uriPath-  , rQuery r uriQuery-  , rJust (rFragment r) uriFragment ]+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 ] {-# INLINE genericRender #-}  rJust :: Monoid m => (a -> m) -> Maybe a -> m rJust = maybe mempty -rScheme :: R b => Render (RText 'Scheme) b-rScheme r = (<> ":") . r+rScheme :: Render (RText 'Scheme) b+rScheme = (<> ":") . renderText {-# INLINE rScheme #-} -rAuthority :: R b => (Word -> b) -> Render Authority b-rAuthority d r Authority {..} = mconcat+rAuthority :: Render Authority b+rAuthority Authority {..} = mconcat   [ "//"-  , rJust (rUserInfo r) authUserInfo-  , r authHost-  , rJust ((":" <>) . d) authPort ]+  , rJust rUserInfo authUserInfo+  , renderText authHost+  , rJust ((":" <>) . renderWord) authPort ] {-# INLINE rAuthority #-} -rUserInfo :: R b => Render UserInfo b-rUserInfo r UserInfo {..} = mconcat-  [ r uiUsername-  , rJust ((":" <>) . r) uiPassword+rUserInfo :: Render UserInfo b+rUserInfo UserInfo {..} = mconcat+  [ renderText uiUsername+  , rJust ((":" <>) . renderText) uiPassword   , "@" ] {-# INLINE rUserInfo #-} -rPath :: R b => Bool -> Render [RText 'PathPiece] b-rPath isAbsolute r ps = leading <> other+rPath :: Bool -> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b+rPath isAbsolute path = leading <> other   where     leading = if isAbsolute then "/" else mempty-    other   = mconcat . intersperse "/" $ r <$> ps+    other =+      case path of+        Nothing -> mempty+        Just (trailingSlash, ps) ->+          (mconcat . intersperse "/" . fmap renderText . NE.toList) ps+          <> if trailingSlash then "/" else mempty {-# INLINE rPath #-} -rQuery :: R b => Render [QueryParam] b-rQuery r = \case+rQuery :: Render [QueryParam] b+rQuery = \case   [] -> mempty-  qs -> "?" <> mconcat (intersperse "&" (rQueryParam r <$> qs))+  qs -> "?" <> mconcat (intersperse "&" (rQueryParam <$> qs)) {-# INLINE rQuery #-} -rQueryParam :: R b => Render QueryParam b-rQueryParam r = \case-  QueryFlag flag -> r flag-  QueryParam k v -> r k <> "=" <> r v+rQueryParam :: Render QueryParam b+rQueryParam = \case+  QueryFlag flag -> renderText flag+  QueryParam k v -> renderText k <> "=" <> renderText v {-# INLINE rQueryParam #-} -rFragment :: R b => Render (RText 'Fragment) b-rFragment r = ("#" <>) . r+rFragment :: Render (RText 'Fragment) b+rFragment = ("#" <>) . renderText {-# INLINE rFragment #-}  ----------------------------------------------------------------------------

@@ -1,6 +1,6 @@ -- | -- Module      :  Text.URI.Types--- Copyright   :  © 2017 Mark Karpov+-- Copyright   :  © 2017–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -18,6 +18,7 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}  module Text.URI.Types   ( -- * Data types@@ -51,6 +52,7 @@ import Data.Char import Data.Data (Data) import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Proxy import Data.Text (Text)@@ -59,11 +61,12 @@ import Data.Word (Word8, Word16) import GHC.Generics import Numeric (showInt, showHex)-import Test.QuickCheck hiding (label)+import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Char import Text.URI.Parser.Text.Utils (pHost)-import qualified Data.Text as T+import qualified Data.List.NonEmpty as NE+import qualified Data.Text          as T  ---------------------------------------------------------------------------- -- Data types@@ -83,8 +86,13 @@     --     -- __Note__: before version /0.1.0.0/ type of 'uriAuthority' was     -- @'Maybe' 'Authority'@-  , uriPath :: [RText 'PathPiece]-    -- ^ Path+  , uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))+    -- ^ '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     -- of query string, so we deconstruct it following RFC 1866 here@@ -96,7 +104,9 @@   arbitrary = URI     <$> arbitrary     <*> arbitrary-    <*> arbitrary+    <*> (do mpieces <- NE.nonEmpty <$> arbitrary+            trailingSlash <- arbitrary+            return ((trailingSlash,) <$> mpieces))     <*> arbitrary     <*> arbitrary @@ -328,6 +338,9 @@  instance Arbitrary (RText 'PathPiece) where   arbitrary = arbText' mkPathPiece++instance Arbitrary (NonEmpty (RText 'PathPiece)) where+  arbitrary = (:|) <$> arbitrary <*> arbitrary  -- | Lift a 'Text' value into @'RText 'QueryKey'@. --

@@ -1,5 +1,5 @@ name:                 modern-uri-version:              0.1.2.1+version:              0.2.0.0 cabal-version:        >= 1.18 tested-with:          GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 license:              BSD3@@ -33,7 +33,10 @@                     , deepseq          >= 1.3 && < 1.5                     , exceptions       >= 0.6 && < 0.9                     , megaparsec       >= 6.0 && < 7.0-                    , profunctors      >=5.2.1 && < 6.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.13                     , text             >= 0.2 && < 1.3   if !impl(ghc >= 8.0)@@ -64,6 +67,8 @@                     , megaparsec       >= 6.0 && < 7.0                     , modern-uri                     , text             >= 0.2 && < 1.3+  if !impl(ghc >= 8.0)+    build-depends:    semigroups       == 0.18.*   other-modules:      Text.URISpec   if flag(dev)     ghc-options:      -Wall -Werror

@@ -3,8 +3,11 @@  module Text.URISpec (spec) where +import Control.Monad import Data.ByteString (ByteString)+import Data.List.NonEmpty (fromList) import Data.Maybe (isNothing, isJust)+import Data.Monoid ((<>)) import Data.String (IsString (..)) import Data.Text (Text) import Data.Void@@ -188,6 +191,32 @@   describe "renderStr" $     it "sort of works" $       fmap URI.renderStr mkTestURI `shouldReturn` testURI+  describe "relativeTo" $ do+    let testResolution r e = do+          base      <- URI.mkURI "http://a/b/c/d;p?q"+          reference <- URI.mkURI r+          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+    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" $+          testResolution "http:g" "http:g"+      context "when the scheme is different from the scheme of base URI" $+        it "reference URI is preserved intact" $+          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+    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  ---------------------------------------------------------------------------- -- Helpers@@ -212,7 +241,7 @@         , URI.uiPassword = Just password }       , URI.authHost = host       , URI.authPort = Just 443 }-    , uriPath = path+    , uriPath = Just (False, fromList path)     , uriQuery = [URI.QueryParam k v]     , uriFragment = Just fragment } @@ -263,3 +292,58 @@       "the parser is expected to succeed, but it failed with:\n" ++       parseErrorPretty' s 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")+    -- Abnormal cases+  , ("../../../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")+    -- 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")+    -- 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")+  ]