On Sun, Jul 04, 2010 at 01:03:27AM +0200, Felix wrote:
> So... You could use the "reserved" fields (you actually *should* use
> the "port-data", but some silly implementor (me) has already broken
> this convention), so you could use the "reserved" fields of the port
> (see around line 1630 in library.scm) to store whatever you want, just
> make sure both tcp.scm and openssl.scm agree on their use. The
> port-type (whether it refers to a socket or not, which is possible
> what you need as well) is in slot #7.
>
> Hm. It would probably be a good idea to use symbolic names instead of
> slot numbers. On the other hand, this is just too low-level anyway, so
> you deserve nothing better. ssl-make-i/o-ports should simply not
> modify the port-data. Very bad. Verboten. Absolutely.
haha, thanks for clarifying :)
Here's a patch that uses the reserved slots to store the tcp ports,
which can then be used to pass to tcp-addresses. This makes Spiffy's
HTTPS work properly. Are you okay with this, Thomas?
Cheers,
Peter
--
http://sjamaan.ath.cx
--
"The process of preparing programs for a digital computer
is especially attractive, not only because it can be economically
and scientifically rewarding, but also because it can be an aesthetic
experience much like composing poetry or music."
-- Donald Knuth
Index: openssl.scm
===================================================================
--- openssl.scm (revision 18697)
+++ openssl.scm (working copy)
@@ -8,6 +8,8 @@
ssl-client-context?
ssl-listen
ssl-close
+ ssl-port?
+ ssl-addresses
ssl-listener?
ssl-listener?
ssl-listener-port
@@ -271,7 +273,28 @@
ssl buffer offset size)
#t))
-(define (ssl-make-i/o-ports ctx fd ssl)
+(define (ssl-port? obj)
+ (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket)))
+
+(define (ensure-ssl-port obj loc)
+ (or (ssl-port? obj)
+ (abort
+ (make-property-condition
+ 'exn
+ 'location loc
+ 'message "expected an ssl port, got"
+ 'arguments (list obj))
+ (make-property-condition
+ 'type))))
+
+(define (ssl-port->tcp-fd p loc)
+ (ensure-ssl-port p loc)
+ (##sys#slot p 11))
+
+(define (ssl-addresses p)
+ (tcp-addresses (ssl-port->tcp-fd p 'ssl-addresses)))
+
+(define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)
;; note that the ctx parameter is never used but it is passed in order
;; to be present in the closure data of the various port functions
;; so it isn't garbage collected before the ports are all gone
@@ -381,10 +404,10 @@
(shutdown)))))
(##sys#setslot in 3 "(ssl)")
(##sys#setslot out 3 "(ssl)")
- (##sys#setslot in 7 'socket)
- (##sys#setslot out 7 'socket)
- (##sys#setslot (##sys#port-data in) 0 fd)
- (##sys#setslot (##sys#port-data out) 0 fd)
+ (##sys#setslot in 10 'ssl-socket) ; first "reserved" slot
+ (##sys#setslot out 10 'ssl-socket) ; Slot 7 should probably stay 'custom
+ (##sys#setslot in 11 tcp-in) ; second "reserved" slot
+ (##sys#setslot out 11 tcp-out)
(values in out))))
(define (ssl-unwrap-context obj)
@@ -416,36 +439,36 @@
;; connect to SSL server
(define (ssl-connect hostname #!optional port (ctx 'sslv2-or-v3))
- (let* ((fd
- (call-with-values (cut tcp-connect hostname port)
- net-unwrap-tcp-ports))
- (ctx
- (if (ssl-client-context? ctx)
- (ssl-unwrap-client-context ctx)
- (ssl-ctx-new ctx #f)))
- (ssl
- (ssl-new ctx)))
- (let ((success? #f))
- (dynamic-wind
- void
- (lambda ()
- (ssl-set-fd! ssl fd)
- (let loop ()
- (case (ssl-connect-ssl ssl)
- ((want-read)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
- (thread-yield!)
- (loop))
- ((want-write)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
- (thread-yield!)
- (loop))))
- (set! success? #t))
- (lambda ()
- (unless success?
- (ssl-free ssl)
- (net-close-socket fd)))))
- (ssl-make-i/o-ports ctx fd ssl)))
+ (receive (tcp-in tcp-out)
+ (tcp-connect hostname port)
+ (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
+ (ctx
+ (if (ssl-client-context? ctx)
+ (ssl-unwrap-client-context ctx)
+ (ssl-ctx-new ctx #f)))
+ (ssl
+ (ssl-new ctx)))
+ (let ((success? #f))
+ (dynamic-wind
+ void
+ (lambda ()
+ (ssl-set-fd! ssl fd)
+ (let loop ()
+ (case (ssl-connect-ssl ssl)
+ ((want-read)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (thread-yield!)
+ (loop))
+ ((want-write)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
+ (thread-yield!)
+ (loop))))
+ (set! success? #t))
+ (lambda ()
+ (unless success?
+ (ssl-free ssl)
+ (net-close-socket fd)))))
+ (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
;; create listener/SSL server context
(define-record-type ssl-listener
@@ -479,32 +502,32 @@
;; accept a connection from an SSL listener
(define (ssl-accept listener)
- (let* ((fd
- (call-with-values (cut tcp-accept (ssl-unwrap-listener listener))
- net-unwrap-tcp-ports))
- (ssl
- (ssl-new (ssl-unwrap-listener-context listener))))
- (let ((success? #f))
- (dynamic-wind
- void
- (lambda ()
- (ssl-set-fd! ssl fd)
- (let loop ()
- (case (ssl-accept-ssl ssl)
- ((want-read)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
- (thread-yield!)
- (loop))
- ((want-write)
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
- (thread-yield!)
- (loop))))
- (set! success? #t))
- (lambda ()
- (unless success?
- (ssl-free ssl)
- (net-close-socket fd)))))
- (ssl-make-i/o-ports (ssl-unwrap-listener-context listener) fd ssl)))
+ (receive (tcp-in tcp-out)
+ (tcp-accept (ssl-unwrap-listener listener))
+ (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
+ (ctx (ssl-unwrap-listener-context listener))
+ (ssl (ssl-new ctx)))
+ (let ((success? #f))
+ (dynamic-wind
+ void
+ (lambda ()
+ (ssl-set-fd! ssl fd)
+ (let loop ()
+ (case (ssl-accept-ssl ssl)
+ ((want-read)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (thread-yield!)
+ (loop))
+ ((want-write)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
+ (thread-yield!)
+ (loop))))
+ (set! success? #t))
+ (lambda ()
+ (unless success?
+ (ssl-free ssl)
+ (net-close-socket fd)))))
+ (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
;; load identifying certificate chain into SSL context
(define (ssl-load-certificate-chain! obj pathname)
_______________________________________________
Chicken-hackers mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-hackers
