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.
This commit is contained in:
Matthew Flatt
parent
efcb607865
commit
1032ce8afe
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user