From 51972b8036e637f41ee7e211df705c1a976ecca3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 10 Mar 2012 10:40:30 -0700 Subject: [PATCH] net/imap: add TLS support Based on a patch from Thomas Spurden original commit: 537f194c4ee81503040aa3067b0530d10130e2be --- collects/net/imap.rkt | 70 +++++++++++++++++++++-------- collects/net/scribblings/imap.scrbl | 17 +++++-- 2 files changed, 64 insertions(+), 23 deletions(-) diff --git a/collects/net/imap.rkt b/collects/net/imap.rkt index 37e8b00be7..05b4d99e67 100644 --- a/collects/net/imap.rkt +++ b/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,33 +314,62 @@ v)) v))) -(define (imap-connect* r w username password inbox) +(define (has-starttls? imap) + (let ([has? #f]) + (check-ok (imap-send imap + "CAPABILITY" + (lambda (caps) + (when (member 'STARTTLS caps) + (set! has? #t))))) + has?)) + +(define (imap-login imap username password inbox) + (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))) + +(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))))) - (let ([imap (make-imap r w #f #f #f #f #f - (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))))) - -(define (imap-connect server 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? - (begin - (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))) + (begin + (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 #:tls? tls? #:try-tls? try-tls?))) (define (imap-reselect imap inbox) (imap-selectish-command imap (list "SELECT" inbox) #t)) diff --git a/collects/net/scribblings/imap.scrbl b/collects/net/scribblings/imap.scrbl index da85e9565d..683550ef9b 100644 --- a/collects/net/scribblings/imap.scrbl +++ b/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 -result value reprsents the connection. +username and password, and selects the specified mailbox. If +@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.,