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

db4
Björn Lindqvist 2014-03-06 18:41:37 +01:00
parent abf610b2e4
commit 39b13b6736
3 changed files with 32 additions and 23 deletions

View File

@ -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

View File

@ -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>> [

View File

@ -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