7d50e61c7f
* Another big chunk of v4-require-isms * Allow `#lang framework/keybinding-lang' for keybinding files * Move hierlist sources into "mrlib/hierlist", leave stub behind svn: r10689
170 lines
5.5 KiB
Scheme
170 lines
5.5 KiB
Scheme
|
|
(define imap-server "imap.cs.utah.edu")
|
|
(define imap-port-no 993)
|
|
(define username "mflatt")
|
|
(define pw (with-input-from-file (build-path (current-load-relative-directory) "pw")
|
|
read))
|
|
(define mailbox-name "INBOX.tmp") ;; !!! ALL CONTENT WILL BE DELETED !!!
|
|
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'imap)
|
|
|
|
(require openssl/mzssl
|
|
net/imap
|
|
mzlib/etc)
|
|
|
|
(define (test-connect)
|
|
(let ([c (ssl-make-client-context)])
|
|
(let-values ([(in out) (ssl-connect imap-server imap-port-no c)])
|
|
(imap-connect* in out username pw mailbox-name))))
|
|
|
|
(define-values (imap cnt recent) (test-connect))
|
|
|
|
(printf "Msgs: ~a; Validity: ~a~n" cnt (imap-uidvalidity imap))
|
|
|
|
(test cnt imap-messages imap)
|
|
(test recent imap-recent imap)
|
|
(test #t number? (imap-uidvalidity imap))
|
|
(test #f imap-pending-expunges? imap)
|
|
(test #f imap-pending-updates? imap)
|
|
(test #f imap-new? imap)
|
|
|
|
(imap-disconnect imap)
|
|
done
|
|
|
|
(define (delete-all)
|
|
(let ([cnt (imap-messages imap)])
|
|
(unless (zero? cnt)
|
|
(let ([all (build-list cnt add1)])
|
|
(test (void) imap-store imap '+ all '|\Deleted|)
|
|
(test (void) imap-expunge imap)
|
|
(test #t imap-pending-expunges? imap)
|
|
(test all imap-get-expunges imap)
|
|
(test null imap-get-expunges imap)
|
|
(test #f imap-pending-expunges? imap)))))
|
|
|
|
(delete-all)
|
|
(test #f imap-new? imap)
|
|
(test 0 imap-messages imap)
|
|
(test '(0 0) 'noop (let-values ([(a b) (imap-noop imap)])
|
|
(list a b)))
|
|
(test (void) imap-poll imap)
|
|
(test 0 imap-messages imap)
|
|
(test 0 imap-recent imap)
|
|
|
|
(test #f imap-new? imap)
|
|
|
|
(define (add-one content total)
|
|
(test (void) imap-append imap mailbox-name content)
|
|
(imap-noop imap)
|
|
(test total imap-messages imap)
|
|
(test #t imap-new? imap)
|
|
(let ([uids (imap-get-messages imap (build-list total add1) '(uid))])
|
|
(test #t list? uids)
|
|
(test total length uids)
|
|
(let ([l (list-ref uids (sub1 total))])
|
|
(test #t list? l)
|
|
(test 1 length l)
|
|
(test #t number? (car l))
|
|
(car l))))
|
|
|
|
|
|
(define sample-head #"Subject: Hello\r\n\r\n")
|
|
(define sample-body #"Hi there.\r\n")
|
|
|
|
(let ([uid (add-one (bytes-append sample-head sample-body) 1)])
|
|
(test (list (list uid
|
|
sample-head
|
|
sample-body
|
|
'(|\Seen|)))
|
|
imap-get-messages imap '(1) '(uid header body flags)))
|
|
(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Answered| |\Seen|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Seen|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted)))
|
|
(test (list '((|\Seen| |\Deleted|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Answered|))) imap-get-messages imap '(1) '(flags))
|
|
|
|
(test #f imap-pending-updates? imap)
|
|
(test null imap-get-updates imap)
|
|
|
|
;; Test multiple-client access:
|
|
(let ()
|
|
(define-values (imap2 cnt2 recent2) (test-connect))
|
|
(test '(1 0) list cnt2 recent2)
|
|
|
|
(let ([uid (add-one (bytes-append sample-head sample-body) 2)])
|
|
(let loop ([n 5])
|
|
(when (zero? n)
|
|
(imap-noop imap2))
|
|
(imap-poll imap2)
|
|
(unless (imap-new? imap2)
|
|
(sleep 0.2)
|
|
(loop (sub1 n))))
|
|
(test #t imap-new? imap2)
|
|
(test 2 imap-messages imap2)
|
|
(let ([uids (imap-get-messages imap2 '(2) '(uid))])
|
|
(test uid caar uids)))
|
|
|
|
;; Delete message on imap2, check notifcation to imap
|
|
(test (void) imap-store imap2 '+ '(2) (list (symbol->imap-flag 'deleted)))
|
|
(test (void) imap-expunge imap2)
|
|
(test '(2) imap-get-expunges imap2)
|
|
(imap-noop imap)
|
|
(err/rt-test (imap-store imap '+ '(2) (list (symbol->imap-flag 'answered))))
|
|
(test #t imap-pending-expunges? imap)
|
|
(test '(2) imap-get-expunges imap)
|
|
|
|
;; Adjust flags on imap2, check notifcation to imap
|
|
(test #f imap-pending-updates? imap)
|
|
(test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
|
|
(imap-noop imap)
|
|
(test #t imap-pending-updates? imap)
|
|
(test #t list? (imap-get-updates imap))
|
|
(test #f imap-pending-updates? imap)
|
|
|
|
;; Check that multiple updates are collapsed:
|
|
(test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))
|
|
(imap-noop imap)
|
|
(test #t imap-pending-updates? imap)
|
|
(test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
|
|
(test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))
|
|
(imap-noop imap)
|
|
(test #t imap-pending-updates? imap)
|
|
(test 1 length (imap-get-updates imap))
|
|
|
|
(test (void) imap-reset-new! imap2)
|
|
(add-one (bytes-append sample-head sample-body) 2)
|
|
(add-one (bytes-append sample-head sample-body) 3)
|
|
(add-one (bytes-append sample-head sample-body) 4)
|
|
(add-one (bytes-append sample-head sample-body) 5)
|
|
(imap-noop imap2)
|
|
(test #t imap-new? imap2)
|
|
(test 5 imap-messages imap)
|
|
(test 5 imap-messages imap2)
|
|
|
|
(test #t list? (imap-get-messages imap '(1 2 3 4 5) '(uid)))
|
|
(test #t list? (imap-get-messages imap2 '(1 2 3 4 5) '(uid)))
|
|
|
|
;; Test deleteing multiple messages, and shifts in flag updates
|
|
(test (void) imap-store imap2 '+ '(2 4) (list (symbol->imap-flag 'deleted)))
|
|
(test (void) imap-store imap2 '+ '(3 5) (list (symbol->imap-flag 'answered)))
|
|
(test (void) imap-expunge imap2)
|
|
(imap-noop imap)
|
|
(imap-noop imap2)
|
|
(test #t imap-pending-expunges? imap)
|
|
(test #t imap-pending-expunges? imap2)
|
|
(test '(2 4) imap-get-expunges imap)
|
|
(test '(2 4) imap-get-expunges imap2)
|
|
(test #t imap-pending-updates? imap)
|
|
(test '(2 3) map car (imap-get-updates imap))
|
|
|
|
(imap-disconnect imap2))
|
|
|
|
(imap-disconnect imap)
|
|
|
|
(report-errs)
|