suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added ssl-set-verify-hostname!

Browse Source
This commit is contained in:
Ryan Culpepper 2012-11-17 15:36:18 -05:00
parent 1c0e08f0a6
commit 5cdb967251
2 changed files with 73 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/openssl/mzssl.rkt
View File

@ -41,6 +41,7 @@
ssl-set-verify!
ssl-try-verify!
ssl-set-verify-hostname!
ssl-peer-verified?
ssl-peer-certificate-hostnames
@ -300,7 +301,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Structs
(define-struct ssl-context (ctx))
(define-struct ssl-context (ctx [verify-hostname? #:mutable]))
(define-struct (ssl-client-context ssl-context) ())
(define-struct (ssl-server-context ssl-context) ())
@ -391,7 +392,7 @@
(SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE
SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER))
(register-finalizer ctx (lambda (v) (SSL_CTX_free v)))
((if client? make-ssl-client-context make-ssl-server-context) ctx)))))
((if client? make-ssl-client-context make-ssl-server-context) ctx #f)))))
(define (ssl-make-client-context [protocol-symbol default-encrypt])
(make-context 'ssl-make-client-context protocol-symbol "" #t))
@ -469,6 +470,13 @@
(if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM)))
ssl-context-or-listener pathname))
(define (ssl-set-verify-hostname! ssl-context on?)
(unless (ssl-context? ssl-context)
(raise-argument-error 'ssl-set-verify-hostname!
"(or/c ssl-client-context? ssl-server-context?)"
ssl-context))
(set-ssl-context-verify-hostname?! ssl-context (and on? #t)))
(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!
@ -965,8 +973,11 @@
#:mode [mode 'connect]
#:close-original? [close-original? #f]
#:shutdown-on-close? [shutdown-on-close? #f]
#:error/ssl [error/ssl error])
(wrap-ports 'port->ssl-ports i o (or context encrypt) mode close-original? shutdown-on-close? error/ssl))
#:error/ssl [error/ssl error]
#:hostname [hostname #f])
(wrap-ports 'port->ssl-ports i o (or context encrypt) mode
close-original? shutdown-on-close? error/ssl
hostname))
(define (create-ssl who context-or-encrypt-method connect/accept error/ssl)
(atomically ; so we register the finalizer (and it's ok since everything is non-blocking)
@ -1023,14 +1034,22 @@
;; Return SSL and the cancel boxL:
(values ssl cancel r-bio w-bio connect?)))))))))
(define (wrap-ports who i o context-or-encrypt-method connect/accept close? shutdown-on-close? error/ssl)
(define (wrap-ports who i o context-or-encrypt-method connect/accept
close? shutdown-on-close? error/ssl
hostname)
(unless (input-port? i)
(raise-argument-error who "input-port?" i))
(unless (output-port? o)
(raise-argument-error who "output-port?" o))
(unless (or (string? hostname) (eq? hostname #f))
(raise-argument-error who "(or/c string? #f)" hostname))
;; Create the SSL connection:
(let-values ([(ssl cancel r-bio w-bio connect?)
(create-ssl who context-or-encrypt-method connect/accept error/ssl)])
(create-ssl who context-or-encrypt-method connect/accept error/ssl)]
[(verify-hostname?)
(cond [(ssl-context? context-or-encrypt-method)
(ssl-context-verify-hostname? context-or-encrypt-method)]
[else #f])])
;; connect/accept:
(let-values ([(buffer) (make-bytes BUFFER-SIZE)]
[(pipe-r pipe-w) (make-pipe)]
@ -1064,6 +1083,13 @@
(error/ssl who "~a failed ~a"
(if connect? "connect" "accept")
estr)]))))))
(when verify-hostname?
(unless hostname
(error/ssl who "~a failed (hostname not provided for verification)"
(if connect? "connect" "accept")))
(unless (hostname-in-cert? (SSL_get_peer_certificate ssl))
(error/ssl who "~a failed (certificate not valid for hostname)"
(if connect? "connect" "accept"))))
;; Connection complete; make ports
(values (register (make-ssl-input-port mzssl) mzssl #t)
(register (make-ssl-output-port mzssl) mzssl #f))))))
@ -1243,7 +1269,7 @@
(close-input-port i)
(close-output-port o)
(raise exn))])
(wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f error/network))))
(wrap-ports who i o (ssl-listener-mzctx ssl-listener) 'accept #t #f error/network #f))))
(define (ssl-accept ssl-listener)
(do-ssl-accept 'ssl-accept tcp-accept ssl-listener))
@ -1261,7 +1287,8 @@
(close-input-port i)
(close-output-port o)
(raise exn))])
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network))))
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network
hostname))))
(define (ssl-connect
hostname port-k

43
collects/openssl/openssl.scrbl
View File

@ -68,6 +68,10 @@ details (including the meanings of the protocol symbols).
Closing the resulting output port does not send a shutdown message to
the server. See also @racket[ports->ssl-ports].
If hostname verification is enabled (see
@racket[ssl-set-verify-hostname!]), the peer's certificate is checked
against @racket[hostname].
@;{
See `enforce-retry?' in "mzssl.rkt", currently set to #f so that this
paragraph does not apply:
@ -230,7 +234,8 @@ Returns @racket[#t] if @racket[v] is a value produced by
[#:encrypt protocol symbol? 'sslv2-or-v3]
[#:close-original? close-original? boolean? #f]
[#:shutdown-on-close? shutdown-on-close? boolean? #f]
[#:error/ssl error procedure? error])
[#:error/ssl error procedure? error]
[#:hostname hostname (or/c string? #f) #f])
(values input-port? output-port?)]{
Returns two values---an input port and an output port---that
@ -275,7 +280,12 @@ communication errors. The default is @racket[error], which raises
@racket[exn:fail:network].
See also @racket[ssl-connect] about the limitations of reading and
writing to an SSL connection (i.e., one direction at a time).}
writing to an SSL connection (i.e., one direction at a time).
If hostname verification is enabled (see
@racket[ssl-set-verify-hostname!]), the peer's certificate is checked
against @racket[hostname].
}
@; ----------------------------------------------------------------------
@ -360,7 +370,7 @@ collection for testing purposes where the peer identifies itself using
@defproc[(ssl-set-verify! [clp (or/c ssl-client-context? ssl-server-context?
ssl-listener?
ssl-port?)]
[on? any/c]) void]{
[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
@ -371,13 +381,19 @@ 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!].}
@racket[ssl-load-verify-root-certificates!].
Verifying the certificate is not sufficient to prevent attacks by
active adversaries, such as
@hyperlink["http://en.wikipedia.org/wiki/Man-in-the-middle_attack"]{man-in-the-middle
attacks}. See also @racket[ssl-set-verify-hostname!].
}
@defproc[(ssl-try-verify! [clp (or/c ssl-client-context? ssl-server-context?
ssl-listener?
ssl-port?)]
[on? any/c]) void]{
[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
@ -389,6 +405,23 @@ whether verification succeeded.}
Returns @racket[#t] if the peer of SSL port @racket[p] has presented a
valid and verified certificate, @racket[#f] otherwise.}
@defproc[(ssl-set-verify-hostname! [ctx (or/c ssl-client-context? ssl-server-context?)]
[on? any/c])
void?]{
Requires hostname verification of SSL peers of connections made using
@racket[ctx] when @racket[on?] is @racket[#t]. When hostname
verification is enabled, the hostname associated with a connection
(see @racket[ssl-connect] or @racket[ports->ssl-ports]) is checked
against the hostnames listed in the peer's certificate. If the peer
certificate does not contain an entry matching the hostname, or if the
peer does not present a certificate, the connection is rejected and an
exception is raised.
Hostname verification does not imply certificate verification. To
verify the certificate itself, also call @racket[ssl-set-verify!].
}
@defproc[(ssl-peer-certificate-hostnames [p ssl-port?])
(listof string?)]{