[Chicken-users] [PATCH] openssl: don't throw startup-on-closed exception in close

[Florian Zumbiehl]

So far, a user of the openssl egg would have had to distinguish whether some
OpenSSL I/O error exception originated in the egg's internal startup function
that does the SSL handshake on the initial read or write or in the actual SSL
I/O code, as in the former case, the ports get closed implicitly, so that the
invocation of startup during close would throw an exception indicating
incorrect API use, while the latter leaves FD and SSL state allocated, so that
one has to invoke close in order to avoid FD and memory leaks.

To fix this, we don't throw an exception anymore when close is invoked on a
port that was closed implicitly, so that closing the ports is always the
correct thing to do.
---
 openssl.scm |   57 ++++++++++++++++++++++++++++++---------------------------
 1 files changed, 30 insertions(+), 27 deletions(-)

diff --git a/openssl.scm b/openssl.scm
index 31c76fd..e8bcc56 100644
--- a/openssl.scm
+++ b/openssl.scm
@@ -357,31 +357,34 @@ EOF
   ;; so it isn't garbage collected before the ports are all gone
   (let ((in-open? #f) (out-open? #f)
         (mutex (make-mutex 'ssl-mutex)))
-    (define (startup)
+    (define (startup #!optional (called-from-close #f))
       (dynamic-wind
           (lambda ()
             (mutex-lock! mutex))
           (lambda ()
-          (when (not ssl)
-            (error "SSL socket already closed"))
-           (unless (or in-open? out-open?)
-             (let ((success? #f))
-               (dynamic-wind
-                   void
-                   (lambda ()
-                     (ssl-set-fd! ssl fd)
-                     (ssl-call/timeout 'ssl-do-handshake
-                                       (lambda () (ssl-do-handshake ssl))
-                                       fd (ssl-handshake-timeout)
-                                       "SSL handshake operation timed out")
-                     (set! in-open? #t)
-                     (set! out-open? #t)
-                     (set! success? #t))
-                   (lambda ()
-                     (unless success?
-                       (ssl-free ssl)
-                      (set! ssl #f)
-                       (net-close-socket fd)))))))
+          (let ((skip-startup (not ssl)))
+             (if skip-startup
+               (when (not called-from-close)
+                 (error "SSL socket already closed"))
+               (unless (or in-open? out-open?)
+                 (let ((success? #f))
+                   (dynamic-wind
+                     void
+                     (lambda ()
+                       (ssl-set-fd! ssl fd)
+                       (ssl-call/timeout 'ssl-do-handshake
+                                         (lambda () (ssl-do-handshake ssl))
+                                         fd (ssl-handshake-timeout)
+                                         "SSL handshake operation timed out")
+                       (set! in-open? #t)
+                       (set! out-open? #t)
+                       (set! success? #t))
+                     (lambda ()
+                       (unless success?
+                         (ssl-free ssl)
+                         (set! ssl #f)
+                         (net-close-socket fd)))))))
+             (not skip-startup)))
           (lambda ()
             (mutex-unlock! mutex))))
     (define (shutdown)
@@ -426,9 +429,9 @@ EOF
                          #t)))))
              ;; close
              (lambda ()
-                (startup)
-               (set! in-open? #f)
-               (shutdown))
+                (when (startup #t)
+                  (set! in-open? #f)
+                  (shutdown)))
              ;; peek
              (lambda ()
                 (startup)
@@ -453,9 +456,9 @@ EOF
                       (loop (fx+ offset ret) (fx- size ret)))))))
            ;; close
            (lambda ()
-              (startup)
-             (set! out-open? #f)
-             (shutdown)))))
+              (when (startup #t)
+                (set! out-open? #f)
+                (shutdown))))))
       (##sys#setslot in 3 "(ssl)")
       (##sys#setslot out 3 "(ssl)")
       ;; first "reserved" slot
-- 
1.7.2.5