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

net/win32-ssl: a native Windows SSL layer

Browse Source 
This implementation of SSL ports is less complete than `openssl', but
it's complete enough to drive HTTPS, and so it can be used to download
a package that provides the DLLs needed for the `openssl' library.

The `net/url' library uses `net/win32-ssl' on Windows when `openssl'
is not available (due to the absence of the OpenSSL DLLs).
This commit is contained in:
Matthew Flatt 2013-08-18 10:51:48 -06:00
parent 2a2ea729ee
commit d9e226824f
5 changed files with 791 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-pkgs/racket-doc/net/scribblings/info.rkt
View File

@ -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))))

54
pkgs/racket-pkgs/racket-doc/net/scribblings/win32-ssl.scrbl Normal file
View File

@ -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.}

4
pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl
View File

@ -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].}

9
racket/collects/net/url-connect.rkt
View File

@ -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)]))

726
racket/collects/net/win32-ssl.rkt Normal file
View File

@ -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)))