Phase 1: add Bridge IMAP connectivity probe
ober
2c1544b4ff3538f044f20391e2030818524c5a31
--- a/Makefile +++ b/Makefile @@ -1,5 +1,7 @@ JERBOA_HOME ?= $(realpath $(CURDIR)/../jerboa) SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +JERBOA_SSL_DIR ?= $(realpath $(CURDIR)/../jerboa-ssl) +LIBDIRS := $(CURDIR):$(JERBOA_SSL_DIR)/lib:$(JERBOA_HOME)/lib .PHONY: help run test doctor clean .DEFAULT_GOAL := help @@ -17,18 +19,19 @@ help: @echo "Environment:" @echo " JERBOA_HOME = $(JERBOA_HOME)" @echo " SCHEME = $(SCHEME)" + @echo " JERBOA_SSL_DIR = $(JERBOA_SSL_DIR)" run: - JERBOA_HOME=$(JERBOA_HOME) \ - $(SCHEME) -q --libdirs $(CURDIR):$(JERBOA_HOME)/lib \ + JERBOA_HOME=$(JERBOA_HOME) JERBOA_SSL_LIB=$(JERBOA_SSL_DIR) \ + $(SCHEME) -q --libdirs $(LIBDIRS) \ --script main.ss -- $(ARGS) doctor: $(MAKE) run ARGS='doctor' test: - JERBOA_HOME=$(JERBOA_HOME) \ - $(SCHEME) -q --libdirs $(CURDIR):$(JERBOA_HOME)/lib \ + JERBOA_HOME=$(JERBOA_HOME) JERBOA_SSL_LIB=$(JERBOA_SSL_DIR) \ + $(SCHEME) -q --libdirs $(LIBDIRS) \ --script test/test-all.ss clean: --- a/README.md +++ b/README.md @@ -12,15 +12,16 @@ first implementation path. ## Current Status -Phase 0 is a project scaffold: +Phase 1 is in progress: - CLI entry point. - Environment config helper. +- Bridge IMAP connectivity probe. - Smoke tests. - Makefile. - Project plan. -No live Proton or Bridge connection is attempted yet. +Live Proton Bridge checks are attempted only when Bridge credentials are set. ## Development @@ -28,6 +29,7 @@ No live Proton or Bridge connection is attempted yet. make run ARGS='--help' make doctor make test +bin/protonmail-read doctor ``` By default the Makefile expects Jerboa at `../jerboa`. Override with: @@ -36,6 +38,12 @@ By default the Makefile expects Jerboa at `../jerboa`. Override with: make JERBOA_HOME=/path/to/jerboa test ``` +The Bridge transport uses `../jerboa-ssl` by default. Override with: + +```sh +make JERBOA_SSL_DIR=/path/to/jerboa-ssl test +``` + ## Bridge Configuration Later phases will read Bridge IMAP settings from environment variables: --- a/bin/protonmail-read +++ b/bin/protonmail-read @@ -3,7 +3,10 @@ set -eu repo_dir=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) jerboa_home=${JERBOA_HOME:-"$repo_dir/../jerboa"} +jerboa_ssl_dir=${JERBOA_SSL_DIR:-"$repo_dir/../jerboa-ssl"} scheme=${SCHEME:-"$jerboa_home/.chez/bin/scheme"} -exec "$scheme" -q --libdirs "$repo_dir:$jerboa_home/lib" \ +export JERBOA_SSL_LIB=${JERBOA_SSL_LIB:-"$jerboa_ssl_dir"} + +exec "$scheme" -q --libdirs "$repo_dir:$jerboa_ssl_dir/lib:$jerboa_home/lib" \ --script "$repo_dir/main.ss" -- "$@" --- a/protonmail/cli.ss +++ b/protonmail/cli.ss @@ -13,7 +13,8 @@ iota 1+ 1- partition make-date make-time) - (protonmail config)) + (protonmail config) + (protonmail imap client)) (define version "0.0.0-phase0") @@ -50,17 +51,37 @@ (define (cmd-doctor) (let ([cfg (config-from-environment)]) (println "protonmail-read doctor") - (println "phase: 0") - (println "status: CLI and config loader are installed") + (println "phase: 1") + (println "status: CLI, config loader, and IMAP probe are installed") (println (string-append "bridge host: " (config-host cfg))) (println (string-append "bridge port: " (number->string (config-port cfg)))) (println (string-append "bridge tls: " (config-tls cfg))) (println (string-append "bridge user: " (redact-secret (config-user cfg)))) (println (string-append "bridge password: " (redact-secret (config-password cfg)))) (if (config-complete? cfg) - (println "config: complete") - (println "config: incomplete")) - (println "network: not checked until phase 1"))) + (begin + (println "config: complete") + (let ([result (guard (e [#t e]) + (imap-probe cfg))]) + (if (condition? result) + (begin + (println "network: failed") + (println (string-append "error: " (condition-message result))) + (exit 1)) + (begin + (println "network: ok") + (println (string-append "imap mode: " (assoc-value 'mode result ""))) + (println (string-append "greeting: " (assoc-value 'greeting result ""))) + (println (string-append "mailboxes: " + (number->string + (assoc-value 'mailbox-count result 0)))))))) + (begin + (println "config: incomplete") + (println "network: skipped"))))) + + (define (assoc-value key alist default) + (let ([item (assq key alist)]) + (if item (cdr item) default))) (define (strip-script-separator args) (if (and (pair? args) (string=? (car args) "--")) new file mode 100644 --- /dev/null +++ b/protonmail/imap/client.ss @@ -0,0 +1,147 @@ +#!chezscheme +;;; (protonmail imap client) - minimal read-only IMAP probe. + +(library (protonmail imap client) + (export + imap-probe + imap-quote + imap-final-ok?) + + (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) + (protonmail config) + (protonmail imap transport)) + + (define (make-client tr greeting) + (vector tr greeting 0)) + + (define (client-transport c) (vector-ref c 0)) + (define (client-greeting c) (vector-ref c 1)) + + (define (string-prefix? prefix s) + (let ([plen (string-length prefix)] + [slen (string-length s)]) + (and (<= plen slen) + (string=? prefix (substring s 0 plen))))) + + (define (last xs) + (cond + [(null? xs) #f] + [(null? (cdr xs)) (car xs)] + [else (last (cdr xs))])) + + (define (next-tag c) + (let ([n (+ 1 (vector-ref c 2))]) + (vector-set! c 2 n) + (string-append "A" (number->string n)))) + + (define (imap-quote s) + (let ([out (open-output-string)]) + (write-char #\" out) + (let loop ([i 0]) + (when (< i (string-length s)) + (let ([ch (string-ref s i)]) + (when (or (char=? ch #\\) (char=? ch #\")) + (write-char #\\ out)) + (write-char ch out) + (loop (+ i 1))))) + (write-char #\" out) + (get-output-string out))) + + (define (imap-command c command) + (let* ([tag (next-tag c)] + [wire (string-append tag " " command)]) + (transport-write-line (client-transport c) wire) + (let loop ([lines '()]) + (let ([line (transport-read-line (client-transport c))]) + (let ([new-lines (cons line lines)]) + (if (string-prefix? tag line) + (reverse new-lines) + (loop new-lines))))))) + + (define (imap-final-ok? lines) + (let ([line (last lines)]) + (and line + (let loop ([i 0]) + (cond + [(> (+ i 3) (string-length line)) #f] + [(string=? " OK" (substring line i (+ i 3))) #t] + [else (loop (+ i 1))]))))) + + (define (require-ok who lines) + (unless (imap-final-ok? lines) + (error who (if (null? lines) "no IMAP response" (last lines)))) + lines) + + (define (normalize-tls-mode mode) + (cond + [(or (string=? mode "tls") (string=? mode "ssl") + (string=? mode "true") (string=? mode "yes")) + "tls"] + [(or (string=? mode "plain") (string=? mode "false") + (string=? mode "no") (string=? mode "off")) + "plain"] + [else "auto"])) + + (define (open-mode cfg mode) + (let ([tr (transport-connect (config-host cfg) (config-port cfg) mode)]) + (let ([greeting (guard (e [#t (transport-close tr) (raise e)]) + (transport-read-line tr))]) + (make-client tr greeting)))) + + (define (open-client cfg) + (let ([mode (normalize-tls-mode (config-tls cfg))]) + (cond + [(string=? mode "auto") + (let ([plain-result (guard (e [#t e]) + (open-mode cfg "plain"))]) + (if (condition? plain-result) + (open-mode cfg "tls") + plain-result))] + [else + (open-mode cfg mode)]))) + + (define (count-list-lines lines) + (let loop ([xs lines] [n 0]) + (cond + [(null? xs) n] + [(string-prefix? "* LIST " (car xs)) + (loop (cdr xs) (+ n 1))] + [else (loop (cdr xs) n)]))) + + (define (imap-probe cfg) + (let ([client #f]) + (guard (e [#t + (when client + (guard (close-error [#t #f]) + (transport-close (client-transport client)))) + (raise e)]) + (set! client (open-client cfg)) + (require-ok 'imap-capability + (imap-command client "CAPABILITY")) + (require-ok 'imap-login + (imap-command client + (string-append + "LOGIN " + (imap-quote (config-user cfg)) + " " + (imap-quote (config-password cfg))))) + (let ([list-lines (require-ok 'imap-list + (imap-command client "LIST \"\" \"*\""))]) + (require-ok 'imap-logout + (imap-command client "LOGOUT")) + (let ([result (list + (cons 'mode (transport-mode (client-transport client))) + (cons 'greeting (client-greeting client)) + (cons 'mailbox-count (count-list-lines list-lines)))]) + (transport-close (client-transport client)) + result))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/protonmail/imap/transport.ss @@ -0,0 +1,79 @@ +#!chezscheme +;;; (protonmail imap transport) - small line-oriented TCP/TLS transport. + +(library (protonmail imap transport) + (export + transport-connect + transport-mode + transport-read-line + transport-write-line + transport-close) + + (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) + (jerboa-ssl)) + + (define (make-transport kind handle) + (vector kind handle)) + + (define (transport-mode tr) + (if (eq? (vector-ref tr 0) 'tls) "tls" "plain")) + + (define (transport-connect host port mode) + (cond + [(string=? mode "tls") + (ssl-init!) + (make-transport 'tls (ssl-connect host port))] + [else + (let ([fd (tcp-connect host port)]) + (tcp-set-timeout fd 10 10) + (make-transport 'plain fd))])) + + (define (transport-close tr) + (cond + [(eq? (vector-ref tr 0) 'tls) + (ssl-close (vector-ref tr 1))] + [else + (tcp-close (vector-ref tr 1))])) + + (define (transport-write-line tr line) + (let ([wire (string-append line "\r\n")]) + (cond + [(eq? (vector-ref tr 0) 'tls) + (ssl-write-string (vector-ref tr 1) wire)] + [else + (tcp-write-string (vector-ref tr 1) wire)]))) + + (define (transport-read-byte tr) + (let ([buf (make-bytevector 1 0)]) + (let ([n (cond + [(eq? (vector-ref tr 0) 'tls) + (ssl-read (vector-ref tr 1) buf 1)] + [else + (tcp-read (vector-ref tr 1) buf 1)])]) + (cond + [(= n 1) (bytevector-u8-ref buf 0)] + [(= n 0) (error 'transport-read-line "connection closed")] + [else (error 'transport-read-line "read failed")])))) + + (define (transport-read-line tr) + (let ([out (open-output-string)]) + (let loop () + (let ([b (transport-read-byte tr)]) + (cond + [(= b 10) + (get-output-string out)] + [(= b 13) + (loop)] + [else + (write-char (integer->char b) out) + (loop)]))))) + + ) ;; end library --- a/test/test-all.ss +++ b/test/test-all.ss @@ -28,6 +28,7 @@ (import (protonmail cli)) (import (protonmail config)) +(import (protonmail imap client)) (define failures 0) @@ -84,6 +85,18 @@ (check "redaction preserves only ends of longer secret" (string=? "ab...yz" (redact-secret "abcdefghijklmnopqrstuvwxyz"))) +(check "imap quote wraps atom" + (string=? "\"INBOX\"" (imap-quote "INBOX"))) + +(check "imap quote escapes special characters" + (string=? "\"a\\\\b\\\"c\"" (imap-quote "a\\b\"c"))) + +(check "imap final OK detects tagged success" + (imap-final-ok? '("* CAPABILITY IMAP4rev1" "A1 OK done"))) + +(check "imap final OK rejects tagged failure" + (not (imap-final-ok? '("A1 NO bad credentials")))) + (if (= failures 0) (begin (fprintf (current-error-port) "~%All tests passed.~%")