io.sockets.secure.openssl: guard against SSL_get_peer_certificate returning null

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

@@ -1,17 +1,23 @@
-USING: accessors alien http.client io.sockets io.sockets.private
-io.sockets.secure.openssl kernel openssl.libcrypto openssl.libssl
-sequences tools.test urls unix.ffi ;
+USING: accessors alien continuations http.client http.server io.servers
+io.sockets io.sockets.private io.sockets.secure io.sockets.secure.openssl
+kernel openssl.libcrypto openssl.libssl sequences system tools.test urls
+unix.ffi ;
 IN: io.sockets.secure.openssl.tests
 
 : new-ssl ( -- ssl )
     SSLv23_client_method SSL_CTX_new SSL_new ;
 
+! This word creates blocking sockets for testing purposes. Factor by
+! default prefers to use non-blocking ones.
+: inet-socket ( -- socket )
+    AF_INET SOCK_STREAM IPPROTO_TCP socket ;
+
 : socket-connect ( remote -- socket )
-    AF_INET SOCK_STREAM IPPROTO_TCP socket swap dupd
-    make-sockaddr/size connect drop ;
+    inet-socket swap dupd make-sockaddr/size connect drop ;
 
 : ssl-socket-connect ( remote -- ssl-socket )
-    socket-connect alien-address BIO_NOCLOSE BIO_new_socket ;
+    socket-connect os windows? [ alien-address ] when
+    BIO_NOCLOSE BIO_new_socket ;
 
 : remote ( -- remote )
     URL" https://www.google.com" url-addr addrspec>> resolve-host first ;
@@ -23,19 +29,16 @@ IN: io.sockets.secure.openssl.tests
     dup SSL_connect drop SSL_get_peer_certificate subject-name
 ] unit-test
 
-[ "www.google.com" ] [
-    new-ssl
-    [
-        remote (client) drop nip handle>> handle>>
-        alien-address BIO_NOCLOSE BIO_new_socket dup SSL_set_bio
-    ]
-    [ SSL_connect drop ]
-    [ SSL_get_peer_certificate ] tri
-    subject-name
+[ t ] [
+    <http-server> 8887 >>insecure f >>secure [
+        [
+            "https://localhost:8887" http-get
+        ] [ certificate-missing-error? ] recover
+    ] with-threaded-server
 ] unit-test
 
-[ "google.com" ] [
-    URL" https://www.google.se" url-addr resolve-host first
-    [ ((client)) ] keep [ <ports> ] dip establish-connection
-    handle>> handle>> SSL_get_peer_certificate subject-name
+[ t ] [
+    [
+        "test" 33 <ssl-handle> handle>> check-subject-name
+    ] [ certificate-missing-error? ] recover
 ] unit-test

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

@@ -204,10 +204,11 @@ M: ssl-handle dispose*
     [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
 
 : check-subject-name ( host ssl-handle -- )
-    SSL_get_peer_certificate
-    [ alternative-dns-names ] [ subject-name ] bi suffix
-    2dup [ subject-names-match? ] with any?
-    [ 2drop ] [ subject-name-verify-error ] if ;
+    SSL_get_peer_certificate [
+        [ alternative-dns-names ] [ subject-name ] bi suffix
+        2dup [ subject-names-match? ] with any?
+        [ 2drop ] [ subject-name-verify-error ] if
+    ] [ certificate-missing-error ] if* ;
 
 M: openssl check-certificate ( host ssl -- )
     current-secure-context config>> verify>> [

basis/io/sockets/secure/secure.factor

@@ -82,6 +82,11 @@ ERROR: subject-name-verify-error expected got ;
 M: subject-name-verify-error summary
     drop "Subject name verification failed" ;
 
+ERROR: certificate-missing-error ;
+
+M: certificate-missing-error summary
+    drop "Host did not present any certificate" ;
+
 ERROR: upgrade-on-non-socket ;
 
 M: upgrade-on-non-socket summary