io.sockets.secure.openssl: guard against SSL_get_peer_certificate returning null
parent
abf610b2e4
commit
39b13b6736
|
@ -1,17 +1,23 @@
|
||||||
USING: accessors alien http.client io.sockets io.sockets.private
|
USING: accessors alien continuations http.client http.server io.servers
|
||||||
io.sockets.secure.openssl kernel openssl.libcrypto openssl.libssl
|
io.sockets io.sockets.private io.sockets.secure io.sockets.secure.openssl
|
||||||
sequences tools.test urls unix.ffi ;
|
kernel openssl.libcrypto openssl.libssl sequences system tools.test urls
|
||||||
|
unix.ffi ;
|
||||||
IN: io.sockets.secure.openssl.tests
|
IN: io.sockets.secure.openssl.tests
|
||||||
|
|
||||||
: new-ssl ( -- ssl )
|
: new-ssl ( -- ssl )
|
||||||
SSLv23_client_method SSL_CTX_new SSL_new ;
|
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 )
|
: socket-connect ( remote -- socket )
|
||||||
AF_INET SOCK_STREAM IPPROTO_TCP socket swap dupd
|
inet-socket swap dupd make-sockaddr/size connect drop ;
|
||||||
make-sockaddr/size connect drop ;
|
|
||||||
|
|
||||||
: ssl-socket-connect ( remote -- ssl-socket )
|
: 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 )
|
: remote ( -- remote )
|
||||||
URL" https://www.google.com" url-addr addrspec>> resolve-host first ;
|
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
|
dup SSL_connect drop SSL_get_peer_certificate subject-name
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "www.google.com" ] [
|
[ t ] [
|
||||||
new-ssl
|
<http-server> 8887 >>insecure f >>secure [
|
||||||
[
|
[
|
||||||
remote (client) drop nip handle>> handle>>
|
"https://localhost:8887" http-get
|
||||||
alien-address BIO_NOCLOSE BIO_new_socket dup SSL_set_bio
|
] [ certificate-missing-error? ] recover
|
||||||
]
|
] with-threaded-server
|
||||||
[ SSL_connect drop ]
|
|
||||||
[ SSL_get_peer_certificate ] tri
|
|
||||||
subject-name
|
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "google.com" ] [
|
[ t ] [
|
||||||
URL" https://www.google.se" url-addr resolve-host first
|
[
|
||||||
[ ((client)) ] keep [ <ports> ] dip establish-connection
|
"test" 33 <ssl-handle> handle>> check-subject-name
|
||||||
handle>> handle>> SSL_get_peer_certificate subject-name
|
] [ certificate-missing-error? ] recover
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -204,10 +204,11 @@ M: ssl-handle dispose*
|
||||||
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
|
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
|
||||||
|
|
||||||
: check-subject-name ( host ssl-handle -- )
|
: check-subject-name ( host ssl-handle -- )
|
||||||
SSL_get_peer_certificate
|
SSL_get_peer_certificate [
|
||||||
[ alternative-dns-names ] [ subject-name ] bi suffix
|
[ alternative-dns-names ] [ subject-name ] bi suffix
|
||||||
2dup [ subject-names-match? ] with any?
|
2dup [ subject-names-match? ] with any?
|
||||||
[ 2drop ] [ subject-name-verify-error ] if ;
|
[ 2drop ] [ subject-name-verify-error ] if
|
||||||
|
] [ certificate-missing-error ] if* ;
|
||||||
|
|
||||||
M: openssl check-certificate ( host ssl -- )
|
M: openssl check-certificate ( host ssl -- )
|
||||||
current-secure-context config>> verify>> [
|
current-secure-context config>> verify>> [
|
||||||
|
|
|
@ -82,6 +82,11 @@ ERROR: subject-name-verify-error expected got ;
|
||||||
M: subject-name-verify-error summary
|
M: subject-name-verify-error summary
|
||||||
drop "Subject name verification failed" ;
|
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 ;
|
ERROR: upgrade-on-non-socket ;
|
||||||
|
|
||||||
M: upgrade-on-non-socket summary
|
M: upgrade-on-non-socket summary
|
||||||
|
|
Loading…
Reference in New Issue