diff --git a/racket/collects/net/win32-ssl.rkt b/racket/collects/net/win32-ssl.rkt index fd0860ce5b..2349109154 100644 --- a/racket/collects/net/win32-ssl.rkt +++ b/racket/collects/net/win32-ssl.rkt @@ -18,9 +18,9 @@ win32-ssl-port? win32-ssl-available?) -(define (win32-ssl-connect host port [protocol 'sslv2-or-v3]) +(define (win32-ssl-connect host port [protocol 'auto]) (define-values (i o) (tcp-connect host port)) - (ports->win32-ssl-ports i o #:encrypt protocol)) + (ports->win32-ssl-ports i o #:encrypt protocol #:hostname host)) (define (win32-ssl-abandon-port port) ;; We don't try to implement shutdown, anyway @@ -126,7 +126,7 @@ (define (check-status who r) (unless (zero? r) - (error who "failed: ~x" r))) + (network-error who "failed: ~x" r))) (define-secur32 AcquireCredentialsHandleW (_fun #:abi winapi @@ -262,7 +262,7 @@ ;; Creating a context (i.e., an SSL connection) ;; Returns a context plus initial bytes for stream -(define (create-context protocol i o out-sb in-sb) +(define (create-context protocol hostname i o out-sb in-sb) ;; Pointers to particular SecBuffer records: (define out-sb0 (ptr-ref out-sb _SecBuffer 0)) (define in-sb0 (ptr-ref in-sb _SecBuffer 0)) @@ -278,26 +278,28 @@ ;; Allocate credentials. (define cred (make-cred-handle 0 0)) (AcquireCredentialsHandleW #f - "Microsoft Unified Security Protocol Provider" - SECPKG_CRED_OUTBOUND ; SECPKG_CRED_INBOUND or SECPKG_CRED_OUTBOUND - #f - (make-SCHANNEL_CRED SCHANNEL_CRED_VERSION - 0 #f - #f - 0 #f ; mappers - 0 #f ; algs - (case protocol - [(secure auto sslv2-or-v3) - (bitwise-ior SP_PROT_TLS1)] - [(sslv2) SP_PROT_SSL2] - [(sslv3) SP_PROT_SSL3] - [(tls) SP_PROT_TLS1]) - 0 0 0 - (bitwise-ior SCH_CRED_MANUAL_CRED_VALIDATION) - 0) - #f - #f - cred) + "Microsoft Unified Security Protocol Provider" + SECPKG_CRED_OUTBOUND + #f + (make-SCHANNEL_CRED SCHANNEL_CRED_VERSION + 0 #f + #f + 0 #f ; mappers + 0 #f ; algs + (case protocol + [(secure auto sslv2-or-v3) + (bitwise-ior SP_PROT_TLS1)] + [(sslv2) SP_PROT_SSL2] + [(sslv3) SP_PROT_SSL3] + [(tls tls11 tls12) SP_PROT_TLS1]) + 0 0 0 + (if (eq? protocol 'secure) + 0 + SCH_CRED_MANUAL_CRED_VALIDATION) + 0) + #f + #f + cred) ;; Allocate a content and take responsibility for freeing ;; credientials, but it's not a real content until the @@ -309,11 +311,15 @@ (define-values (r attr) (InitializeSecurityContextW cred (if init? #f (ctx->handle ctx)) - #f + (if (eq? protocol 'secure) + hostname + #f) (bitwise-ior ISC_REQ_REPLAY_DETECT ISC_REQ_SEQUENCE_DETECT ISC_REQ_CONFIDENTIALITY ISC_REQ_STREAM ISC_REQ_ALLOCATE_MEMORY - ISC_REQ_MANUAL_CRED_VALIDATION) + (if (eq? protocol 'secure) + 0 + ISC_REQ_MANUAL_CRED_VALIDATION)) 0 SECURITY_NATIVE_DREP (if init? @@ -348,7 +354,7 @@ (define (get-leftover-bytes) (if (equal? (SecBuffer-BufferType in-sb1) SECBUFFER_EXTRA) - ;; Same the leftover bytes: + ;; Save the leftover bytes: (let ([amt (SecBuffer-cbBuffer in-sb1)]) (log-win32-ssl-debug "init context: leftover ~a" amt) (memcpy buffer (ptr-add buffer (- data-len amt)) amt) @@ -362,12 +368,15 @@ (values ctx (let ([n (get-leftover-bytes)]) (subbytes buffer 0 n)))] - [(= r SEC_I_CONTINUE_NEEDED) + [(or (= r SEC_I_CONTINUE_NEEDED) + (= r SEC_E_INCOMPLETE_MESSAGE)) ;; Pull more data from the server - (define data-len (get-leftover-bytes)) + (define new-data-len (if (= r SEC_E_INCOMPLETE_MESSAGE) + data-len + (get-leftover-bytes))) ;; Unlikely, but maybe it's possible that we don't have room ;; to read more due to leftover bytes: - (when (= data-len buffer-size) + (when (= new-data-len buffer-size) (define new-buffer (malloc (* 2 buffer-size) 'atomic-interior)) (memcpy new-buffer buffer buffer-size) (set! buffer-size (* 2 buffer-size)) @@ -375,14 +384,16 @@ ;; Go back to non-atomic mode for a potentially blocking read: (define n (call-as-nonatomic (lambda () - (read-bytes-avail! buffer i data-len buffer-size)))) + (read-bytes-avail! buffer i new-data-len buffer-size)))) (log-win32-ssl-debug "init context: read ~a" n) - (when (eof-object? n) (error "unexpected EOF")) - (loop (+ data-len n) #f)] + (when (eof-object? n) (network-error "unexpected EOF")) + (loop (+ new-data-len n) (if (= r SEC_I_CONTINUE_NEEDED) + #f + init?))] ;; Some other things are allowed to happen without implying ;; failure, but we don't handle all of them. - [else (error 'create-context - "unexpected result: ~x" r)]))))) + [else (network-error 'create-context + "unexpected result: ~x" r)]))))) (define (decrypt ctx in-pre-r in-post-w out-sb) ;; Read encrypted byte from `in-pre-r', write decrypted bytes to @@ -420,7 +431,7 @@ (and (= SECBUFFER_DATA (SecBuffer-BufferType sb)) sb))) (unless sb - (error "expected decrypted data")) + (network-error "expected decrypted data")) (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer sb) (SecBuffer-cbBuffer sb)) in-post-w) @@ -446,7 +457,7 @@ ;; Other end closed the connection. (close-output-port in-post-w)] [else - (error 'decrypt "unexpected result: ~x" r)]))) + (network-error 'decrypt "unexpected result: ~x" r)]))) (define (encrypt ctx bstr start end out-sb sizes buffer) ;; Encrypt bytes [start, end) from bstr. @@ -497,16 +508,18 @@ ;; The encrypted bytes don't fit in the unencrypted space? (divide-and-conquer)] [else - (error 'decrypt "unexpected result: ~x" r)])])) + (network-error 'decrypt "unexpected result: ~x" r)])])) ;; Wrap input and output ports to produce SSL versions of the ports: -(define (ports->win32-ssl-ports i o #:encrypt [protocol 'sslv2-or-v3]) +(define (ports->win32-ssl-ports i o + #:encrypt [protocol 'auto] + #:hostname [hostname #f]) ;; Working space for encoding, decoding, and more: (define out-sb (make-SecBuffers 4)) (define in-sb (make-SecBuffers 2)) ;; Allocate the encoding/decoding context: - (define-values (ctx init-bytes) (create-context protocol i o out-sb in-sb)) + (define-values (ctx init-bytes) (create-context protocol hostname i o out-sb in-sb)) ;; Get some sizes that we need for encoding: (define sizes (make-SecPkgContext_StreamSizes 0 0 0 0 0)) @@ -664,6 +677,18 @@ ;; Done: (values (register in) (register out))) +;; ---------------------------------------- +;; Errors + +(define network-error + (case-lambda + [(str) (network-error 'win32-ssl str)] + [(who msg . args) + (raise + (exn:fail:network + (format "~a: ~a" who (apply format msg args)) + (current-continuation-marks)))])) + ;; ---------------------------------------- ;; Recognizing win32 ports