attoparsec-uri 0.0.5 → 0.0.5.1
raw patch · 5 files changed
+105/−41 lines, 5 filesdep +attoparsec-uridep +tastydep +tasty-quickcheckdep −purescript-isodep ~attoparsec-ip
Dependencies added: attoparsec-uri, tasty, tasty-quickcheck
Dependencies removed: purescript-iso
Dependency ranges changed: attoparsec-ip
Files
- attoparsec-uri.cabal +7/−5
- src/Data/URI.hs +42/−17
- src/Data/URI/Auth.hs +16/−10
- src/Data/URI/Auth/Host.hs +17/−7
- test/Spec.hs +23/−2
attoparsec-uri.cabal view
@@ -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 <https://github.com/githubuser/purescript-iso#readme> 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
src/Data/URI.hs view
@@ -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)
src/Data/URI/Auth.hs view
@@ -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
src/Data/URI/Auth/Host.hs view
@@ -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
test/Spec.hs view
@@ -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