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

opt-lambda -> define/kw, and remove etc.ss

Browse Source 
svn: r4120
This commit is contained in:
Eli Barzilay 2006-08-23 04:41:20 +00:00
parent 12e3a16de0
commit 7bb28055f4
1 changed files with 51 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/openssl/mzssl.ss
View File

@ -16,7 +16,6 @@
(module mzssl mzscheme (module mzssl mzscheme
(require (lib "foreign.ss") (require (lib "foreign.ss")
(lib "port.ss") (lib "port.ss")
(lib "etc.ss")
(lib "kw.ss")) (lib "kw.ss"))
(provide ssl-available? (provide ssl-available?
@ -299,23 +298,22 @@
(string-append also-expect "'sslv2-or-v3, 'sslv2, 'sslv3, or 'tls") (string-append also-expect "'sslv2-or-v3, 'sslv2, 'sslv3, or 'tls")
e)))]))) e)))])))
(define make-context (define (make-context who protocol-symbol also-expected client?)
(opt-lambda (who protocol-symbol also-expected client?)
(let ([meth (encrypt->method who also-expected protocol-symbol client?)]) (let ([meth (encrypt->method who also-expected protocol-symbol client?)])
(atomically ; so we reliably register the finalizer (atomically ; so we reliably register the finalizer
(let ([ctx (SSL_CTX_new meth)]) (let ([ctx (SSL_CTX_new meth)])
(check-valid ctx who "context creation") (check-valid ctx who "context creation")
(SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE) (SSL_CTX_set_mode ctx SSL_MODE_ENABLE_PARTIAL_WRITE)
(register-finalizer ctx (lambda (v) (SSL_CTX_free v))) (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)))))
(define ssl-make-client-context (define/kw (ssl-make-client-context
(opt-lambda ([protocol-symbol default-encrypt]) #:optional [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 (define/kw (ssl-make-server-context
(opt-lambda ([protocol-symbol default-encrypt]) #:optional [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?)
(if (ssl-context? context-or-encrypt-method) (if (ssl-context? context-or-encrypt-method)
@ -372,18 +370,15 @@
1)))) 1))))
ssl-listener pathname)) ssl-listener pathname))
(define ssl-load-private-key! (define/kw (ssl-load-private-key! ssl-context-or-listener pathname
(opt-lambda (ssl-context-or-listener pathname [rsa? #t] [asn1? #f]) #:optional [rsa? #t] [asn1? #f])
(ssl-load-... 'ssl-load-private-key! (ssl-load-...
'ssl-load-private-key!
(lambda (ctx path) (lambda (ctx path)
((if rsa? ((if rsa? SSL_CTX_use_RSAPrivateKey_file SSL_CTX_use_PrivateKey_file)
SSL_CTX_use_RSAPrivateKey_file
SSL_CTX_use_PrivateKey_file)
ctx path ctx path
(if asn1? (if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM)))
SSL_FILETYPE_ASN1 ssl-context-or-listener pathname))
SSL_FILETYPE_PEM)))
ssl-context-or-listener pathname)))
(define (ssl-set-verify! ssl-context-or-listener on?) (define (ssl-set-verify! ssl-context-or-listener on?)
(let ([ctx (get-context/listener 'ssl-set-verify! (let ([ctx (get-context/listener 'ssl-set-verify!
@ -927,13 +922,15 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL listen ;; SSL listen
(define ssl-listen (define/kw (ssl-listen port-k
(opt-lambda (port-k [queue-k 5] [reuse? #f] [hostname-or-#f #f] [protocol-symbol-or-context default-encrypt]) #:optional [queue-k 5] [reuse? #f] [hostname-or-#f #f]
(let ([ctx (cond [protocol-symbol-or-context default-encrypt])
[(ssl-server-context? protocol-symbol-or-context) protocol-symbol-or-context] (let ([ctx (if (ssl-server-context? protocol-symbol-or-context)
[else (make-context 'ssl-listen protocol-symbol-or-context "server context, " #f)])]) protocol-symbol-or-context
(let ([l (tcp-listen port-k queue-k reuse? hostname-or-#f)]) (make-context 'ssl-listen protocol-symbol-or-context
(make-ssl-listener l ctx))))) "server context, " #f))]
[l (tcp-listen port-k queue-k reuse? hostname-or-#f)])
(make-ssl-listener l ctx)))
(define (ssl-close l) (define (ssl-close l)
(unless (ssl-listener? l) (unless (ssl-listener? l)
@ -975,15 +972,23 @@
(raise exn))]) (raise exn))])
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f)))) (wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f))))
(define ssl-connect (define/kw (ssl-connect
(opt-lambda (hostname port-k [client-context-or-protocol-symbol default-encrypt]) hostname port-k
(do-ssl-connect 'ssl-connect tcp-connect hostname port-k #:optional [client-context-or-protocol-symbol default-encrypt])
client-context-or-protocol-symbol))) (do-ssl-connect 'ssl-connect
tcp-connect
hostname
port-k
client-context-or-protocol-symbol))
(define ssl-connect/enable-break (define/kw (ssl-connect/enable-break
(opt-lambda (hostname port-k [client-context-or-protocol-symbol default-encrypt]) hostname port-k
(do-ssl-connect 'ssl-connect/enable-break tcp-connect/enable-break hostname port-k #:optional [client-context-or-protocol-symbol default-encrypt])
client-context-or-protocol-symbol))) (do-ssl-connect 'ssl-connect/enable-break
tcp-connect/enable-break
hostname
port-k
client-context-or-protocol-symbol))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization ;; Initialization