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

remove error checks obviated by contracts

Browse Source
This commit is contained in:
Ryan Culpepper 2012-11-24 18:56:02 -05:00
parent 994f2998de
commit dc2a63182d
1 changed files with 38 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/openssl/mzssl.rkt
View File

@ -144,7 +144,7 @@
[any/c] [any/c]
any)] any)]
[ssl-abandon-port [ssl-abandon-port
(c-> ssl-port? void?)] (c-> (and/c input-port? ssl-port?) void?)]
[ssl-port? [ssl-port?
(c-> any/c boolean?)])) (c-> any/c boolean?)]))
@ -450,27 +450,21 @@
(define default-encrypt 'sslv2-or-v3) (define default-encrypt 'sslv2-or-v3)
(define (encrypt->method who also-expect e client?) (define (encrypt->method who e client?)
((case e ((case e
[(sslv2-or-v3) (if client? [(sslv2-or-v3)
SSLv23_client_method (if client? SSLv23_client_method SSLv23_server_method)]
SSLv23_server_method)] [(sslv2)
[(sslv2) (if client? (if client? SSLv2_client_method SSLv2_server_method)]
SSLv2_client_method [(sslv3)
SSLv2_server_method)] (if client? SSLv3_client_method SSLv3_server_method)]
[(sslv3) (if client? [(tls)
SSLv3_client_method (if client? TLSv1_client_method TLSv1_server_method)]
SSLv3_server_method)]
[(tls) (if client?
TLSv1_client_method
TLSv1_server_method)]
[else [else
(raise-argument-error who (error 'encrypt->method "internal error, unknown encrypt: ~e" e)])))
(format "(or/c ~a'sslv2-or-v3 'sslv2 'sslv3 'tls)" also-expect)
e)])))
(define (make-context who protocol-symbol also-expected client?) (define (make-context who protocol-symbol client?)
(let ([meth (encrypt->method who also-expected protocol-symbol client?)]) (let ([meth (encrypt->method who protocol-symbol client?)])
(atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error)
(let ([ctx (SSL_CTX_new meth)]) (let ([ctx (SSL_CTX_new meth)])
(check-valid ctx who "context creation") (check-valid ctx who "context creation")
@ -479,16 +473,16 @@
((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f))))) ((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f)))))
(define (ssl-make-client-context [protocol-symbol default-encrypt]) (define (ssl-make-client-context [protocol-symbol default-encrypt])
(make-context 'ssl-make-client-context protocol-symbol "" #t)) (make-context 'ssl-make-client-context protocol-symbol #t))
(define (ssl-make-server-context [protocol-symbol default-encrypt]) (define (ssl-make-server-context [protocol-symbol default-encrypt])
(make-context 'ssl-make-server-context protocol-symbol "" #f)) (make-context 'ssl-make-server-context protocol-symbol #f))
(define (get-context who context-or-encrypt-method client? (define (get-context who context-or-encrypt-method client?
#:need-unsealed? [need-unsealed? #f]) #:need-unsealed? [need-unsealed? #f])
(if (ssl-context? context-or-encrypt-method) (if (ssl-context? context-or-encrypt-method)
(extract-ctx who need-unsealed? context-or-encrypt-method) (extract-ctx who need-unsealed? context-or-encrypt-method)
(let ([ctx (SSL_CTX_new (encrypt->method who "ssl-context? " context-or-encrypt-method client?))]) (let ([ctx (SSL_CTX_new (encrypt->method who context-or-encrypt-method client?))])
(SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE) (SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE)
ctx))) ctx)))
@ -512,20 +506,12 @@
(ssl-context-ctx mzctx)) (ssl-context-ctx mzctx))
(define (ssl-seal-context! mzctx) (define (ssl-seal-context! mzctx)
(unless (ssl-context? mzctx)
(raise-argument-error 'ssl-seal-context!
"(or/c ssl-client-context? ssl-server-context?)"
mzctx))
(set-ssl-context-sealed?! mzctx #t)) (set-ssl-context-sealed?! mzctx #t))
(define (ssl-load-... who load-it ssl-context-or-listener pathname (define (ssl-load-... who load-it ssl-context-or-listener pathname
#:try? [try? #f]) #:try? [try? #f])
(let ([ctx (get-context/listener who ssl-context-or-listener (let ([ctx (get-context/listener who ssl-context-or-listener
#:need-unsealed? #t)]) #:need-unsealed? #t)])
(unless (path-string? pathname)
(raise-argument-error 'ssl-load-certificate-chain!
"path-string?"
pathname))
(let ([path (let ([path
(path->complete-path (cleanse-path pathname) (path->complete-path (cleanse-path pathname)
(current-directory))]) (current-directory))])
@ -572,11 +558,7 @@
(define (ssl-load-verify-source! context src #:try? [try? #f]) (define (ssl-load-verify-source! context src #:try? [try? #f])
(define (bad-source) (define (bad-source)
(error 'ssl-load-verify-root-certificates! (error 'ssl-load-verify-root-certificates!
"bad source: ~e" src)) "internal error: bad source: ~e" src))
(unless (ssl-context? context)
(raise-argument-error 'ssl-load-verify-source!
"(or/c ssl-client-context? ssl-server-context?)"
context))
(cond [(path-string? src) (cond [(path-string? src)
(ssl-load-... 'ssl-load-verify-root-certificates! (ssl-load-... 'ssl-load-verify-root-certificates!
(lambda (a b) (SSL_CTX_load_verify_locations a b #f)) (lambda (a b) (SSL_CTX_load_verify_locations a b #f))
@ -603,12 +585,6 @@
(ssl-load-verify-source! ctx src #:try? #t))) (ssl-load-verify-source! ctx src #:try? #t)))
(define (ssl-set-ciphers! context cipher-spec) (define (ssl-set-ciphers! context cipher-spec)
(unless (ssl-context? context)
(raise-argument-error 'ssl-set-ciphers!
"(or/c ssl-client-context? ssl-server-context?)"
context))
(unless (string? cipher-spec)
(raise-argument-error 'ssl-set-ciphers! "string?" cipher-spec))
(let* ([ctx (extract-ctx 'ssl-set-ciphers! #t context)] (let* ([ctx (extract-ctx 'ssl-set-ciphers! #t context)]
[result (SSL_CTX_set_cipher_list ctx cipher-spec)]) [result (SSL_CTX_set_cipher_list ctx cipher-spec)])
(unless (= result 1) (unless (= result 1)
@ -616,10 +592,7 @@
(void))) (void)))
(define (ssl-set-verify-hostname! ssl-context on?) (define (ssl-set-verify-hostname! ssl-context on?)
(unless (ssl-context? ssl-context) ;; to check not sealed:
(raise-argument-error 'ssl-set-verify-hostname!
"(or/c ssl-client-context? ssl-server-context?)"
ssl-context))
(void (extract-ctx 'ssl-set-verify-hostname! #t ssl-context)) (void (extract-ctx 'ssl-set-verify-hostname! #t ssl-context))
(set-ssl-context-verify-hostname?! ssl-context (and on? #t))) (set-ssl-context-verify-hostname?! ssl-context (and on? #t)))
@ -653,8 +626,7 @@
SSL_VERIFY_NONE) SSL_VERIFY_NONE)
#f))] #f))]
[else [else
(let-values ([(mzssl input?) (lookup who "(or/c ssl-context? ssl-listener? ssl-port?)" (let-values ([(mzssl input?) (lookup who ssl-context-or-listener-or-port)])
ssl-context-or-listener-or-port)])
(SSL_set_verify (mzssl-ssl mzssl) (SSL_set_verify (mzssl-ssl mzssl)
(if on? (if on?
mode mode
@ -1167,7 +1139,7 @@
(case connect/accept (case connect/accept
[(connect) #t] [(connect) #t]
[(accept) #f] [(accept) #f]
[else (raise-argument-error who "(or/c 'connect 'accept)" connect/accept)])) [else (error who "internal error: bad connect/accept: ~e" connect/accept)]))
(unless (or (symbol? context-or-encrypt-method) (unless (or (symbol? context-or-encrypt-method)
(if connect? (if connect?
(ssl-client-context? context-or-encrypt-method) (ssl-client-context? context-or-encrypt-method)
@ -1178,7 +1150,7 @@
(if connect? "client" "server") (if connect? "client" "server")
context-or-encrypt-method)) context-or-encrypt-method))
(atomically ;; connect functions to subsequent check-valid (ie, ERR_get_error) (atomically ;; connect functions to subsequent check-valid (ie, ERR_get_error)
(let ([ctx (get-context who context-or-encrypt-method (eq? connect/accept 'connect))]) (let ([ctx (get-context who context-or-encrypt-method connect?)])
(check-valid ctx who "context creation") (check-valid ctx who "context creation")
(with-failure (with-failure
(lambda () (when (and ctx (symbol? context-or-encrypt-method)) (lambda () (when (and ctx (symbol? context-or-encrypt-method))
@ -1206,12 +1178,6 @@
(define (wrap-ports who i o context-or-encrypt-method connect/accept (define (wrap-ports who i o context-or-encrypt-method connect/accept
close? shutdown-on-close? error/ssl close? shutdown-on-close? error/ssl
hostname) 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: ;; Create the SSL connection:
(let-values ([(ssl r-bio w-bio connect?) (let-values ([(ssl 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)]
@ -1270,30 +1236,28 @@
(hash-set! ssl-ports port (make-ephemeron port (cons mzssl input?))) (hash-set! ssl-ports port (make-ephemeron port (cons mzssl input?)))
port) port)
(define (lookup who what port) (define (lookup who port)
(let ([v (hash-ref ssl-ports port #f)]) (let ([v (hash-ref ssl-ports port #f)])
(unless v (unless v
(raise-argument-error who what port)) (error who "internal error: not an SSL port or listener: ~e" port))
(let ([p (ephemeron-value v)]) (let ([p (ephemeron-value v)])
(values (car p) (cdr p))))) (values (car p) (cdr p)))))
(define (ssl-addresses p [port-numbers? #f]) (define (ssl-addresses p [port-numbers? #f])
(let-values ([(mzssl input?) (lookup 'ssl-addresses "(or/c ssl-port? ssl-listener?)" p)]) (let-values ([(mzssl input?) (lookup 'ssl-addresses p)])
(tcp-addresses (if (eq? 'listener input?) (tcp-addresses (if (eq? 'listener input?)
(ssl-listener-l mzssl) (ssl-listener-l mzssl)
(if input? (mzssl-i mzssl) (mzssl-o mzssl))) (if input? (mzssl-i mzssl) (mzssl-o mzssl)))
port-numbers?))) port-numbers?)))
(define (ssl-abandon-port p) (define (ssl-abandon-port p)
(let-values ([(mzssl input?) (lookup 'ssl-abandon-port "(and/c ssl-port? output-port?)" p)]) (let-values ([(mzssl input?) (lookup 'ssl-abandon-port p)])
(when input?
(raise-argument-error 'ssl-abandon-port "(and/c ssl-port? output-port?)" p))
(set-mzssl-shutdown-on-close?! mzssl #f) (set-mzssl-shutdown-on-close?! mzssl #f)
;; Call close-output-port to flush, shutdown, and decrement mzssl refcount. ;; Call close-output-port to flush, shutdown, and decrement mzssl refcount.
(close-output-port p))) (close-output-port p)))
(define (ssl-peer-verified? p) (define (ssl-peer-verified? p)
(let-values ([(mzssl input?) (lookup 'ssl-peer-verified? "ssl-port?" p)]) (let-values ([(mzssl input?) (lookup 'ssl-peer-verified? p)])
(and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl))) (and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl)))
(SSL_get_peer_certificate (mzssl-ssl mzssl)) (SSL_get_peer_certificate (mzssl-ssl mzssl))
#t))) #t)))
@ -1324,7 +1288,7 @@
;; ssl-port->cert : symbol ssl-port -> Cert/#f ;; ssl-port->cert : symbol ssl-port -> Cert/#f
(define (ssl-port->cert who p) (define (ssl-port->cert who p)
(let-values ([(mzssl _input?) (lookup who "ssl-port?" p)]) (let-values ([(mzssl _input?) (lookup who p)])
(SSL_get_peer_certificate (mzssl-ssl mzssl)))) (SSL_get_peer_certificate (mzssl-ssl mzssl))))
;; hostname-in-cert? : string Cert -> boolean ;; hostname-in-cert? : string Cert -> boolean
@ -1410,15 +1374,12 @@
[protocol-symbol-or-context default-encrypt]) [protocol-symbol-or-context default-encrypt])
(let* ([ctx (if (ssl-server-context? protocol-symbol-or-context) (let* ([ctx (if (ssl-server-context? protocol-symbol-or-context)
protocol-symbol-or-context protocol-symbol-or-context
(make-context 'ssl-listen protocol-symbol-or-context (make-context 'ssl-listen protocol-symbol-or-context #f))]
"server context, " #f))]
[l (tcp-listen port-k queue-k reuse? hostname-or-#f)] [l (tcp-listen port-k queue-k reuse? hostname-or-#f)]
[ssl-l (make-ssl-listener l ctx)]) [ssl-l (make-ssl-listener l ctx)])
(register ssl-l ssl-l 'listener))) (register ssl-l ssl-l 'listener)))
(define (ssl-close l) (define (ssl-close l)
(unless (ssl-listener? l)
(raise-argument-error 'ssl-close "ssl-listener?" l))
(tcp-close (ssl-listener-l l))) (tcp-close (ssl-listener-l l)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1457,8 +1418,7 @@
(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)))) hostname))))
(define (ssl-connect (define (ssl-connect hostname port-k
hostname port-k
[client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect (do-ssl-connect 'ssl-connect
tcp-connect tcp-connect
@ -1466,8 +1426,7 @@
port-k port-k
client-context-or-protocol-symbol)) client-context-or-protocol-symbol))
(define (ssl-connect/enable-break (define (ssl-connect/enable-break hostname port-k
hostname port-k
[client-context-or-protocol-symbol default-encrypt]) [client-context-or-protocol-symbol default-encrypt])
(do-ssl-connect 'ssl-connect/enable-break (do-ssl-connect 'ssl-connect/enable-break
tcp-connect/enable-break tcp-connect/enable-break