From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp10.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms5.migadu.com with LMTPS id yL7uDNQR9GMFVQAAbAwnHQ (envelope-from ) for ; Tue, 21 Feb 2023 01:35:32 +0100 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp10.migadu.com with LMTPS id oDJEDNQR9GOlzAAAG6o9tA (envelope-from ) for ; Tue, 21 Feb 2023 01:35:32 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id CCDB73D80C for ; Tue, 21 Feb 2023 01:35:31 +0100 (CET) Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=systemreboot.net header.s=default header.b=Ww8J79yZ; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=systemreboot.net (policy=none) ARC-Seal: i=1; s=key1; d=yhetil.org; t=1676939731; a=rsa-sha256; cv=none; b=SH8A4Z+Ytac36/IpP3nGZ1ghbSfyI9Clq5MocOBrSfR3OtqGqrX9kX+cLqtWwSPxSOi4Y4 CUlTSH27dumt/IAZd/AVJh8Qtk1TzXrQiZtjoZxj40AGhtVpluen1xcDyiPx+/r+Uv/Vol UUcer7que2a/SvL1xU3iqlhpkszbcEyIEYMu+Wxbq7Wqj6XfJBLI2W+4Xk9K4lts9kKtw1 2TkmsZgBBbq/i+Qe9xRVcoloqpGiKP436NWrzHlXwQCyd6b+MKE1T7yBSlUyNOFawrGsOi 9+10uLrvcXBXqgp2QK3DQplULsKIoCH7GVkr3q6tCjVDaljmJXZOTTd4gqycFA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=systemreboot.net header.s=default header.b=Ww8J79yZ; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=systemreboot.net (policy=none) ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1676939731; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=Adyq9Dvy/1wccjId62/qluNhdCKUvEw3LL9tRKzE9b0=; b=YOhoDpGL9t+e/8rpOVEgFNgA52s5fXsDVB/6MmG6mbqQPlzCAv60W4gJA3ES28vCCoLbBA OyOLq9zkJg4i8aETjfR50adKVIHgTnndigtC+gYE72JFklrxriKtpSxnS2005btQRev4+8 BqEZWDEZh8y63FsGvO6DnJ+cZpPngjjQ2gaCE99JF9gWiyKJFegipMJJdDk7+RosVpucaq aMZXUHXXyNEfyEUp9VFIS5LHhjpH1W5+7tywpG9GOeNG/nzKe/10j0ER7Npk1zPVI170vJ ooM2g7olIRoAloJnPoR4QxFSHMME8ScBQJvU9TeBYYzpQi4Cwe8tKb/HkapUYg== Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pUGcb-0001zR-6Q; Mon, 20 Feb 2023 19:35:05 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pUGcZ-0001yh-6Q for guix-patches@gnu.org; Mon, 20 Feb 2023 19:35:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pUGcY-0005NQ-St for guix-patches@gnu.org; Mon, 20 Feb 2023 19:35:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1pUGcY-0002tI-If for guix-patches@gnu.org; Mon, 20 Feb 2023 19:35:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#61645] [PATCH v2 3/4] client: Support sending email to issues. References: <20230220013821.27440-1-arunisaac@systemreboot.net> In-Reply-To: <20230220013821.27440-1-arunisaac@systemreboot.net> Resent-From: Arun Isaac Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 21 Feb 2023 00:35:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 61645 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 61645@debbugs.gnu.org Cc: Ricardo Wurmus , Arun Isaac Received: via spool by 61645-submit@debbugs.gnu.org id=B61645.167693964311012 (code B ref 61645); Tue, 21 Feb 2023 00:35:02 +0000 Received: (at 61645) by debbugs.gnu.org; 21 Feb 2023 00:34:03 +0000 Received: from localhost ([127.0.0.1]:53941 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pUGba-0002rX-Oo for submit@debbugs.gnu.org; Mon, 20 Feb 2023 19:34:03 -0500 Received: from mugam.systemreboot.net ([139.59.75.54]:49220) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pUGbX-0002qg-Aw for 61645@debbugs.gnu.org; Mon, 20 Feb 2023 19:34:00 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=systemreboot.net; s=default; h=Content-Transfer-Encoding:Content-Type: MIME-Version:Message-Id:Date:Subject:Cc:To:From:Sender:Reply-To:Content-ID: Content-Description:Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc :Resent-Message-ID:In-Reply-To:References:List-Id:List-Help:List-Unsubscribe: List-Subscribe:List-Post:List-Owner:List-Archive; bh=Adyq9Dvy/1wccjId62/qluNhdCKUvEw3LL9tRKzE9b0=; b=Ww8J79yZldHDMHYwARM9pG4Fc4 bOedpKOPynkwvu4dUoAvqprRc9UVNx+Mj8cPOTP8F+M6fxKRdoU5C8xYAFM7eYxP3H+meoZhC5d1O bOBajN5xMzGxErIfcjLGGW5Ad20UjaQIqaLzsHKQ3rhmIM9dvlLQXMDjLFcZfJU+qMKR8EVSDpg0i Yp5vDlIQdmGwSlHCsK34FO+KDzh6yap3/kdlcAityz2TvNzFszN1AkVn138l/H5FH0A6hi4788sBP ONmHdwG3Dk+oYzFuMhhRS2yKiufUoJPFpAMjHF2TYuIfgDSBzf+yL5+Ea+F84WqXsbp6ZtCRPQgHF KA1dajew==; Received: from [192.168.2.1] (port=45752 helo=steel.lan) by systemreboot.net with esmtpsa (TLS1.3) tls TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 (Exim 4.96) (envelope-from ) id 1pUGbR-0009Uh-2Y; Tue, 21 Feb 2023 06:03:55 +0530 From: Arun Isaac Date: Tue, 21 Feb 2023 00:33:36 +0000 Message-Id: <20230221003336.5374-1-arunisaac@systemreboot.net> X-Mailer: git-send-email 2.38.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: X-Migadu-Queue-Id: CCDB73D80C X-Spam-Score: -0.35 X-Migadu-Spam-Score: -0.35 X-Migadu-Scanner: scn0.migadu.com List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-TUID: p1+fOxV6eQTC * 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 . (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 +;;; +;;; 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 +;;; . + +(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