;;; mumi -- Mediocre, uh, mail interface ;;; Copyright © 2023 Arun Isaac ;;; ;;; This file is part of mumi. ;;; ;;; mumi is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; mumi 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 ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with mumi. If not, see . (define-module (mumi client) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #: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! send-email)) (define (git-top-level) "Return the top-level directory of the current git repository." (let loop ((curdir (getcwd))) (cond ((file-exists? (string-append curdir "/.git")) curdir) ((string=? curdir "/") (error "No git top level found")) (else (loop (dirname curdir)))))) (define (client-config-directory) "Return client configuration directory." (string-append (git-top-level) "/.mumi")) (define (client-config key) "Return client configuration value corresponding to KEY." (or (assq-ref (call-with-input-file (string-append (client-config-directory) "/config") read) key) (case key ((mumi-scheme) 'https) (else (format (current-error-port) "Key '~a not configured for mumi client.~%" key))))) (define (graphql-endpoint) "Return GraphQL endpoint." (uri->string (build-uri (client-config 'mumi-scheme) #:host (client-config 'mumi-host) #:path "/graphql"))) (define (iso8601->date str) "Convert ISO-8601 date/time+zone string to date object." (string->date str "~Y-~m-~dT~H:~M:~S~z")) (define (list-issue issue) "List issue described by ISSUE association list." (display (colorize-string (string-append "#" (number->string (assoc-ref issue "number"))) 'YELLOW)) (display " ") (unless (assoc-ref issue "open") (display (colorize-string "✓" 'BOLD 'GREEN)) (display " ")) (display (colorize-string (assoc-ref issue "title") 'MAGENTA 'UNDERLINE)) (newline) (display (string-append "opened " (colorize-string (time->string (iso8601->date (assoc-ref issue "date"))) 'CYAN) " by " (colorize-string (let ((submitter (assoc-ref issue "submitter"))) (if (eq? (assoc-ref submitter "name") 'null) (assoc-ref submitter "address") (assoc-ref submitter "name"))) 'CYAN))) (newline)) (define (search query) "Search for issues with QUERY and list results." (vector-for-each (lambda (_ issue) (list-issue issue)) (assoc-ref (graphql-http-get (graphql-endpoint) `(document (query (#(issues #:search ,query) number title open date (submitter name address))))) "issues"))) (define (current-issue-file) "Return path to current issue number file." (string-append (client-config-directory) "/current-issue")) (define (current-issue-number) "Return current issue number." (let ((issue-file (current-issue-file))) (and (file-exists? issue-file) (call-with-input-file issue-file read)))) (define (print-current-issue) "Print current issue." (let ((issue-number (current-issue-number))) (if issue-number (list-issue (assoc-ref (graphql-http-get (graphql-endpoint) `(document (query (#(issue #:number ,issue-number) number title open date (submitter name address))))) "issue")) (begin (format (current-error-port) "No current issue!~%") (exit #f))))) (define (set-current-issue! issue-number) "Set current issue number." ;; TODO: Write file atomically. (call-with-output-file (current-issue-file) (cut write issue-number <>))) (define (clear-current-issue!) "Clear current issue." (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 #:optional (options '())) "Send PATCHES using git send-email to the TO address with OPTIONS. Return the message ID of the first email sent." (let ((command (cons* "git" "send-email" (string-append "--to=" to) (append options 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 (reply-email-headers issue-number) "Return an association list of email headers when replying to ISSUE-NUMBER." (let ((messages (assoc-ref (assoc-ref (graphql-http-get (graphql-endpoint) `(document (query (#(issue #:number ,issue-number) (messages (from name address) date))))) "issue") "messages"))) ;; When sending email to an issue, we Cc all issue participants. ;; TODO: Also add an In-Reply-To header. `((x-debbugs-cc . ,(delete-duplicates (map (lambda (message) (let ((from (assoc-ref message "from"))) (string-append (assoc-ref from "name") " <" (assoc-ref from "address") ">"))) (vector->list messages))))))) (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. (let ((issue-number (current-issue-number))) (git-send-email (string-append (number->string issue-number) "@" (client-config 'debbugs-host)) patches (map (cut string-append "--add-header=X-Debbugs-Cc: " <>) (assq-ref (reply-email-headers issue-number) 'x-debbugs-cc)))) (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)))))