diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/info.rkt b/pkgs/racket-pkgs/racket-doc/net/scribblings/info.rkt index 9d984775cd..456253bc84 100644 --- a/pkgs/racket-pkgs/racket-doc/net/scribblings/info.rkt +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/info.rkt @@ -1,3 +1,4 @@ #lang info -(define scribblings '(("net.scrbl" (multi-page) (net-library)))) +(define scribblings '(("net.scrbl" (multi-page) (net-library)) + ("win32-ssl.scrbl" (multi-page) (net-library)))) diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/win32-ssl.scrbl b/pkgs/racket-pkgs/racket-doc/net/scribblings/win32-ssl.scrbl new file mode 100644 index 0000000000..9bf1201d0f --- /dev/null +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/win32-ssl.scrbl @@ -0,0 +1,54 @@ +#lang scribble/doc +@(require "common.rkt" + (for-label net/win32-ssl + openssl)) + +@title[#:tag "win32-ssl"]{Windows Native SSL: Secure Communication} + +@defmodule[net/win32-ssl]{The @racketmodname[net/win32-ssl] module +offers a fraction of the functionality of @racketmodname[openssl] and +works only on Windows, but it has the advantage that it works before +OpenSSL libraries are installed.} + +@defproc[(win32-ssl-connect [hostname string?] + [port-no (integer-in 1 65535)] + [client-protocol + (or/c 'sslv2-or-v3 + 'sslv2 + 'sslv3 + 'tls) + 'sslv2-or-v3]) + (values (and/c input-port? win32-ssl-port?) + (and/c output-port? win32-ssl-port?))]{ + +Like @racket[ssl-connect], but without support for client contexts +(which could enable certificate checking, for example).} + + +@defproc[(win32-ssl-abandon-port [in (and/c win32-ssl-port? output-port?)]) void?]{ + +Analogous to @racket[ssl-abandon-port].} + + +@defproc[(ports->win32-ssl-ports + [input-port input-port?] + [output-port output-port?] + [#:encrypt protocol (or/c 'sslv2-or-v3 'sslv2 'sslv3 'tls) 'sslv2-or-v3]) + (values (and/c input-port? win32-ssl-port?) + (and/c output-port? win32-ssl-port?))]{ + +Analogous to @racket[ports->ssl-ports].} + + +@defproc[(win32-ssl-port? [v any/c]) boolean?]{ + +Returns @racket[#t] of @racket[v] is an SSL port produced by +@racket[win32-ssl-connect] or +@racket[ports->win32-ssl-ports].} + + +@defthing[win32-ssl-available? boolean?]{ + +A boolean value that reports whether the Windows native SSL library was +successfully loaded. Calling @racket[win32-ssl-connect], @|etc| when this +value is @racket[#f] will raise an exception.} diff --git a/pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl index 0bd34da293..a897040814 100644 --- a/pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl +++ b/pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl @@ -37,7 +37,7 @@ distributions.} @defthing[ssl-available? boolean?]{ -A boolean value which says whether the system openssl library was +A boolean value that reports whether the system OpenSSL library was successfully loaded. Calling @racket[ssl-connect], @|etc| when this value is @racket[#f] (library not loaded) will raise an exception.} @@ -235,7 +235,7 @@ The @racket[ssl-accept/enable-break] procedure is analogous to @racket[tcp-accept/enable-break].} -@defproc[(ssl-abandon-port [in (and/c ssl-port? output-port?)]) void?]{ +@defproc[(ssl-abandon-port [p ssl-port?]) void?]{ Analogous to @racket[tcp-abandon-port].} diff --git a/racket/collects/net/url-connect.rkt b/racket/collects/net/url-connect.rkt index 5f80bb4188..42fc1be1de 100644 --- a/racket/collects/net/url-connect.rkt +++ b/racket/collects/net/url-connect.rkt @@ -3,7 +3,8 @@ (require (rename-in racket/tcp [tcp-connect plain-tcp-connect] [tcp-abandon-port plain-tcp-abandon-port]) - openssl) + openssl + "win32-ssl.rkt") (provide (all-defined-out)) @@ -15,10 +16,14 @@ ;; `current-connect-scheme' (define (tcp-connect host port) (cond [(equal? (current-connect-scheme) "https") - (ssl-connect host port (current-https-protocol))] + (if (or ssl-available? + (not win32-ssl-available?)) + (ssl-connect host port (current-https-protocol)) + (win32-ssl-connect host port (current-https-protocol)))] [else (plain-tcp-connect host port)])) (define (tcp-abandon-port port) (cond [(ssl-port? port) (ssl-abandon-port port)] + [(win32-ssl-port? port) (win32-ssl-abandon-port port)] [else (plain-tcp-abandon-port port)])) diff --git a/racket/collects/net/win32-ssl.rkt b/racket/collects/net/win32-ssl.rkt new file mode 100644 index 0000000000..b980d3f32b --- /dev/null +++ b/racket/collects/net/win32-ssl.rkt @@ -0,0 +1,726 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/winapi + ffi/unsafe/atomic + ffi/unsafe/alloc + racket/tcp + racket/port) + +;; A native Win32 implementation of SSL ports, which can be useful if +;; the openssl library is not available (perhaps because the openssl +;; library is going to be downloaded and installed via HTTPS). Various +;; options, including certificate checking, are not currently supported. + +(provide win32-ssl-connect + win32-ssl-abandon-port + ports->win32-ssl-ports + win32-ssl-port? + win32-ssl-available?) + +(define (win32-ssl-connect host port [protocol'sslv2-or-v3]) + (define-values (i o) (tcp-connect host port)) + (ports->win32-ssl-ports i o #:encrypt protocol)) + +(define (win32-ssl-abandon-port port) + ;; We don't try to implement shutdown, anyway + (if (input-port? port) + (close-input-port port) + (close-output-port port))) + +;; ---------------------------------------- +;; Win32 bindings + +(define secur32-lib (and (eq? 'windows (system-type)) + (ffi-lib "secur32.dll"))) + +(define win32-ssl-available? (and secur32-lib #t)) + +(define-ffi-definer define-secur32 secur32-lib + #:default-make-fail make-not-available) + +(define _LONG _long) +(define _ULONG _ulong) +(define _DWORD _int32) + +(define-cstruct _cred-handle ([a _intptr] [b _intptr])) +(define-cstruct _ctx-handle ([a _intptr] [b _intptr])) + +(define _SECURITY_STATUS _ULONG) +(define _TimeStamp _int64) + +(define SECPKG_CRED_INBOUND #x00000001) +(define SECPKG_CRED_OUTBOUND #x00000002) + +(define ISC_REQ_REPLAY_DETECT #x00000004) +(define ISC_REQ_SEQUENCE_DETECT #x00000008) +(define ISC_REQ_CONFIDENTIALITY #x00000010) +(define ISC_REQ_ALLOCATE_MEMORY #x00000100) +(define ISC_REQ_STREAM #x00008000) +(define ISC_REQ_USE_SUPPLIED_CREDS #x00000080) +(define ISC_REQ_MANUAL_CRED_VALIDATION #x00080000) + +(define SECURITY_NATIVE_DREP #x00000010) + +(define SECBUFFER_VERSION 0) +(define SECBUFFER_EMPTY 0) +(define SECBUFFER_DATA 1) +(define SECBUFFER_TOKEN 2) +(define SECBUFFER_EXTRA 5) +(define SECBUFFER_STREAM_TRAILER 6) +(define SECBUFFER_STREAM_HEADER 7) +(define SECBUFFER_ALERT 17) + +(define SEC_E_OK 0) +(define SEC_I_CONTINUE_NEEDED #x00090312) +(define SEC_E_INCOMPLETE_MESSAGE #x80090318) +(define SEC_E_BUFFER_TOO_SMALL #x80090321) + +(define SECPKG_ATTR_STREAM_SIZES 4) + +(define-cstruct _SecBuffer ([cbBuffer _ULONG] + [BufferType _ULONG] + [pvBuffer _pointer])) + +(define-cstruct _SecBufferDesc ([vers _ULONG] + [cBuffers _ULONG] + [pBuffers _pointer])) ; array of _SecBuffers + +(define-cstruct _SCHANNEL_CRED ([version _DWORD] + [cCreds _DWORD] + [paCred _pointer] + [hRootStore _pointer] + [cMappers _DWORD] + [aphMappers _pointer] + [cSupportedAlgs _DWORD] + [palgSupportedAlgs _pointer] + [grbitEnabledProtocols _DWORD] + [dwMinimumCipherStrength _DWORD] + [dwMaximumCipherStrength _DWORD] + [dwSessionLifespan _DWORD] + [dwFlags _DWORD] + [dwCredFormat _DWORD])) + +(define-cstruct _SecPkgContext_StreamSizes ([cbHeader _ULONG] + [cbTrailer _ULONG] + [cbMaximumMessage _ULONG] + [cBuffers _ULONG] + [cbBlockSize _ULONG])) + +(define SP_PROT_SSL2_SERVER #x00000004) +(define SP_PROT_SSL2_CLIENT #x00000008) +(define SP_PROT_SSL2 (bitwise-ior SP_PROT_SSL2_SERVER SP_PROT_SSL2_CLIENT)) +(define SP_PROT_SSL3_SERVER #x00000010) +(define SP_PROT_SSL3_CLIENT #x00000020) +(define SP_PROT_SSL3 (bitwise-ior SP_PROT_SSL3_SERVER SP_PROT_SSL3_CLIENT)) +(define SP_PROT_TLS1_SERVER #x00000040) +(define SP_PROT_TLS1_CLIENT #x00000080) +(define SP_PROT_TLS1 (bitwise-ior SP_PROT_TLS1_SERVER SP_PROT_TLS1_CLIENT)) +(define SCH_CRED_MANUAL_CRED_VALIDATION #x00000008) +(define SCH_CRED_NO_DEFAULT_CREDS #x00000010) +(define SCHANNEL_CRED_VERSION #x00000004) + +(define-secur32 InitSecurityInterfaceW + (_fun #:abi winapi -> _pointer)) + +(define (check-status who r) + (unless (zero? r) + (error who "failed: ~x" r))) + +(define-secur32 AcquireCredentialsHandleW + (_fun #:abi winapi + _string/utf-16 ; principal + _string/utf-16 ; package, such as "Negotiate" + _ULONG ; SECPKG_CRED_INBOUND or SECPKG_CRED_OUTBOUND + _pointer ; pvLogonID, NULL ok + _pointer ; pAuthData, NULL ok + _pointer ; pGetKeyFn, NULL ok + _pointer ; pvGetKeyArgument, NULL ok + _cred-handle-pointer ; receives the result + (ts : (_ptr o _TimeStamp)) + -> + (r : _SECURITY_STATUS) + -> + (check-status 'AcquireCredentialsHandleW r))) + +(define-secur32 FreeCredentialsHandle + (_fun #:abi winapi + _cred-handle-pointer + -> + (r : _SECURITY_STATUS) + -> + (check-status 'FreeCredentialsHandle r))) + +(define-secur32 FreeContextBuffer + (_fun #:abi winapi + _pointer + -> + (r : _SECURITY_STATUS) + -> + (check-status 'FreeContextBuffer r))) + +(define-secur32 InitializeSecurityContextW + (_fun #:abi winapi + _cred-handle-pointer + _ctx-handle-pointer/null ; NULL on first call + _string/utf-16 ; server name + _ULONG ; ISC_REQ_ALLOCATE_MEMORY, etc. + _ULONG ; reserved, 0 + _ULONG ; SECURITY_NATIVE_DREP + _SecBufferDesc-pointer/null ; input, NULL on first call + _ULONG ; reserved, 0 + _ctx-handle-pointer/null ; non-NULL on first call only + _SecBufferDesc-pointer ; output buffer + (attr : (_ptr o _ULONG)) + (ts : (_ptr o _TimeStamp)) ; timeout out, can ignore + -> + (r : _SECURITY_STATUS) + -> + (values r attr))) + +(define-secur32 DeleteSecurityContext + (_fun #:abi winapi + _ctx-handle-pointer + -> + (r : _SECURITY_STATUS) + -> + (check-status 'DeleteSecurityContext r))) + +(define-secur32 DecryptMessage + (_fun #:abi winapi + _ctx-handle-pointer + _SecBufferDesc-pointer ; input and output buffer + _ULONG + _pointer + -> + _SECURITY_STATUS)) + +(define-secur32 EncryptMessage + (_fun #:abi winapi + _ctx-handle-pointer + _ULONG + _SecBufferDesc-pointer ; input and output buffer + _ULONG + -> + _SECURITY_STATUS)) + +(define-secur32 QueryContextAttributesW + (_fun #:abi winapi + _ctx-handle-pointer + _ULONG ; attribute + _pointer ; receives the result + -> + (r : _SECURITY_STATUS) + -> + (check-status 'QueryContextAttributes r))) + +(define-logger win32-ssl) + +;; ---------------------------------------- +;; Credential and context finalization + +;; We allocate a credential and context handle at the same time +;; (atomically), so we only have to finalize credential--context +;; pairs. + +(define free-ctx + ((deallocator) + (lambda (ctx) + (unless (and (zero? (ctx-handle-a (car ctx))) + (zero? (ctx-handle-b (car ctx)))) + (DeleteSecurityContext (car ctx))) + (FreeCredentialsHandle (cdr ctx))))) +(define make-ctx + ((allocator free-ctx) + (lambda (cred) + (cons (make-ctx-handle 0 0) cred)))) +(define (ctx->handle ctx) (car ctx)) + +;; ---------------------------------------- +;; Helpers to manage the clunky SecBuffer API + +(define (make-SecBuffers n) + (cast (malloc n _SecBuffer 'atomic-interior) _pointer _SecBuffer-pointer)) + +(define (make-SecBuffers! sbs . vals) + (define n + (let loop ([pos 0] [vals vals]) + (cond + [(null? vals) pos] + [else + (define sb (ptr-ref sbs _SecBuffer pos)) + (set-SecBuffer-cbBuffer! sb (car vals)) + (set-SecBuffer-BufferType! sb (cadr vals)) + (set-SecBuffer-pvBuffer! sb (caddr vals)) + (loop (add1 pos) (cdddr vals))]))) + (make-SecBufferDesc SECBUFFER_VERSION + n + sbs)) + +;; ---------------------------------------- +;; 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) + ;; Pointers to particular SecBuffer records: + (define out-sb0 (ptr-ref out-sb _SecBuffer 0)) + (define in-sb0 (ptr-ref in-sb _SecBuffer 0)) + (define in-sb1 (ptr-ref in-sb _SecBuffer 1)) + + ;; To stream communication during protocol set-up: + (define buffer-size 4096) + (define buffer (make-sized-byte-string (malloc buffer-size 'atomic-interior) + buffer-size)) + + (call-as-atomic + (lambda () + ;; 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 + [(sslv2-or-v3 sslv3) (bitwise-ior SP_PROT_SSL2 SP_PROT_SSL3)] + [(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) + + ;; Allocate a content and take responsibility for freeing + ;; credientials, but it's not a real content until the + ;; 0 values are replaced with an new context: + (define ctx (make-ctx cred)) + + ;; Loop to let the client and server communicate to set up the protocol: + (let loop ([data-len 0] [init? #t]) + (define-values (r attr) + (InitializeSecurityContextW cred + (if init? #f (ctx->handle ctx)) + #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) + 0 + SECURITY_NATIVE_DREP + (if init? + #f + (make-SecBuffers! in-sb + data-len + SECBUFFER_TOKEN + buffer + 0 + SECBUFFER_EMPTY + #f)) + 0 + (if init? (ctx->handle ctx) #f) + (make-SecBuffers! out-sb + 0 + SECBUFFER_TOKEN + #f))) + (log-win32-ssl-debug "init context: status ~x" r) + + (when (or (= r SEC_E_OK) + (= r SEC_I_CONTINUE_NEEDED)) + (unless (zero? (SecBuffer-cbBuffer out-sb0)) + ;; Go back to non-atomic mode for a potentially blocking write: + (call-as-nonatomic + (lambda () + (log-win32-ssl-debug "init context: write ~a" (SecBuffer-cbBuffer out-sb0)) + (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer out-sb0) + (SecBuffer-cbBuffer out-sb0)) + o) + (flush-output o))) + (FreeContextBuffer (SecBuffer-pvBuffer out-sb0)))) + + (define (get-leftover-bytes) + (if (equal? (SecBuffer-BufferType in-sb1) SECBUFFER_EXTRA) + ;; Same 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) + amt) + 0)) + + (cond + [(= r SEC_E_OK) + ;; Success: + (log-win32-ssl-debug "init context: done") + (values ctx + (let ([n (get-leftover-bytes)]) + (subbytes buffer 0 n)))] + [(= r SEC_I_CONTINUE_NEEDED) + ;; Pull more data from the server + (define 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) + (define new-buffer (malloc (* 2 buffer-size) 'atomic-interior)) + (memcpy new-buffer buffer buffer-size) + (set! buffer-size (* 2 buffer-size)) + (set! buffer (make-sized-byte-string new-buffer buffer-size))) + ;; 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)))) + (log-win32-ssl-debug "init context: read ~a" n) + (when (eof-object? n) (error "unexpected EOF")) + (loop (+ data-len n) #f)] + ;; 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)]))))) + +(define (decrypt ctx in-pre-r in-post-w out-sb) + ;; Read encrypted byte from `in-pre-r', write decrypted bytes to + ;; `in-port-w'. + ;; Loop to try to get a big enough chunk from the input to be able + ;; to decrypt it. + (let loop ([size 4096] [prev-n 0]) + (define buffer (make-bytes size)) + (define n (peek-bytes-avail!* buffer 0 #f in-pre-r)) + (define r (DecryptMessage (ctx->handle ctx) + (make-SecBuffers! out-sb + n + SECBUFFER_DATA + buffer + 0 + SECBUFFER_EMPTY + #f + 0 + SECBUFFER_EMPTY + #f + 0 + SECBUFFER_EMPTY + #f) + 0 + #f)) + (log-win32-ssl-debug "decrypt status: ~x" r) + (cond + [(= r SEC_E_OK) + ;; Successfully decrypted some. Figure out how many bytes + ;; were used (to remove them from `in-pre-r') and + ;; write decrypted bytes to `in-post-w'. + (define sb + (for/or ([i (in-range 0 4)]) + (define sb (ptr-ref out-sb _SecBuffer i)) + (and (= SECBUFFER_DATA (SecBuffer-BufferType sb)) + sb))) + (unless sb + (error "expected decrypted data")) + (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer sb) + (SecBuffer-cbBuffer sb)) + in-post-w) + (define remain (or (for/or ([i (in-range 1 4)]) + (define sb (ptr-ref out-sb _SecBuffer i)) + (and (= SECBUFFER_EXTRA (SecBuffer-BufferType sb)) + (SecBuffer-cbBuffer sb))) + 0)) + (log-win32-ssl-debug "decrypted ~a to ~a (~a remain)" + (- n remain) + (SecBuffer-cbBuffer sb) + remain) + (read-bytes! buffer in-pre-r 0 (- n remain)) + (unless (zero? remain) + (loop size 0))] + [(= r SEC_E_INCOMPLETE_MESSAGE) + ;; If `prev-n' is the same as `n', then we must have + ;; tried everything that's currently available. + (unless (= prev-n n) + ;; Try with a larger buffer: + (loop (* size 2) n))] + [else + (error 'decrypt "unexpected result: ~x" r)]))) + +(define (encrypt ctx bstr start end out-sb sizes buffer) + ;; Encrypt bytes [start, end) from bstr. + ;; If we have too much to encrypt at once, we'll encrypt + ;; halves separately: + (define (divide-and-conquer) + + (define mid (quotient (+ start end) 2)) + (bytes-append (encrypt ctx bstr start mid sizes buffer) + (encrypt ctx bstr mid end sizes buffer))) + (cond + [((- end start) . > . (bytes-length buffer)) + ;; Too much right from the start: + (divide-and-conquer)] + [else + ;; EncryptMessage expects certain size buffers in a + ;; certain layout: + (define msize (SecPkgContext_StreamSizes-cbMaximumMessage sizes)) + (define hsize (SecPkgContext_StreamSizes-cbHeader sizes)) + (define tsize (SecPkgContext_StreamSizes-cbTrailer sizes)) + (define dsize (- end start)) + (memcpy buffer hsize bstr start (- end start)) + (define r (EncryptMessage (ctx->handle ctx) + 0 + (make-SecBuffers! out-sb + hsize + SECBUFFER_STREAM_HEADER + buffer + dsize + SECBUFFER_DATA + (ptr-add buffer hsize) + tsize + SECBUFFER_STREAM_TRAILER + (ptr-add buffer (+ hsize dsize)) + 0 + SECBUFFER_EMPTY + #f) + 0)) + (log-win32-ssl-debug "encrypt status: ~x" r) + (cond + [(= r SEC_E_OK) + ;; Success: + (define len (+ (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 0)) + (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 1)) + (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 2)))) + (subbytes buffer 0 len)] + [(= r SEC_E_BUFFER_TOO_SMALL) + ;; The encrypted bytes don't fit in the unencrypted space? + (divide-and-conquer)] + [else + (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]) + ;; 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)) + + ;; Get some sizes that we need for encoding: + (define sizes (make-SecPkgContext_StreamSizes 0 0 0 0 0)) + (QueryContextAttributesW (ctx->handle ctx) + SECPKG_ATTR_STREAM_SIZES + sizes) + (define msize (SecPkgContext_StreamSizes-cbMaximumMessage sizes)) + (define hsize (SecPkgContext_StreamSizes-cbHeader sizes)) + (define tsize (SecPkgContext_StreamSizes-cbTrailer sizes)) + + ;; Some pipes to manage the decoding stream: + (define-values (in-pre-r in-pre-w) (make-pipe)) + (define-values (in-post-r in-post-w) (make-pipe)) + + (write-bytes init-bytes in-pre-w) + (decrypt ctx in-pre-r in-post-w out-sb) + + ;; More working space: + (define buffer (make-bytes (max 8000 (+ msize hsize tsize)))) + + ;; Port lock and state: + (define lock (make-semaphore 1)) + (define leftover-bytes #f) + (define refcount 2) + + ;; Close original ports when both new ports are closed: + (define (close!) + (set! refcount (sub1 refcount)) + (when (zero? refcount) + (close-input-port i) + (close-output-port o) + (let ([v ctx]) + (set! ctx #f) + (when v (free-ctx v))))) + + ;; Callbacks used below (written here so that they're allocated once): + (define (lock-unavailable/read) (wrap-evt lock (lambda () 0))) + (define (lock-unavailable/write) (wrap-evt lock (lambda () #f))) + + (define (read-in bstr) + (let loop () + (define n (read-bytes-avail!* bstr in-post-r)) + (cond + [(eof-object? n) n] + [(zero? n) + ;; Any input on the underlying port? + (define n (read-bytes-avail!* buffer i)) + (cond + [(eof-object? n) + ;; Nothing decrypted, hit eof; return eof, even though + ;; we have leftover encrypted bytes: + (close-output-port in-post-w) + n] + [(zero? n) + ;; Nothing decrypted, no new input, so wait for input: + (log-win32-ssl-debug "blocked") + (wrap-evt i (lambda (v) 0))] + [else + (log-win32-ssl-debug "underlying receive: ~a" n) + ;; Get some fresh bytes, so try decoding now: + (write-bytes buffer in-pre-w 0 n) + (decrypt ctx in-pre-r in-post-w out-sb) + (loop)])] + [else n]))) + + ;; The new input port: + (define in (make-input-port/read-to-peek + (format "SSL ~a" (object-name i)) + ;; read: + (lambda (bstr) + (call-with-semaphore + lock + read-in + lock-unavailable/read + bstr)) + ;; peek: + (lambda (bstr offset slow) + ;; Try fast peek on decrypted port: + (define n (peek-bytes-avail!* bstr offset #f in-post-r)) + (if (zero? n) + (slow bstr offset) + n)) + ;; close + (lambda () + (call-with-semaphore + lock + close!)))) + + + (define (write-out bstr start end non-block? enable-break?) + (cond + [(and (= start end) + (not leftover-bytes)) + ;; Nothing to flush: + 0] + [(not leftover-bytes) + ;; Nothing in the output buffer, so we can encrypt more + (define encrypted-bstr (encrypt ctx bstr start end out-sb sizes buffer)) + (define n (write-bytes-avail* encrypted-bstr o)) + (cond + [(zero? n) + (wrap-evt o (lambda (v) #f))] + [(= n (bytes-length encrypted-bstr)) + ;; all written + (- end start)] + [else + ;; we're forced to save the leftover bytes and + ;; claim that they're written anyway: + (set! leftover-bytes (subbytes encrypted-bstr n)) + (- end start)])] + [else + ;; Try sending leftover bytes (for flush or not): + (define n (write-bytes-avail* leftover-bytes o)) + (cond + [(zero? n) + (wrap-evt o (lambda (v) #f))] + [(= n (bytes-length leftover-bytes)) + (set! leftover-bytes #f) + (if (= start end) + 0 ; flushed all + #f)] + [else + (set! leftover-bytes (subbytes leftover-bytes n)) + #f])])) + + ;; The new output port: + (define out (make-output-port + (format "SSL ~a" (object-name 0)) + o + ;; write-out + (lambda (bstr start end non-block? enable-break?) + (call-with-semaphore + lock + write-out + lock-unavailable/write + bstr start end non-block? enable-break?)) + ;; close + (lambda () + ;; flush: + (let loop () + (define r + (call-with-semaphore + lock + (lambda () + (write-out #"" 0 0 #f #f)))) + (cond + [(equal? r 0) (void)] + [(evt? r) (sync r) (loop)] + [else (loop)])) + ;; actually close: + (call-with-semaphore + lock + close!)))) + + ;; Done: + (values (register in) (register out))) + +;; ---------------------------------------- +;; Recognizing win32 ports + +(define win32-ssl-ports (make-weak-hash)) + +(define (register p) + (hash-set! win32-ssl-ports p #t) + p) + +(define (win32-ssl-port? p) + (hash-ref win32-ssl-ports p #f)) + +;; ---------------------------------------- +;; Initialization + +(when (eq? 'windows (system-type)) + (void (InitSecurityInterfaceW))) + +;; ---------------------------------------- + +#; +(module+ main + ;; Use `openssl' to implement server side for tests: + (require openssl) + (define server (ssl-make-server-context)) + (ssl-load-certificate-chain! server (collection-file-path "test.pem" "openssl")) + (ssl-load-private-key! server (collection-file-path "test.pem" "openssl")) + + ;; Check that data is sent correctly: + (define N 100) + (define M 3) + (define s (make-bytes N)) + (for ([i N]) + (bytes-set! s i (bitwise-and i 255))) + (for ([c 100]) + (printf "~s\n" c) + (define-values (i1 o1) (make-pipe (+ 4096 (random 4096)))) + (define-values (i2 o2) (make-pipe (+ 4096 (random 4096)))) + (define (fail who) (log-error "no good ~s" who) (exit 1)) + (define t1 + (thread + (lambda () + (define-values (si so) (ports->ssl-ports i1 o2 + #:mode 'accept + #:context server)) + (for ([j M]) (write s so)) + (flush-output so) + (for ([j M]) + (unless (equal? s (read si)) + (fail 'server))) + (close-output-port so) + (close-input-port si)))) + (define t2 + (thread + (lambda () + (define-values (ci co) (ports->win32-ssl-ports i2 o1)) + (for ([j M]) + (unless (equal? s (read ci)) + (fail 'client))) + (for ([j M]) + (write s co)) + (close-output-port co) + (close-input-port ci)))) + (sync t1) + (sync t2)))