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
|
||||
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
|
||||
|
|
|
@ -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>> [
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue