diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + ] diff --git a/genvalidity-network-uri.cabal b/genvalidity-network-uri.cabal new file mode 100644 --- /dev/null +++ b/genvalidity-network-uri.cabal @@ -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 diff --git a/src/Data/GenValidity/URI.hs b/src/Data/GenValidity/URI.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/URI.hs @@ -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 +-- @ +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 diff --git a/test/Data/GenValidity/URISpec.hs b/test/Data/GenValidity/URISpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/URISpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}