Support downloading of attachments.
[software/mumi.git] / mumi / web / view / utils.scm
index f0d58c07a1c21160f9cf93eb21d6ba5a37166635..ce2827ed5dd1230b04651e614a9c9f44b10a2912 100644 (file)
@@ -18,6 +18,7 @@
 (define-module (mumi web view utils)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (debbugs email)
   #:use-module (mumi messages)
               (string-take value (or (string-index value #\;)
                                      (string-length value)))))
 
-(define (display-multipart-chunk headers body)
-  (let ((classes
-         (string-join `("multipart"
-                        ,(or (and=> (assoc-ref headers "content-type")
-                                    (lambda (value)
-                                      (content-type->css-class (first value))))
-                             "")))))
-    `(div (@ (class ,classes))
-          ,(prettify body))))
-
-(define (display-message-body message)
-  "Convenience procedure to render MESSAGE, even when it is a
-multipart message."
+(define (display-message-body bug-num message)
+  "Convenience procedure to render MESSAGE (part of bug with number
+BUG-NUM), even when it is a multipart message."
+  (define (display-multipart-chunk headers body . path)
+    (let* ((type
+            (and=> (assoc-ref headers "content-type")
+                   (lambda (value)
+                     (content-type->css-class (first value)))))
+           (binary-attachment?
+            (and (and=> (assoc-ref headers "content-disposition")
+                        (lambda (value)
+                          (string-contains (first value) "attachment")))
+                 type
+                 (string-contains type "application")
+                 (first (assoc-ref headers "content-disposition"))))
+           (attachment-name
+            (or (and=> binary-attachment?
+                       (lambda (value)
+                         (and=> (string-match "filename=([^ ;]+)" value)
+                                (lambda (m)
+                                  (match:substring m 1)))))
+                "file")))
+      (if binary-attachment?
+          `(div (@ (class "attachment"))
+                "Attachment: "
+                (a (@ (href ,(string-append "/issue/"
+                                            (number->string bug-num)
+                                            "/attachment/"
+                                            (number->string (email-msg-num message))
+                                            "/" (string-join (map number->string path) "/"))))
+                   ,attachment-name))
+          `(div (@ (class ,(string-join `("multipart" ,(or type "")))))
+                ,(prettify body)))))
   (cond
    ((multipart-message? message)
     => (lambda (attributes)
@@ -117,18 +138,22 @@ multipart message."
                  "[Failed to process the following multipart message.  Sorry!]")
              (prettify (email-body message))))
            (parts
-            (map (match-lambda
-                   (() "")
-                   ((#:headers hs #:body '()) "")
-                   ((#:headers hs #:body (? string? body))
-                    (display-multipart-chunk hs body))
-                   ;; Message parts can be nested.
-                   ((#:headers hs #:body sub-parts)
-                    (map (match-lambda
-                           ((#:headers hs #:body body)
-                            (display-multipart-chunk hs body)))
-                         sub-parts)))
-                 parts)))))
+            (map (lambda (part part-num)
+                   (match part
+                     (() "")
+                     ((#:headers hs #:body '()) "")
+                     ((#:headers hs #:body (? string? body))
+                      (display-multipart-chunk hs body part-num))
+                     ;; Message parts can be nested.
+                     ((#:headers hs #:body sub-parts)
+                      (map (lambda (part sub-part-num)
+                             (match part
+                               ((#:headers hs #:body body)
+                                (display-multipart-chunk hs body part-num sub-part-num))))
+                           sub-parts
+                           (iota (length parts))))))
+                 parts
+                 (iota (length parts)))))))
    ;; Regular message with a simple body.
    (else
     (prettify (email-body message)))))