60 lines
1.9 KiB
Racket
60 lines
1.9 KiB
Racket
#lang scheme/base
|
|
(provide make-ssl-tcp@)
|
|
(require scheme/unit
|
|
"tcp-sig.ss"
|
|
openssl/mzssl)
|
|
|
|
(define (make-ssl-tcp@
|
|
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
|
|
client-cert-file client-key-file client-root-cert-files)
|
|
(unit
|
|
(import)
|
|
(export tcp^)
|
|
|
|
(define ctx (ssl-make-client-context))
|
|
(when client-cert-file
|
|
(ssl-load-certificate-chain! ctx client-cert-file))
|
|
(when client-key-file
|
|
(ssl-load-private-key! ctx client-key-file))
|
|
(when client-root-cert-files
|
|
(ssl-set-verify! ctx #t)
|
|
(map (lambda (f)
|
|
(ssl-load-verify-root-certificates! ctx f))
|
|
client-root-cert-files))
|
|
|
|
(define (tcp-abandon-port p)
|
|
(if (input-port? p)
|
|
(close-input-port p)
|
|
(close-output-port p)))
|
|
|
|
(define tcp-accept ssl-accept)
|
|
(define tcp-accept/enable-break ssl-accept/enable-break)
|
|
|
|
;; accept-ready? doesn't really work for SSL:
|
|
(define (tcp-accept-ready? p)
|
|
#f)
|
|
|
|
(define tcp-addresses ssl-addresses)
|
|
(define tcp-close ssl-close)
|
|
(define (tcp-connect hostname port-k)
|
|
(ssl-connect hostname port-k ctx))
|
|
(define (tcp-connect/enable-break hostname port-k)
|
|
(ssl-connect/enable-break hostname port-k ctx))
|
|
|
|
(define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
|
|
(let ([l (ssl-listen port allow-k reuse? hostname)])
|
|
(when server-cert-file
|
|
(ssl-load-certificate-chain! l server-cert-file))
|
|
(when server-key-file
|
|
(ssl-load-private-key! l server-key-file))
|
|
(when server-root-cert-files
|
|
(ssl-set-verify! l #t)
|
|
(map (lambda (f)
|
|
(ssl-load-verify-root-certificates! l f))
|
|
server-root-cert-files))
|
|
(when server-suggest-auth-file
|
|
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
|
|
l))
|
|
|
|
(define tcp-listener? ssl-listener?)))
|