[bug#61645] [PATCH v2 3/4] client: Support sending email to issues.

[Arun Isaac <arunisaac@systemreboot.net>]

* mumi/client.scm: Import (rnrs io ports), (srfi srfi-71), (srfi
srfi-171), (ice-9 match), (ice-9 popen), (web client), (web response)
and (email email).
(issue-number-of-message, call-with-input-pipe, git-send-email): New
functions.
(send-email): New public function.
* scripts/mumi.in (show-mumi-usage): Document send-email subcommand.
(main): Add send-email subcommand.
* tests/client.scm: New file.
* Makefile.am (SCM_TESTS): Add tests/client.scm.
---
 Makefile.am      |   1 +
 mumi/client.scm  | 105 ++++++++++++++++++++++++++++++++++++++++++++++-
 scripts/mumi.in  |   5 +++
 tests/client.scm |  93 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 203 insertions(+), 1 deletion(-)
 create mode 100644 tests/client.scm

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..09f83ee 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,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)))))
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..2948aed
--- /dev/null
+++ b/tests/client.scm
@@ -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")
-- 
2.38.1