mumi/web/view/utils.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
   4 ;;;
   5 ;;; This program is free software: you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Affero General Public License
   7 ;;; as published by the Free Software Foundation, either version 3 of
   8 ;;; the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Affero General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Affero General Public
  16 ;;; License along with this program.  If not, see
  17 ;;; <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mumi web view utils)
  20   #:use-module (ice-9 rdelim)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 regex)
  23   #:use-module (ice-9 receive)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (syntax-highlight)
  27   #:use-module (syntax-highlight scheme)
  28   #:use-module (email email)
  29   #:use-module (mumi messages)
  30   #:export (prettify
  31             avatar-color
  32             display-message-body))
  33
  34 ;; TODO: at some point this should tokenize the text, then apply
  35 ;; styles, then output sxml, but for now we keep it simple
  36 (define (process line context)
  37   (cond
  38    ((string-prefix? "--8<---------------cut here" line)
  39     (values `(span (@ (class "line cut-here")) ,line) #f))
  40    ((and (member 'diff context)
  41          (string= "---" line))
  42     (values `(span (@ (class "line diff separator")) ,line) #f))
  43    ((string-prefix? "diff --git" line)
  44     (values `(span (@ (class "line diff file")) ,line) 'diff))
  45    ((and (member 'diff context)
  46          (string-prefix? "+" line))
  47     (values `(span (@ (class "line diff addition")) ,line) #f))
  48    ((and (member 'diff context)
  49          (string-prefix? "-" line)
  50          (not (string= "--" line))
  51          (not (string= "-- " line)))
  52     (values `(span (@ (class "line diff deletion")) ,line) #f))
  53    ((and (member 'diff context)
  54          (string-prefix? "@@" line))
  55     (values `(span (@ (class "line diff range")) ,line) #f))
  56    ((string-prefix? ">" line)
  57     (values `(span (@ (class "line quote")) ,line) #f))
  58    ((or (string-prefix? "Signed-off-by" line)
  59         (string-prefix? "Co-authored-by" line))
  60     (values `(span (@ (class "commit attribution")) ,line) #f))
  61    ((or (string-prefix? "From: " line)
  62         (string-prefix? "Date: " line)
  63         (string-prefix? "Subject: " line))
  64     (values `(span (@ (class "commit header")) ,line) 'commit))
  65    ((and (member 'commit context)
  66          (or (string-prefix? "* " line)
  67              (string-prefix? " * " line)))
  68     (values `(span (@ (class "commit changelog")) ,line) #f))
  69    (else
  70     (values `(span (@ (class "line")) ,line) #f))))
  71
  72 (define (prettify text)
  73   "Read each line of TEXT and apply PROCESS to it."
  74   (let ((res (fold (lambda (line acc)
  75                      (match acc
  76                        ((#:result res #:context context)
  77                         (receive (processed new-context)
  78                             (process line context)
  79                           `(#:result ,(append (list processed '(br)) res)
  80                             #:context ,(if new-context
  81                                            (cons new-context context)
  82                                            context))))))
  83                    '(#:result () #:context ())
  84                    (string-split text #\newline))))
  85     ;; Drop the first line break, because it's for an eof
  86     ;; read.
  87     (match (reverse (cadr (find-tail (cut eq? #:result <>) res)))
  88       ((_ . rest) rest)
  89       (() '()))))
  90
  91 (define colors
  92   (circular-list "#8dd3c7" "#bebada" "#fb8072"
  93                  "#80b1d3" "#fdb462" "#b3de69"
  94                  "#fccde5" "#d9d9d9" "#bc80bd"
  95                  "#ccebc5" "#ffed6f"))
  96
  97 (define (avatar-color who participants)
  98   (or (and=> (assoc-ref (zip participants colors) who)
  99              first)
 100       (first colors)))
 101
 102 (define (content-type->css-class value)
 103   "Convert a content-type header value to a CSS class name."
 104   (string-append (symbol->string (assoc-ref value 'type))
 105                  "-"
 106                  (symbol->string (assoc-ref value 'subtype))))
 107
 108 (define (display-message-body bug-num message-number message)
 109   "Convenience procedure to render MESSAGE (part of bug with number
 110 BUG-NUM), even when it is a multipart message."
 111   (define (display-multipart-chunk headers body path)
 112     (define (attachment-url)
 113       (string-append "/issue/"
 114                      (number->string bug-num)
 115                      "/attachment/"
 116                      (number->string message-number)
 117                      "/" (string-join (map number->string path) "/")))
 118     (let* ((content-type (assoc-ref headers 'content-type))
 119            (attachment?
 120             (and (and=> (assoc-ref headers 'content-disposition)
 121                         (cut assoc-ref <> 'type))
 122                  content-type
 123                  (assoc-ref content-type 'type)))
 124            (binary-attachment? (and attachment?
 125                                     (eq? (assoc-ref content-type 'type) 'application)))
 126            (attachment-name
 127             (or (and=> (assoc-ref headers 'content-disposition)
 128                        (cut assoc-ref <> 'filename))
 129                 "file")))
 130       (cond
 131        (binary-attachment?
 132         `(div (@ (class "attachment"))
 133               "Attachment: "
 134               (a (@ (href ,(attachment-url))) ,attachment-name)))
 135        ((string-suffix? ".scm" attachment-name)
 136         `(div (@ (class "multipart scheme"))
 137               (div (@ (class "download-part"))
 138                    (a (@ (href ,(attachment-url)))
 139                       "Download"))
 140               ,(highlights->sxml (highlight lex-scheme body))))
 141        (else
 142         `(div (@ (class ,(string-join
 143                           (list "multipart" (or (and content-type
 144                                                      (content-type->css-class content-type))
 145                                                 "")))))
 146               (div (@ (class "download-part"))
 147                    (a (@ (href ,(attachment-url)))
 148                       "Download"))
 149               ,(prettify body))))))
 150   (define (display-mime-entity entity . path)
 151     (match entity
 152       (($ <mime-entity> headers (? string? body))
 153        (apply display-multipart-chunk `(,headers ,body ,path)))
 154       ;; Message parts can be nested.
 155       (($ <mime-entity> headers sub-parts)
 156        (map (lambda (part sub-part-num)
 157               (apply display-mime-entity part
 158                      (append path (list sub-part-num))))
 159             sub-parts
 160             (iota (length sub-parts))))))
 161   (cond
 162    ((multipart-message? message)
 163     (let ((parts (email-body message)))
 164       (map (lambda (part part-num)
 165              (display-mime-entity part part-num))
 166            parts
 167            (iota (length parts)))))
 168    ;; Regular message with a simple body.
 169    (else
 170     (prettify (email-body message)))))