io.sockets.secure, io.sockets.secure.openssl: improved host name verification that takes into account a certificates subject alternative names.

basis/io/sockets/secure/openssl/openssl-docs.factor

@@ -0,0 +1,21 @@
+USING: help.markup help.syntax ;
+IN: io.sockets.secure.openssl
+
+
+HELP: subject-name
+{ $values { "certificate" "an SSL peer certificate" } }
+{ $description "The subject name of a certificate." } ;
+
+HELP: subject-names-match?
+{ $values { "host" "a host name" } { "subject" "a subject name" } }
+{ $description "True if the host name matches the subject name." }
+{ $examples
+    { $code
+        "\"www.google.se\" \"*.google.se\" subject-names-match?"
+        "t"
+    }
+} ;
+
+HELP: alternative-dns-names
+{ $values { "certificate" "an SSL peer certificate" } }
+{ $description "Alternative subject names for the certificate." } ;

basis/io/sockets/secure/openssl/openssl-tests.factor

@@ -0,0 +1,4 @@
+USING: accessors http.client kernel tools.test ;
+IN: io.sockets.secure.openssl.tests
+
+[ 200 ] [ "https://www.google.se" http-get drop code>> ] unit-test

basis/io/sockets/secure/openssl/openssl.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays kernel sequences namespaces math
+USING: accessors byte-arrays classes.struct kernel sequences namespaces math
 math.order combinators init alien alien.c-types alien.data
 alien.strings libc continuations destructors summary splitting
 assocs random math.parser locals unicode.case openssl
 openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
-io.encodings.8-bit.latin1 io.timeouts io.sockets.secure ;
+io.encodings.8-bit.latin1 io.encodings.utf8 io.timeouts io.sockets.secure ;
 IN: io.sockets.secure.openssl
 
 GENERIC: ssl-method ( symbol -- method )
@@ -175,25 +175,33 @@ M: ssl-handle dispose*
     [ 256 X509_NAME_get_text_by_NID ] keep
     swap -1 = [ drop f ] [ latin1 alien>string ] if ;
 
-: common-name ( certificate -- host )
+: subject-name ( certificate -- host )
     X509_get_subject_name x509name>string ;
 
 : issuer-name ( certificate -- issuer )
     X509_get_issuer_name x509name>string ;
 
-: common-names-match? ( expected actual -- ? )
+: name-stack>seq ( name-stack -- seq )
+    dup sk_num iota [ sk_value GENERAL_NAME_st memory>struct ] with map ;
+
+: alternative-dns-names ( certificate -- dns-names )
+    NID_subject_alt_name f f X509_get_ext_d2i [ name-stack>seq ] [ { } ] if*
+    [ type>> GEN_DNS = ] filter
+    [ d>> dNSName>> data>> utf8 alien>string ] map ;
+
+: subject-names-match? ( host subject -- ? )
     [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
 
-: check-common-name ( host ssl-handle -- )
-    SSL_get_peer_certificate common-name
-    2dup common-names-match?
-    [ 2drop ] [ common-name-verify-error ] if ;
+: check-subject-name ( host ssl-handle -- )
+    SSL_get_peer_certificate [ alternative-dns-names ] [ subject-name ] bi
+    suffix 2dup [ subject-names-match? ] with filter empty?
+    [ subject-name-verify-error ] [ 2drop ] if ;
 
 M: openssl check-certificate ( host ssl -- )
     current-secure-context config>> verify>> [
         handle>>
         [ nip check-verify-result ]
-        [ check-common-name ]
+        [ check-subject-name ]
         2bi
     ] [ 2drop ] if ;
 

basis/io/sockets/secure/secure-docs.factor

@@ -126,8 +126,8 @@ HELP: premature-close
 HELP: certificate-verify-error
 { $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ;
 
-HELP: common-name-verify-error
-{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ;
+HELP: subject-name-verify-error
+{ $error-description "Thrown during certificate verification if the subject names on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ;
 
 HELP: upgrade-on-non-socket
 { $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called with the " { $link input-stream } " and " { $link output-stream } " variables not set to a socket. This error can also indicate that the connection has already been upgraded to a secure connection." } ;

basis/io/sockets/secure/secure.factor

@@ -77,10 +77,10 @@ ERROR: certificate-verify-error result ;
 M: certificate-verify-error summary
     drop "Certificate verification failed" ;
 
-ERROR: common-name-verify-error expected got ;
+ERROR: subject-name-verify-error expected got ;
 
-M: common-name-verify-error summary
-    drop "Common name verification failed" ;
+M: subject-name-verify-error summary
+    drop "Subject name verification failed" ;
 
 ERROR: upgrade-on-non-socket ;