From 1032ce8afea53bea9a2739982dfecba641ec637d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Mar 2012 10:42:02 -0700 Subject: [PATCH] openssl: make `ssl-set-verify!' and `ssl-try-verify!' work on ports Using the functions on a port triggers renegotiation of the connection, which s useful for cases such as a web server that requires a certificate only for certain paths. This functionality also allows better testing of the SSL library. --- collects/openssl/mzssl.rkt | 164 +++++++++++++++++++------- collects/openssl/openssl.scrbl | 43 ++++--- collects/tests/openssl/peer-verif.rkt | 148 +++++++++++++++-------- 3 files changed, 246 insertions(+), 109 deletions(-) diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index bd385f4fb7..a67834b392 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -37,19 +37,14 @@ ssl-load-verify-root-certificates! ssl-load-suggested-certificate-authorities! - ssl-set-verify! - - ;sets the ssl server to try an verify certificates - ;it does not require verification though. - ssl-try-verify! + ssl-set-verify! + ssl-try-verify! - ;call on an ssl port, this will return true if the peer - ;presented a valid certificate and was verified - ssl-peer-verified? - ssl-peer-subject-name - ssl-peer-issuer-name + ssl-peer-verified? + ssl-peer-subject-name + ssl-peer-issuer-name - ports->ssl-ports + ports->ssl-ports ssl-listen ssl-close @@ -138,6 +133,11 @@ (define-ssl SSL_shutdown (_fun _SSL* -> _int)) (define-ssl SSL_get_verify_result (_fun _SSL* -> _long)) (define-ssl SSL_get_peer_certificate (_fun _SSL* -> _X509*)) + (define-ssl SSL_set_verify (_fun _SSL* _int _pointer -> _void)) + (define-ssl SSL_set_session_id_context (_fun _SSL* _bytes _int -> _int)) + (define-ssl SSL_renegotiate (_fun _SSL* -> _int)) + (define-ssl SSL_renegotiate_pending (_fun _SSL* -> _int)) + (define-ssl SSL_do_handshake (_fun _SSL* -> _int)) (define-crypto X509_get_subject_name (_fun _X509* -> _X509_NAME*)) (define-crypto X509_get_issuer_name (_fun _X509* -> _X509_NAME*)) @@ -188,6 +188,26 @@ ;; has an implicitation for clients as noted at the top of this file. (define enforce-retry? #f) + ;; Needed for `renegotiate': + (define-cstruct _ssl_struct ([version _int] + [type _int] + [method _pointer] + [rbio _pointer] + [wbio _pointer] + [bbio _pointer] + [rwstate _int] + [in_handshake _int] + [handshake_func _fpointer] + [server _int] + [new_session _int] + [quiet_shutdown _int] + [shutdown _int] + [state _int] + ;; ... + )) + + (define SSL_ST_ACCEPT #x2000) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Error handling @@ -332,16 +352,18 @@ (SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE) ctx))) - (define (get-context/listener who ssl-context-or-listener) + (define (get-context/listener who ssl-context-or-listener [fail? #t]) (cond [(ssl-context? ssl-context-or-listener) (ssl-context-ctx ssl-context-or-listener)] [(ssl-listener? ssl-context-or-listener) (ssl-context-ctx (ssl-listener-mzctx ssl-context-or-listener))] [else - (raise-type-error who - "SSL context or listener" - ssl-context-or-listener)])) + (if fail? + (raise-type-error who + "SSL context or listener" + ssl-context-or-listener) + #f)])) (define (ssl-load-... who load-it ssl-context-or-listener pathname) (let ([ctx (get-context/listener 'ssl-load-certificate-chain! @@ -390,31 +412,80 @@ (if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM))) ssl-context-or-listener pathname)) - (define (ssl-set-verify! ssl-context-or-listener on?) - (let ([ctx (get-context/listener 'ssl-set-verify! - ssl-context-or-listener)]) - (SSL_CTX_set_verify ctx - (if on? - (bitwise-ior SSL_VERIFY_PEER - SSL_VERIFY_FAIL_IF_NO_PEER_CERT) - SSL_VERIFY_NONE) - #f))) - - (define (ssl-try-verify! ssl-context-or-listener on?) - (let ([ctx (get-context/listener 'ssl-set-verify! - ssl-context-or-listener)]) - - ;required by openssl. This is more for when calling i2d_SSL_SESSION/d2i_SSL_SESSION - ;for instance if we were saving sessions in a database etc... We aren't using that - ;so a generic session name should be fine. - (let ([bytes #"racket"]) - (SSL_CTX_set_session_id_context ctx bytes (bytes-length bytes))) - - (SSL_CTX_set_verify ctx - (if on? - SSL_VERIFY_PEER - SSL_VERIFY_NONE) - #f))) + (define (ssl-try-verify! ssl-context-or-listener-or-port on?) + (do-ssl-set-verify! ssl-context-or-listener-or-port on? + 'ssl-try-verify! + SSL_VERIFY_PEER)) + + (define (ssl-set-verify! ssl-context-or-listener-or-port on?) + (do-ssl-set-verify! ssl-context-or-listener-or-port on? + 'ssl-set-verify! + (bitwise-ior SSL_VERIFY_PEER + SSL_VERIFY_FAIL_IF_NO_PEER_CERT))) + + (define (do-ssl-set-verify! ssl-context-or-listener-or-port on? who mode) + (cond + [(get-context/listener who + ssl-context-or-listener-or-port + #f) + => (lambda (ctx) + ;; required by openssl. This is more for when calling i2d_SSL_SESSION/d2i_SSL_SESSION + ;; for instance if we were saving sessions in a database etc... We aren't using that + ;; so a generic session name should be fine. + (let ([bytes #"racket"]) + (SSL_CTX_set_session_id_context ctx bytes (bytes-length bytes))) + + (SSL_CTX_set_verify ctx + (if on? + mode + SSL_VERIFY_NONE) + #f))] + [else + (let-values ([(mzssl input?) (lookup who "SSL context, listener, or port" + ssl-context-or-listener-or-port)]) + (SSL_set_verify (mzssl-ssl mzssl) + (if on? + mode + SSL_VERIFY_NONE) + #f) + (let ([bytes #"racket"]) + (SSL_set_session_id_context (mzssl-ssl mzssl) bytes (bytes-length bytes))) + (when on? (renegotiate who mzssl)))])) + + (define (renegotiate who mzssl) + (define (check-err thunk) + (let loop () + (define v (thunk)) + (when (negative? v) + (define err (SSL_get_error (mzssl-ssl mzssl) v)) + (cond + [(= err SSL_ERROR_WANT_READ) + (let ([n (pump-input-once mzssl #f)]) + (if (eq? n 0) + (let ([out-blocked? (pump-output mzssl)]) + (sync (mzssl-i mzssl) + (if out-blocked? + (mzssl-o mzssl) + never-evt)) + (loop)) + (loop)))] + [(= err SSL_ERROR_WANT_WRITE) + (if (pump-output-once mzssl #f #f) + (loop) + (begin + (sync (mzssl-o mzssl)) + (loop)))] + [else + (error who "failed: ~a" (get-error-message (ERR_get_error)))])))) + (check-err (lambda () (SSL_renegotiate (mzssl-ssl mzssl)))) + (check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl)))) + ;; Really demanding a negotiation from the server side + ;; requires a hacky little dance: + (when (positive? (ssl_struct-server + (cast (mzssl-ssl mzssl) _pointer _ssl_struct-pointer))) + (set-ssl_struct-state! (cast (mzssl-ssl mzssl) _pointer _ssl_struct-pointer) + SSL_ST_ACCEPT) + (check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SSL ports @@ -686,7 +757,7 @@ (set! must-write-len len)) (let ([n (pump-input-once mzssl #f)]) (if (eq? n 0) - (begin + (let ([out-blocked? (pump-output mzssl)]) (when enforce-retry? (set-mzssl-must-write! mzssl (make-semaphore))) (wrap-evt (choice-evt @@ -701,10 +772,13 @@ (set! must-write-len len)) (if (pump-output-once mzssl #f #f) (do-write len non-block? enable-break?) - (begin - (when enforce-retry? - (set-mzssl-must-write! mzssl (make-semaphore))) - (wrap-evt (mzssl-o mzssl) (lambda (x) #f))))] + (let ([n (pump-input-once mzssl #f)]) + (if (positive? n) + (do-write len non-block? enable-break?) + (begin + (when enforce-retry? + (set-mzssl-must-write! mzssl (make-semaphore))) + (wrap-evt (mzssl-o mzssl) (lambda (x) #f))))))] [else (set! must-write-len #f) ((mzssl-error mzssl) 'write-bytes diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl index cb5b14110c..dfb94c2704 100644 --- a/collects/openssl/openssl.scrbl +++ b/collects/openssl/openssl.scrbl @@ -321,19 +321,6 @@ You can use the file @filepath{test.pem} of the @filepath{openssl} collection for testing purposes. Since @filepath{test.pem} is public, such a test configuration obviously provides no security.} -@defproc[(ssl-set-verify! - (context-or-listener (or/c ssl-client-context? ssl-server-context? - ssl-listener?)) - (verify? boolean?)) - void?]{ - -Enables or disables verification of a connection peer's certificates. -By default, verification is disabled. - -Enabling verification also requires, at a minimum, designating trusted -certificate authorities with -@racket[ssl-load-verify-root-certificates!].} - @defproc[(ssl-load-verify-root-certificates! (context-or-listener (or/c ssl-client-context? ssl-server-context? ssl-listener?)) @@ -350,7 +337,7 @@ such a test configuration obviously provides no security.} @defproc[(ssl-load-suggested-certificate-authorities! (context-or-listener (or/c ssl-client-context? ssl-server-context? - ssl-listener?)) + ssl-listener?)) (pathname path-string?)) void?]{ @@ -370,6 +357,33 @@ collection for testing purposes where the peer identifies itself using @; ---------------------------------------------------------------------- @section[#:tag "peer-verif"]{Peer Verification} +@defproc[(ssl-set-verify! [clp (or/c ssl-client-context? ssl-server-context? + ssl-listener? + ssl-port?)] + [on? any/c]) void]{ + +Requires certificate verification on the peer SSL connection when +@racket[on?] is @racket[#t]. If @racket[clp] is an SSL port, then the +connection is immediately renegotiated, and an exception is raised +immediately if certificate verification fails. If @racket[clp] is a +context or listener, certification verification happens on each +subsequent connection using the context or listener. + +Enabling verification also requires, at a minimum, designating trusted +certificate authorities with +@racket[ssl-load-verify-root-certificates!].} + + +@defproc[(ssl-try-verify! [clp (or/c ssl-client-context? ssl-server-context? + ssl-listener? + ssl-port?)] + [on? any/c]) void]{ + +Like @racket[ssl-set-verify!], but when peer certificate verification fails, +then connection continues to work. Use @racket[ssl-peer-verified?] to determine +whether verification succeeded.} + + @defproc[(ssl-peer-verified? [p ssl-port?]) boolean?]{ Returns @racket[#t] if the peer of SSL port @racket[p] has presented a @@ -382,6 +396,7 @@ If @racket[ssl-peer-verified?] would return @racket[#t] for the certificate presented by the SSL port's peer, otherwise the result is @racket[#f].} + @defproc[(ssl-peer-issuer-name [p ssl-port?]) (or/c bytes? #f)]{ If @racket[ssl-peer-verified?] would return @racket[#t] for diff --git a/collects/tests/openssl/peer-verif.rkt b/collects/tests/openssl/peer-verif.rkt index d98f789440..30e219cc2f 100644 --- a/collects/tests/openssl/peer-verif.rkt +++ b/collects/tests/openssl/peer-verif.rkt @@ -9,70 +9,118 @@ (unless (equal? got expect) (error 'check fmt got))) -(define ssl-server-context (ssl-make-server-context 'sslv3)) - (define-runtime-path server-key "server_key.pem") (define-runtime-path server-crt "server_crt.pem") (define-runtime-path client-key "client_key.pem") (define-runtime-path client-crt "client_crt.pem") (define-runtime-path cacert "cacert.pem") -(ssl-load-private-key! ssl-server-context server-key) -(ssl-load-certificate-chain! ssl-server-context server-crt) -(ssl-load-verify-root-certificates! ssl-server-context cacert) -(ssl-try-verify! ssl-server-context #t) +(define (go valid? + #:later [later-mode #f] + #:early [early-mode (and (not later-mode) 'try)] + #:accept-fail? [accept-fail? #f] + #:verify-fail? [verify-fail? #f]) + (define ssl-server-context (ssl-make-server-context 'sslv3)) -(define ssl-listener (ssl-listen 55000 - 4 - #f - "127.0.0.1" - ssl-server-context)) + (ssl-load-private-key! ssl-server-context server-key) + (ssl-load-certificate-chain! ssl-server-context server-crt) + (ssl-load-verify-root-certificates! ssl-server-context cacert) + (when early-mode + ((if (eq? early-mode 'try) ssl-try-verify! ssl-set-verify!) + ssl-server-context + #t)) -(define listener-main - (thread - (lambda() - (let-values ([(in out) (ssl-accept ssl-listener)]) - (check "Server: Accepted connection.~n" #t #t) - (check "Server: Verified ~v~n" (ssl-peer-verified? in) #t) - (check "Server: Verified ~v~n" (ssl-peer-verified? out) #t) - (check "Server: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) - #"/CN=testclient.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT") - (check "Server: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) - #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department") - (ssl-close ssl-listener) - (check "Server: From Client: ~a~n" (read-line in) "yay the connection was made") - (close-input-port in) - (close-output-port out))))) + (define ssl-listener (ssl-listen 55000 + 4 + #t + "127.0.0.1" + ssl-server-context)) + + (define listener-main + (thread + (lambda() + (with-handlers ([(lambda (x) (and accept-fail? + (exn? x) + (regexp-match? #rx"accept failed" (exn-message x)))) + (lambda (x) (ssl-close ssl-listener))] + [(lambda (x) (and verify-fail? (eq? x 'escape))) + (lambda (x) (void))]) + (let-values ([(in out) (ssl-accept ssl-listener)]) + (check "Server: Accepted connection.~n" #t #t) + (when later-mode + (check "Server: From Client: ~a~n" (read-line in) "we're started") + (with-handlers ([(lambda (x) (and verify-fail? + (exn? x) + (regexp-match? #rx"ssl-set-verify!: failed" (exn-message x)))) + (lambda (x) + (ssl-close ssl-listener) + (raise 'escape))]) + ((if (eq? later-mode 'try) ssl-try-verify! ssl-set-verify!) in #t)) + (write-string "still going\n" out) + (flush-output out)) + (check "Server: Verified ~v~n" (ssl-peer-verified? in) valid?) + (check "Server: Verified ~v~n" (ssl-peer-verified? out) valid?) + (check "Server: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) + (and valid? + #"/CN=testclient.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT")) + (check "Server: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) + (and valid? + #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department")) + (ssl-close ssl-listener) + (check "Server: From Client: ~a~n" (read-line in) "yay the connection was made") + (close-input-port in) + (close-output-port out)))))) -(define ssl-client-context (ssl-make-client-context 'sslv3)) + (define ssl-client-context (ssl-make-client-context 'sslv3)) -(ssl-load-private-key! ssl-client-context client-key) + (ssl-load-private-key! ssl-client-context client-key) -;connection will still proceed if these methods aren't called -;change to #f to try it -(when #t - (ssl-load-certificate-chain! ssl-client-context client-crt) - (ssl-load-verify-root-certificates! ssl-client-context cacert) - (ssl-set-verify! ssl-client-context #t)) + ;;connection will still proceed if these methods aren't called + ;;change to #f to try it + (when valid? + (ssl-load-certificate-chain! ssl-client-context client-crt) + (ssl-load-verify-root-certificates! ssl-client-context cacert) + (ssl-set-verify! ssl-client-context #t)) -(let-values ([(in out) (ssl-connect "127.0.0.1" - 55000 - ssl-client-context)]) - (check "Client: Made connection.~n" #t #t) - (check "Client: Verified ~v~n" (ssl-peer-verified? in) #t) - (check "Client: Verified ~v~n" (ssl-peer-verified? out) #t) - (check "Client: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) - #"/CN=test.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT") - (check "Client: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) - #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department") - (write-string (format "yay the connection was made~n") out) - (close-input-port in) - (close-output-port out)) + (let-values ([(in out) (ssl-connect "127.0.0.1" + 55000 + ssl-client-context)]) + (check "Client: Made connection.~n" #t #t) + (when later-mode + (write-string "we're started\n" out) + (flush-output out) + (unless verify-fail? + (check "Client: From Server: ~a~n" (read-line in) "still going"))) + (check "Client: Verified ~v~n" (ssl-peer-verified? in) valid?) + (check "Client: Verified ~v~n" (ssl-peer-verified? out) valid?) + (check "Client: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) + #"/CN=test.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT") + (check "Client: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) + #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department") + + (write-string (format "yay the connection was made~n") out) + (close-input-port in) + (close-output-port out)) + (thread-wait listener-main)) -(thread-wait listener-main) +(go #t) +(go #t #:early 'req) +(go #f) +(go #t #:later 'try) +(go #f #:later 'try) +(go #t #:later 'req) + +(define (check-fail thunk) + (define s + (with-handlers ([exn? (lambda (exn) (exn-message exn))]) + (thunk) + "success")) + (unless (regexp-match? #rx"connect failed" s) + (error 'test "failed: ~s" s))) + +(check-fail (lambda () (go #f #:early 'req #:accept-fail? #t))) +(go #f #:later 'req #:verify-fail? #t) -;certificate revocation list -;enables denial of connections that provide a certificate on the given certificate revocation list