Allow download of raw message.

diff --git a/assets/css/screen.css b/assets/css/screen.css
index 841944cf7a3ab29aab18ff7352314beb15659e53..e8447d0be143b944d728f7d92393fcac14c07fc0 100644 (file)
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -296,6 +296,7 @@ details {
     margin-right: 0.2em;
 }
 
+.download-message,
 .download-part {
     float: right;
     font-size: 0.8em;
@@ -333,6 +334,10 @@ details {
     }
 }
 
+.message .from {
+    display: inline-block;
+}
+
 .message .from .address {
     font-weight: bold;
 }

diff --git a/mumi/debbugs.scm b/mumi/debbugs.scm
index 943930aaadd25b710507441ba42e09be55b15c11..75e55b460b31d31710b523d3e27432598a97ac57 100644 (file)
--- a/mumi/debbugs.scm
+++ b/mumi/debbugs.scm
@@ -52,11 +52,14 @@
             bug-tags))
 
 (define* (read-emails-from-bug-log port
-                                   #:optional (keep '(incoming-recv)))
+                                   #:key
+                                   (keep '(incoming-recv))
+                                   raw?)
   "Read the Debbugs bug log from PORT and return a list of parsed
-email objects.  According to the documentation of the Perl module
-Debbugs::Log there are four record types that are separated with
-single control characters on a line of their own.
+email objects.  Return the raw emails as a list when RAW? is #T.
+According to the documentation of the Perl module Debbugs::Log there
+are four record types that are separated with single control
+characters on a line of their own.
 
 * autocheck
 
@@ -101,30 +104,33 @@ ends with ^C.
             (#\etx
              (let ((mails*
                     (if (member type keep)
-                        ;; TODO: This is very ugly.  The first few
-                        ;; lines of the raw messages stored in Debbugs
-                        ;; logs seem to confuse the email parser, so we
-                        ;; try to strip them off.
-                        (let* ((content (string-join
-                                         (drop-while (lambda (line)
-                                                       (or (string-prefix? "From " line)
-                                                           (string-prefix? "Received" line)
-                                                           (string-prefix? "\t" line)
-                                                           (string-prefix? " " line)))
-                                                     (reverse lines)) "\n"))
-                               (mail (catch #t
-                                       (lambda ()
-                                         (parse-email content))
-                                       (lambda args
-                                         (format (current-error-port)
-                                                 "failed to process email~%")
-                                         #f))))
-                          (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
-                            (if (and id (not (hash-ref msgids id)))
-                                (begin
-                                  (hash-set! msgids id #t)
-                                  (cons mail mails))
-                                mails)))
+                        (if raw?
+                            (cons (string-join (reverse lines) "\n")
+                                  mails)
+                            ;; TODO: This is very ugly.  The first few
+                            ;; lines of the raw messages stored in Debbugs
+                            ;; logs seem to confuse the email parser, so we
+                            ;; try to strip them off.
+                            (let* ((content (string-join
+                                             (drop-while (lambda (line)
+                                                           (or (string-prefix? "From " line)
+                                                               (string-prefix? "Received" line)
+                                                               (string-prefix? "\t" line)
+                                                               (string-prefix? " " line)))
+                                                         (reverse lines)) "\n"))
+                                   (mail (catch #t
+                                           (lambda ()
+                                             (parse-email content))
+                                           (lambda args
+                                             (format (current-error-port)
+                                                     "failed to process email~%")
+                                             #f))))
+                              (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
+                                (if (and id (not (hash-ref msgids id)))
+                                    (begin
+                                      (hash-set! msgids id #t)
+                                      (cons mail mails))
+                                    mails))))
                         mails)))
                (loop msgids mails* '() 'init #f)))
             ;; Ctrl-E, beginning of email in recips

diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm
index 346f46947a733656b73ad1e4e99e15cb82662da9..9761b48d191c69ee7bcbfb5fcd9cbf44c5cf469f 100644 (file)
--- a/mumi/web/controller.scm
+++ b/mumi/web/controller.scm
@@ -166,6 +166,10 @@
      (handle-download (string->number id)
                       (string->number msg-num)
                       (map string->number path)))
+    (('GET "issue" (? string->number id)
+           "raw" (? string->number msg-num))
+     (download-raw (string->number id)
+                   (string->number msg-num)))
     (('GET "issue" not-an-id)
      (render-html (unknown not-an-id)))
     (('GET "help")

diff --git a/mumi/web/download.scm b/mumi/web/download.scm
index 91a8bc35eee7bba9abd5a7d9136e2b209b495ec6..03812a97e8e6d6742a4f140353ce1c867c1d5ef9 100644 (file)
--- a/mumi/web/download.scm
+++ b/mumi/web/download.scm
@@ -1,5 +1,5 @@
 ;;; mumi -- Mediocre, uh, mail interface
-;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This program is free software: you can redistribute it and/or
@@ -23,10 +23,12 @@
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (mumi debbugs)
   #:use-module (mumi messages)
   #:use-module (mumi web render)
   #:use-module (mumi web view html)
-  #:export (handle-download))
+  #:export (handle-download
+            download-raw))
 
 (define (handle-download id msg-num path)
   "Handle download of an attachment for bug ID, message number
@@ -54,3 +56,24 @@ PATH."
                 (html-response (email-headers entry) (email-body entry)))
                (_ #f)))
       (apply render-html (unknown id))))
+
+(define (download-raw id msg-num)
+  "Handle download of an attachment for bug ID, message number
+MSG-NUM, in the possibly nested message part identified by the list
+PATH."
+  (define (get-emails file)
+    (call-with-input-file file
+      (cut read-emails-from-bug-log <> #:raw? #t)))
+  (define emails
+    (let* ((candidate (lambda (archived?)
+                        (bug-id->log-file id #:archived? archived?)))
+           (file (find file-exists?
+                       (list (candidate #f)
+                             (candidate #t)))))
+      (and file (get-emails file))))
+  (if (and emails (> (length emails) msg-num))
+      (list `((content-type text)
+              (content-disposition text/plain
+                                   (filename . ,(format #f "~a-~a.mbox" id msg-num))))
+            (list-ref emails msg-num))
+      (apply render-html (unknown id))))

diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 3ce0a12771d1dece505c1f21e6025082ed26e38b..11fab7281264ab3b66c70748cf46d82996d4e240 100644 (file)
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -72,7 +72,7 @@
        (@ (rel "stylesheet")
           (media "screen")
           (type "text/css")
-          (href "/css/screen.css?202005120000"))))
+          (href "/css/screen.css?202005130000"))))
      (body ,@body
            (footer (@ (class "text-center"))
                    (p "Copyright © 2016—2020 by the GNU Guix community."
@@ -565,6 +565,10 @@ currently disabled."))
                                                       message-number)))
                            (title ,(date->string (date message))))
                         ,(time->string (date message)))))
+              (div (@ (class "download-message"))
+                   (a (@ (href ,(format #f "issue/~a/raw/~a"
+                                        id message-number)))
+                      ,download-icon))
               ,@(if (string-suffix? previous-subject (subject message))
                     '()
                     `((div (@ (class "subject")) ,(subject message))))

diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index 46dcf65c0b2e45835d4cebb76ecbd9f608eb7350..bda6cbe892c5c538c1cb419aff88786032a15da1 100644 (file)
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -34,6 +34,7 @@
   #:use-module (web uri)
   #:export (prettify
             avatar-color
+            download-icon
             display-message-body
             time->string))