net/imap: detect full set of special characters for encoding
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.
This commit is contained in:
parent
c7e8166725
commit
07eb3be4b6
|
@ -217,8 +217,11 @@
|
||||||
[(box? cmd) (fprintf w "~a" (unbox cmd))]
|
[(box? cmd) (fprintf w "~a" (unbox cmd))]
|
||||||
[(string? cmd) (loop (string->bytes/utf-8 cmd))]
|
[(string? cmd) (loop (string->bytes/utf-8 cmd))]
|
||||||
[(bytes? cmd)
|
[(bytes? cmd)
|
||||||
(if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
|
(if (or
|
||||||
(equal? cmd #""))
|
;; Check for anything in `atom-specials` from the IMAP RFC:
|
||||||
|
(regexp-match #px#"[] *%\"\r\n(){}\\\\[:cntrl:]]" cmd)
|
||||||
|
;; The empty string is also a special case:
|
||||||
|
(equal? cmd #""))
|
||||||
(if (regexp-match #rx#"[\"\r\n]" cmd)
|
(if (regexp-match #rx#"[\"\r\n]" cmd)
|
||||||
(begin
|
(begin
|
||||||
;; Have to send size, then continue if the
|
;; Have to send size, then continue if the
|
||||||
|
|
|
@ -10,6 +10,49 @@
|
||||||
(unless (equal? expect got)
|
(unless (equal? expect got)
|
||||||
(error 'test "failed: ~s vs. ~s" 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
|
(define imap-config-file
|
||||||
(build-path (find-system-path 'home-dir) ".imap-test-config"))
|
(build-path (find-system-path 'home-dir) ".imap-test-config"))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user