diff --git a/attoparsec-uri.cabal b/attoparsec-uri.cabal --- a/attoparsec-uri.cabal +++ b/attoparsec-uri.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0ae9f20b928e639e246cb20ca5770cdfb9f4458893cd265a957a279465db2137 +-- hash: f9910ee56c54b63aa347b32714c1bb69ef1471f797e32db8e67b6c8b19b22a99 name: attoparsec-uri -version: 0.0.5 +version: 0.0.5.1 synopsis: URI parser / printer using attoparsec description: Please see the README on GitHub at category: Web @@ -39,7 +39,7 @@ build-depends: QuickCheck , attoparsec - , attoparsec-ip >=0.0.1 + , attoparsec-ip ==0.0.2 , base >=4.7 && <4.11 , bytedump , ip >=1.3.0 @@ -60,13 +60,15 @@ build-depends: QuickCheck , attoparsec - , attoparsec-ip >=0.0.1 + , attoparsec-ip ==0.0.2 + , attoparsec-uri , base >=4.7 && <4.11 , bytedump , ip >=1.3.0 - , purescript-iso , quickcheck-instances , strict + , tasty + , tasty-quickcheck , text , vector default-language: Haskell2010 diff --git a/src/Data/URI.hs b/src/Data/URI.hs --- a/src/Data/URI.hs +++ b/src/Data/URI.hs @@ -18,13 +18,16 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Monoid ((<>)) -import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1) +import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1, ()) import Data.Char (isControl, isSpace) -import Control.Monad (void) +import Control.Monad (void, when) import Control.Applicative ((<|>), optional) import Data.Data (Typeable) import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (oneof, listOf, listOf1, elements) +import Test.QuickCheck.Instances () data URI = URI @@ -35,9 +38,30 @@ , uriQuery :: !(Vector (Pair Text (Maybe Text))) -- ^ list of key-value pairs - @https://hackage.haskell.org/?foo=bar&baz&qux=@ is -- @[("foo", Just "bar"), ("baz", Nothing), ("qux", Just "")]@ , uriFragment :: !(Maybe Text) -- ^ uri suffix - @https://hackage.haskell.org/#some-header@ is @Just "some-header"@ - } deriving (Eq, Typeable, Generic) + } deriving (Show, Eq, Typeable, Generic) +instance Arbitrary URI where + arbitrary = URI <$> arbitraryScheme + <*> arbitrary + <*> arbitrary + <*> arbitraryPath + <*> arbitraryQuery + <*> arbitraryScheme + where + arbitraryScheme = oneof [pure Nothing, Just <$> arbitraryNonEmptyText] + arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z']) + arbitraryPath = + oneof [pure Nothing, Just . V.fromList <$> listOf1 arbitraryNonEmptyText] + arbitraryQuery = + V.fromList <$> listOf go + where + go = do + a <- arbitraryNonEmptyText + mb <- oneof [pure Nothing, Just <$> arbitraryNonEmptyText] + pure (a :!: mb) + + printURI :: URI -> Text printURI URI{..} = maybe "" (<> ":") uriScheme @@ -77,38 +101,39 @@ where parseScheme :: Parser Text parseScheme = do - sch <- takeWhile1 (\c -> c `notElem` [':','/','@','.']) - _ <- char ':' + sch <- takeWhile1 (\c -> c `notElem` [':','/','@','.','[','*']) "scheme value" + when (sch == "localhost") (fail "can't be localhost") + void (char ':') "scheme colon" pure sch parseSlashes :: Parser Bool parseSlashes = do - mS <- optional (string "//") + mS <- optional (string "//") "slashes" case mS of P.Nothing -> pure False P.Just _ -> pure True parsePath :: Parser (Maybe (Vector Text)) parsePath = let withRoot = do - void (char '/') - Just . V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/' - withoutRoot = pure Nothing + void (char '/') "root" + (Just . V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/') "path" + withoutRoot = pure Nothing "empty path" in withRoot <|> withoutRoot parseQuery :: Parser (Vector (Pair Text (Maybe Text))) parseQuery = - ( do void (char '?') + ( do void (char '?') "uri query init" let parse1 = do - k <- parseChunkWithout ['=','&','#'] - mV <- ( Just <$> do void $ char '=' - parseChunkWithout ['&','#'] + k <- parseChunkWithout ['=','&','#'] "uri query key" + mV <- ( Just <$> do void (char '=') "uri query sep" + parseChunkWithout ['&','#'] "uri query val" ) <|> pure Nothing pure (k :!: mV) - qs <- parse1 `sepBy` char '&' - pure $ V.fromList qs + qs <- parse1 `sepBy` char '&' "query params" + pure (V.fromList qs) ) <|> pure V.empty parseFragment :: Parser Text parseFragment = do - void $ char '#' - parseChunkWithout [] + void (char '#') "fragment init" + parseChunkWithout [] "fragment value" parseChunkWithout :: [Char] -> Parser Text parseChunkWithout xs = takeWhile (\c -> not (isControl c || isSpace c) && c `notElem` xs) diff --git a/src/Data/URI/Auth.hs b/src/Data/URI/Auth.hs --- a/src/Data/URI/Auth.hs +++ b/src/Data/URI/Auth.hs @@ -15,21 +15,31 @@ import Data.Text (Text) import Data.Word (Word16) import qualified Data.Text as T -import Data.Attoparsec.Text (Parser, char, decimal, peekChar, takeWhile1) +import Data.Attoparsec.Text (Parser, char, decimal, takeWhile1, ()) import Data.Monoid ((<>)) import Control.Monad (void) import Control.Applicative (optional) import Data.Data (Typeable) import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (oneof, listOf1, elements) data URIAuth = URIAuth { uriAuthUser :: !(Maybe Text) -- ^ a designated user - @ssh://git\@github.com@ is @git@ , uriAuthHost :: !URIAuthHost , uriAuthPort :: !(Maybe Word16) -- ^ the port, if it exists - @foobar.com:3000@ is @3000@ as a 16-bit unsigned int. - } deriving (Eq, Typeable, Generic) + } deriving (Show, Eq, Typeable, Generic) +instance Arbitrary URIAuth where + arbitrary = URIAuth <$> arbitraryUser <*> arbitrary <*> arbitraryPort + where + arbitraryUser = oneof [pure Nothing, Just <$> arbitraryNonEmptyText] + arbitraryPort = oneof [pure Nothing, Just <$> arbitrary] + arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z']) + + printURIAuth :: URIAuth -> Text printURIAuth URIAuth{..} = maybe "" (<> "@") uriAuthUser @@ -44,15 +54,11 @@ <*> (toStrictMaybe <$> optional parsePort) where parseUser = do - u <- takeWhile1 (\c -> c `notElem` ['@','.',':','/','?','&','=']) - mC <- peekChar - case mC of - P.Nothing -> fail "no user @ thing" - _ -> do - void $ char '@' - pure u + u <- takeWhile1 (\c -> c `notElem` ['@','.',':','/','?','&','=']) "user value" + void (char '@') "user @" + pure u parsePort = do - void $ char ':' + void (char ':') "port delimiter" decimal toStrictMaybe P.Nothing = Nothing diff --git a/src/Data/URI/Auth/Host.hs b/src/Data/URI/Auth/Host.hs --- a/src/Data/URI/Auth/Host.hs +++ b/src/Data/URI/Auth/Host.hs @@ -13,8 +13,10 @@ import qualified Data.Vector as V import Data.Text (Text) import qualified Data.Text as T -import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1) +import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1, ()) import Data.Attoparsec.IP (ipv4, ipv6) +import Data.Monoid ((<>)) +import Control.Monad (void) import Control.Applicative ((<|>)) import Net.Types (IPv4, IPv6) import qualified Net.IPv4 as IPv4 @@ -23,7 +25,7 @@ import Data.Data (Typeable) import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Gen (oneof) +import Test.QuickCheck.Gen (oneof, listOf1, elements) import Test.QuickCheck.Instances () @@ -38,7 +40,7 @@ Host { uriAuthHostName :: !(Vector Text) , uriAuthHostSuffix :: !Text - } deriving (Eq, Typeable, Generic) + } deriving (Show, Eq, Typeable, Generic) instance Arbitrary URIAuthHost where arbitrary = oneof @@ -46,9 +48,12 @@ , IPv4 <$> arbitraryIPv4 , IPv6 <$> arbitraryIPv6 , pure Localhost - , Host <$> arbitrary <*> arbitrary + , Host <$> arbitraryNonEmptyVector arbitraryNonEmptyText + <*> arbitraryNonEmptyText ] where + arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z']) + arbitraryNonEmptyVector x = V.fromList <$> listOf1 x arbitraryIPv4 = IPv4.ipv4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary arbitraryIPv6 = @@ -59,7 +64,7 @@ printURIAuthHost x = case x of Glob -> "*" IPv4 l4 -> IPv4.encode l4 - IPv6 r6 -> IPv6.encode r6 + IPv6 r6 -> "[" <> IPv6.encode r6 <> "]" Localhost -> "localhost" Host ns c -> T.intercalate "." (V.toList (ns `V.snoc` c)) @@ -67,12 +72,17 @@ parseURIAuthHost :: Parser URIAuthHost parseURIAuthHost = (IPv4 <$> ipv4) - <|> (IPv6 <$> ipv6) + <|> (IPv6 <$> ipv6') <|> parseHost where + ipv6' = do + void (char '[') "init ipv6" + x <- ipv6 + void (char ']') "end ipv6" + pure x parseHost :: Parser URIAuthHost parseHost = do - xss@(x:xs) <- takeWhile1 (\c -> c `notElem` ['.',':','/','?']) `sepBy1` char '.' + xss@(x:xs) <- (takeWhile1 (\c -> c `notElem` ['.',':','/','?','#']) `sepBy1` char '.') "host chunks" if null xs then case () of _ | x == "localhost" -> pure Localhost diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,26 @@ -import Test.Tasty (testGroup) +import Data.URI.Auth.Host (printURIAuthHost, parseURIAuthHost) +import Data.URI.Auth (printURIAuth, parseURIAuth) +import Data.URI (printURI, parseURI) + +import Data.Text (Text) +import Data.Attoparsec.Text (Parser, parseOnly) +import Test.Tasty (testGroup, defaultMain) import qualified Test.Tasty.QuickCheck as Q +import Test.QuickCheck.Property (Result, succeeded, failed) + + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = defaultMain $ testGroup "URI tests" + [ Q.testProperty "URIAuthHost" (parsePrintIso printURIAuthHost parseURIAuthHost) + , Q.testProperty "URIAuth" (parsePrintIso printURIAuth parseURIAuth) + , Q.testProperty "URI" (parsePrintIso printURI parseURI) + ] + + +parsePrintIso :: Eq a => (a -> Text) -> Parser a -> a -> Result +parsePrintIso print' parser x = case parseOnly parser (print' x) of + Left _ -> failed + Right y + | y == x -> succeeded + | otherwise -> failed