dormouse-uri 0.1.0.1 → 0.2.0.0

raw patch · 11 files changed

+244/−304 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−1
• dormouse-uri.cabal +2/−2
• src/Dormouse/Uri.hs +6/−1
• src/Dormouse/Uri/Parser.hs +82/−107
• src/Dormouse/Uri/QQ.hs +16/−0
• src/Dormouse/Uri/RFC3986.hs +4/−9
• src/Dormouse/Uri/Types.hs +30/−42
• src/Dormouse/Url.hs +1/−2
• test/Dormouse/Generators/UriComponents.hs +25/−67
• test/Dormouse/Uri/ParserSpec.hs +66/−69
• test/Dormouse/Uri/QQSpec.hs +4/−4

@@ -1,3 +1,10 @@-# Changelog for dormouse+# Changelog for dormouse-uri++## v0.2.0.0++- Uri type no longer includes Relative References+- New UriReference type can hold Uri or Relative References+- New QuasiQuoter for UriReference+- Use of Username/Password are removed as this usage is deprecated as per RFC 3986, UserInfo type is now used instead  ## Unreleased changes

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d508cc2541c26dac72e00ed351d5551d186ecc83c31bfaa78e30d2a5a0962e63+-- hash: b8a506a500d16ae04b32a32f96f93aa0b0c0993f219d0beed44057eda0b8f0c7  name:           dormouse-uri-version:        0.1.0.1+version:        0.2.0.0 synopsis:       Library for type-safe representations of Uri/Urls description:    Dormouse-Uri provides type safe handling of `Uri`s and `Url`s.                 .

@@ -6,6 +6,7 @@ module Dormouse.Uri   ( module Dormouse.Uri.Types   , parseUri+  , parseUriRef   ) where  import Control.Exception.Safe (MonadThrow, throw)@@ -16,6 +17,10 @@ import Dormouse.Uri.Parser import Dormouse.Uri.Types --- | Parse an ascii 'ByteString' as an absolute uri, throwing a 'UriException' in @m@ if this fails+-- | Parse an ascii 'ByteString' as a  uri, throwing a 'UriException' in @m@ if this fails parseUri :: MonadThrow m => SB.ByteString -> m Uri parseUri bs = either (throw . UriException . T.pack) return $ parseOnly pUri bs++-- | Parse an ascii 'ByteString' as a uri reference, throwing a 'UriException' in @m@ if this fails+parseUriRef :: MonadThrow m => SB.ByteString -> m UriReference+parseUriRef bs = either (throw . UriException . T.pack) return $ parseOnly pUriRef bs

@@ -4,11 +4,9 @@  module Dormouse.Uri.Parser   ( pUri-  , pAbsoluteUri+  , pUriRef   , pRelativeUri   , pScheme-  , pUsername-  , pPassword   , pUserInfo   , pIPv4   , pRegName@@ -20,69 +18,68 @@   , pPathRel   , pQuery   , pFragment+  , percentDecode   ) where +import Data.Word ( Word8 )  import Control.Applicative ((<|>)) import Data.Attoparsec.ByteString.Char8 as A-import Data.Char as C-import Data.Bits (Bits, shiftL, (.|.))+import qualified Data.Attoparsec.ByteString as AB+import qualified Data.ByteString.Internal as BS (c2w, w2c)+import Data.Bits (shiftL, (.|.)) import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Dormouse.Uri.Types import Dormouse.Uri.RFC3986 import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8 -repack :: String -> T.Text-repack = TE.decodeUtf8 . B8.pack- pMaybe :: Parser a -> Parser (Maybe a) pMaybe p = option Nothing (Just <$> p)  pAsciiAlpha :: Parser Char pAsciiAlpha = satisfy isAsciiAlpha -pAsciiAlphaNumeric :: Parser Char-pAsciiAlphaNumeric = satisfy isAsciiAlphaNumeric--pSubDelim :: Parser Char-pSubDelim = satisfy isSubDelim--pUnreserved :: Parser Char-pUnreserved = satisfy isUnreserved+data PDState = Percent | Hex1 Word8 | Other | PDError -pSizedHexadecimal :: (Integral a, Bits a) => Int -> Parser a-pSizedHexadecimal n = do-    bytes <- A.take n-    if B.all isHexDigit' bytes then return $ B.foldl' step 0 $ bytes else fail "pSizedHexadecimal"-  where +percentDecode :: B.ByteString -> Maybe B.ByteString+percentDecode xs =+  if B.elem 37 xs then+    case B.foldl' f (B.empty, Other) xs of+      (_, PDError)  -> Nothing +      (bs, _)       -> Just bs+  else +    Just xs+  where+    f (es, Percent) e                                     = (es, Hex1 e)+    f (es, Hex1 e1) e2 | isHexDigit' e1 && isHexDigit' e2 = (B.snoc es (hexToWord8 e1 `shiftL` 4 .|. hexToWord8 e2), Other)+    f (es, Hex1 _)  _                                     = (es, PDError)+    f (es, Other)   37                                    = (es, Percent)+    f (es, Other)   e                                     = (B.snoc es e, Other)+    f (es, PDError) _                                     = (es, PDError)+    hexToWord8 w | w >= 48 && w <= 57 = fromIntegral (w - 48)+                 | w >= 97            = fromIntegral (w - 87)+                 | otherwise          = fromIntegral (w - 55)     isHexDigit' w = (w >= 48 && w <= 57) ||  (w >= 97 && w <= 102) ||(w >= 65 && w <= 70)-    step a w | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)-             | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)-             | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55) -pPercentEnc :: Parser Char-pPercentEnc = do-  _ <- char '%'-  hexdig1 <- pSizedHexadecimal 1-  hexdig2 <- pSizedHexadecimal 1-  return . chr $ hexdig1 * 16 + hexdig2+takeWhileW8 :: (Char -> Bool) -> Parser B.ByteString +takeWhileW8 f = AB.takeWhile (f . BS.w2c) -pUsername :: Parser Username-pUsername = do-  xs <- many1' (satisfy isUsernameChar <|> pPercentEnc)-  return $ Username (repack xs)+takeWhile1W8 :: (Char -> Bool) -> Parser B.ByteString +takeWhile1W8 f = AB.takeWhile1 (f . BS.w2c) -pPassword :: Parser Password-pPassword = do-  xs <- many1' (satisfy isPasswordChar <|> pPercentEnc)-  return $ Password (repack xs)+pUserInfo :: Parser UserInfo+pUserInfo = do+  xs <- takeWhileW8 (\x -> isUserInfoChar x || x == '%')+  xs' <- maybe (fail "Failed to percent-decode") pure $ percentDecode xs+  _ <- char '@'+  return $ UserInfo (TE.decodeUtf8 xs')  pRegName :: Parser T.Text pRegName = do-  xs <- many1' (satisfy isRegNameChar <|> pPercentEnc)-  return . repack $ xs+  xs <- takeWhileW8 (\x -> isRegNameChar x || x == '%')+  xs' <- maybe (fail "Failed to percent-decode") pure $ percentDecode xs+  return . TE.decodeUtf8 $ xs'  pIPv4 :: Parser T.Text pIPv4 = do@@ -102,16 +99,9 @@  pHost :: Parser Host pHost = do-  hostText <- pIPv4 <|> pRegName+  hostText <- pRegName <|> pIPv4   return . Host  $ hostText -pUserInfo :: Parser UserInfo-pUserInfo = do-  username <- pUsername-  password <- pMaybe (char ':' *> pPassword)-  _ <- char '@'-  return $ UserInfo { userInfoUsername = username, userInfoPassword = password }- pPort :: Parser Int pPort =    (char ':' *> decimal) >>= \case@@ -130,78 +120,62 @@     _                                         -> fail "Invalid authority termination character, must be /, ?, # or end of input"   return Authority { authorityUserInfo = authUserInfo, authorityHost = authHost, authorityPort = authPort} -pPathChar :: Parser Char -pPathChar = satisfy isPathChar <|> pPercentEnc--pPathCharNc :: Parser Char -pPathCharNc = satisfy isPathCharNoColon <|> pPercentEnc--pSegmentNz :: Parser PathSegment -pSegmentNz = PathSegment . repack <$> many1' pPathChar--pSegmentNzNc :: Parser PathSegment -pSegmentNzNc = PathSegment . repack <$> many1' pPathCharNc--pSegment :: Parser PathSegment-pSegment = PathSegment . repack <$> many' pPathChar--pPathsAbEmpty :: Parser [PathSegment]-pPathsAbEmpty = many1' (char '/' *> pSegment)--pPathsAbsolute :: Parser [PathSegment]-pPathsAbsolute = do-  _ <- char '/'-  seg <- pSegmentNz-  comps <- many' (char '/' *> pSegment)-  return $ seg : comps--pPathsNoScheme :: Parser [PathSegment]-pPathsNoScheme = do-  seg <- pSegmentNzNc-  comps <- many' (char '/' *> pSegment)-  return $ seg : comps--pPathsRootless :: Parser [PathSegment]-pPathsRootless = do-  seg <- pSegmentNz-  comps <- many' (char '/' *> pSegment)-  return $ seg : comps--pPathsEmpty :: Parser [PathSegment]-pPathsEmpty = return []--pPathAbsAuth :: Parser (Path 'Absolute)-pPathAbsAuth = fmap Path (pPathsAbEmpty <|> pPathsAbsolute <|> pPathsEmpty)+pPathAbsAuth :: Parser (Path rt)+pPathAbsAuth = do+  p <- takeWhileW8 (\x -> isPathChar x || x == '%' || x == '/')+  p' <- maybe (fail "Failed to percent-decode") pure $ percentDecode p+  let ps = PathSegment <$> T.split (== '/') (TE.decodeUtf8 p')+  case ps of -- begins with "/" is empty+    (PathSegment x):xs | T.null x -> return $ Path xs+    (PathSegment _):_             -> fail "must begin with /"+    xs                            -> return $ Path xs  pPathAbsNoAuth :: Parser (Path 'Absolute)-pPathAbsNoAuth = fmap Path (pPathsAbsolute <|> pPathsRootless <|> pPathsEmpty)+pPathAbsNoAuth = do+  p <- takeWhileW8 (\x -> isPathChar x || x == '%' || x == '/')+  p' <- maybe (fail "Failed to percent-decode") pure $ percentDecode p+  let ps = PathSegment <$> T.split (== '/') (TE.decodeUtf8 p')+  case ps of -- begins with "/" but not "//" OR begins with segment OR empty+    (PathSegment x1):(PathSegment x2):_ | T.null x1 && T.null x2 -> fail "cannot begin with //"+    (PathSegment x):xs                  | T.null x               -> return $ Path xs+    xs                                                           -> return $ Path xs  pPathRel :: Parser (Path 'Relative)-pPathRel = fmap Path (pPathsAbsolute <|> pPathsNoScheme <|> pPathsEmpty)+pPathRel = do+  p <- takeWhileW8 (\x -> isPathChar x || x == '%' || x == '/')+  p' <- maybe (fail "Failed to percent-decode") pure $ percentDecode p+  let ps = PathSegment <$> T.split (== '/') (TE.decodeUtf8 p')+  case ps of+    (PathSegment x1):(PathSegment x2):_ | T.null x1 && T.null x2 -> fail "cannot begin with //"+    (PathSegment x):_                   | T.isPrefixOf ":" x     -> fail "first character of a relative path cannot be :"+    (PathSegment x):xs                  | T.null x               -> return $ Path xs+    xs                                                           -> return $ Path xs  pQuery :: Parser Query pQuery = do-  queryText <- (char '?' *> (many1' (satisfy isQueryChar <|> pPercentEnc)))+  qt <- char '?' *> takeWhile1W8 (\x -> isQueryChar x || x == '%')+  queryText <- maybe (fail "Failed to percent-decode") pure $ percentDecode qt   _ <- peekChar >>= \case     Nothing           -> return ()     Just c | c == '#' -> return ()     c                 -> fail $ "Invalid query termination character: " <> show c <> ", must be # or end of input"-  return . Query . repack $ queryText+  return . Query . TE.decodeUtf8 $ queryText  pFragment :: Parser Fragment pFragment = do-  fragmentText <- (char '#' *> (many1' (satisfy isFragmentChar <|> pPercentEnc)))+  ft <- char '#' *> takeWhile1W8 (\x -> isFragmentChar x || x == '%')+  fragmentText <- maybe (fail "Failed to percent-decode") pure $ percentDecode ft   _ <- peekChar >>= \case     Nothing           -> return ()     c                 -> fail $ "Invalid fragment termination character: " <> show c <> ", must be end of input"-  return . Fragment . repack $ fragmentText+  return . Fragment . TE.decodeUtf8 $ fragmentText  pScheme :: Parser Scheme pScheme = do   x <- pAsciiAlpha-  xs <- many' (pAsciiAlphaNumeric <|> char '+' <|> char '.' <|> char '-' )+  xs <- A.takeWhile isSchemeChar   _ <- char ':'-  return $ Scheme (T.toLower . repack $ x:xs)+  return $ Scheme (T.toLower . TE.decodeUtf8 $ B.cons (BS.c2w x) xs)  pAbsolutePart :: Parser (Scheme, Maybe Authority) pAbsolutePart = do@@ -209,22 +183,23 @@   authority <- pMaybe pAuthority   return (scheme, authority) -pRelativeUri :: Parser Uri+pRelativeUri :: Parser RelRef pRelativeUri = do-  path <- pPathRel+  authority <- pMaybe pAuthority+  path <- if isJust authority then pPathAbsAuth else pPathRel   query <- pMaybe pQuery   fragment <- pMaybe pFragment   _ <- endOfInput-  return $ RelativeUri $ RelUri { uriPath = path, uriQuery = query, uriFragment = fragment }+  return  $ RelRef { relRefAuthority = authority, relRefPath = path, relRefQuery = query, relRefFragment = fragment } -pAbsoluteUri :: Parser Uri-pAbsoluteUri = do+pUri :: Parser Uri+pUri = do   (scheme, authority) <- pAbsolutePart   path <- if isJust authority then pPathAbsAuth else pPathAbsNoAuth   query <- pMaybe pQuery   fragment <- pMaybe pFragment   _ <- endOfInput-  return $ AbsoluteUri $ AbsUri {uriScheme = scheme, uriAuthority = authority, uriPath = path, uriQuery = query, uriFragment = fragment }+  return $ Uri {uriScheme = scheme, uriAuthority = authority, uriPath = path, uriQuery = query, uriFragment = fragment } -pUri :: Parser Uri-pUri = pAbsoluteUri <|> pRelativeUri+pUriRef :: Parser UriReference+pUriRef = (AbsoluteUri <$> pUri) <|> (RelativeRef <$> pRelativeUri)

@@ -4,6 +4,7 @@  module Dormouse.Uri.QQ   ( uri+  , uriRef   ) where    import Data.ByteString.Char8 (pack)@@ -22,6 +23,21 @@       case parseUri (pack s) of         Left err -> fail $ show err         Right x  -> appE [|(==)|] [| (x :: Uri) |] `viewP` [p|True|]+  , quoteType = error "Not supported"+  , quoteDec =error "Not supported"+  }++uriRef :: QuasiQuoter+uriRef = QuasiQuoter +  { quoteExp = \s -> +      let res = parseUriRef $ pack s in+      case res of+        Left err -> fail $ show err+        Right x -> [| x :: UriReference |]+  , quotePat = \s ->+      case parseUriRef (pack s) of+        Left err -> fail $ show err+        Right x  -> appE [|(==)|] [| (x :: UriReference) |] `viewP` [p|True|]   , quoteType = error "Not supported"   , quoteDec =error "Not supported"   }

@@ -6,8 +6,7 @@   , isAsciiAlphaNumeric   , isUnreserved   , isSchemeChar-  , isUsernameChar-  , isPasswordChar+  , isUserInfoChar   , isRegNameChar   , isPathChar   , isPathCharNoColon@@ -45,13 +44,9 @@ isSchemeChar :: Char -> Bool isSchemeChar c = isAsciiAlphaNumeric c || c == '+' || c == '.' || c == '-' --- | Checks whether a char is a valid username char in RFC3986-isUsernameChar :: Char -> Bool-isUsernameChar c = isUnreserved c || isSubDelim c---- | Checks whether a char is a valid password char in RFC3986-isPasswordChar :: Char -> Bool-isPasswordChar c = isUnreserved c || isSubDelim c || c == ':'+-- | Checks whether a char is a valid user info char in RFC3986+isUserInfoChar :: Char -> Bool+isUserInfoChar c = isUnreserved c || isSubDelim c || c == ':'  -- | Checks whether a char is a valid reg-name char in RFC3986 isRegNameChar :: Char -> Bool

@@ -5,7 +5,7 @@ {-# LANGUAGE DeriveLift #-}  module Dormouse.Uri.Types-  ( UriReference(..)+  ( UriReferenceType(..)   , Authority(..)   , Fragment(..)   , Host(..)@@ -13,43 +13,30 @@   , PathSegment(..)   , Query(..)   , Scheme(..)-  , Username(..)-  , Password(..)   , UserInfo(..)   , Uri(..)-  , AbsUri(..)-  , RelUri(..)+  , RelRef(..)+  , UriReference(..)   ) where  import Data.String (IsString(..)) import qualified Data.List as L import Data.Text (Text, unpack, pack)+import qualified Data.Text as T import Language.Haskell.TH.Syntax (Lift(..)) --- | The Username subcomponent of a URI UserInfo-newtype Username = Username { unUsername :: Text } deriving (Eq, Lift)--instance Show Username where-  show username = unpack $ unUsername username--instance IsString Username where-  fromString s = Username $ pack s---- | The Password subcomponent of a URI UserInfo-newtype Password = Password { unPassword :: Text } deriving (Eq, Lift)--instance Show Password where-  show _ = "****"--instance IsString Password where-  fromString s = Password $ pack s- -- | The UserInfo subcomponent of a URI Authority-data UserInfo = UserInfo -  { userInfoUsername :: Username-  , userInfoPassword :: Maybe Password-  } deriving (Eq, Show, Lift)+newtype UserInfo = UserInfo +  { unUserInfo :: Text+  } deriving (Eq, Lift) +instance Show UserInfo where+  show userInfo = -- applications should not render as clear text anything after the first colon+    case T.split (==':') $ unUserInfo userInfo of +      [] -> ""+      [x] -> unpack x+      x:_ -> unpack x <> ":****"+ -- | The Host subcomponent of a URI Authority newtype Host = Host { unHost :: Text } deriving (Eq, Lift) @@ -75,10 +62,10 @@ instance Show Fragment where   show fragment = unpack $ unFragment fragment -data UriReference = Absolute | Relative+data UriReferenceType = Absolute | Relative  -- | The Path component of a URI, including a series of individual Path Segments-newtype Path (ref :: UriReference) = Path { unPath :: [PathSegment]} deriving (Eq, Lift)+newtype Path (ref :: UriReferenceType) = Path { unPath :: [PathSegment]} deriving (Eq, Lift)  instance Show (Path ref) where   show path = "[" <> L.intercalate "," (fmap show . unPath $ path) <> "]"@@ -107,8 +94,9 @@ instance Show Scheme where   show scheme = unpack . unScheme $ scheme --- | The data associated with an Absolute URI-data AbsUri = AbsUri+-- | A Uniform Resource Identifier (URI) is a compact sequence of characters that identifies an abstract or physical resource.+-- It is defined according to RFC 3986 (<https://tools.ietf.org/html/rfc3986>).+data Uri = Uri   { uriScheme :: Scheme   , uriAuthority :: Maybe Authority   , uriPath :: Path 'Absolute@@ -116,19 +104,19 @@   , uriFragment :: Maybe Fragment   } deriving (Eq, Show, Lift) --- | The data associated with a Relative URI-data RelUri = RelUri-  { uriPath :: Path 'Relative-  , uriQuery :: Maybe Query-  , uriFragment :: Maybe Fragment+-- | The data associated with a URI Relative Reference+data RelRef = RelRef+  { relRefAuthority :: Maybe Authority+  , relRefPath :: Path 'Relative+  , relRefQuery :: Maybe Query+  , relRefFragment :: Maybe Fragment   } deriving (Eq, Show, Lift) --- | A Uniform Resource Identifier (URI) is a compact sequence of characters that identifies an abstract or physical resource.--- It is defined according to RFC 3986 (<https://tools.ietf.org/html/rfc3986>).  URIs can be absolute (i.e. defined against a--- specific scheme) or relative.-data Uri -  = AbsoluteUri AbsUri-  | RelativeUri RelUri+-- | A URI-reference is either a URI or a relative reference.  If the URI-reference's prefix does not match the syntax of a scheme +-- followed by its colon separator, then the URI-reference is a relative reference.+data UriReference +  = AbsoluteUri Uri+  | RelativeRef RelRef   deriving (Lift, Eq, Show)  

@@ -33,13 +33,12 @@  -- | Ensure that the supplied Uri is a Url ensureUrl :: MonadThrow m => Uri -> m AnyUrl-ensureUrl (AbsoluteUri AbsUri {uriScheme = scheme, uriAuthority = maybeAuthority, uriPath = path, uriQuery = query, uriFragment = fragment}) = do+ensureUrl Uri {uriScheme = scheme, uriAuthority = maybeAuthority, uriPath = path, uriQuery = query, uriFragment = fragment} = do   authority <- maybe (throw $ UrlException "Supplied Url had no authority component") return maybeAuthority   case unScheme scheme of     "http"  -> return $ AnyUrl $ HttpUrl UrlComponents { urlAuthority = authority, urlPath = path, urlQuery = query, urlFragment = fragment }     "https" -> return $ AnyUrl $ HttpsUrl UrlComponents { urlAuthority = authority, urlPath = path, urlQuery = query, urlFragment = fragment }     s       -> throw $ UrlException ("Supplied Url had a scheme of " <> T.pack (show s) <> " which was not http or https.")-ensureUrl (RelativeUri _) = throw $ UrlException "Supplied Uri was a relative Uri - it must provide a scheme and authority to be considered a valid url"  -- | Parse an ascii 'ByteString' as a url, throwing a 'UriException' in @m@ if this fails parseUrl :: MonadThrow m => SB.ByteString -> m AnyUrl

@@ -3,10 +3,6 @@ module Dormouse.Generators.UriComponents    ( genValidScheme   , genInvalidScheme-  , genValidUsername-  , genInvalidUsername-  , genValidPassword-  , genInvalidPassword   , genValidUserInfo   , genInvalidUserInfo   , genValidIPv4@@ -19,13 +15,13 @@   , genValidPathRel   , genValidQuery   , genValidFragment-  , genValidAbsoluteUri+  , genValidUri+  , genValidUriRef   )   where  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8-import Data.ByteString.Internal (c2w, w2c) import qualified Data.Char as C import qualified Data.Text as T import Dormouse.Uri.Encode@@ -76,70 +72,21 @@         _                   -> first : remainder ++ [':']   return $ B8.pack finalBs -genUsernameChar :: Gen B.ByteString-genUsernameChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isUsernameChar Gen.ascii)]--genValidUsername :: Gen B.ByteString-genValidUsername = do-  list <- Gen.list (Range.constant 1 20) genUsernameChar-  return $ B.intercalate "" list--genInvalidUsername :: Gen B.ByteString-genInvalidUsername = do-  invalids <- Gen.list (Range.constant 1 5) genInvalidUsernameChar-  valids <- Gen.list (Range.constant 0 15) genUsernameChar-  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids-  where-    genInvalidUsernameChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isUsernameChar x) && x /= '%'  && C.isPrint x) Gen.ascii--genPasswordChar :: Gen B.ByteString-genPasswordChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPasswordChar Gen.ascii)]--genValidPassword :: Gen B.ByteString-genValidPassword = do-  list <- Gen.list (Range.constant 1 20) genPasswordChar-  return $ B.intercalate "" list--genInvalidPassword :: Gen B.ByteString-genInvalidPassword = do-  invalids <- Gen.list (Range.constant 1 5) genInvalidPasswordChar-  valids <- Gen.list (Range.constant 0 15) genPasswordChar-  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids-  where-    genInvalidPasswordChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isPasswordChar x) && x /= '%' && C.isPrint x) Gen.ascii+genUserInfoChar :: Gen B.ByteString+genUserInfoChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isUserInfoChar Gen.ascii)]  genValidUserInfo :: Gen B.ByteString genValidUserInfo = do-  username <- genValidUsername-  maybePassword <- Gen.maybe genValidPassword-  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword-  return $ B.append (B.append username passwordSuffix) "@"--data UserInfoFailureMode -  = InvalidUsername-  | InvalidPassword-  | MissingAtSuffix--userInfoFailureMode :: Int -> UserInfoFailureMode-userInfoFailureMode 1 = InvalidUsername-userInfoFailureMode 2 = InvalidPassword-userInfoFailureMode 3 = MissingAtSuffix-userInfoFailureMode _ = undefined+  list <- Gen.list (Range.constant 1 20) genUserInfoChar+  return $ B.append (B.intercalate "" list) "@"  genInvalidUserInfo :: Gen B.ByteString genInvalidUserInfo = do-  failureMode <- fmap userInfoFailureMode $ Gen.element [1..3]-  username <- case failureMode of-    InvalidUsername -> Gen.filter (B.all (\x -> w2c x /= ':')) genInvalidUsername -- if the username is supposed to be invalid, ensure that ':' is not present, otherwise the user info could be interpreted as valid if valid chars precede the ':'-    _               -> genValidUsername-  maybePassword <- case failureMode of -    InvalidPassword -> fmap Just genInvalidPassword-    _               -> Gen.maybe $ genValidPassword-  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword-  let complete = case failureMode of-        MissingAtSuffix -> B.append (B.append username passwordSuffix) "#"-        _               -> B.append (B.append username passwordSuffix) "@"-  return complete+  invalids <- Gen.list (Range.constant 1 5) genInvalidUserInfoChar+  valids <- Gen.list (Range.constant 0 15) genUserInfoChar+  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids+  where+    genInvalidUserInfoChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isUserInfoChar x) && x /= '%' && C.isPrint x) Gen.ascii  genValidIPv4 :: Gen B.ByteString genValidIPv4 = do@@ -208,7 +155,7 @@ genValidPathsEmpty = return B.empty  genValidPathAbsAuth :: Gen B.ByteString-genValidPathAbsAuth = Gen.choice [genPathsAbEmpty, genPathsAbsolute, genValidPathsEmpty]+genValidPathAbsAuth = Gen.choice [genPathsAbEmpty]  genValidPathAbsNoAuth :: Gen B.ByteString genValidPathAbsNoAuth = Gen.choice [genPathsAbsolute, genPathsRootless, genValidPathsEmpty]@@ -232,8 +179,8 @@   list <- Gen.list (Range.constant 1 50) genFragmentChar   return $ B.append "#" $ B.intercalate "" list -genValidAbsoluteUri :: Gen B.ByteString-genValidAbsoluteUri = do+genValidUri :: Gen B.ByteString+genValidUri = do   scheme <- genValidScheme   authority <- Gen.maybe genValidAuthority   path <- case authority of@@ -243,4 +190,15 @@   fragment <- Gen.maybe genValidFragment   return . B.intercalate "" $ [scheme, maybe B.empty id authority, path, maybe B.empty id query, maybe B.empty id fragment] +genValidRelRef :: Gen B.ByteString+genValidRelRef = do+  authority <- Gen.maybe genValidAuthority+  path <- case authority of+    Just _  -> genValidPathAbsAuth+    Nothing -> genValidPathRel+  query <- Gen.maybe genValidQuery+  fragment <- Gen.maybe genValidFragment+  return . B.intercalate "" $ [maybe B.empty id authority, path, maybe B.empty id query, maybe B.empty id fragment] +genValidUriRef :: Gen B8.ByteString+genValidUriRef = Gen.choice [genValidUri, genValidRelRef]

@@ -1,21 +1,16 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE ViewPatterns #-}  module Dormouse.Uri.ParserSpec   ( spec   ) where +import Data.Maybe (fromJust) import Test.Hspec import Test.Hspec.Hedgehog import Control.Monad.IO.Class import Data.Attoparsec.ByteString.Char8-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.Char as C import Data.Either (isLeft, isRight) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -28,7 +23,7 @@   uriWithHostAndPath :: Uri-uriWithHostAndPath = AbsoluteUri $ AbsUri+uriWithHostAndPath = Uri   { uriScheme = Scheme "http"   , uriAuthority = Just $ Authority {authorityUserInfo = Nothing, authorityHost = Host "google.com", authorityPort = Nothing}   , uriPath = Path [PathSegment "test1", PathSegment "test2"]@@ -37,10 +32,10 @@   }  uriWithHostUsernameAndPath :: Uri-uriWithHostUsernameAndPath = AbsoluteUri $ AbsUri+uriWithHostUsernameAndPath = Uri   { uriScheme = Scheme "http"   , uriAuthority = Just $ Authority -    { authorityUserInfo = Just (UserInfo {userInfoUsername = "j.t.kirk", userInfoPassword = Nothing})+    { authorityUserInfo = Just $ UserInfo "j.t.kirk"     , authorityHost = Host "google.com"     , authorityPort = Nothing     }@@ -50,10 +45,10 @@   }  uriWithHostUsernamePasswordAndPath :: Uri-uriWithHostUsernamePasswordAndPath = AbsoluteUri $ AbsUri+uriWithHostUsernamePasswordAndPath = Uri   { uriScheme = Scheme "http"   , uriAuthority = Just $ Authority -    { authorityUserInfo = Just (UserInfo {userInfoUsername = "j.t.kirk", userInfoPassword = Just "11a"})+    { authorityUserInfo = Just $ UserInfo "j.t.kirk:11a"     , authorityHost = Host "google.com"     , authorityPort = Nothing     }@@ -63,7 +58,7 @@   }  uriWithHostPathAndPort :: Uri-uriWithHostPathAndPort = AbsoluteUri $ AbsUri+uriWithHostPathAndPort = Uri   { uriScheme = Scheme "https"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Just 123 }   , uriPath = Path ["forum", "questions", ""]@@ -72,7 +67,7 @@   }  uriWithHostPathQueryAndFragment :: Uri-uriWithHostPathQueryAndFragment = AbsoluteUri $ AbsUri+uriWithHostPathQueryAndFragment = Uri   { uriScheme = Scheme "https"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }   , uriPath = Path ["forum", "questions", ""]@@ -81,7 +76,7 @@   }  uriWithUnicodeInQuery :: Uri-uriWithUnicodeInQuery = AbsoluteUri $ AbsUri+uriWithUnicodeInQuery = Uri   { uriScheme = Scheme "https"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }   , uriPath = Path ["forum", "questions", ""]@@ -90,7 +85,7 @@   }  uriWithSpacesInQuery :: Uri-uriWithSpacesInQuery = AbsoluteUri $ AbsUri+uriWithSpacesInQuery = Uri   { uriScheme = Scheme "https"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }   , uriPath = Path ["forum", "questions", ""]@@ -100,7 +95,7 @@   uriWithUnicodeInFragment :: Uri-uriWithUnicodeInFragment = AbsoluteUri $ AbsUri+uriWithUnicodeInFragment = Uri   { uriScheme = Scheme "https"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }   , uriPath = Path ["forum", "questions", ""]@@ -108,8 +103,17 @@   , uriFragment = Just $ "😀😀😀"   } +uriWithUnicodeInPath :: Uri+uriWithUnicodeInPath = Uri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }+  , uriPath = Path ["test", "dsdsfdsfds😀😀😀", ""]+  , uriQuery = Nothing+  , uriFragment = Nothing +  }+ ldapUri :: Uri-ldapUri = AbsoluteUri $ AbsUri+ldapUri = Uri   { uriScheme = Scheme "ldap"   , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "192.168.0.1", authorityPort = Nothing }   , uriPath = Path [PathSegment "c=GB"]@@ -118,7 +122,7 @@   }  telUri :: Uri-telUri = AbsoluteUri $ AbsUri+telUri = Uri   { uriScheme = Scheme "tel"   , uriAuthority = Nothing   , uriPath = Path ["+1-816-555-1212"]@@ -126,19 +130,6 @@   , uriFragment = Nothing   } -infixr 5 :<--pattern b :< bs <- (B.uncons -> Just (b, bs))-pattern Empty   <- (B.uncons -> Nothing)--percentDecode :: B.ByteString -> B.ByteString-percentDecode Empty = B.empty-percentDecode (x :< Empty) = B.singleton x-percentDecode (x :< y :< Empty) = B.cons x $ B.singleton y-percentDecode (p :< x :< y :< xs) -  | p == c2w '%' = B.cons (fromIntegral $ C.digitToInt (w2c x) * 16 + C.digitToInt (w2c y)) (percentDecode xs)-  | otherwise    = B.cons p $ percentDecode (B.cons x $ B.cons y $ xs)- spec :: Spec spec = do   describe "pScheme" $ do@@ -150,24 +141,6 @@       schemeText <- forAll genInvalidScheme       let res = parseOnly (pScheme <* endOfInput) schemeText       isLeft res === True-  describe "pUsername" $ do-    it "returns the matching username for all valid usernames" $ hedgehog $ do-      usernameText <- forAll genValidUsername-      let res = parseOnly (pUsername <* endOfInput) usernameText-      res === (Right . Username . TE.decodeUtf8 . percentDecode $ usernameText)-    it "fails for invalid usernames" $ hedgehog $ do-      usernameText <- forAll genInvalidUsername-      let res = parseOnly (pUsername <* endOfInput) usernameText-      isLeft res === True-  describe "pPassword" $ do-    it "returns the matching password for all valid passwords" $ hedgehog $ do-      passwordText <- forAll genValidPassword-      let res = parseOnly (pPassword <* endOfInput) passwordText-      res === (Right . Password . TE.decodeUtf8 . percentDecode $ passwordText)-    it "fails for invalid passwords" $ hedgehog $ do-      passwordText <- forAll genInvalidPassword-      let res = parseOnly (pPassword <* endOfInput) passwordText-      isLeft res === True   describe "pUserInfo" $ do     it "generates a user info for all valid user infos" $ hedgehog $ do       userInfoText <- forAll genValidUserInfo@@ -181,17 +154,17 @@     it "returns the matching ip address for all valid ip addresses" $ hedgehog $ do       ipv4Text <- forAll genValidIPv4       let res = parseOnly (pIPv4 <* endOfInput) ipv4Text-      res === (Right . TE.decodeUtf8 . percentDecode $ ipv4Text)+      res === (Right . TE.decodeUtf8 . fromJust . percentDecode $ ipv4Text)   describe "pRegName" $ do     it "returns the matching reg name for all valid reg names" $ hedgehog $ do       regNameText <- forAll genValidRegName       let res = parseOnly (pRegName <* endOfInput) regNameText-      res === (Right . TE.decodeUtf8 . percentDecode $ regNameText)+      res === (Right . TE.decodeUtf8 . fromJust . percentDecode $ regNameText)   describe "pHost" $ do     it "returns the matching host for all valid hosts" $ hedgehog $ do       hostText <- forAll genValidHost       let res = parseOnly (pHost <* endOfInput) hostText-      res === (Right . Host . TE.decodeUtf8 . percentDecode $ hostText)+      res === (Right . Host . TE.decodeUtf8 . fromJust . percentDecode $ hostText)   describe "pPort" $ do     it "returns the matching host for all valid ports" $ hedgehog $ do       portText <- forAll genValidPort@@ -221,48 +194,72 @@     it "returns the matching query for all valid queries" $ hedgehog $ do       queryText <- forAll genValidQuery       let res = parseOnly (pQuery <* endOfInput) queryText-      res === (Right . Query . T.tail . TE.decodeUtf8 . percentDecode $ queryText)+      res === (Right . Query . T.tail . TE.decodeUtf8 . fromJust . percentDecode $ queryText)   describe "pFragment" $ do     it "returns the matching fragment for all valid fragments" $ hedgehog $ do       fragmentText <- forAll genValidFragment       let res = parseOnly (pFragment <* endOfInput) fragmentText-      res === (Right . Fragment . T.tail . TE.decodeUtf8 . percentDecode $ fragmentText)-  describe "pAbsoluteUri" $ do-    it "generates an absolute uri for all valid absolute uris" $ hedgehog $ do-      uriText <- forAll genValidAbsoluteUri-      let res = parseOnly (pAbsoluteUri <* endOfInput) uriText+      res === (Right . Fragment . T.tail . TE.decodeUtf8 . fromJust . percentDecode $ fragmentText)+  describe "pUri" $ do+    it "generates a uri for all valid uris" $ hedgehog $ do+      uriText <- forAll genValidUri+      let res = parseOnly (pUri <* endOfInput) uriText       isRight res === True+  describe "pUriRef" $ do+    it "generates a uri ref for all valid uri refs" $ hedgehog $ do+      uriRefText <- forAll genValidUriRef+      let res = parseOnly (pUriRef <* endOfInput) uriRefText+      isRight res === True   describe "parseURI" $ do     it "generates uri components correctly for uri with scheme, host and path" $ do       let res = parseOnly pUri "http://google.com/test1/test2"-      res `shouldBe` (Right uriWithHostAndPath)+      res `shouldBe` Right uriWithHostAndPath     it "generates uri components correctly for uri with upper case scheme, host and path" $ do       let res = parseOnly pUri "HTTP://google.com/test1/test2"-      res `shouldBe` (Right uriWithHostAndPath)+      res `shouldBe` Right uriWithHostAndPath     it "generates uri components correctly for uri with host, username and path" $ do       let res = parseOnly pUri "http://j.t.kirk@google.com/test1/test2"-      res `shouldBe` (Right uriWithHostUsernameAndPath)+      res `shouldBe` Right uriWithHostUsernameAndPath     it "generates uri components correctly for uri with host, username and path" $ do       let res = parseOnly pUri "http://j.t.kirk:11a@google.com/test1/test2"-      res `shouldBe` (Right uriWithHostUsernamePasswordAndPath)+      res `shouldBe` Right uriWithHostUsernamePasswordAndPath     it "generates uri components correctly for uri with host, username, path and port" $ do       let res = parseOnly pUri "https://www.example.com:123/forum/questions/"-      res `shouldBe` (Right uriWithHostPathAndPort)+      res `shouldBe` Right uriWithHostPathAndPort     it "generates uri components correctly for uri with host, username, path, port, query and fragment" $ do       let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=networking&order=newest#top"-      res `shouldBe` (Right uriWithHostPathQueryAndFragment)+      res `shouldBe` Right uriWithHostPathQueryAndFragment     it "generates uri components correctly when there is percent encoded unicode in the query" $ do       let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=networking&order=newest%F0%9F%98%80"-      res `shouldBe` (Right uriWithUnicodeInQuery)+      res `shouldBe` Right uriWithUnicodeInQuery     it "generates uri components correctly when there are spaces in the query" $ do       let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=with%20space"-      res `shouldBe` (Right uriWithSpacesInQuery)+      res `shouldBe` Right uriWithSpacesInQuery     it "generates uri components correctly when there is percent encoded unicode in the fragment" $ do       let res = parseOnly pUri "https://www.example.com/forum/questions/#%F0%9F%98%80%F0%9F%98%80%F0%9F%98%80"-      res `shouldBe` (Right uriWithUnicodeInFragment)+      res `shouldBe` Right uriWithUnicodeInFragment+    it "generates uri components correctly when there is percent encoded unicode in the path" $ do+      let res = parseOnly pUri "https://www.example.com/test/dsdsfdsfds%F0%9F%98%80%F0%9F%98%80%F0%9F%98%80/"+      res `shouldBe` Right uriWithUnicodeInPath     it "generates uri components correctly for ldap uri" $ do       let res = parseOnly pUri "ldap://192.168.0.1/c=GB?objectClass?one"-      res `shouldBe` (Right ldapUri)+      res `shouldBe` Right ldapUri     it "generates uri components correctly for tel uri" $ do       let res = parseOnly pUri "tel:+1-816-555-1212"-      res `shouldBe` (Right telUri)+      res `shouldBe` Right telUri+    it "fails for missing scheme" $ do+      let res = parseOnly pUri "://"+      isLeft res `shouldBe` True+    it "fails for special character scheme" $ do+      let res = parseOnly pUri "!!!://"+      isLeft res `shouldBe` True+    it "fails for path only" $ do+      let res = parseOnly pUri "/path"+      isLeft res `shouldBe` True+    it "fails for query only" $ do+      let res = parseOnly pUri "?query"+      isLeft res `shouldBe` True+    it "fails for fragment only" $ do+      let res = parseOnly pUri "#fragment"+      isLeft res `shouldBe` True+

@@ -53,14 +53,14 @@       matched `shouldBe` False   describe "relativeUri pattern" $ do     it "pattern matches correctly against a matching uri" $ do-      let uri' = [uri|/myPath|]+      let uri' = [uriRef|/myPath|]       let matched = case uri' of-            [uri|/myPath|] -> True+            [uriRef|/myPath|] -> True             _ -> False       matched `shouldBe` True     it "pattern match doesn't match a different uri" $ do-      let uri' = [uri|/myPath2|]+      let uri' = [uriRef|/myPath2|]       let matched = case uri' of-            [uri|/myPath|] -> True+            [uriRef|/myPath|] -> True             _ -> False       matched `shouldBe` False