07eb3be4b6
Quote marks (at a minimum) should be triggered by any of the characters in `atom-specials` from the IMAP RFC. The previous trigger would not have worked for a password that includes parentheses, curly braces, or an open quare bracket, for example.
226 lines
7.9 KiB
Racket
226 lines
7.9 KiB
Racket
#lang racket/base
|
|
(require openssl/mzssl
|
|
net/imap
|
|
mzlib/etc)
|
|
|
|
(define (test expect f . args)
|
|
(define got (if (procedure? f)
|
|
(apply f args)
|
|
(car args)))
|
|
(unless (equal? expect got)
|
|
(error 'test "failed: ~s vs. ~s" expect got)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (try-connect username password expected-login)
|
|
|
|
(define-values (ci so) (make-pipe))
|
|
(define-values (si co) (make-pipe))
|
|
|
|
(define got-login #f)
|
|
|
|
(define t
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(define l (read-line si))
|
|
(define m (regexp-match #rx"^([a-z0-9]*) ([A-Z]+)(.*)\r$" l))
|
|
(unless m (log-error "?? ~s" l))
|
|
(define (reply s)
|
|
(fprintf so "~a ~a\r\n" (cadr m) s)
|
|
(flush-output so))
|
|
(case (caddr m)
|
|
[("NOOP") (reply "OK NOOP completed")]
|
|
[("CAPABILITY") (reply "OK CAPABILITY completed")]
|
|
[("LOGIN")
|
|
(set! got-login (cadddr m))
|
|
(reply "OK LOGIN completed")]
|
|
[("SELECT")
|
|
(reply "OK SELECT completed")]
|
|
[else
|
|
(log-error "?? ~s" l)])
|
|
(loop)))))
|
|
|
|
(imap-connect* ci co username password "INBOX")
|
|
|
|
(test expected-login 'login got-login))
|
|
|
|
|
|
(try-connect "user" "password" " user password")
|
|
(for ([special-char (in-string "](){}\\%")])
|
|
(try-connect "user"
|
|
(format "pass~aword" special-char)
|
|
(format " user \"pass~aword\"" special-char)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define imap-config-file
|
|
(build-path (find-system-path 'home-dir) ".imap-test-config"))
|
|
|
|
(when (file-exists? imap-config-file)
|
|
(define config (with-input-from-file imap-config-file
|
|
read))
|
|
|
|
(define imap-server (hash-ref config 'imap-server))
|
|
(define imap-port-no (hash-ref config 'imap-port-no))
|
|
(define username (hash-ref config 'username))
|
|
(define pw (hash-ref config 'pw))
|
|
(define mailbox-name (hash-ref config 'mailbox-name "INBOX.tmp")) ;; !!! ALL CONTENT WILL BE DELETED !!!
|
|
|
|
(define (test-connect)
|
|
(if (zero? (random 2))
|
|
(parameterize ([imap-port-number 993])
|
|
(imap-connect #:tls? #t imap-server username pw mailbox-name))
|
|
(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)
|
|
|
|
(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| |\Recent|)))
|
|
imap-get-messages imap '(1) '(uid header body flags)))
|
|
(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Answered| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted)))
|
|
(test (list '((|\Deleted| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
|
|
(test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered)))
|
|
(test (list '((|\Answered| |\Recent|))) 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)
|
|
(test 'exn values (with-handlers ([exn:fail:contract? (lambda (x) 'exn)])
|
|
(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)
|
|
|
|
(printf "tests passed\n"))
|
|
|
|
|
|
|
|
|