diff --git a/basis/io/sockets/secure/openssl/openssl-tests.factor b/basis/io/sockets/secure/openssl/openssl-tests.factor index 3349801f2e..525df80170 100644 --- a/basis/io/sockets/secure/openssl/openssl-tests.factor +++ b/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 ] [ + 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 [ ] dip establish-connection - handle>> handle>> SSL_get_peer_certificate subject-name +[ t ] [ + [ + "test" 33 handle>> check-subject-name + ] [ certificate-missing-error? ] recover ] unit-test diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index a2d690a88d..0c6aba05f0 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/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>> [ diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index fdee739070..987e58d3fb 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/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