diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +0.1.3 +* Include test modules in distribution + + 0.1.2 * Add support for GHC 7.10 diff --git a/src/URI/ByteString/Lens.hs b/src/URI/ByteString/Lens.hs --- a/src/URI/ByteString/Lens.hs +++ b/src/URI/ByteString/Lens.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module URI.ByteString.Lens where ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4,8,0) import Control.Applicative -#endif import Data.ByteString (ByteString) import Data.Word +------------------------------------------------------------------------------- +import Prelude ------------------------------------------------------------------------------- import URI.ByteString.Types ------------------------------------------------------------------------------- diff --git a/src/URI/ByteString/Types.hs b/src/URI/ByteString/Types.hs --- a/src/URI/ByteString/Types.hs +++ b/src/URI/ByteString/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -6,12 +5,12 @@ ------------------------------------------------------------------------------- import Data.ByteString (ByteString) -#if !MIN_VERSION_base(4,8,0) import Data.Monoid -#endif import Data.Typeable import Data.Word import GHC.Generics +------------------------------------------------------------------------------- +import Prelude ------------------------------------------------------------------------------- diff --git a/test/URI/ByteString/Arbitrary.hs b/test/URI/ByteString/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/URI/ByteString/Arbitrary.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module URI.ByteString.Arbitrary where + + +------------------------------------------------------------------------------- +import Control.Applicative +import Data.Derive.Arbitrary (makeArbitrary) +import Data.DeriveTH (derive) +import Test.QuickCheck +import Test.QuickCheck.Instances () +------------------------------------------------------------------------------- +import Prelude +------------------------------------------------------------------------------- +import URI.ByteString +------------------------------------------------------------------------------- + + +instance Arbitrary UserInfo where + arbitrary = UserInfo <$> arbitrary + <*> arbitrary + + +instance Arbitrary Authority where + arbitrary = Authority <$> arbitrary + <*> arbitrary + <*> arbitrary + + +instance Arbitrary Host where + arbitrary = Host <$> arbitrary + + +instance Arbitrary Port where + arbitrary = Port <$> arbitrary + + +instance Arbitrary URI where + arbitrary = URI <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + +instance Arbitrary RelativeRef where + arbitrary = RelativeRef <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + +instance Arbitrary Scheme where + arbitrary = Scheme <$> arbitrary + + +instance Arbitrary Query where + arbitrary = Query <$> arbitrary + + +instance Arbitrary URIParserOptions where + arbitrary = URIParserOptions <$> arbitrary + + +$(derive makeArbitrary ''SchemaError) +$(derive makeArbitrary ''URIParseError) diff --git a/test/URI/ByteStringTests.hs b/test/URI/ByteStringTests.hs new file mode 100644 --- /dev/null +++ b/test/URI/ByteStringTests.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module URI.ByteStringTests (tests) where + +------------------------------------------------------------------------------- +import Control.Lens +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import Data.Monoid +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +------------------------------------------------------------------------------- +import Prelude +------------------------------------------------------------------------------- +import URI.ByteString +import URI.ByteString.Arbitrary () +------------------------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "URI.Bytestring" + [ + parseUriTests + , uriParseErrorInstancesTests + , lensTests + ] + + +------------------------------------------------------------------------------- +parseUriTests :: TestTree +parseUriTests = testGroup "parseUri" + [ + testParses "http://www.example.org/" $ + URI (Scheme "http") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "/" + mempty + Nothing + , testParseHost "http://www.example.org" "www.example.org" + -- IPV4 + , testParseHost "http://192.168.1.1" "192.168.1.1" + -- IPV6 + , testParseHost "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210" + , testParseHost "http://[1080:0:0:0:8:800:200C:417A]" "1080:0:0:0:8:800:200C:417A" + , testParseHost "http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1" + , testParseHost "http://[::192.9.5.5]" "::192.9.5.5" + , testParseHost "http://[::FFFF:129.144.52.38]" "::FFFF:129.144.52.38" + , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" + , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" + -- IPVFuture + , testParseHost "http://[v1.fe80::a+en1]" "v1.fe80::a+en1" + , testParses "https://user:pass:wo%20rd@www.example.org?foo=bar&foo=baz+quux#frag" $ + URI (Scheme "https") + (Just (Authority (Just (UserInfo "user" "pass:wo rd")) (Host "www.example.org") Nothing)) + "" + (Query [("foo", "bar"), ("foo", "baz quux")]) + (Just "frag") + , testParses "http://www.google.com:80/aclk?sa=l&ai=CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw&sig=AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ&rct=j&q=&ved=0CCUQ0Qw&adurl=http://www.aruba.com/where-to-stay/hotels-and-resorts%3Ftid%3D122" + URI { uriScheme = Scheme {schemeBS = "http"} + , uriAuthority = Just Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.google.com"}, authorityPort = Just (Port 80)} + , uriPath = "/aclk" + , uriQuery = Query {queryPairs = + [("sa", "l") + ,("ai", "CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw") + ,("sig", "AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ") + ,("rct", "j") + ,("q", "") + ,("ved", "0CCUQ0Qw") + ,("adurl", "http://www.aruba.com/where-to-stay/hotels-and-resorts?tid=122") + ]} + , uriFragment = Nothing + } + + , testParseFailure "$$$$://www.example.org/" (MalformedScheme NonAlphaLeading) + , testParses "http://www.example.org/foo#bar" $ + URI (Scheme "http") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "/foo" + mempty + (Just "bar") + , testParseFailure "http://www.example.org/foo#bar#baz" MalformedFragment + , testParseFailure "https://www.example.org?listParam[]=foo,bar" MalformedQuery + , testParsesLax "https://www.example.org?listParam[]=foo,bar" $ + URI (Scheme "https") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "" + (Query [("listParam[]", "foo,bar")]) + Nothing + + , testParses "https://www.example.org?listParam%5B%5D=foo,bar" $ + URI (Scheme "https") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "" + (Query [("listParam[]", "foo,bar")]) + Nothing + + , parseTestURI strictURIParserOptions "http://www.example.org/." $ + Right $ URI + (Scheme "http") + (Just (Authority Nothing (Host "www.example.org") Nothing)) + "/." + (Query []) + Nothing + , parseTestURI strictURIParserOptions "http:/." $ + Right $ URI + (Scheme "http") + Nothing + "/." + (Query []) + Nothing + + -- RFC 3986, Section 4.2 + , parseTestRelativeRef strictURIParserOptions "verysimple" $ + Right $ RelativeRef + Nothing + "verysimple" + (Query []) + Nothing + , parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $ + Left $ MalformedPath + , parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $ + Right $ RelativeRef + Nothing + "./this:that/thap/sub" + (Query [("1", "2")]) + Nothing + ] + + +------------------------------------------------------------------------------- +uriParseErrorInstancesTests :: TestTree +uriParseErrorInstancesTests = testGroup "URIParseError instances" + [ + testProperty "roundtrips between Show and Read" $ \(e :: URIParseError) -> + read (show e) == e + ] + +lensTests :: TestTree +lensTests = testGroup "lenses" + [ + testProperty "schemeBSL Lens" $ \bs bs' -> + let wrapped = Scheme bs + in (wrapped ^. schemeBSL) === schemeBS wrapped .&&. + (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'} + , testProperty "hostBSL Lens" $ \bs bs' -> + let wrapped = Host bs + in (wrapped ^. hostBSL) === hostBS wrapped .&&. + (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'} + , testProperty "portNumberL Lens" $ \n n' -> + let wrapped = Port n + in (wrapped ^. portNumberL) === portNumber wrapped .&&. + (wrapped & portNumberL .~ n') === wrapped { portNumber = n'} + , testProperty "queryPairsL Lens" $ \ps ps' -> + let wrapped = Query ps + in wrapped ^. queryPairsL === queryPairs wrapped .&&. + (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'} + + , testProperty "authorityUserInfoL Lens" $ \a ui -> + (a ^. authorityUserInfoL === authorityUserInfo a) .&&. + ((a & authorityUserInfoL .~ ui) === a { authorityUserInfo = ui }) + , testProperty "authorityHostL Lens" $ \a host -> + (a ^. authorityHostL === authorityHost a) .&&. + ((a & authorityHostL .~ host) === a { authorityHost = host }) + , testProperty "authorityPortL Lens" $ \a port -> + (a ^. authorityPortL === authorityPort a) .&&. + ((a & authorityPortL .~ port) === a { authorityPort = port }) + + , testProperty "uiUsernameL Lens" $ \ui bs -> + (ui ^. uiUsernameL === uiUsername ui) .&&. + ((ui & uiUsernameL .~ bs) === ui { uiUsername = bs }) + , testProperty "uiPasswordL Lens" $ \ui bs -> + (ui ^. uiPasswordL === uiPassword ui) .&&. + ((ui & uiPasswordL .~ bs) === ui { uiPassword = bs }) + + , testProperty "uriSchemeL Lens" $ \uri x -> + (uri ^. uriSchemeL === uriScheme uri) .&&. + ((uri & uriSchemeL .~ x) === uri { uriScheme = x }) + , testProperty "uriAuthorityL Lens" $ \uri x -> + (uri ^. uriAuthorityL === uriAuthority uri) .&&. + ((uri & uriAuthorityL .~ x) === uri { uriAuthority = x }) + , testProperty "uriPathL Lens" $ \uri x -> + (uri ^. uriPathL === uriPath uri) .&&. + ((uri & uriPathL .~ x) === uri { uriPath = x }) + , testProperty "uriQueryL Lens" $ \uri x -> + (uri ^. uriQueryL === uriQuery uri) .&&. + ((uri & uriQueryL .~ x) === uri { uriQuery = x }) + , testProperty "uriFragmentL Lens" $ \uri x -> + (uri ^. uriFragmentL === uriFragment uri) .&&. + ((uri & uriFragmentL .~ x) === uri { uriFragment = x }) + + , testProperty "rrAuthorityL Lens" $ \rr x -> + (rr ^. rrAuthorityL === rrAuthority rr) .&&. + ((rr & rrAuthorityL .~ x) === rr { rrAuthority = x }) + , testProperty "rrPathL Lens" $ \rr x -> + (rr ^. rrPathL === rrPath rr) .&&. + ((rr & rrPathL .~ x) === rr { rrPath = x }) + , testProperty "rrQueryL Lens" $ \rr x -> + (rr ^. rrQueryL === rrQuery rr) .&&. + ((rr & rrQueryL .~ x) === rr { rrQuery = x }) + , testProperty "rrFragmentL Lens" $ \rr x -> + (rr ^. rrFragmentL === rrFragment rr) .&&. + ((rr & rrFragmentL .~ x) === rr { rrFragment = x }) + ] + +testParses :: ByteString -> URI -> TestTree +testParses = testParses' strictURIParserOptions + + +testParseHost :: ByteString -> ByteString -> TestTree +testParseHost uri expectedHost = + testParses uri $ + URI (Scheme "http") + (Just (Authority Nothing (Host expectedHost) Nothing)) + mempty + mempty + Nothing + + +testParsesLax :: ByteString -> URI -> TestTree +testParsesLax = testParses' laxURIParserOptions + + +testParses' :: URIParserOptions -> ByteString -> URI -> TestTree +testParses' opts s u = testGroup "testParses'" + [ parseTestURI opts s $ Right u + , parseTestRelativeRef opts (makeRelativeRefBS s) $ Right (makeRelativeRefTyped u) + ] + + +makeRelativeRefTyped :: URI -> RelativeRef +makeRelativeRefTyped (URI _ a p q f) = RelativeRef a p q f + + +makeRelativeRefBS :: ByteString -> ByteString +makeRelativeRefBS s = B8.tail x + where + (_, x) = B8.break (==':') s + + +testParseFailure :: ByteString -> URIParseError -> TestTree +testParseFailure s = parseTestURI strictURIParserOptions s . Left + + +parseTestURI + :: URIParserOptions + -> ByteString + -> Either URIParseError URI + -> TestTree +parseTestURI opts s r = testCase (B8.unpack s) $ parseURI opts s @?= r + + +parseTestRelativeRef + :: URIParserOptions + -> ByteString + -> Either URIParseError RelativeRef + -> TestTree +parseTestRelativeRef opts s r = + testCase (B8.unpack s) $ parseRelativeRef opts s @?= r diff --git a/uri-bytestring.cabal b/uri-bytestring.cabal --- a/uri-bytestring.cabal +++ b/uri-bytestring.cabal @@ -1,5 +1,5 @@ name: uri-bytestring -version: 0.1.2 +version: 0.1.3 synopsis: Haskell URI parsing as ByteStrings description: uri-bytestring aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the URI data. license: BSD3 @@ -33,7 +33,7 @@ build-depends: - attoparsec >= 0.10 && < 0.13 + attoparsec >= 0.10 && < 0.14 , base >= 4.6 && < 4.9 , bytestring >= 0.9.1 && < 0.11 , blaze-builder >= 0.3.0.0 && < 0.5 @@ -49,6 +49,9 @@ test-suite test type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + URI.ByteString.Arbitrary + URI.ByteStringTests hs-source-dirs: test build-depends: uri-bytestring