From d7d1b6fea197980a2f5f65ba9deee948ab7a2be3 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Fri, 19 Aug 2011 14:19:09 -0700
Subject: [PATCH] io.sockets: check ipv4 and ipv6 for valid address strings.

---
 basis/io/sockets/sockets-tests.factor |  6 +++
 basis/io/sockets/sockets.factor       | 54 +++++++++++++++++----------
 2 files changed, 41 insertions(+), 19 deletions(-)

diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor
index 7e57f87a9e..685d5a649a 100644
--- a/basis/io/sockets/sockets-tests.factor
+++ b/basis/io/sockets/sockets-tests.factor
@@ -29,6 +29,12 @@ os unix? [
 
 [ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test
 
+! Test bad hostnames
+[ "google.com" f <inet4> ] must-fail
+[ "a.b.c.d" f <inet4> ] must-fail
+[ "google.com" f <inet6> ] must-fail
+[ "a.b.c.d" f <inet6> ] must-fail
+
 ! Test present on addrspecs
 [ "4.4.4.4:12" ] [ "4.4.4.4" 12 <inet4> present ] unit-test
 [ "::1:12" ] [ "::1" 12 <inet6> present ] unit-test
diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor
index 0865500f76..2da840833c 100644
--- a/basis/io/sockets/sockets.factor
+++ b/basis/io/sockets/sockets.factor
@@ -68,27 +68,32 @@ SLOT: port
 
 TUPLE: ipv4 { host ?string read-only } ;
 
-C: <ipv4> ipv4
-
-M: ipv4 inet-ntop ( data addrspec -- str )
-    drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
-
 <PRIVATE
 
+ERROR: invalid-ipv4 string reason ;
+
+M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
+
 ERROR: malformed-ipv4 sequence ;
 
 ERROR: bad-ipv4-component string ;
 
 : parse-ipv4 ( string -- seq )
-    "." split dup length 4 = [ malformed-ipv4 ] unless
-    [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ;
+    [ f ] [
+        "." split dup length 4 = [ malformed-ipv4 ] unless
+        [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as
+    ] if-empty ;
 
-ERROR: invalid-ipv4 string reason ;
-
-M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
+: check-ipv4 ( string -- )
+    [ parse-ipv4 drop ] [ invalid-ipv4 ] recover ;
 
 PRIVATE>
 
+: <ipv4> ( host -- ipv4 ) dup check-ipv4 ipv4 boa ;
+
+M: ipv4 inet-ntop ( data addrspec -- str )
+    drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
+
 M: ipv4 inet-pton ( str addrspec -- data )
     drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
 
@@ -113,7 +118,8 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
 
 TUPLE: inet4 < ipv4 { port integer read-only } ;
 
-C: <inet4> inet4
+: <inet4> ( host port -- inet4 )
+    over check-ipv4 inet4 boa ;
 
 M: ipv4 with-port [ host>> ] dip <inet4> ;
 
@@ -129,15 +135,12 @@ TUPLE: ipv6
 { host ?string read-only }
 { scope-id integer read-only } ;
 
-: <ipv6> ( host -- ipv6 ) 0 ipv6 boa ;
-
-M: ipv6 inet-ntop ( data addrspec -- str )
-    drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
-
-ERROR: invalid-ipv6 string reason ;
-
 <PRIVATE
 
+ERROR: invalid-ipv6 host reason ;
+
+M: invalid-ipv6 summary drop "Invalid IPv6 address" ;
+
 ERROR: bad-ipv6-component obj ;
 
 ERROR: bad-ipv4-embedded-prefix obj ;
@@ -157,6 +160,18 @@ ERROR: more-than-8-components ;
         ] if
     ] if-empty ;
 
+: check-ipv6 ( string -- )
+    [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ;
+
+PRIVATE>
+
+: <ipv6> ( host -- ipv6 ) dup check-ipv6 0 ipv6 boa ;
+
+M: ipv6 inet-ntop ( data addrspec -- str )
+    drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+
+<PRIVATE
+
 : pad-ipv6 ( string1 string2 -- seq )
     2dup [ length ] bi@ + 8 swap -
     dup 0 < [ more-than-8-components ] when
@@ -200,7 +215,8 @@ M: ipv6 present
 
 TUPLE: inet6 < ipv6 { port integer read-only } ;
 
-: <inet6> ( host port -- inet6 ) [ 0 ] dip inet6 boa ;
+: <inet6> ( host port -- inet6 )
+    [ dup check-ipv6 0 ] dip inet6 boa ;
 
 M: ipv6 with-port
     [ [ host>> ] [ scope-id>> ] bi ] dip