diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,1 @@ +Copyright 2018 Alex Brandt diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for network-arbitrary + +## 0.1.0.0 -- 2018-01-05 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Alex Brandt + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# Description + +[Arbitrary] Instances for [Network][network-category] Types + +# Getting Started + +Documentation is available on [Hackage]. A great guide to [QuickCheck] is +. + +# Reporting Issues + +Any issues discovered should be recorded on [github][issues]. If you believe +you've found an error or have a suggestion for a new feature; please, ensure +that it is reported. + +If you would like to contribute a fix or new feature; please, submit a pull +request. This project follows [git flow] and utilizes [travis] to automatically +check pull requests before a manual review. + +# Contributors + +The `COPYRIGHT` file contains a list of contributors with their respective +copyrights and other information. If you submit a pull request and would like +attribution; please, add yourself to the `COPYRIGHT` file. + +[Arbitrary]: https://hackage.haskell.org/package/QuickCheck/docs/Test-QuickCheck-Arbitrary.html#t:Arbitrary +[git flow]: http://nvie.com/posts/a-successful-git-branching-model/ +[Hackage]: https://hackage.haskell.org/package/network-uri-json +[Haskell]: https://www.haskell.org/ +[issues]: https://github.com/alunduil/network-arbitrary/issues +[network-category]: https://hackage.haskell.org/packages/#cat:Network +[QuickCheck]: https://hackage.haskell.org/package/QuickCheck +[travis]: https://travis-ci.org/alunduil/network-arbitrary diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/network-arbitrary.cabal b/network-arbitrary.cabal new file mode 100644 --- /dev/null +++ b/network-arbitrary.cabal @@ -0,0 +1,77 @@ +name: network-arbitrary +version: 0.1.0.0 +synopsis: Arbitrary Instances for Network Types + +description: + Arbitrary instances for Network types. + +homepage: https://github.com/alunduil/network-arbitrary +bug-reports: https://github.com/alunduil/network-arbitrary/issues +license: MIT +license-file: LICENSE +author: Alex Brandt +maintainer: alunduil@alunduil.com +copyright: (c) 2018 Alex Brandt +category: Testing +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.6 && < 9.0 + +extra-source-files: + ChangeLog.md + , COPYRIGHT + , LICENSE + , README.md + , Setup.hs + +source-repository head + type: git + location: https://github.com/alunduil/network-arbitrary + branch: develop + +library + default-language: Haskell2010 + + ghc-options: -Wall -fwarn-tabs -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + + hs-source-dirs: + src + + exposed-modules: + Network.URI.Arbitrary + + other-modules: + + build-depends: + base >= 4.6 && < 4.12 + , network-uri == 2.6.* + , QuickCheck >= 2.9 && < 2.11 + + other-extensions: + +test-suite network-arbitrary-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + + ghc-options: -Wall -fwarn-tabs -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + + hs-source-dirs: + src + , test + + other-modules: + Network.URI.ArbitrarySpec + + build-tool-depends: + hspec-discover:hspec-discover == 2.4.* + + build-depends: + base >= 4.6 && < 4.12 + , hspec == 2.4.* + , network-uri == 2.6.* + , QuickCheck >= 2.9 && < 2.11 + + other-extensions: diff --git a/src/Network/URI/Arbitrary.hs b/src/Network/URI/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Arbitrary.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module : Network.URI.Arbitrary +Description : Arbitrary Instances for Network.URI +Copyright : (c) Alex Brandt, 2018 +License : MIT + +Arbitrary instances for "Network.URI". +-} +module Network.URI.Arbitrary () where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (replicateM) +import Data.List (intercalate) +import Network.URI (URI (..), URIAuth (..)) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), choose, elements, Gen, listOf, listOf1, oneof, suchThat) + +instance Arbitrary URI where + arbitrary = + do uriScheme <- scheme + uriAuthority <- arbitrary :: Gen (Maybe URIAuth) + uriPath <- path (null uriScheme) $ maybe True emptyAuthority uriAuthority + uriQuery <- oneof [query, return ""] + uriFragment <- oneof [fragment, return ""] + + return URI {..} + where emptyAuthority URIAuth{..} = all null [uriUserInfo, uriRegName, uriPort] + + shrink URI{..} = [ URI uriScheme' uriAuthority' uriPath' uriQuery' uriFragment' | (uriScheme', uriAuthority', uriPath', uriQuery', uriFragment') <- shrink (uriScheme, uriAuthority, uriPath, uriQuery, uriFragment) ] + +instance Arbitrary URIAuth where + arbitrary = URIAuth <$> userinfo + <*> host `suchThat` (not . null) + <*> port + + shrink URIAuth{..} = [ URIAuth uriUserInfo' uriRegName' uriPort' | (uriUserInfo', uriRegName', uriPort') <- shrink (uriUserInfo, uriRegName, uriPort) ] + +-- * RFC 3986 Generators +-- +-- Some generators are handled by the 'Arbitrary' instances above, and others +-- are folded into symbols that are preceeded or followed by identifying +-- tokens. + +scheme :: Gen String +scheme = + do a <- alpha + r <- listOf $ oneof [alpha, digit, elements ['+', '-', '.']] + return $ a : (r ++ ":") + +userinfo :: Gen String +userinfo = + do u <- concat <$> userinfo' + if null u + then return "" + else return $ u ++ "@" + where userinfo' = listOf $ oneof [ replicateM 1 $ oneof [unreserved, subDelims, return ':'] + , percentEncoded + ] + +host :: Gen String +host = oneof [ ipLiteral + , ipv4Address + , regName + ] + +port :: Gen String +port = + do p <- listOf digit + if null p + then return "" + else return $ ':':p + +ipLiteral :: Gen String +ipLiteral = + do x <- oneof [ ipv6Address + --, ipvFuture + ] + return $ "[" ++ x ++ "]" + +{- TODO Check that "Network.URI" implements this correctly. +ipvFuture :: Gen String +ipvFuture = + do h <- hexdig + o <- oneof [ unreserved, subDelims, return ':' ] + return ['v', h, '.', o] +-} + +ipv6Address :: Gen String +ipv6Address = concat <$> oneof [ sequence [b 6, ls32] + , sequence [return "::", b 5, ls32] + , sequence [h16, return "::", b 4, ls32] + , sequence [b 1, h16, return "::", b 3, ls32] + , sequence [b 2, h16, return "::", b 2, ls32] + , sequence [b 3, h16, return "::", b 1, ls32] + , sequence [b 4, h16, return "::", ls32] + , sequence [b 5, h16, return "::", h16] + , sequence [b 6, h16, return "::"] + ] + where b n = fmap concat $ replicateM n $ fmap (++ ":") h16 :: Gen String + +h16 :: Gen String +h16 = replicateM 4 hexdig + +ls32 :: Gen String +ls32 = oneof [ intercalate ":" <$> replicateM 2 h16 + , ipv4Address + ] + +ipv4Address :: Gen String +ipv4Address = intercalate "." <$> replicateM 4 decOctet + +decOctet :: Gen String +decOctet = (show :: Int -> String) <$> choose (0, 255) + +regName :: Gen String +regName = fmap concat $ listOf $ oneof [ replicateM 1 unreserved + , percentEncoded + , replicateM 1 subDelims + ] + +path :: Bool -> Bool -> Gen String +path emptyScheme emptyURIAuth = if emptyURIAuth + then oneof [ pathAbsolute + , if emptyScheme then pathNoScheme else pathRootless + , return "" + ] + else pathAbEmpty + +pathAbEmpty :: Gen String +pathAbEmpty = concat <$> listOf ((('/':) . concat) <$> listOf pchar) + +pathAbsolute :: Gen String +pathAbsolute = ('/':) <$> oneof [return "", pathRootless] + +pathNoScheme :: Gen String +pathNoScheme = concat <$> sequence [segment1nc, pathAbEmpty] + +pathRootless :: Gen String +pathRootless = concat <$> sequence [ concat <$> listOf1 pchar + , pathAbEmpty + ] + +segment1nc :: Gen String +segment1nc = oneof [ replicateM 1 unreserved + , percentEncoded + , replicateM 1 subDelims + , replicateM 1 $ return '@' + ] + +pchar :: Gen String +pchar = oneof [ replicateM 1 unreserved + , percentEncoded + , replicateM 1 subDelims + , replicateM 1 $ return ':' + , replicateM 1 $ return '@' + ] + +query :: Gen String +query = fmap (('?':) . concat) $ listOf $ oneof [ pchar + , return "/" + , return "?" + ] + +fragment :: Gen String +fragment = fmap (('#':) . concat) $ listOf $ oneof [ pchar + , return "/" + , return "?" + ] + +percentEncoded :: Gen String +percentEncoded = ('%':) <$> replicateM 2 hexdig + +unreserved :: Gen Char +unreserved = oneof [ alpha, digit, elements ['-', '.', '_', '~']] + +subDelims :: Gen Char +subDelims = elements ['!', '$', '&', '\'', '(', ')', '*', '+', ',', ';', '='] + +-- * RFC 2234 Generators + +alpha :: Gen Char +alpha = elements $ ['a'..'z'] ++ ['A'..'Z'] + +digit :: Gen Char +digit = elements ['0'..'9'] + +hexdig :: Gen Char +hexdig = oneof [digit, elements ['A'..'F']] diff --git a/test/Network/URI/ArbitrarySpec.hs b/test/Network/URI/ArbitrarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/URI/ArbitrarySpec.hs @@ -0,0 +1,25 @@ +{-| +Module : Network.URI.ArbitrarySpec +Description : Tests for Network.URI.Arbitrary +Copyright : (c) Alex Brandt, 2018 +License : MIT + +Tests for "Network.URI.Arbitrary". +-} +module Network.URI.ArbitrarySpec (main, spec) where + +import Network.URI (isURIReference, parseURIReference, uriToString) +import Test.Hspec (describe, hspec, Spec) +import Test.Hspec.QuickCheck (prop) + +import Network.URI.Arbitrary () + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "properties" $ + do prop "isURIReference (uriToString id u \"\")" $ \ u -> isURIReference (uriToString id u "") + + prop "Just u == parseURIReference (uriToString id u \"\")" $ \ u -> Just u == parseURIReference (uriToString id u "") 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 hspec-discover #-}