net/imap: add TLS support

Based on a patch from Thomas Spurden

original commit: 537f194c4e

collects/net/imap.rkt

@@ -1,6 +1,9 @@
 #lang racket/base
 
-(require racket/contract/base racket/tcp "private/rbtree.rkt")
+(require racket/contract/base 
+         racket/tcp 
+         openssl 
+         "private/rbtree.rkt")
 
 ;; define the imap struct and its predicate here, for use in the contract, below
 (define-struct imap (r w exists recent unseen uidnext uidvalidity
@@ -311,25 +314,54 @@
                                         v))
                     v)))
 
-(define (imap-connect* r w username password inbox)
+(define (has-starttls? imap)
-  (with-handlers ([void
+  (let ([has? #f])
-                   (lambda (x)
+    (check-ok (imap-send imap
-                     (close-input-port r)
+                         "CAPABILITY"
-                     (close-output-port w)
+                         (lambda (caps) 
-                     (raise x))])
+                           (when (member 'STARTTLS caps)
+                             (set! has? #t)))))
+    has?))
 
-    (let ([imap (make-imap r w #f #f #f #f #f
+(define (imap-login imap username password inbox)
-                           (new-tree) (new-tree) #f)])
-      (check-ok (imap-send imap "NOOP" void))
   (let ([reply (imap-send imap (list "LOGIN" username password) void)])
     (if (and (pair? reply) (tag-eq? 'NO (car reply)))
       (error 'imap-connect
         "username or password rejected by server: ~s" reply)
       (check-ok reply)))
   (let-values ([(init-count init-recent) (imap-reselect imap inbox)])
-        (values imap init-count init-recent)))))
+    (values imap init-count init-recent)))
 
-(define (imap-connect server username password inbox)
+(define (ports->tls-ports r w)  
+  (ports->ssl-ports r w #:close-original? #t #:encrypt 'tls))
+
+(define (imap-connect* r w username password inbox
+                       #:tls? [tls? #f]
+                       #:try-tls? [try-tls? #t])
+  (with-handlers ([void
+                   (lambda (x)
+                     (close-input-port r)
+                     (close-output-port w)
+                     (raise x))])
+    (let-values ([(r w)
+                  (if tls?
+                      (ports->tls-ports r w)
+                      (values r w))])
+      (let ([imap (make-imap r w #f #f #f #f #f
+                             (new-tree) (new-tree) #f)])
+        (check-ok (imap-send imap "NOOP" void))
+        (define imap-maybe-tls
+          (if (and (not tls?) try-tls? (has-starttls? imap))
+              (begin
+                (check-ok (imap-send imap "STARTTLS" void))
+                (let-values ([(ssl-in ssl-out) (ports->tls-ports r w)])
+                  (make-imap ssl-in ssl-out #f #f #f #f #f (new-tree) (new-tree) #f)))
+              imap))
+        (imap-login imap-maybe-tls username password inbox)))))
+
+(define (imap-connect server username password inbox 
+                       #:tls? [tls? #f]
+                       #:try-tls? [try-tls? #t])
   ;; => imap count-k recent-k
   (let-values ([(r w)
                 (if debug-via-stdio?
@@ -337,7 +369,7 @@
                       (printf "stdin == ~a\n" server)
                       (values  (current-input-port) (current-output-port)))
                     (tcp-connect server (imap-port-number)))])
-    (imap-connect* r w username password inbox)))
+    (imap-connect* r w username password inbox #:tls? tls? #:try-tls? try-tls?)))
 
 (define (imap-reselect imap inbox)
   (imap-selectish-command imap (list "SELECT" inbox) #t))

collects/net/scribblings/imap.scrbl

@@ -55,13 +55,20 @@ opaque), @racket[#f] otherwise.}
 @defproc[(imap-connect [server string?]
                        [username (or/c string? bytes?)]
                        [password (or/c string? bytes?)]
-                       [mailbox (or/c string? bytes?)])
+                       [mailbox (or/c string? bytes?)]
+                       [#:tls? tls? any/c #f]
+                       [#:try-tls? try-tls? any/c #t])
          (values imap-connection? exact-nonnegative-integer? exact-nonnegative-integer?)]{
 
 Establishes an IMAP connection to the given server using the given
-username and password, and selects the specified mailbox. The first
+username and password, and selects the specified mailbox. If
-result value reprsents the connection.
+@racket[tls?]  is true, a TLS connection is made to the server before
+communicating using the IMAP protocol. If @racket[tls?] is @racket[#f]
+but @racket[try-tls?] is true, then after the IMAP connection is
+initially established, the connection is switched to a TLS connection
+if the server supports it.
 
+The first result value represents the connection.
 The second and third return values indicate the total number of
 messages in the mailbox and the number of recent messages (i.e.,
 messages received since the mailbox was last selected), respectively.
@@ -87,7 +94,9 @@ is @racket[143].}
                         [out output-port?]
                         [username (or/c string? bytes?)]
                         [password (or/c string? bytes?)]
-                        [mailbox (or/c string? bytes?)])
+                        [mailbox (or/c string? bytes?)]
+                        [#:tls? tls? any/c #f]
+                        [#:try-tls? try-tls? any/c #t])
          (values imap-connection? exact-nonnegative-integer? exact-nonnegative-integer?)]{
 
 Like @racket[imap-connect], but given input and output ports (e.g.,