@@ -58,6 +58,7 @@ SOURCES = \
TEST_EXTENSIONS = .scm
SCM_TESTS = \
+ tests/client.scm \
tests/debbugs.scm \
tests/xapian.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,97 @@
(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)
+ "Trial ~a/~a: Server has not yet received our email. Will retry in ~a seconds.~%"
+ (1+ i) retries retry-interval)
+ (sleep retry-interval))
+ (loop (1- retries)))))))
+
+(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 patch)
+ "Send email using git send-email and return the message ID of the sent
+email."
+ (let ((command (list "git" "send-email"
+ (string-append "--to=" to)
+ patch)))
+ (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."
+ (match patches
+ ((first-patch other-patches ...)
+ ;; If an issue is current, send patches to that issue's email
+ ;; address. 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.
+ (for-each (cute git-send-email
+ (string-append (number->string
+ (or (current-issue-number)
+ (issue-number-of-message
+ (git-send-email (client-config 'patch-email-address)
+ first-patch))))
+ "@"
+ (client-config 'debbugs-host))
+ <>)
+ (if (current-issue-number)
+ patches
+ other-patches)))))
@@ -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))
new file mode 100644
@@ -0,0 +1,93 @@
+;;; 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")
+ ("git" "send-email" "--to=12345@example.com" "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")
+ ("git" "send-email" "--to=12345@example.com" "bar.patch")
+ ("git" "send-email" "--to=12345@example.com" "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-end "client")