I've just started learning Racket and as a first task wanted to scape my
IMAP mail boxes. One of my accounts requires STARTTLS and the other
(gmail) requires a connection over SSL. I wrote a simple modification
to net/imap so it automatically switches to TLS if the server
capabilities include STARTTLS, and provides a new function
imap-connect-tls to connect via TLS. It seems to work fine on my two
IMAP accounts.
I'm not very happy with the has-starttls? function, but am not sure how
to avoid the set!.
I'm not sure whether it is better to create a new imap 'object' using
make-imap after switching to TLS (which is what I've done) or to modify
the existing 'object' (which doesn't seem very functionaly).
The patch is against Racket 5.2.1.
(Please keep me CC'ed as I'm not subscribed to the list)
--
Thomas Spurden
--- orig/imap.rkt 2012-02-02 04:16:57.000000000 +0000
+++ new/imap.rkt 2012-03-03 20:06:51.412601571 +0000
@@ -1,6 +1,6 @@
#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
@@ -20,7 +20,7 @@
(provide
imap-connection?
- imap-connect imap-connect*
+ imap-connect imap-connect-tls imap-connect*
imap-disconnect
imap-force-disconnect
imap-reselect
@@ -311,6 +311,21 @@
v))
v)))
+(define (has-starttls? imap)
+ (let ([has #f])
+ (begin
+ (check-ok (imap-send imap "CAPABILITY" (lambda (caps) (if (member 'STARTTLS caps) (set! has #t) #f)))))
+ 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 (imap-connect* r w username password inbox)
(with-handlers ([void
(lambda (x)
@@ -321,13 +336,18 @@
(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)))))
+ (if (has-starttls? imap)
+ (begin
+ (check-ok (imap-send imap "STARTTLS" void))
+ (let-values ([(ssl-in ssl-out) (ports->ssl-ports r w #:close-original? #t #:encrypt 'tls)])
+ (imap-login (make-imap ssl-in ssl-out #f #f #f #f #f (new-tree) (new-tree) #f) username password inbox))
+ )
+ (imap-login imap username password inbox)))))
+
+(define (imap-connect-tls server username password inbox)
+ (let-values ([(tcp-in tcp-out) (tcp-connect server (imap-port-number))])
+ (let-values ([(ssl-in ssl-out) (ports->ssl-ports tcp-in tcp-out #:close-original? #t #:encrypt 'tls)])
+ (imap-connect* ssl-in ssl-out username password inbox))))
(define (imap-connect server username password inbox)
;; => imap count-k recent-k
_________________________
Racket Developers list:
http://lists.racket-lang.org/dev
