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

net/win32-ssl: enable 'secure mode

Browse Source 
Validate server certificate in 'secure mode.
This commit is contained in:
Matthew Flatt 2016-01-06 09:02:27 -07:00
parent c706ee2c05
commit 8dfce37977
1 changed files with 65 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
racket/collects/net/win32-ssl.rkt
View File

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