genvalidity-network-uri (empty) → 0.0.0.0
raw patch · 5 files changed
+641/−0 lines, 5 filesdep +QuickCheckdep +basedep +criterion
Dependencies added: QuickCheck, base, criterion, genvalidity, genvalidity-criterion, genvalidity-network-uri, genvalidity-sydtest, iproute, network-uri, sydtest, validity, validity-network-uri
Files
- bench/Main.hs +17/−0
- genvalidity-network-uri.cabal +78/−0
- src/Data/GenValidity/URI.hs +395/−0
- test/Data/GenValidity/URISpec.hs +150/−0
- test/Spec.hs +1/−0
+ bench/Main.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Criterion.Main as Criterion+import Data.GenValidity.Criterion+import Data.GenValidity.URI ()+import Network.URI++main :: IO ()+main =+ Criterion.defaultMain+ [ genValidBench @URIAuth,+ genValidBench @URI+ ]
+ genvalidity-network-uri.cabal view
@@ -0,0 +1,78 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name: genvalidity-network-uri+version: 0.0.0.0+synopsis: GenValidity support for URI+category: Testing+homepage: https://github.com/NorfairKing/validity#readme+bug-reports: https://github.com/NorfairKing/validity/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright: (c) 2022 Tom Sydney Kerckhove+license: MIT+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/validity++library+ exposed-modules:+ Data.GenValidity.URI+ other-modules:+ Paths_genvalidity_network_uri+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , genvalidity >=1.0+ , iproute+ , network-uri+ , validity >=0.5+ , validity-network-uri+ default-language: Haskell2010++test-suite genvalidity-network-uri-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.GenValidity.URISpec+ Paths_genvalidity_network_uri+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , genvalidity+ , genvalidity-network-uri+ , genvalidity-sydtest+ , network-uri+ , sydtest+ , validity-network-uri+ default-language: Haskell2010++benchmark genvalidity-network-uri-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_genvalidity_network_uri+ hs-source-dirs:+ bench/+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , criterion+ , genvalidity+ , genvalidity-criterion+ , genvalidity-network-uri+ , network-uri+ default-language: Haskell2010
+ src/Data/GenValidity/URI.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-duplicate-exports #-}++-- | 'GenValid' instances for 'URI' and 'URIAuth'+--+-- The main API of this module is in the orphan instances @GenValid URI@ and @GenValid URIAuth@.+module Data.GenValidity.URI+ ( -- ** Specific Generators+ genURIReference,+ genURI,+ genRelativeReference,+ genAbsoluteURI,++ -- * Export everything for testing, **You probably do not want to use any of the functions below**.+ module Data.GenValidity.URI,+ )+where++import Data.Char as Char+import Data.GenValidity+import Data.IP+import Data.Validity.URI+import Data.Word+import Network.URI+import Test.QuickCheck+import Text.Printf++-- | Generate an 'URI' that parses using 'parseURIReference'.+genURIReference :: Gen URI+genURIReference =+ oneof+ [ genURI,+ genRelativeReference+ ]++-- | Generate an 'URI' that parses using 'parseURI'.+genURI :: Gen URI+genURI = (`suchThatMap` (parseURI . dangerousURIToString)) $ do+ uriScheme <- genScheme `suchThat` (not . null)+ uriAuthority <- genValid+ uriPath <- case uriAuthority of+ Just _ -> genPathAbEmpty+ Nothing ->+ oneof+ [ genPathAbsolute,+ genPathNoScheme,+ genPathEmpty+ ]+ uriQuery <- genQuery+ uriFragment <- genFragment+ pure URI {..}++-- | Generate an 'URI' that parses using 'parseRelativeReference'.+genRelativeReference :: Gen URI+genRelativeReference = (`suchThatMap` (parseRelativeReference . dangerousURIToString)) $ do+ let uriScheme = ""+ uriAuthority <- genValid+ uriPath <- case uriAuthority of+ Just _ -> genPathAbEmpty+ Nothing ->+ oneof+ [ genPathAbsolute,+ genPathNoScheme,+ genPathEmpty+ ]+ uriQuery <- genQuery+ uriFragment <- genFragment+ pure URI {..}++-- | Generate an 'URI' that parses using 'parseAbsoluteURI'.+genAbsoluteURI :: Gen URI+genAbsoluteURI = (`suchThatMap` (parseAbsoluteURI . dangerousURIToString)) $ do+ uriScheme <- genScheme `suchThat` (not . null)+ uriAuthority <- genValid+ uriPath <- case uriAuthority of+ Just _ -> genPathAbEmpty+ Nothing ->+ oneof+ [ genPathAbsolute,+ genPathNoScheme,+ genPathEmpty+ ]+ uriQuery <- genQuery+ let uriFragment = ""+ pure URI {..}++instance GenValid URIAuth where+ genValid = (`suchThat` isValid) $ do+ uriUserInfo <- genUserInfo+ uriRegName <- genHost+ uriPort <- genPort+ pure $ URIAuth {..}++instance GenValid URI where+ genValid = (`suchThat` isValid) . (`suchThatMap` (parseURIReference . dangerousURIToString)) $ do+ uriScheme <- genScheme+ uriAuthority <- genValid+ uriPath <- genPath+ uriQuery <- genQuery+ uriFragment <- genFragment+ pure $ URI {..}++genScheme :: Gen String+genScheme =+ oneof+ [ pure "",+ nullOrAppend ':'+ <$> ( (:)+ <$> genCharALPHA+ <*> genStringBy+ ( frequency+ [ (4, genCharALPHA),+ (3, genCharDIGIT),+ (1, elements ['+', '-', '.'])+ ]+ )+ ),+ -- Common schemes+ elements+ [ "http:",+ "https:",+ "ftp:",+ "ftps:",+ "ldap:",+ "mailto:",+ "news:",+ "tel:",+ "telnet:",+ "urn:",+ "ws:",+ "wss:"+ ]+ ]++genUserInfo :: Gen String+genUserInfo =+ nullOrAppend '@' . concat+ <$> genListOf+ ( frequency+ [ (4, (: []) <$> genCharUnreserved),+ (1, genPercentEncodedChar),+ (1, (: []) <$> genCharSubDelim),+ (1, pure ":")+ ]+ )++genHost :: Gen String+genHost =+ oneof+ [ genIPLiteral,+ genIPv4Address,+ genRegName+ ]++genIPLiteral :: Gen String+genIPLiteral = do+ a <-+ oneof+ [ genIPv6Address,+ genIPvFuture+ ]+ pure $ "[" ++ a ++ "]"++genIPv6Address :: Gen String+genIPv6Address = show . toIPv6w <$> genValid++genIPvFuture :: Gen String+genIPvFuture = do+ hd <- genStringBy1 genCharHEXDIG+ s <-+ genStringBy1+ ( frequency+ [ (4, genCharUnreserved),+ (1, genCharSubDelim),+ (1, pure ':')+ ]+ )+ pure $ concat ["v", hd, ".", s]++genIPv4Address :: Gen String+genIPv4Address = show . toIPv4w <$> genValid++genRegName :: Gen String+genRegName =+ concat+ <$> genListOf+ ( frequency+ [ (4, (: []) <$> genCharUnreserved),+ (1, genPercentEncodedChar),+ (1, (: []) <$> genCharSubDelim)+ ]+ )++genPort :: Gen String+genPort = nullOrPrepend ':' <$> genStringBy genCharDIGIT++genPercentEncodedChar :: Gen String+genPercentEncodedChar = do+ octet <- choose (0, 255)+ pure $ '%' : printf "%x" (octet :: Word8)++genPath :: Gen String+genPath =+ -- @+ -- path = path-abempty ; begins with "/" or is empty+ -- / path-absolute ; begins with "/" but not "//"+ -- / path-noscheme ; begins with a non-colon segment+ -- / path-rootless ; begins with a segment+ -- / path-empty ; zero characters+ -- @+ oneof+ [ genPathAbEmpty,+ genPathAbsolute,+ genPathNoScheme,+ genPathRootless,+ genPathEmpty+ ]++-- @+-- path-abempty = *( "/" segment )+-- @+genPathAbEmpty :: Gen String+genPathAbEmpty = do+ segments <- genListOf genSegment+ pure $ concatMap ('/' :) segments++-- @+-- path-absolute = "/" [ segment-nz *( "/" segment ) ]+-- @+genPathAbsolute :: Gen String+genPathAbsolute = do+ firstSegment <- genSegmentNz+ restSegments <- genListOf genSegment+ pure $ '/' : firstSegment ++ concatMap ('/' :) restSegments++-- @+-- path-noscheme = segment-nz-nc *( "/" segment )+-- @+genPathNoScheme :: Gen String+genPathNoScheme = do+ firstSegment <- genSegmentNzNc+ restSegments <- genListOf genSegment+ pure $ firstSegment ++ concatMap ('/' :) restSegments++-- @+-- path-rootless = segment-nz *( "/" segment )+-- @+genPathRootless :: Gen String+genPathRootless = do+ firstSegment <- genSegmentNz+ restSegments <- genListOf genSegment+ pure $ firstSegment ++ concatMap ('/' :) restSegments++-- @+-- path-empty = 0<pchar>+-- @+genPathEmpty :: Gen String+genPathEmpty = pure ""++-- @+-- segment = *pchar+-- @+genSegment :: Gen String+genSegment = concat <$> genListOf genPathChar++-- @+-- segment-nz = 1*pchar+-- @+genSegmentNz :: Gen String+genSegmentNz = concat <$> genListOf1 genPathChar++-- @+-- segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )+-- ; non-zero-length segment without any colon ":"+-- @+genSegmentNzNc :: Gen String+genSegmentNzNc =+ concat+ <$> genListOf1+ ( frequency+ [ (4, (: []) <$> genCharUnreserved),+ (1, genPercentEncodedChar),+ (1, (: []) <$> genCharSubDelim),+ (1, pure "@")+ ]+ )++-- @+-- pchar = unreserved / pct-encoded / sub-delims / ":" / "@"+-- @+genPathChar :: Gen String+genPathChar =+ frequency+ [ (4, (: []) <$> genCharUnreserved),+ (1, genPercentEncodedChar),+ (1, (: []) <$> genCharSubDelim),+ (1, elements [":", "@"])+ ]++-- @+-- query = *( pchar / "/" / "?" )+-- @+genQuery :: Gen String+genQuery =+ nullOrPrepend '?' . concat+ <$> genListOf+ ( frequency+ [ (4, genPathChar),+ ( 1,+ elements+ [ "/",+ "?",+ "&" -- '&' is not specified but very common in queries so we add it here.+ ]+ )+ ]+ )++-- @+-- fragment = *( pchar / "/" / "?" )+-- @+genFragment :: Gen String+genFragment =+ nullOrPrepend '#' . concat+ <$> genListOf+ ( frequency+ [ (4, genPathChar),+ (1, elements ["/", "?"])+ ]+ )++genCharUnreserved :: Gen Char+genCharUnreserved =+ frequency+ [ (1, elements ['+', '-', '.', '~']),+ (4, genCharALPHA),+ (3, genCharDIGIT)+ ]++genCharReserved :: Gen Char+genCharReserved =+ oneof+ [ genCharGenDelim,+ genCharSubDelim+ ]++genCharGenDelim :: Gen Char+genCharGenDelim =+ elements+ [ ':',+ '/',+ '?',+ '#',+ '[',+ ']',+ '@'+ ]++genCharSubDelim :: Gen Char+genCharSubDelim =+ elements+ [ '!',+ '$',+ '&',+ '\'',+ '(',+ ')',+ '*',+ '+',+ ',',+ ';',+ '='+ ]++genCharHEXDIG :: Gen Char+genCharHEXDIG = elements $ ['1' .. '9'] ++ ['A' .. 'F'] ++ ['a' .. 'f']++genCharALPHA :: Gen Char+genCharALPHA =+ Char.chr+ <$> oneof+ [ choose (0x41, 0x5A),+ choose (0x61, 0x7A)+ ]++genCharDIGIT :: Gen Char+genCharDIGIT =+ Char.chr+ <$> choose (0x30, 0x39)++nullOrAppend :: Char -> String -> String+nullOrAppend c s = if null s then s else s ++ [c]++nullOrPrepend :: Char -> String -> String+nullOrPrepend c s = if null s then s else c : s
+ test/Data/GenValidity/URISpec.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeApplications #-}++module Data.GenValidity.URISpec (spec) where++import Data.GenValidity.URI+import Data.Validity.URI+import Network.URI+import Test.QuickCheck+import Test.Syd+import Test.Syd.Validity++spec :: Spec+spec = do+ describe "GenValid URIAuth" $ do+ genValidSpec @URIAuth++ describe "URI" $ do+ describe "considers these examples from the spec valid" $ do+ let roundtripSpec string = it ("Considers valid: " <> show string) $+ case parseURIReference string of+ Nothing -> expectationFailure "should not happen."+ Just uri -> case parseURIReference (dangerousURIToString uri) of+ Nothing -> expectationFailure "should not happen."+ Just uri' -> uri' `shouldBe` uri++ considersValidSpec string = it ("Considers valid: " <> show string) $+ case parseURIReference string of+ Nothing -> expectationFailure "should not happen."+ Just uri -> shouldBeValid uri++ exampleSpec string = do+ considersValidSpec string+ roundtripSpec string++ -- From the spec+ exampleSpec "ftp://ftp.is.co.za/rfc/rfc1808.txt"+ exampleSpec "http://www.ietf.org/rfc/rfc2396.txt"+ exampleSpec "ldap://[2001:db8::7]/c=GB?objectClass?one"+ exampleSpec "mailto:John.Doe@example.com"+ exampleSpec "news:comp.infosystems.www.servers.unix"+ exampleSpec "tel:+1-816-555-1212"+ exampleSpec "telnet://192.0.2.16:80/"+ exampleSpec "urn:oasis:names:specification:docbook:dtd:xml:4.1.2"+ exampleSpec "foo://example.com:8042/over/there?name=ferret#nose"+ exampleSpec "urn:example:animal:ferret:nose"++ -- Extras+ exampleSpec "//:...@255.255.255.241:55?:%5f@67/?P?#6S3e"+ exampleSpec "//4+5*2:...@!8I)Z?%f4?#%aeF"++ describe "genScheme" $ do+ it "generates schemes that are considered valid by validateScheme" $+ forAll genScheme $ \schemeCandidate ->+ case prettyValidation (validateScheme schemeCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genUserInfo" $ do+ it "generates user info that are considered valid by validateUserInfo" $+ forAll genUserInfo $ \userinfoCandidate ->+ case prettyValidation (validateUserInfo userinfoCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genHost" $ do+ it "generates user info that are considered valid by validateHost" $+ forAll genHost $ \hostCandidate ->+ case prettyValidation (validateHost hostCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genPort" $ do+ it "generates user info that are considered valid by validatePort" $+ forAll genPort $ \portCandidate ->+ case prettyValidation (validatePort portCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genPath" $ do+ it "generates user info that are considered valid by validatePath" $+ forAll genPath $ \portCandidate ->+ case prettyValidation (validatePath portCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genQuery" $ do+ it "generates user info that are considered valid by validateQuery" $+ forAll genQuery $ \portCandidate ->+ case prettyValidation (validateQuery portCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genFragment" $ do+ it "generates user info that are considered valid by validateFragment" $+ forAll genFragment $ \portCandidate ->+ case prettyValidation (validateFragment portCandidate) of+ Nothing -> pure ()+ Just err -> expectationFailure err++ describe "genAbsoluteURI" $ do+ it "generates valid URI values" $+ genGeneratesValid genAbsoluteURI+ it "generates values that roundtrip through parseAbsoluteURI" $+ forAll genAbsoluteURI $ \uri ->+ case parseAbsoluteURI (dangerousURIToString uri) of+ Nothing -> expectationFailure "Should have parsed."+ Just uri' -> uri' `shouldBe` uri++ describe "genURIReference" $ do+ it "generates valid URI values" $+ genGeneratesValid genURIReference+ it "generates values that roundtrip through parseURIReference" $+ forAll genURIReference $ \uri ->+ case parseURIReference (dangerousURIToString uri) of+ Nothing -> expectationFailure "Should have parsed."+ Just uri' -> uri' `shouldBe` uri++ describe "genRelativeReference" $ do+ it "generates valid URI values" $+ genGeneratesValid genRelativeReference+ it "generates values that roundtrip through parseRelativeReference" $+ forAll genRelativeReference $ \uri ->+ case parseRelativeReference (dangerousURIToString uri) of+ Nothing -> expectationFailure "Should have parsed."+ Just uri' -> uri' `shouldBe` uri++ describe "genURI" $ do+ it "generates valid URI values" $+ genGeneratesValid genURI+ it "generates values that roundtrip through parseURI" $+ forAll genURI $ \uri ->+ case parseURI (dangerousURIToString uri) of+ Nothing -> expectationFailure "Should have parsed."+ Just uri' -> uri' `shouldBe` uri++ modifyMaxSuccess (* 10) $+ describe "GenValid URI" $ do+ genValidSpec @URI++ it "generates values that roundtrip through parseURIReference" $+ forAllValid $ \uri ->+ case parseURIReference (dangerousURIToString uri) of+ Nothing -> expectationFailure "should not happen."+ Just uri' -> uri' `shouldBe` uri++ it "produces URI that roundtrip through parsing" $+ forAll genValid $ \uri ->+ case parseURIReference (dangerousURIToString uri) of+ Nothing -> expectationFailure $ "Could not parse uri: " <> show (dangerousURIToString uri)+ Just uri' -> uri' `shouldBe` uri
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}