diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | mumi/client.scm | 112 | ||||
| -rw-r--r-- | scripts/mumi.in | 5 | ||||
| -rw-r--r-- | tests/client.scm | 118 |
4 files changed, 235 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index a8c11a1..86ba4f0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -58,6 +58,7 @@ SOURCES = \ TEST_EXTENSIONS = .scm SCM_TESTS = \ + tests/client.scm \ tests/debbugs.scm \ tests/xapian.scm diff --git a/mumi/client.scm b/mumi/client.scm index ae3a0a9..b8d588b 100644 --- a/mumi/client.scm +++ b/mumi/client.scm @@ -17,18 +17,27 @@ ;;; along with mumi. If not, see <http://www.gnu.org/licenses/>. (define-module (mumi client) + #:use-module (rnrs io ports) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-43) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) #:use-module (term ansi-color) + #:use-module (web client) + #:use-module (web response) #:use-module (web uri) + #:use-module (email email) #:use-module (kolam http) #:use-module (mumi config) #:use-module (mumi web view utils) #:export (search print-current-issue set-current-issue! - clear-current-issue!)) + clear-current-issue! + send-email)) (define (git-top-level) "Return the top-level directory of the current git repository." @@ -152,3 +161,104 @@ (let ((issue-file (current-issue-file))) (when (file-exists? issue-file) (delete-file issue-file)))) + +(define* (issue-number-of-message message-id #:optional (retries 15)) + "Return issue number that MESSAGE-ID belongs to. Retry RETRIES number +of times with an interval of 60 seconds between retries." + ;; TODO: Re-implement this using our GraphQL endpoint once it + ;; supports retrieving the issue from a message ID. Later, + ;; re-implement this using a GraphQL subscription when kolam + ;; supports it. + (define (poll-issue-number-of-message message-id) + (let ((response _ (http-get (build-uri (client-config 'mumi-scheme) + #:host (client-config 'mumi-host) + #:path (string-append "/msgid/" message-id))))) + (and (>= (response-code response) 300) + (< (response-code response) 400) + (match (split-and-decode-uri-path + (uri-path (response-location response))) + (("issue" issue-number) + (string->number issue-number)))))) + + (let loop ((i retries)) + (if (zero? i) + (begin + (format (current-error-port) + "Mail not acknowledged by issue tracker. Giving up.~%") + (exit #f)) + (or (poll-issue-number-of-message message-id) + (begin + (let ((retry-interval 60)) + (format (current-error-port) + "Server has not yet received our email. Will retry in ~a seconds. ~a retries remaining.~%" + retry-interval (1- i)) + (sleep retry-interval)) + (loop (1- i))))))) + +(define (call-with-input-pipe command proc) + "Call PROC with input pipe to COMMAND. COMMAND is a list of program +arguments." + (match command + ((prog args ...) + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port (apply open-pipe* OPEN_READ prog args))) + (cut proc port) + (cut close-pipe port)))))) + +(define (git-send-email to patches) + "Send PATCHES using git send-email to the TO address and return the +message ID of the first email sent." + (let ((command (cons* "git" "send-email" + (string-append "--to=" to) + patches))) + (display (string-join command)) + (newline) + (call-with-input-pipe command + (lambda (port) + ;; FIXME: This messes up the order of stdout and stderr. + (let ((message-id + ;; Read till you get the Message ID. + (port-transduce (tlog (lambda (_ line) + (display line) + (newline))) + (rany (lambda (line) + (and (string-prefix-ci? "Message-ID:" line) + (assq-ref + (parse-email-headers + (string-append line "\n")) + 'message-id)))) + get-line + port))) + ;; Pass through the rest. + (display (get-string-all port)) + message-id))))) + +(define (send-email patches) + "Send PATCHES via email." + (if (current-issue-number) + ;; If an issue is current, send patches to that issue's email + ;; address. + (git-send-email (string-append (number->string (current-issue-number)) + "@" + (client-config 'debbugs-host)) + patches) + (match patches + ;; If it's a single patch, send it to the patch email address + ;; and be done with it + ((patch) + (git-send-email (client-config 'patch-email-address) + (list patch))) + ;; Else, send first patch to the patch email address and get an + ;; issue number. Then, send the remaining patches to that + ;; issue's email address. + ((first-patch other-patches ...) + (git-send-email + (string-append (number->string + (issue-number-of-message + (git-send-email (client-config 'patch-email-address) + (list first-patch)))) + "@" + (client-config 'debbugs-host)) + other-patches))))) diff --git a/scripts/mumi.in b/scripts/mumi.in index dfd082d..2295328 100644 --- a/scripts/mumi.in +++ b/scripts/mumi.in @@ -126,6 +126,9 @@ `mumi new': clear current issue presumably to open a new one. + `mumi send-email': + send patches to debbugs. + `mumi web [--address=address] [--port=port] [--listen-repl[=port]] [--disable-mailer]': start the application web server. @@ -158,6 +161,8 @@ (client:print-current-issue)) (("new") (client:clear-current-issue!)) + (("send-email" . patches) + (client:send-email patches)) (("mailer" . rest) (let* ((opts (parse-options rest)) (sender (assoc-ref opts 'sender)) diff --git a/tests/client.scm b/tests/client.scm new file mode 100644 index 0000000..fb03713 --- /dev/null +++ b/tests/client.scm @@ -0,0 +1,118 @@ +;;; mumi -- Mediocre, uh, mail interface +;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(use-modules (srfi srfi-26) + (srfi srfi-64) + (ice-9 match)) + +(define (with-variable variable value thunk) + "Set VARIABLE to VALUE, run THUNK and restore the old value of +VARIABLE. Return the value returned by THUNK." + (let ((old-value (variable-ref variable))) + (dynamic-wind + (cut variable-set! variable value) + thunk + (cut variable-set! variable old-value)))) + +(define (with-variables variable-bindings thunk) + "Set VARIABLE-BINDINGS, run THUNK and restore the old values of the +variables. Return the value returned by THUNK. VARIABLE-BINDINGS is a +list of pairs mapping variables to their values." + (match variable-bindings + (((variable . value) tail ...) + (with-variable variable value + (cut with-variables tail thunk))) + (() (thunk)))) + +(define-syntax-rule (var@@ module-name variable-name) + (module-variable (resolve-module 'module-name) + 'variable-name)) + +(define (trace-calls function-variable thunk) + "Run THUNK and return a list of argument lists FUNCTION-VARIABLE is +called with." + (let ((args-list (list))) + (with-variable function-variable (lambda args + (set! args-list + (cons args args-list))) + thunk) + (reverse args-list))) + +(define client-config-stub + (cons (var@@ (mumi client) client-config) + (lambda (key) + (case key + ((debbugs-host) "example.com") + ((patch-email-address) "foo@patches.com") + (else (error "Key unimplemented in stub" key)))))) + +(test-begin "client") + +(test-equal "send patches to new issue" + '(("git" "send-email" "--to=foo@patches.com" "foo.patch") + ("git" "send-email" "--to=12345@example.com" "bar.patch" "foobar.patch")) + (map (match-lambda + ((command _) command)) + (trace-calls (var@@ (mumi client) call-with-input-pipe) + (lambda () + (with-variables (list (cons (var@@ (mumi client) issue-number-of-message) + (const 12345)) + client-config-stub) + (cut (@@ (mumi client) send-email) + (list "foo.patch" "bar.patch" "foobar.patch"))))))) + +(test-equal "send patches to existing issue" + '(("git" "send-email" "--to=12345@example.com" "foo.patch" "bar.patch" "foobar.patch")) + (map (match-lambda + ((command _) command)) + (trace-calls (var@@ (mumi client) call-with-input-pipe) + (lambda () + (with-variables (list (cons (var@@ (mumi client) current-issue-number) + (const 12345)) + client-config-stub) + (cut (@@ (mumi client) send-email) + (list "foo.patch" "bar.patch" "foobar.patch"))))))) + +(test-equal "send single patch to new issue" + '(("git" "send-email" "--to=foo@patches.com" "foo.patch")) + (map (match-lambda + ((command _) command)) + (trace-calls (var@@ (mumi client) call-with-input-pipe) + (lambda () + (with-variables (list (cons (var@@ (mumi client) issue-number-of-message) + (lambda _ + (error "Do not poll server for issue number"))) + client-config-stub) + (cut (@@ (mumi client) send-email) + (list "foo.patch"))))))) + +(test-equal "send single patch to existing issue" + '(("git" "send-email" "--to=12345@example.com" "foo.patch")) + (map (match-lambda + ((command _) command)) + (trace-calls (var@@ (mumi client) call-with-input-pipe) + (lambda () + (with-variables (list (cons (var@@ (mumi client) current-issue-number) + (const 12345)) + (cons (var@@ (mumi client) issue-number-of-message) + (lambda _ + (error "Do not poll server for issue number"))) + client-config-stub) + (cut (@@ (mumi client) send-email) + (list "foo.patch"))))))) + +(test-end "client") |