1#lang racket/base
2(require ffi/unsafe
3         ffi/unsafe/define
4         ffi/unsafe/nsstring
5         ffi/unsafe/alloc
6         ffi/unsafe/atomic
7         ffi/unsafe/custodian
8         ffi/unsafe/schedule
9         ffi/unsafe/os-thread
10         racket/port
11         racket/format
12         openssl)
13
14(provide osx-ssl-connect
15         osx-ssl-abandon-port
16         osx-ssl-output-port?
17         osx-old-openssl?)
18
19(define (osx-old-openssl?)
20  (and (or (eq? 'macosx (system-type))
21           (eq? 'darwin (system-type 'os*)))
22       (not (eq? 'ppc (system-type 'arch))) ; Mac OS 10.5 is too old for this to work?
23       (or (not ssl-available?)
24           (not (memq 'tls12 (supported-client-protocols))))))
25
26(define cf-lib
27  (and (or (eq? 'macosx (system-type))
28           (eq? 'darwin (system-type 'os*)))
29       (ffi-lib "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation")))
30(define net-lib
31  (and (or (eq? 'macosx (system-type))
32           (eq? 'darwin (system-type 'os*)))
33       (ffi-lib
34        "/System/Library/Frameworks/CFNetwork.framework/CFNetwork"
35        #:fail (lambda ()
36                 ;; Path inside "CoreServices.framework" needed for OS X 10.5
37                 (ffi-lib "/System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/CFNetwork.framework/CFNetwork")))))
38
39(define-ffi-definer define-cf cf-lib
40  #:default-make-fail make-not-available)
41(define-ffi-definer define-net net-lib
42  #:default-make-fail make-not-available)
43(define-ffi-definer define-racket #f
44  #:default-make-fail make-not-available)
45
46(define _CFReadStreamRef (_cpointer/null 'CFReadStreamRef))
47(define _CFWriteStreamRef (_cpointer/null 'CFWriteStreamRef))
48(define _CFErrorRef (_cpointer/null 'CFError))
49
50(define _CFRunLoopRef (_cpointer/null 'CFRunLoopRef))
51
52(define _CFDictionaryRef (_cpointer/null 'CFDictionaryRef))
53
54(define _Boolean _bool)
55(define _CFIndex _long)
56
57(define-cf CFRelease (_fun _pointer -> _void)
58  #:wrap (deallocator))
59
60(define retain
61  ((allocator CFRelease) (lambda (p) p)))
62
63;; Call in atomic mode to ensure `retain` calls:
64(define-cf CFStreamCreatePairWithSocketToHost
65  (_fun (_pointer = #f)
66        _NSString
67        _int32
68        (in : (_ptr o _CFReadStreamRef))
69        (out : (_ptr o _CFWriteStreamRef))
70        -> _void
71        -> (values (and in (retain in)) (and out (retain out)))))
72
73(define-cf CFReadStreamScheduleWithRunLoop (_fun _CFReadStreamRef _CFRunLoopRef _pointer -> _void))
74(define-cf CFWriteStreamScheduleWithRunLoop (_fun _CFWriteStreamRef _CFRunLoopRef _pointer -> _void))
75
76(define-cf CFReadStreamOpen (_fun _CFReadStreamRef -> _Boolean))
77(define-cf CFWriteStreamOpen (_fun _CFWriteStreamRef -> _Boolean))
78
79(define-cf CFReadStreamClose (_fun _CFReadStreamRef -> _void))
80(define-cf CFWriteStreamClose (_fun _CFWriteStreamRef -> _void))
81
82(define-cf CFReadStreamHasBytesAvailable (_fun _CFReadStreamRef -> _Boolean))
83(define-cf CFReadStreamRead (_fun _CFReadStreamRef _pointer _CFIndex -> _CFIndex))
84
85(define-cf CFWriteStreamCanAcceptBytes (_fun _CFWriteStreamRef -> _Boolean))
86(define-cf CFWriteStreamWrite (_fun _CFWriteStreamRef _pointer _CFIndex -> _CFIndex))
87
88(define-cf kCFRunLoopDefaultMode _pointer)
89
90(define-cf CFRunLoopStop (_fun _CFRunLoopRef -> _void))
91
92(define-cstruct _CFStreamError ([domain _int]
93                                [error _int32]))
94
95(define-cf CFReadStreamGetError (_fun _CFReadStreamRef -> _CFStreamError))
96(define-cf CFWriteStreamGetError (_fun _CFWriteStreamRef -> _CFStreamError))
97
98(define-cf NSStreamSocketSecurityLevelNegotiatedSSL _pointer)
99(define-cf NSStreamSocketSecurityLevelKey _pointer)
100
101(define-net kCFStreamPropertySSLSettings _pointer)
102(define-net kCFStreamSSLValidatesCertificateChain _pointer)
103(define-net kCFStreamSSLLevel _pointer)
104
105(define-cf kCFBooleanFalse _pointer)
106(define-cf kCFBooleanTrue _pointer)
107
108(define-net kCFStreamSocketSecurityLevelSSLv2 _pointer)
109(define-net kCFStreamSocketSecurityLevelSSLv3 _pointer)
110(define-net kCFStreamSocketSecurityLevelTLSv1 _pointer)
111(define-net kCFStreamSocketSecurityLevelNegotiatedSSL _pointer)
112
113(define-cf CFReadStreamSetProperty (_fun _CFReadStreamRef _pointer _pointer -> _Boolean))
114(define-cf CFWriteStreamSetProperty (_fun _CFWriteStreamRef _pointer _pointer -> _Boolean))
115
116(define-cstruct _CFStreamClientContext ([version _CFIndex]
117                                        [info _pointer]
118                                        [retain _pointer]
119                                        [release _pointer]
120                                        [copy _pointer]))
121
122(define-cf CFReadStreamSetClient (_fun _CFReadStreamRef
123                                       _int
124                                       (_fun #:atomic? #t
125                                             #:async-apply (lambda (f) (f))
126                                             _CFReadStreamRef _int _pointer -> _void)
127                                       _CFStreamClientContext-pointer
128                                       -> _Boolean))
129(define-cf CFWriteStreamSetClient (_fun _CFWriteStreamRef
130                                        _int
131                                        (_fun #:atomic? #t
132                                              #:async-apply (lambda (f) (f))
133                                              _CFWriteStreamRef _int _pointer -> _void)
134                                        _CFStreamClientContext-pointer
135                                        -> _Boolean))
136
137(define kCFStreamEventNone 0)
138(define kCFStreamEventOpenCompleted 1)
139(define kCFStreamEventHasBytesAvailable 2)
140(define kCFStreamEventCanAcceptBytes 4)
141(define kCFStreamEventErrorOccurred 8)
142(define kCFStreamEventEndEncountered 16)
143
144(define all-evts (bitwise-ior
145                  kCFStreamEventOpenCompleted
146                  kCFStreamEventHasBytesAvailable
147                  kCFStreamEventCanAcceptBytes
148                  kCFStreamEventErrorOccurred
149                  kCFStreamEventEndEncountered))
150
151(define _CFStreamStatus
152  (_enum '(kCFStreamStatusNotOpen
153           kCFStreamStatusOpening
154           kCFStreamStatusOpen
155           kCFStreamStatusReading
156           kCFStreamStatusWriting
157           kCFStreamStatusAtEnd
158           kCFStreamStatusClosed
159           kCFStreamStatusError)))
160
161(define-cf CFReadStreamGetStatus
162  (_fun _CFReadStreamRef -> _CFStreamStatus))
163(define-cf CFWriteStreamGetStatus
164  (_fun _CFWriteStreamRef -> _CFStreamStatus))
165
166(define-cf CFReadStreamCopyError
167  (_fun _CFReadStreamRef -> _CFErrorRef)
168  #:wrap (allocator CFRelease))
169(define-cf CFWriteStreamCopyError
170  (_fun _CFWriteStreamRef -> _CFErrorRef)
171  #:wrap (allocator CFRelease))
172(define-cf CFErrorCopyDescription
173  (_fun _CFErrorRef -> _NSString))
174
175(define-cf CFDictionaryCreate
176  (_fun (_pointer = #f)
177        (keys : (_list i _pointer))
178        (vals : (_list i _pointer))
179        (_CFIndex = (length keys))
180        (_pointer = #f)
181        (_pointer = #f)
182        -> _CFDictionaryRef)
183  #:wrap (allocator CFRelease))
184
185;; ----------------------------------------
186
187(define-cstruct _Scheme_Proc_Sequence ([num_procs _racket]
188                                       [data _pointer]
189                                       [proc1 _pointer]
190                                       [proc2 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) _pointer -> _pointer)]
191                                       [proc3 _pointer]
192                                       [proc4 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) -> _pointer)])
193  #:malloc-mode 'nonatomic)
194
195(define _pthread (_cpointer/null 'pthread))
196
197(define-racket pthread_create
198  (_fun (p : (_ptr o _pthread)) _pointer _pointer _pointer
199        -> (r : _int)
200        -> (and (zero? r)
201                p)))
202(define-racket pthread_detach
203  (_fun _pointer -> _int))
204
205(define-racket scheme_call_sequence_of_procedures-ptr _fpointer
206  #:c-id scheme_call_sequence_of_procedures)
207
208(define-cf CFRunLoopGetCurrent (_fun -> _CFRunLoopRef))
209(define-cf CFRunLoopRun (_fun #:blocking? #t _CFRunLoopRef -> _void))
210(define-cf CFRunLoopGetCurrent-ptr _fpointer
211  #:c-id CFRunLoopGetCurrent)
212(define-cf CFRunLoopRun-ptr _fpointer
213  #:c-id CFRunLoopRun)
214
215(define stop-and-release
216  ((deallocator)
217   (lambda (run-loop)
218     (CFRunLoopStop run-loop)
219     (CFReleaseRunLoop run-loop))))
220
221(define-cf CFRetainRunLoop (_fun _CFRunLoopRef -> _CFRunLoopRef)
222  #:c-id CFRetain
223  #:wrap (allocator stop-and-release))
224(define-cf CFReleaseRunLoop (_fun _pointer -> _void)
225  #:c-id CFRelease)
226
227(define (launch-run-loop-in-pthread init-reg more-retain)
228  (define run-loop #f)
229  (cond
230    [(os-thread-enabled?)
231     (define create-done (make-os-semaphore))
232     (define retain-done (make-os-semaphore))
233     (define setup-done create-done)
234     (call-in-os-thread
235      (lambda ()
236        (define rl (CFRunLoopGetCurrent))
237        (set! run-loop rl)
238        (os-semaphore-post create-done)
239        (os-semaphore-wait retain-done)
240        (init-reg rl)
241        (os-semaphore-post setup-done)
242        (CFRunLoopRun rl)
243        (void/reference-sink more-retain)))
244     (os-semaphore-wait create-done)
245     ;; To be on the safe side, register a finalizer in the Racket thread:
246     (set! run-loop (CFRetainRunLoop run-loop))
247     (os-semaphore-post retain-done)
248     (os-semaphore-wait setup-done)]
249    [else
250     (define done (make-semaphore))
251     (define (setup r)
252       ;; Called in atomic mode in arbitrary Racket thread:
253       (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef)))
254       (init-reg run-loop)
255       (semaphore-post done)
256       (unsafe-signal-received)
257       #f)
258     (define (finished)
259       (free-immobile-cell retainer)
260       #f)
261     ;; Retains callbacks until the thread is done:
262     (define retainer (malloc-immobile-cell
263                       (vector setup finished more-retain)))
264     (define seq (make-Scheme_Proc_Sequence 4
265                                            #f
266                                            CFRunLoopGetCurrent-ptr
267                                            ;; `#:aync-apply` moves the following
268                                            ;; back to the main thread (in atomic mode):
269                                            setup
270                                            CFRunLoopRun-ptr
271                                            ;; `#:async-apply` here, too:
272                                            finished))
273     (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq))
274     (unless pth (error "could not start run-loop thread"))
275     (pthread_detach pth)
276
277     (semaphore-wait done)
278     (set! done seq) ; retains `seq` until here
279
280     (void)])
281  run-loop)
282
283;; ----------------------------------------
284
285(define (osx-ssl-connect host port [protocol 'auto])
286  (define-syntax-rule (check-ok (op arg ...))
287    (unless (op arg ...)
288      (error 'op "failed")))
289
290  (define-values (in out)
291    (call-as-atomic
292     (lambda ()
293       (CFStreamCreatePairWithSocketToHost host port))))
294
295  (check-ok (CFReadStreamSetProperty in
296                                     NSStreamSocketSecurityLevelKey
297                                     NSStreamSocketSecurityLevelNegotiatedSSL))
298  (check-ok (CFWriteStreamSetProperty out
299                                      NSStreamSocketSecurityLevelKey
300                                      NSStreamSocketSecurityLevelNegotiatedSSL))
301
302  (unless (eq? protocol 'secure)
303    (define d (CFDictionaryCreate
304               (list kCFStreamSSLValidatesCertificateChain
305                     kCFStreamSSLLevel)
306               (list kCFBooleanFalse
307                     (case protocol
308                       [(sslv2) kCFStreamSocketSecurityLevelSSLv2]
309                       [(sslv3) kCFStreamSocketSecurityLevelSSLv3]
310                       [(tls tls11 tls12) kCFStreamSocketSecurityLevelTLSv1]
311                       [else kCFStreamSocketSecurityLevelNegotiatedSSL]))))
312    (check-ok (CFReadStreamSetProperty in kCFStreamPropertySSLSettings d))
313    (check-ok (CFWriteStreamSetProperty out kCFStreamPropertySSLSettings d))
314    (CFRelease d))
315
316  (define in-ready (make-semaphore))
317  (define out-ready (make-semaphore 1))
318
319  ;; These callback must be retained so that they're not GCed
320  ;; until the run loop is terminated:
321  (define in-callback (lambda (_in evt _null)
322                        (void (semaphore-try-wait? in-ready))
323                        (semaphore-post in-ready)
324                        (unsafe-signal-received)))
325  (define out-callback (lambda (_out evt _null)
326                         (void (semaphore-try-wait? out-ready))
327                         (semaphore-post out-ready)
328                         (unsafe-signal-received)))
329
330  (define context (make-CFStreamClientContext 0 #f #f #f #f))
331  (check-ok (CFReadStreamSetClient in all-evts in-callback context))
332  (check-ok (CFWriteStreamSetClient out all-evts out-callback context))
333
334  (define run-loop
335    (launch-run-loop-in-pthread
336     ;; This function will be called as atomic within the scheduler
337     ;; or in a separate OS thread:
338     (lambda (run-loop)
339       (CFReadStreamScheduleWithRunLoop in run-loop kCFRunLoopDefaultMode)
340       (CFWriteStreamScheduleWithRunLoop out run-loop kCFRunLoopDefaultMode))
341     (list in-callback out-callback)))
342
343  (check-ok (CFWriteStreamOpen out))
344  (check-ok (CFReadStreamOpen in))
345
346  (let loop ()
347    (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusOpening)
348              (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusOpening))
349      (sync in-ready out-ready)
350      (loop)))
351
352  (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError)
353            (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusError))
354    (raise
355     (exn:fail:network
356      (~a "osx-ssl-connect: connection failed\n"
357          "  message: " (let ([err (if (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError)
358                                       (CFReadStreamCopyError in)
359                                       (CFWriteStreamCopyError out))])
360                          (begin0
361                            (CFErrorCopyDescription err)
362                            (CFRelease err)))
363          "\n"
364          "  address: " host "\n"
365          "  port number: " port)
366      (current-continuation-marks))))
367
368  (define open-count 2)
369  (define skip-close-out? #f)
370
371  (define in-cust-reg (register-custodian-shutdown in (lambda (v) (close!))))
372  (define out-cust-reg (register-custodian-shutdown out (lambda (v) (close!))))
373
374  (define (close!)
375    (call-as-atomic
376     (lambda ()
377       (set! open-count (sub1 open-count))
378       (when (zero? open-count)
379         (unregister-custodian-shutdown in in-cust-reg)
380         (unregister-custodian-shutdown out out-cust-reg)
381         (stop-and-release run-loop)
382         (CFRelease in)
383         (CFRelease out)))))
384
385  (define-values (in-buffer-in in-buffer-out) (make-pipe))
386  (define IN-BUFFER-SIZE 4096)
387  (define in-buffer (make-bytes IN-BUFFER-SIZE))
388
389  (define lock (make-semaphore 1))
390
391  ;; Callbacks used below (written here so that they're allocated once):
392  (define (lock-unavailable/read) (wrap-evt lock (lambda () 0)))
393  (define (lock-unavailable/write) (wrap-evt lock (lambda () #f)))
394
395  (define (read-in bstr)
396    (define n (read-bytes-avail!* bstr in-buffer-in))
397    (cond
398     [(positive? n) n]
399     [(zero? n)
400      (void (semaphore-try-wait? in-ready))
401      (cond
402       [(CFReadStreamHasBytesAvailable in)
403        (define use-bstr
404          (if ((bytes-length bstr) . < . IN-BUFFER-SIZE)
405              in-buffer
406              bstr))
407        (define n (CFReadStreamRead in use-bstr (bytes-length use-bstr)))
408        (cond
409         [(zero? n) eof]
410         [(negative? n)
411          (raise-osx-ssl-network-error 'read-bytes
412                                       (CFReadStreamGetError in))]
413         [else
414          (cond
415           [(eq? use-bstr in-buffer)
416            (write-bytes in-buffer in-buffer-out 0 n)
417            ;; Try again:
418            0]
419           [else n])])]
420       [(equal? (CFReadStreamGetStatus in)
421                'kCFStreamStatusError)
422        (raise-osx-ssl-network-error 'read-bytes
423                                     (CFReadStreamGetError in))]
424       [else
425        (wrap-evt (semaphore-peek-evt in-ready) (lambda (v) 0))])]))
426
427  (define (write-out bstr start end buffer? breakable?)
428    (cond
429     [(= start end) 0]
430     [else
431      (void (semaphore-try-wait? out-ready))
432      (cond
433       [(CFWriteStreamCanAcceptBytes out)
434        (let ([n (CFWriteStreamWrite out
435                                     (if (zero? start)
436                                         bstr
437                                         (substring bstr start end))
438                                     (- end start))])
439          (cond
440           [(zero? n)
441            (wrap-evt always-evt (lambda (v) #f))]
442           [(negative? n)
443            (raise-osx-ssl-network-error 'write-bytes
444                                         (CFWriteStreamGetError out))]
445           [else n]))]
446       [(equal? (CFWriteStreamGetStatus out)
447                'kCFStreamStatusError)
448        (raise-osx-ssl-network-error 'write-bytes
449                                     (CFWriteStreamGetError out))]
450       [else
451        (wrap-evt (semaphore-peek-evt out-ready) (lambda (v) #f))])]))
452
453  (values (make-input-port/read-to-peek
454           'osx-ssl
455           ;; read:
456           (lambda (bstr)
457             (call-with-semaphore
458              lock
459              read-in
460              lock-unavailable/read
461              bstr))
462           ;; peek:
463           (lambda (bstr offset slow)
464             ;; Try fast peek on buffer port:
465             (define n (peek-bytes-avail!* bstr offset #f in-buffer-in))
466             (if (zero? n)
467                 (slow bstr offset)
468                 n))
469           (lambda ()
470             (call-with-semaphore
471              lock
472              (lambda ()
473                (CFReadStreamClose in)
474                (close!)))))
475
476          (osx-ssl-output-port
477           (make-output-port
478            'osx-ssl
479            (semaphore-peek-evt out-ready)
480            ;; write
481            (lambda (bstr start end non-block? enable-break?)
482              (call-with-semaphore
483               lock
484               write-out
485               lock-unavailable/write
486               bstr start end non-block? enable-break?))
487            ;; close
488            (lambda ()
489              (call-with-semaphore
490               lock
491               (lambda ()
492                 (unless skip-close-out?
493                   (CFWriteStreamClose out))
494                 (close!)))))
495           ;; abandon:
496           (lambda (self)
497             (set! skip-close-out? #t)
498             (close-output-port self)))))
499
500(struct osx-ssl-output-port (port abandon)
501        #:property prop:output-port 0)
502
503(define (osx-ssl-abandon-port p)
504  (if (osx-ssl-output-port? p)
505      ((osx-ssl-output-port-abandon p) p)
506      (close-output-port p)))
507
508(define (raise-osx-ssl-network-error who err)
509  (raise
510   (exn:fail:network
511    (~a who ": failed " (CFStreamError->list err))
512    (current-continuation-marks))))
513