1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 ffi/winapi 5 ffi/unsafe/atomic 6 ffi/unsafe/alloc 7 racket/tcp 8 racket/port) 9 10;; A native Win32 implementation of SSL ports, which can be useful if 11;; the openssl library is not available (perhaps because the openssl 12;; library is going to be downloaded and installed via HTTPS). Various 13;; options, including certificate checking, are not currently supported. 14 15(provide win32-ssl-connect 16 win32-ssl-abandon-port 17 ports->win32-ssl-ports 18 win32-ssl-port? 19 win32-ssl-available?) 20 21(define (win32-ssl-connect host port [protocol 'auto]) 22 (define-values (i o) (tcp-connect host port)) 23 (ports->win32-ssl-ports i o #:encrypt protocol #:hostname host)) 24 25(define (win32-ssl-abandon-port port) 26 ;; We don't try to implement shutdown, anyway 27 (if (input-port? port) 28 (close-input-port port) 29 (close-output-port port))) 30 31;; ---------------------------------------- 32;; Win32 bindings 33 34(define secur32-lib (and (eq? 'windows (system-type)) 35 (ffi-lib "secur32.dll"))) 36 37(define win32-ssl-available? (and secur32-lib #t)) 38 39(define-ffi-definer define-secur32 secur32-lib 40 #:default-make-fail make-not-available) 41 42(define _LONG _long) 43(define _ULONG _ulong) 44(define _DWORD _int32) 45 46(define-cstruct _cred-handle ([a _intptr] [b _intptr])) 47(define-cstruct _ctx-handle ([a _intptr] [b _intptr])) 48 49(define _SECURITY_STATUS _ULONG) 50(define _TimeStamp _int64) 51 52(define SECPKG_CRED_INBOUND #x00000001) 53(define SECPKG_CRED_OUTBOUND #x00000002) 54 55(define ISC_REQ_REPLAY_DETECT #x00000004) 56(define ISC_REQ_SEQUENCE_DETECT #x00000008) 57(define ISC_REQ_CONFIDENTIALITY #x00000010) 58(define ISC_REQ_ALLOCATE_MEMORY #x00000100) 59(define ISC_REQ_STREAM #x00008000) 60(define ISC_REQ_USE_SUPPLIED_CREDS #x00000080) 61(define ISC_REQ_MANUAL_CRED_VALIDATION #x00080000) 62 63(define SECURITY_NATIVE_DREP #x00000010) 64 65(define SECBUFFER_VERSION 0) 66(define SECBUFFER_EMPTY 0) 67(define SECBUFFER_DATA 1) 68(define SECBUFFER_TOKEN 2) 69(define SECBUFFER_EXTRA 5) 70(define SECBUFFER_STREAM_TRAILER 6) 71(define SECBUFFER_STREAM_HEADER 7) 72(define SECBUFFER_ALERT 17) 73 74(define SEC_E_OK 0) 75(define SEC_I_CONTINUE_NEEDED #x00090312) 76(define SEC_I_CONTEXT_EXPIRED #x00090317) 77(define SEC_E_INCOMPLETE_MESSAGE #x80090318) 78(define SEC_E_BUFFER_TOO_SMALL #x80090321) 79 80(define SECPKG_ATTR_STREAM_SIZES 4) 81 82(define-cstruct _SecBuffer ([cbBuffer _ULONG] 83 [BufferType _ULONG] 84 [pvBuffer _pointer])) 85 86(define-cstruct _SecBufferDesc ([vers _ULONG] 87 [cBuffers _ULONG] 88 [pBuffers _pointer])) ; array of _SecBuffers 89 90(define-cstruct _SCHANNEL_CRED ([version _DWORD] 91 [cCreds _DWORD] 92 [paCred _pointer] 93 [hRootStore _pointer] 94 [cMappers _DWORD] 95 [aphMappers _pointer] 96 [cSupportedAlgs _DWORD] 97 [palgSupportedAlgs _pointer] 98 [grbitEnabledProtocols _DWORD] 99 [dwMinimumCipherStrength _DWORD] 100 [dwMaximumCipherStrength _DWORD] 101 [dwSessionLifespan _DWORD] 102 [dwFlags _DWORD] 103 [dwCredFormat _DWORD])) 104 105(define-cstruct _SecPkgContext_StreamSizes ([cbHeader _ULONG] 106 [cbTrailer _ULONG] 107 [cbMaximumMessage _ULONG] 108 [cBuffers _ULONG] 109 [cbBlockSize _ULONG])) 110 111(define SP_PROT_SSL2_SERVER #x00000004) 112(define SP_PROT_SSL2_CLIENT #x00000008) 113(define SP_PROT_SSL2 (bitwise-ior SP_PROT_SSL2_SERVER SP_PROT_SSL2_CLIENT)) 114(define SP_PROT_SSL3_SERVER #x00000010) 115(define SP_PROT_SSL3_CLIENT #x00000020) 116(define SP_PROT_SSL3 (bitwise-ior SP_PROT_SSL3_SERVER SP_PROT_SSL3_CLIENT)) 117(define SP_PROT_TLS1_SERVER #x00000040) 118(define SP_PROT_TLS1_CLIENT #x00000080) 119(define SP_PROT_TLS1 (bitwise-ior SP_PROT_TLS1_SERVER SP_PROT_TLS1_CLIENT)) 120(define SP_PROT_TLS1_1_SERVER #x00000100) 121(define SP_PROT_TLS1_1_CLIENT #x00000200) 122(define SP_PROT_TLS1_1 (bitwise-ior SP_PROT_TLS1_1_SERVER SP_PROT_TLS1_1_CLIENT)) 123(define SP_PROT_TLS1_2_SERVER #x00000400) 124(define SP_PROT_TLS1_2_CLIENT #x00000800) 125(define SP_PROT_TLS1_2 (bitwise-ior SP_PROT_TLS1_2_SERVER SP_PROT_TLS1_2_CLIENT)) 126(define SCH_CRED_MANUAL_CRED_VALIDATION #x00000008) 127(define SCH_CRED_NO_DEFAULT_CREDS #x00000010) 128(define SCHANNEL_CRED_VERSION #x00000004) 129 130(define-secur32 InitSecurityInterfaceW 131 (_fun #:abi winapi -> _pointer)) 132 133(define (check-status who r) 134 (unless (zero? r) 135 (network-error who "failed: ~x" r))) 136 137(define-secur32 AcquireCredentialsHandleW 138 (_fun #:abi winapi 139 _string/utf-16 ; principal 140 _string/utf-16 ; package, such as "Negotiate" 141 _ULONG ; SECPKG_CRED_INBOUND or SECPKG_CRED_OUTBOUND 142 _pointer ; pvLogonID, NULL ok 143 _pointer ; pAuthData, NULL ok 144 _pointer ; pGetKeyFn, NULL ok 145 _pointer ; pvGetKeyArgument, NULL ok 146 _cred-handle-pointer ; receives the result 147 (ts : (_ptr o _TimeStamp)) 148 -> 149 (r : _SECURITY_STATUS) 150 -> 151 (check-status 'AcquireCredentialsHandleW r))) 152 153(define-secur32 FreeCredentialsHandle 154 (_fun #:abi winapi 155 _cred-handle-pointer 156 -> 157 (r : _SECURITY_STATUS) 158 -> 159 (check-status 'FreeCredentialsHandle r))) 160 161(define-secur32 FreeContextBuffer 162 (_fun #:abi winapi 163 _pointer 164 -> 165 (r : _SECURITY_STATUS) 166 -> 167 (check-status 'FreeContextBuffer r))) 168 169(define-secur32 InitializeSecurityContextW 170 (_fun #:abi winapi 171 _cred-handle-pointer 172 _ctx-handle-pointer/null ; NULL on first call 173 _string/utf-16 ; server name 174 _ULONG ; ISC_REQ_ALLOCATE_MEMORY, etc. 175 _ULONG ; reserved, 0 176 _ULONG ; SECURITY_NATIVE_DREP 177 _SecBufferDesc-pointer/null ; input, NULL on first call 178 _ULONG ; reserved, 0 179 _ctx-handle-pointer/null ; non-NULL on first call only 180 _SecBufferDesc-pointer ; output buffer 181 (attr : (_ptr o _ULONG)) 182 (ts : (_ptr o _TimeStamp)) ; timeout out, can ignore 183 -> 184 (r : _SECURITY_STATUS) 185 -> 186 (values r attr))) 187 188(define-secur32 DeleteSecurityContext 189 (_fun #:abi winapi 190 _ctx-handle-pointer 191 -> 192 (r : _SECURITY_STATUS) 193 -> 194 (check-status 'DeleteSecurityContext r))) 195 196(define-secur32 DecryptMessage 197 (_fun #:abi winapi 198 _ctx-handle-pointer 199 _SecBufferDesc-pointer ; input and output buffer 200 _ULONG 201 _pointer 202 -> 203 _SECURITY_STATUS)) 204 205(define-secur32 EncryptMessage 206 (_fun #:abi winapi 207 _ctx-handle-pointer 208 _ULONG 209 _SecBufferDesc-pointer ; input and output buffer 210 _ULONG 211 -> 212 _SECURITY_STATUS)) 213 214(define-secur32 QueryContextAttributesW 215 (_fun #:abi winapi 216 _ctx-handle-pointer 217 _ULONG ; attribute 218 _pointer ; receives the result 219 -> 220 (r : _SECURITY_STATUS) 221 -> 222 (check-status 'QueryContextAttributes r))) 223 224(define-logger win32-ssl) 225 226;; ---------------------------------------- 227;; Credential and context finalization 228 229;; We allocate a credential and context handle at the same time 230;; (atomically), so we only have to finalize credential--context 231;; pairs. 232 233(define free-ctx 234 ((deallocator) 235 (lambda (ctx) 236 (unless (and (zero? (ctx-handle-a (car ctx))) 237 (zero? (ctx-handle-b (car ctx)))) 238 (DeleteSecurityContext (car ctx))) 239 (FreeCredentialsHandle (cdr ctx))))) 240(define make-ctx 241 ((allocator free-ctx) 242 (lambda (cred) 243 (cons (make-ctx-handle 0 0) cred)))) 244(define (ctx->handle ctx) (car ctx)) 245 246;; ---------------------------------------- 247;; Helpers to manage the clunky SecBuffer API 248 249(define (make-SecBuffers n) 250 (define p (malloc n _SecBuffer 'atomic-interior)) 251 (cpointer-push-tag! p SecBuffer-tag) 252 p) 253 254(define (make-SecBuffers! sbs . vals) 255 (define n 256 (let loop ([pos 0] [vals vals]) 257 (cond 258 [(null? vals) pos] 259 [else 260 (define sb (ptr-ref sbs _SecBuffer pos)) 261 (set-SecBuffer-cbBuffer! sb (car vals)) 262 (set-SecBuffer-BufferType! sb (cadr vals)) 263 (set-SecBuffer-pvBuffer! sb (caddr vals)) 264 (loop (add1 pos) (cdddr vals))]))) 265 (make-SecBufferDesc SECBUFFER_VERSION 266 n 267 sbs)) 268 269;; ---------------------------------------- 270;; Creating a context (i.e., an SSL connection) 271 272;; Returns a context plus initial bytes for stream 273(define (create-context protocol hostname i o out-sb in-sb) 274 ;; Pointers to particular SecBuffer records: 275 (define out-sb0 (ptr-ref out-sb _SecBuffer 0)) 276 (define in-sb0 (ptr-ref in-sb _SecBuffer 0)) 277 (define in-sb1 (ptr-ref in-sb _SecBuffer 1)) 278 279 ;; To stream communication during protocol set-up: 280 (define buffer-size 4096) 281 (define buffer (malloc buffer-size 'atomic-interior)) 282 (define tmp-buffer (make-bytes buffer-size)) 283 284 (call-as-atomic 285 (lambda () 286 ;; Allocate credentials. 287 (define cred (make-cred-handle 0 0)) 288 (AcquireCredentialsHandleW #f 289 "Microsoft Unified Security Protocol Provider" 290 SECPKG_CRED_OUTBOUND 291 #f 292 (make-SCHANNEL_CRED SCHANNEL_CRED_VERSION 293 0 #f 294 #f 295 0 #f ; mappers 296 0 #f ; algs 297 (case protocol 298 [(secure auto) 299 (bitwise-ior SP_PROT_TLS1 SP_PROT_TLS1_1 SP_PROT_TLS1_2)] 300 [(sslv2) SP_PROT_SSL2] 301 [(sslv3) SP_PROT_SSL3] 302 [(tls) SP_PROT_TLS1] 303 [(tls11) SP_PROT_TLS1_1] 304 [(tls12) SP_PROT_TLS1_2] 305 [else 0]) 306 0 0 0 307 (if (eq? protocol 'secure) 308 0 309 SCH_CRED_MANUAL_CRED_VALIDATION) 310 0) 311 #f 312 #f 313 cred) 314 315 ;; Allocate a content and take responsibility for freeing 316 ;; credientials, but it's not a real content until the 317 ;; 0 values are replaced with an new context: 318 (define ctx (make-ctx cred)) 319 320 ;; Loop to let the client and server communicate to set up the protocol: 321 (let loop ([data-len 0] [init? #t]) 322 (define-values (r attr) 323 (InitializeSecurityContextW cred 324 (if init? #f (ctx->handle ctx)) 325 (if (eq? protocol 'secure) 326 hostname 327 #f) 328 (bitwise-ior ISC_REQ_REPLAY_DETECT ISC_REQ_SEQUENCE_DETECT 329 ISC_REQ_CONFIDENTIALITY ISC_REQ_STREAM 330 ISC_REQ_ALLOCATE_MEMORY 331 (if (eq? protocol 'secure) 332 0 333 ISC_REQ_MANUAL_CRED_VALIDATION)) 334 0 335 SECURITY_NATIVE_DREP 336 (if init? 337 #f 338 (make-SecBuffers! in-sb 339 data-len 340 SECBUFFER_TOKEN 341 buffer 342 0 343 SECBUFFER_EMPTY 344 #f)) 345 0 346 (if init? (ctx->handle ctx) #f) 347 (make-SecBuffers! out-sb 348 0 349 SECBUFFER_TOKEN 350 #f))) 351 (log-win32-ssl-debug "init context: status ~x" r) 352 353 (when (or (= r SEC_E_OK) 354 (= r SEC_I_CONTINUE_NEEDED)) 355 (unless (zero? (SecBuffer-cbBuffer out-sb0)) 356 ;; Go back to non-atomic mode for a potentially blocking write: 357 (call-as-nonatomic 358 (lambda () 359 (log-win32-ssl-debug "init context: write ~a" (SecBuffer-cbBuffer out-sb0)) 360 (write-bytes (pointer->bytes (SecBuffer-pvBuffer out-sb0) 361 (SecBuffer-cbBuffer out-sb0)) 362 o) 363 (flush-output o))) 364 (FreeContextBuffer (SecBuffer-pvBuffer out-sb0)))) 365 366 (define (get-leftover-bytes) 367 (if (equal? (SecBuffer-BufferType in-sb1) SECBUFFER_EXTRA) 368 ;; Save the leftover bytes: 369 (let ([amt (SecBuffer-cbBuffer in-sb1)]) 370 (log-win32-ssl-debug "init context: leftover ~a" amt) 371 (memcpy buffer (ptr-add buffer (- data-len amt)) amt) 372 amt) 373 0)) 374 375 (cond 376 [(= r SEC_E_OK) 377 ;; Success: 378 (log-win32-ssl-debug "init context: done") 379 (values ctx 380 (let ([n (get-leftover-bytes)]) 381 (pointer->bytes buffer n)) 382 buffer)] 383 [(or (= r SEC_I_CONTINUE_NEEDED) 384 (= r SEC_E_INCOMPLETE_MESSAGE)) 385 ;; Pull more data from the server 386 (define new-data-len (if (= r SEC_E_INCOMPLETE_MESSAGE) 387 data-len 388 (get-leftover-bytes))) 389 ;; Unlikely, but maybe it's possible that we don't have room 390 ;; to read more due to leftover bytes: 391 (when (= new-data-len buffer-size) 392 (define new-buffer (malloc (* 2 buffer-size) 'atomic-interior)) 393 (memcpy new-buffer buffer buffer-size) 394 (set! buffer-size (* 2 buffer-size)) 395 (set! buffer new-buffer) 396 (set! tmp-buffer (make-bytes buffer-size))) 397 ;; Go back to non-atomic mode for a potentially blocking read: 398 (define n (call-as-nonatomic 399 (lambda () 400 (read-bytes-avail! tmp-buffer i 0 (- buffer-size new-data-len))))) 401 (log-win32-ssl-debug "init context: read ~a" n) 402 (when (eof-object? n) (network-error "unexpected EOF")) 403 (memcpy buffer new-data-len tmp-buffer n) 404 (loop (+ new-data-len n) (if (= r SEC_I_CONTINUE_NEEDED) 405 #f 406 init?))] 407 ;; Some other things are allowed to happen without implying 408 ;; failure, but we don't handle all of them. 409 [else (network-error 'create-context 410 "unexpected result: ~x" r)]))))) 411 412(define (decrypt ctx in-pre-r in-post-w out-sb msg-size) 413 ;; Read encrypted byte from `in-pre-r', write decrypted bytes to 414 ;; `in-port-w'. 415 ;; Loop to try to get a big enough chunk from the input to be able 416 ;; to decrypt it. 417 (let loop ([size 4096] [prev-n 0]) 418 (define buffer (make-bytes size)) 419 (define n (peek-bytes! buffer 0 in-pre-r 0 (min (bytes-length buffer) 420 (pipe-content-length in-pre-r)))) 421 (define immobile-buffer (malloc (add1 n) 'atomic-interior)) 422 (memcpy immobile-buffer buffer n) 423 (define r (DecryptMessage (ctx->handle ctx) 424 (make-SecBuffers! out-sb 425 n 426 SECBUFFER_DATA 427 immobile-buffer 428 0 429 SECBUFFER_EMPTY 430 #f 431 0 432 SECBUFFER_EMPTY 433 #f 434 0 435 SECBUFFER_EMPTY 436 #f) 437 0 438 #f)) 439 (log-win32-ssl-debug "decrypt status: ~x" r) 440 (cond 441 [(= r SEC_E_OK) 442 ;; Successfully decrypted some. Figure out how many bytes 443 ;; were used (to remove them from `in-pre-r') and 444 ;; write decrypted bytes to `in-post-w'. 445 (define sb 446 (for/or ([i (in-range 0 4)]) 447 (define sb (ptr-ref out-sb _SecBuffer i)) 448 (and (= SECBUFFER_DATA (SecBuffer-BufferType sb)) 449 sb))) 450 (unless sb 451 (network-error "expected decrypted data")) 452 (write-bytes (pointer->bytes (SecBuffer-pvBuffer sb) 453 (SecBuffer-cbBuffer sb)) 454 in-post-w) 455 (define remain (or (for/or ([i (in-range 0 4)]) 456 (define sb (ptr-ref out-sb _SecBuffer i)) 457 (and (= SECBUFFER_EXTRA (SecBuffer-BufferType sb)) 458 (SecBuffer-cbBuffer sb))) 459 0)) 460 (log-win32-ssl-debug "decrypted ~a to ~a (~a remain)" 461 (- n remain) 462 (SecBuffer-cbBuffer sb) 463 remain) 464 (read-bytes! buffer in-pre-r 0 (- n remain)) 465 (void/reference-sink immobile-buffer) 466 (unless (zero? remain) 467 (loop size 0))] 468 [(= r SEC_E_INCOMPLETE_MESSAGE) 469 ;; If `prev-n' is the same as `n', then we must have 470 ;; tried everything that's currently available. 471 (unless (= prev-n n) 472 ;; Try with a larger buffer: 473 (loop (* size 2) n))] 474 [(= r SEC_I_CONTEXT_EXPIRED) 475 ;; Other end closed the connection. 476 (close-output-port in-post-w)] 477 [else 478 (network-error 'decrypt "unexpected result: ~x" r)]))) 479 480(define (encrypt ctx bstr start end out-sb sizes buffer buffer-len) 481 ;; Encrypt bytes [start, end) from bstr. 482 ;; If we have too much to encrypt at once, we'll encrypt 483 ;; halves separately: 484 (define (divide-and-conquer) 485 (define mid (quotient (+ start end) 2)) 486 (bytes-append (encrypt ctx bstr start mid out-sb sizes buffer buffer-len) 487 (encrypt ctx bstr mid end out-sb sizes buffer buffer-len))) 488 (cond 489 [((- end start) . > . buffer-len) 490 ;; Too much right from the start: 491 (divide-and-conquer)] 492 [else 493 ;; EncryptMessage expects certain size buffers in a 494 ;; certain layout: 495 (define msize (SecPkgContext_StreamSizes-cbMaximumMessage sizes)) 496 (define hsize (SecPkgContext_StreamSizes-cbHeader sizes)) 497 (define tsize (SecPkgContext_StreamSizes-cbTrailer sizes)) 498 (define dsize (- end start)) 499 (memcpy buffer hsize bstr start (- end start)) 500 (define r (EncryptMessage (ctx->handle ctx) 501 0 502 (make-SecBuffers! out-sb 503 hsize 504 SECBUFFER_STREAM_HEADER 505 buffer 506 dsize 507 SECBUFFER_DATA 508 (ptr-add buffer hsize) 509 tsize 510 SECBUFFER_STREAM_TRAILER 511 (ptr-add buffer (+ hsize dsize)) 512 0 513 SECBUFFER_EMPTY 514 #f) 515 0)) 516 (log-win32-ssl-debug "encrypt status: ~x" r) 517 (cond 518 [(= r SEC_E_OK) 519 ;; Success: 520 (define len (+ (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 0)) 521 (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 1)) 522 (SecBuffer-cbBuffer (ptr-ref out-sb _SecBuffer 2)))) 523 (define result (make-bytes len)) 524 (memcpy result buffer len) 525 result] 526 [(= r SEC_E_BUFFER_TOO_SMALL) 527 ;; The encrypted bytes don't fit in the unencrypted space? 528 (divide-and-conquer)] 529 [else 530 (network-error 'decrypt "unexpected result: ~x" r)])])) 531 532;; Wrap input and output ports to produce SSL versions of the ports: 533(define (ports->win32-ssl-ports i o 534 #:encrypt [protocol 'auto] 535 #:hostname [hostname #f]) 536 ;; Working space for encoding, decoding, and more: 537 (define out-sb (make-SecBuffers 4)) 538 (define in-sb (make-SecBuffers 2)) 539 540 ;; Allocate the encoding/decoding context: 541 (define-values (ctx init-bytes tok-buffer) (create-context protocol hostname i o out-sb in-sb)) 542 543 ;; Get some sizes that we need for encoding: 544 (define sizes (make-SecPkgContext_StreamSizes 0 0 0 0 0)) 545 (QueryContextAttributesW (ctx->handle ctx) 546 SECPKG_ATTR_STREAM_SIZES 547 sizes) 548 (define msize (SecPkgContext_StreamSizes-cbMaximumMessage sizes)) 549 (define hsize (SecPkgContext_StreamSizes-cbHeader sizes)) 550 (define tsize (SecPkgContext_StreamSizes-cbTrailer sizes)) 551 (define msg-size (+ msize hsize tsize)) 552 553 ;; Some pipes to manage the decoding stream: 554 (define-values (in-pre-r in-pre-w) (make-pipe)) 555 (define-values (in-post-r in-post-w) (make-pipe)) 556 557 (write-bytes init-bytes in-pre-w) 558 (decrypt ctx in-pre-r in-post-w out-sb msg-size) 559 560 ;; More working space: 561 (define buffer (make-bytes (max 8000 (+ msize hsize tsize)))) 562 (define out-buffer-len (bytes-length buffer)) 563 (define out-buffer (malloc (add1 out-buffer-len) 'atomic-interior)) 564 565 ;; Port lock and state: 566 (define lock (make-semaphore 1)) 567 (define leftover-bytes #f) 568 (define refcount 2) 569 570 ;; Close original ports when both new ports are closed: 571 (define (close!) 572 (set! refcount (sub1 refcount)) 573 (when (zero? refcount) 574 (close-input-port i) 575 (close-output-port o) 576 (let ([v ctx]) 577 (set! ctx #f) 578 (when v (free-ctx v))) 579 (void/reference-sink tok-buffer) 580 (void/reference-sink in-sb) 581 (void/reference-sink out-sb))) 582 583 ;; Callbacks used below (written here so that they're allocated once): 584 (define (lock-unavailable/read) (wrap-evt lock (lambda () 0))) 585 (define (lock-unavailable/write) (wrap-evt lock (lambda () #f))) 586 587 (define (read-in bstr) 588 (let loop () 589 (define n (read-bytes-avail!* bstr in-post-r)) 590 (cond 591 [(eof-object? n) n] 592 [(zero? n) 593 ;; Any input on the underlying port? 594 (define n (read-bytes-avail!* buffer i)) 595 (cond 596 [(eof-object? n) 597 ;; Nothing decrypted, hit eof; return eof, even though 598 ;; we have leftover encrypted bytes: 599 (close-output-port in-post-w) 600 n] 601 [(zero? n) 602 ;; Nothing decrypted, no new input, so wait for input: 603 (wrap-evt i (lambda (v) 0))] 604 [else 605 (log-win32-ssl-debug "underlying receive: ~a" n) 606 ;; Got some fresh bytes, so try decoding now: 607 (write-bytes buffer in-pre-w 0 n) 608 (decrypt ctx in-pre-r in-post-w out-sb msg-size) 609 (loop)])] 610 [else n]))) 611 612 ;; The new input port: 613 (define in (make-input-port/read-to-peek 614 (format "SSL ~a" (object-name i)) 615 ;; read: 616 (lambda (bstr) 617 (call-with-semaphore 618 lock 619 read-in 620 lock-unavailable/read 621 bstr)) 622 ;; peek: 623 (lambda (bstr offset slow) 624 ;; Try fast peek on decrypted port: 625 (define n (peek-bytes-avail!* bstr offset #f in-post-r)) 626 (if (zero? n) 627 (slow bstr offset) 628 n)) 629 ;; close 630 (lambda () 631 (call-with-semaphore 632 lock 633 close!)))) 634 635 636 (define (write-out bstr start end non-block? enable-break?) 637 (cond 638 [(and (= start end) 639 (not leftover-bytes)) 640 ;; Nothing to flush: 641 0] 642 [(not leftover-bytes) 643 ;; Nothing in the output buffer, so we can encrypt more 644 (define encrypted-bstr (encrypt ctx bstr start end out-sb sizes out-buffer out-buffer-len)) 645 (define n (write-bytes-avail* encrypted-bstr o)) 646 (cond 647 [(zero? n) 648 (wrap-evt o (lambda (v) #f))] 649 [(= n (bytes-length encrypted-bstr)) 650 ;; all written 651 (- end start)] 652 [else 653 ;; we're forced to save the leftover bytes and 654 ;; claim that they're written anyway: 655 (set! leftover-bytes (subbytes encrypted-bstr n)) 656 (- end start)])] 657 [else 658 ;; Try sending leftover bytes (for flush or not): 659 (define n (write-bytes-avail* leftover-bytes o)) 660 (cond 661 [(zero? n) 662 (wrap-evt o (lambda (v) #f))] 663 [(= n (bytes-length leftover-bytes)) 664 (set! leftover-bytes #f) 665 (if (= start end) 666 0 ; flushed all 667 #f)] 668 [else 669 (set! leftover-bytes (subbytes leftover-bytes n)) 670 #f])])) 671 672 ;; The new output port: 673 (define out (make-output-port 674 (format "SSL ~a" (object-name 0)) 675 o 676 ;; write-out 677 (lambda (bstr start end non-block? enable-break?) 678 (call-with-semaphore 679 lock 680 write-out 681 lock-unavailable/write 682 bstr start end non-block? enable-break?)) 683 ;; close 684 (lambda () 685 ;; flush: 686 (let loop () 687 (define r 688 (call-with-semaphore 689 lock 690 (lambda () 691 (write-out #"" 0 0 #f #f)))) 692 (cond 693 [(equal? r 0) (void)] 694 [(evt? r) (sync r) (loop)] 695 [else (loop)])) 696 ;; actually close: 697 (call-with-semaphore 698 lock 699 close!)))) 700 701 ;; Done: 702 (values (register in) (register out))) 703 704;; ---------------------------------------- 705;; Errors 706 707(define network-error 708 (case-lambda 709 [(str) (network-error 'win32-ssl str)] 710 [(who msg . args) 711 (raise 712 (exn:fail:network 713 (format "~a: ~a" who (apply format msg args)) 714 (current-continuation-marks)))])) 715 716;; ---------------------------------------- 717;; Recognizing win32 ports 718 719(define win32-ssl-ports (make-weak-hash)) 720 721(define (register p) 722 (hash-set! win32-ssl-ports p #t) 723 p) 724 725(define (win32-ssl-port? p) 726 (hash-ref win32-ssl-ports p #f)) 727 728;; ---------------------------------------- 729 730(define (pointer->bytes p len) 731 (define bstr (make-bytes len)) 732 (memcpy bstr p len) 733 bstr) 734 735;; ---------------------------------------- 736;; Initialization 737 738(when (eq? 'windows (system-type)) 739 (void (InitSecurityInterfaceW))) 740 741;; ---------------------------------------- 742 743#; 744(module+ main 745 ;; Use `openssl' to implement server side for tests: 746 (require openssl) 747 (define server (ssl-make-server-context)) 748 (ssl-load-certificate-chain! server (collection-file-path "test.pem" "openssl")) 749 (ssl-load-private-key! server (collection-file-path "test.pem" "openssl")) 750 751 ;; Check that data is sent correctly: 752 (define N 100) 753 (define M 3) 754 (define s (make-bytes N)) 755 (for ([i N]) 756 (bytes-set! s i (bitwise-and i 255))) 757 (for ([c 100]) 758 (printf "~s\n" c) 759 (define-values (i1 o1) (make-pipe (+ 4096 (random 4096)))) 760 (define-values (i2 o2) (make-pipe (+ 4096 (random 4096)))) 761 (define (fail who) (log-error "no good ~s" who) (exit 1)) 762 (define t1 763 (thread 764 (lambda () 765 (define-values (si so) (ports->ssl-ports i1 o2 766 #:mode 'accept 767 #:context server)) 768 (for ([j M]) (write s so)) 769 (flush-output so) 770 (for ([j M]) 771 (unless (equal? s (read si)) 772 (fail 'server))) 773 (close-output-port so) 774 (close-input-port si)))) 775 (define t2 776 (thread 777 (lambda () 778 (define-values (ci co) (ports->win32-ssl-ports i2 o1)) 779 (for ([j M]) 780 (unless (equal? s (read ci)) 781 (fail 'client))) 782 (for ([j M]) 783 (write s co)) 784 (close-output-port co) 785 (close-input-port ci)))) 786 (sync t1) 787 (sync t2))) 788