Merge pull request #18 from garyb/ipv4address-parsing

Fix parsing of IPv4 addresses

Author: garyb

bower.json

@@ -25,6 +25,7 @@
     "purescript-unfoldable": "^3.0.0"
   },
   "devDependencies": {
-    "purescript-test-unit": "11.0.0"
+    "purescript-test-unit": "11.0.0",
+    "purescript-strongcheck": "^3.1.0"
   }
 }

src/Data/URI/Host.purs

@@ -6,14 +6,13 @@ module Data.URI.Host
 import Prelude
 
 import Control.Alt ((<|>))
-
-import Data.String as S
+import Data.Int as Int
+import Data.Maybe (Maybe(..))
 import Data.URI.Common (parseSubDelims, parsePCTEncoded, parseUnreserved, joinWith, rxPat)
 import Data.URI.Types (Host(..))
-
-import Text.Parsing.StringParser (Parser, try)
+import Text.Parsing.StringParser (Parser, try, fail)
 import Text.Parsing.StringParser.Combinators ((<?>), many1)
-import Text.Parsing.StringParser.String (string)
+import Text.Parsing.StringParser.String (string, char)
 
 parseHost ∷ Parser Host
 parseHost = parseIPv6Address <|> parseIPv4Address <|> parseRegName
@@ -23,12 +22,24 @@ parseIPv6Address ∷ Parser Host
 parseIPv6Address = IPv6Address <$> (string "[" *> rxPat "[a-f0-9\\.:]+" <* string "]") <?> "IPv6 address"
 
 parseIPv4Address ∷ Parser Host
-parseIPv4Address = IPv4Address <$> rxPat pattern <?> "IPv4 address"
+parseIPv4Address = IPv4Address <$> parse <?> "IPv4 address"
   where
-  pattern ∷ String
-  pattern = S.joinWith "" ["(", octet, "\\.", octet, "\\.", octet, "\\.", octet, ")"]
-  octet ∷ String
-  octet = "(1[0-9]{2}|[1-9][0-9]|[0-9]|2[0-4][0-9]|25[0-5])"
+  parse ∷ Parser String
+  parse = do
+    o1 <- octet
+    _ <- char '.'
+    o2 <- octet
+    _ <- char '.'
+    o3 <- octet
+    _ <- char '.'
+    o4 <- octet
+    pure $ show o1 <> "." <> show o2 <> "." <> show o3 <> "." <> show o4
+  octet ∷ Parser Int
+  octet = do
+    s <- rxPat "0|([1-9][0-9]{0,2})"
+    case Int.fromString s of
+      Just n | n >= 0 && n <= 255 -> pure n
+      _ -> fail "Invalid IPv4 address octet"
 
 parseRegName ∷ Parser Host
 parseRegName =

src/Data/URI/Host/Gen.purs

@@ -0,0 +1,15 @@
+module Data.URI.Host.Gen where
+
+import Prelude
+
+import Control.Monad.Gen as Gen
+import Data.String as S
+import Data.URI.Host (Host(..))
+
+genIPv4 :: forall m. Gen.MonadGen m => m Host
+genIPv4 = do
+  a <- Gen.chooseInt 0 255
+  b <- Gen.chooseInt 0 255
+  c <- Gen.chooseInt 0 255
+  d <- Gen.chooseInt 0 255
+  pure $ IPv4Address $ S.joinWith "." $ show <$> [a, b, c, d]

test/Main.purs

@@ -4,15 +4,25 @@ import Prelude
 import Control.Alternative (empty)
 import Control.Monad.Aff.AVar (AVAR)
 import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Class (liftEff)
 import Control.Monad.Eff.Console (CONSOLE)
+import Control.Monad.Eff.Random (RANDOM)
+import Data.Array as A
 import Data.Either (isLeft, Either(..))
-import Data.List (List(Nil), singleton, (:))
+import Data.Foldable (findMap)
+import Data.List (List(..), singleton, (:))
 import Data.Maybe (Maybe(Nothing, Just))
 import Data.Path.Pathy (currentDir, parentDir', file, dir, rootDir, (</>))
-import Data.Tuple (Tuple(Tuple))
+import Data.Tuple (Tuple(..), snd)
 import Data.URI (Authority(Authority), HierarchicalPart(HierarchicalPart), Host(IPv4Address, NameAddress, IPv6Address), Query(Query), RelativePart(RelativePart), RelativeRef(RelativeRef), URI(URI), URIScheme(URIScheme), runParseURIRef)
+import Data.URI.Host as Host
+import Data.URI.Host.Gen as Host.Gen
 import Data.URI.Query (parseQuery, printQuery)
-import Test.Unit (suite, test, TestSuite)
+import Test.StrongCheck ((===))
+import Test.StrongCheck as SC
+import Test.StrongCheck.Gen as SCG
+import Test.StrongCheck.LCG as SCL
+import Test.Unit (Test, suite, test, TestSuite, success, failure)
 import Test.Unit.Assert (assert, equal)
 import Test.Unit.Console (TESTOUTPUT)
 import Test.Unit.Main (runTest)
@@ -42,8 +52,22 @@ testParseQueryParses uri query =
     ("parses: \"" <> uri <> "\"")
     (equal (Right query) (runParser parseQuery uri))
 
-main :: forall eff. Eff ( console :: CONSOLE , testOutput :: TESTOUTPUT, avar :: AVAR | eff ) Unit
+main :: forall eff. Eff ( console :: CONSOLE , testOutput :: TESTOUTPUT, avar :: AVAR, random :: RANDOM | eff ) Unit
 main = runTest $ suite "Data.URI" do
+
+  suite "parseIPv4Address" do
+
+    test "parseIPv4Address / printHost roundtrip" do
+      forAll do
+        ipv4 <- Host.Gen.genIPv4
+        let printed = Host.printHost ipv4
+        let parsed = runParser Host.parseIPv4Address printed
+        pure $ pure ipv4 === parsed
+
+    test "0-lead octets should not parse" do
+      assert ("parse should fail for 192.168.001.1") $
+        isLeft $ runParser Host.parseIPv4Address "192.168.001.1"
+
   suite "runParseURIRef" do
     testRunParseURIRefParses
       "sql2:///?q=foo&var.bar=baz"
@@ -312,4 +336,25 @@ main = runTest $ suite "Data.URI" do
       "key1=&key2="
       (Query (Tuple "key1" (Just "") : Tuple "key2" (Just "") : Nil))
 
+forAll :: forall e prop. SC.Testable prop => SCG.Gen prop -> Test (random :: RANDOM | e)
+forAll = quickCheck
+
+quickCheck :: forall e prop. SC.Testable prop => prop -> Test (random :: RANDOM | e)
+quickCheck = quickCheck' 100
 
+quickCheck' :: forall e prop. SC.Testable prop => Int -> prop -> Test (random :: RANDOM | e)
+quickCheck' tries prop = do
+  seed <- liftEff $ SCL.randomSeed
+  let
+    results = SC.quickCheckPure tries seed prop
+    successes = A.length $ A.filter ((_ == SC.Success) <<< snd) $ results
+    findErr = findMap case _ of
+      Tuple seed' (SC.Failed msg) -> Just (Tuple seed' msg)
+      _ -> Nothing
+  case findErr results of
+    Nothing ->
+      success
+    Just (Tuple seed' msg) ->
+      failure $
+        show (tries - successes) <> "/" <> show tries <> " tests failed: "
+          <> msg <> " (seed " <> show (SCL.runSeed seed') <> ")"