Phase 2: add structured IMAP parser
ober
dc6e9f4951a86d7a81c29224de0bd66deb868c28
--- a/README.md +++ b/README.md @@ -12,11 +12,12 @@ first implementation path. ## Current Status -Phase 1 is in progress: +Phase 2 is in progress: - CLI entry point. - Environment config helper. - Bridge IMAP connectivity probe. +- Structured IMAP response parser. - Smoke tests. - Makefile. - Project plan. new file mode 100644 --- /dev/null +++ b/protonmail/imap/parser.ss @@ -0,0 +1,216 @@ +#!chezscheme +;;; (protonmail imap parser) - small structured parser for IMAP responses. + +(library (protonmail imap parser) + (export + imap-tokenize + imap-parse-line + imap-response? + imap-response-kind + imap-response-tag + imap-response-status + imap-response-name + imap-response-data + imap-response-raw + imap-response-literal-length + imap-literal-marker? + imap-literal-marker-length) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time)) + + (define lparen-token '(lparen)) + (define rparen-token '(rparen)) + + (define (lparen-token? x) (eq? x lparen-token)) + (define (rparen-token? x) (eq? x rparen-token)) + + (define (make-literal-marker n) + (vector 'literal-marker n)) + + (define (imap-literal-marker? x) + (and (vector? x) + (= (vector-length x) 2) + (eq? (vector-ref x 0) 'literal-marker))) + + (define (imap-literal-marker-length x) + (vector-ref x 1)) + + (define (digit? ch) + (and (char>=? ch #\0) (char<=? ch #\9))) + + (define (spaces? ch) + (or (char=? ch #\space) (char=? ch #\tab))) + + (define (atom-end? ch) + (or (spaces? ch) (char=? ch #\() (char=? ch #\)))) + + (define (numeric-string? s) + (and (> (string-length s) 0) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #t] + [(digit? (string-ref s i)) (loop (+ i 1))] + [else #f])))) + + (define (parse-quoted s start) + (let ([out (open-output-string)]) + (let loop ([i (+ start 1)]) + (cond + [(>= i (string-length s)) + (error 'imap-tokenize "unterminated quoted string")] + [(char=? (string-ref s i) #\\) + (when (>= (+ i 1) (string-length s)) + (error 'imap-tokenize "unterminated escape in quoted string")) + (write-char (string-ref s (+ i 1)) out) + (loop (+ i 2))] + [(char=? (string-ref s i) #\") + (values (get-output-string out) (+ i 1))] + [else + (write-char (string-ref s i) out) + (loop (+ i 1))])))) + + (define (parse-literal-marker s start) + (let loop ([i (+ start 1)] [digits '()]) + (cond + [(>= i (string-length s)) + (error 'imap-tokenize "unterminated literal marker")] + [(digit? (string-ref s i)) + (loop (+ i 1) (cons (string-ref s i) digits))] + [(char=? (string-ref s i) #\+) + (loop (+ i 1) digits)] + [(char=? (string-ref s i) #\}) + (let ([n (string->number (list->string (reverse digits)))]) + (unless n + (error 'imap-tokenize "invalid literal marker")) + (values (make-literal-marker n) (+ i 1)))] + [else + (error 'imap-tokenize "invalid literal marker")]))) + + (define (parse-atom s start) + (let loop ([i start]) + (if (or (= i (string-length s)) + (atom-end? (string-ref s i))) + (let ([atom (substring s start i)]) + (values (if (string-ci=? atom "NIL") #f atom) i)) + (loop (+ i 1))))) + + (define (imap-tokenize line) + (let loop ([i 0] [tokens '()]) + (cond + [(>= i (string-length line)) (reverse tokens)] + [(spaces? (string-ref line i)) (loop (+ i 1) tokens)] + [(char=? (string-ref line i) #\() + (loop (+ i 1) (cons lparen-token tokens))] + [(char=? (string-ref line i) #\)) + (loop (+ i 1) (cons rparen-token tokens))] + [(char=? (string-ref line i) #\") + (let-values ([(value next) (parse-quoted line i)]) + (loop next (cons value tokens)))] + [(char=? (string-ref line i) #\{) + (let-values ([(value next) (parse-literal-marker line i)]) + (loop next (cons value tokens)))] + [else + (let-values ([(value next) (parse-atom line i)]) + (loop next (cons value tokens)))]))) + + (define (parse-values tokens) + (let loop ([xs tokens] [acc '()]) + (cond + [(null? xs) (values (reverse acc) '())] + [(lparen-token? (car xs)) + (let-values ([(inner rest) (parse-list (cdr xs))]) + (loop rest (cons inner acc)))] + [(rparen-token? (car xs)) + (values (reverse acc) xs)] + [else + (loop (cdr xs) (cons (car xs) acc))]))) + + (define (parse-list tokens) + (let-values ([(items rest) (parse-values tokens)]) + (cond + [(null? rest) + (error 'imap-parse-line "unterminated parenthesized list")] + [(rparen-token? (car rest)) + (values items (cdr rest))] + [else + (error 'imap-parse-line "invalid parenthesized list")]))) + + (define (tokens->data tokens) + (let-values ([(items rest) (parse-values tokens)]) + (unless (null? rest) + (error 'imap-parse-line "unexpected right parenthesis")) + items)) + + (define (make-response kind tag status name data raw literal-length) + (vector 'imap-response kind tag status name data raw literal-length)) + + (define (imap-response? x) + (and (vector? x) + (= (vector-length x) 8) + (eq? (vector-ref x 0) 'imap-response))) + + (define (imap-response-kind r) (vector-ref r 1)) + (define (imap-response-tag r) (vector-ref r 2)) + (define (imap-response-status r) (vector-ref r 3)) + (define (imap-response-name r) (vector-ref r 4)) + (define (imap-response-data r) (vector-ref r 5)) + (define (imap-response-raw r) (vector-ref r 6)) + (define (imap-response-literal-length r) (vector-ref r 7)) + + (define (find-literal-length x) + (cond + [(imap-literal-marker? x) (imap-literal-marker-length x)] + [(pair? x) + (or (find-literal-length (car x)) + (find-literal-length (cdr x)))] + [else #f])) + + (define (imap-parse-line line) + (let ([tokens (imap-tokenize line)]) + (cond + [(null? tokens) + (make-response 'unknown #f #f #f '() line #f)] + [(and (string? (car tokens)) (string=? (car tokens) "+")) + (let ([data (tokens->data (cdr tokens))]) + (make-response 'continuation #f #f "+" data line + (find-literal-length data)))] + [(and (string? (car tokens)) (string=? (car tokens) "*")) + (parse-untagged line (cdr tokens))] + [else + (parse-tagged line tokens)]))) + + (define (parse-tagged raw tokens) + (let* ([tag (car tokens)] + [status (if (pair? (cdr tokens)) (cadr tokens) #f)] + [data (if (and (pair? tokens) (pair? (cdr tokens))) + (tokens->data (cddr tokens)) + '())]) + (make-response 'tagged tag status status data raw + (find-literal-length data)))) + + (define (parse-untagged raw tokens) + (cond + [(null? tokens) + (make-response 'untagged #f #f #f '() raw #f)] + [(and (string? (car tokens)) (numeric-string? (car tokens)) + (pair? (cdr tokens))) + (let* ([seq (string->number (car tokens))] + [name (cadr tokens)] + [data (cons seq (tokens->data (cddr tokens)))]) + (make-response 'untagged #f #f name data raw + (find-literal-length data)))] + [else + (let* ([name (car tokens)] + [data (tokens->data (cdr tokens))]) + (make-response 'untagged #f #f name data raw + (find-literal-length data)))])) + + ) ;; end library --- a/test/test-all.ss +++ b/test/test-all.ss @@ -29,6 +29,7 @@ (import (protonmail cli)) (import (protonmail config)) (import (protonmail imap client)) +(import (protonmail imap parser)) (define failures 0) @@ -97,6 +98,51 @@ (check "imap final OK rejects tagged failure" (not (imap-final-ok? '("A1 NO bad credentials")))) +(let ([r (imap-parse-line "* LIST (\\HasNoChildren) \"/\" \"INBOX\"")]) + (check "parser recognizes untagged LIST" + (and (eq? 'untagged (imap-response-kind r)) + (string=? "LIST" (imap-response-name r)))) + (check "parser decodes LIST data" + (equal? '(("\\HasNoChildren") "/" "INBOX") + (imap-response-data r)))) + +(let ([r (imap-parse-line "* SEARCH 1 2 3")]) + (check "parser recognizes SEARCH data" + (equal? '("1" "2" "3") (imap-response-data r)))) + +(let ([r (imap-parse-line "A1 OK completed")]) + (check "parser recognizes tagged OK" + (and (eq? 'tagged (imap-response-kind r)) + (string=? "A1" (imap-response-tag r)) + (string=? "OK" (imap-response-status r))))) + +(let ([r (imap-parse-line "A2 NO bad credentials")]) + (check "parser recognizes tagged NO" + (and (eq? 'tagged (imap-response-kind r)) + (string=? "NO" (imap-response-status r))))) + +(let ([r (imap-parse-line "A3 BAD syntax error")]) + (check "parser recognizes tagged BAD" + (and (eq? 'tagged (imap-response-kind r)) + (string=? "BAD" (imap-response-status r))))) + +(let ([r (imap-parse-line "* LIST (\\Noselect) \"/\" NIL")]) + (check "parser converts NIL atom" + (equal? '(("\\Noselect") "/" #f) (imap-response-data r)))) + +(let ([r (imap-parse-line "* 1 FETCH (FLAGS (\\Seen) UID 23)")]) + (check "parser handles nested FETCH list" + (equal? '(1 ("FLAGS" ("\\Seen") "UID" "23")) + (imap-response-data r)))) + +(let ([r (imap-parse-line "* 1 FETCH (UID 123 BODY[] {12})")]) + (check "parser detects FETCH literal length" + (= 12 (imap-response-literal-length r)))) + +(let ([r (imap-parse-line "* LIST () \"/\" \"a\\\\b\\\"c\"")]) + (check "parser decodes escaped quoted strings" + (equal? '(() "/" "a\\b\"c") (imap-response-data r)))) + (if (= failures 0) (begin (fprintf (current-error-port) "~%All tests passed.~%")