path: root/mumi/web/view/utils.scm

;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.

(define-module (mumi web view utils)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 iconv)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (syntax-highlight)
  #:use-module (syntax-highlight scheme)
  #:use-module (email email)
  #:use-module (mumi messages)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:export (prettify
            avatar-color
            display-message-body
            time->string))

(define-record-type <block>
  (make-block type lines)
  block?
  (type   block-type)
  (lines  block-raw-lines set-block-lines!))

(define (block-lines block)
  (reverse (block-raw-lines block)))

(define (add-block-line! block line)
  (set-block-lines! block
                    (cons line (block-raw-lines block)))
  block)

(define (process line blocks context)
  "Process the current LINE.  Add it to the latest block in BLOCKS or
add it to a new block, dependent on CONTEXT.  Return the blocks along
with the next context."
  (match blocks
    ((block . other-blocks)
     (cond
      ((string-null? line)
       (values (cons (add-block-line! block `(br))
                     other-blocks)
               context))
      ((eq? context 'snippet)
       (if (string-prefix? "--8<---------------cut here" line)
           (values blocks #f)
           (values (cons (add-block-line! block
                                          `(span (@ (class "line")) ,line))
                         other-blocks)
                   context)))
      ((eq? context 'diff)
       (if (string= "--" line)
           ;; Retry
           (process line blocks #f)
           ;; Format line and add to current block
           (let ((formatted-line
                  (cond
                   ((string= "---" line)
                    `(span (@ (class "line diff separator")) ,line))
                   ((string-prefix? "+" line)
                    `(span (@ (class "line diff addition")) ,line))
                   ((and (string-prefix? "-" line)
                         (not (string= "--" line))
                         (not (string= "-- " line)))
                    `(span (@ (class "line diff deletion")) ,line))
                   ((string-prefix? "@@" line)
                    `(span (@ (class "line diff range")) ,line))
                   (else
                    `(span (@ (class "line")) ,line)))))
             (values (cons (add-block-line! block formatted-line)
                           other-blocks)
                     context))))
      ((eq? context 'quote)
       (if (string-prefix? ">" line)
           ;; Add line to current block
           (values (cons (add-block-line! block
                                          `(span (@ (class "line")) ,line))
                         other-blocks)
                   context)
           ;; Retry
           (process line blocks #f)))
      (else
       (let ((new-context
              (cond
               ((string-prefix? "diff --git" line)
                'diff)
               ((string-prefix? ">" line)
                'quote)
               ((string-prefix? "--8<---------------cut here" line)
                'snippet)
               (else 'text)))
             (formatted-line
              (cond
               ((or (string-contains line "https://")
                    (string-contains line "http://")) =>
                    (lambda (index)
                      (let* ((pre (string-take line index))
                             (post (string-drop line index))
                             (uri+ (string-split post (char-set #\< #\> #\space))))
                        (match uri+
                          ((uri-string . rest)
                           (or (and=> (string->uri uri-string)
                                      (lambda (uri)
                                        `(span (@ (class "line"))
                                               ,(string-trim-right pre #\<)
                                               (a (@ (href ,uri-string))
                                                  ,uri-string)
                                               ,@rest)))
                               `(span (@ (class "line")) ,line)))))))
               ((or (string-prefix? "Signed-off-by" line)
                    (string-prefix? "Co-authored-by" line))
                `(span (@ (class "line commit attribution")) ,line))
               ((or (string-prefix? "From: " line)
                    (string-prefix? "Date: " line)
                    (string-prefix? "Subject: " line))
                `(span (@ (class "line commit header")) ,line))
               ((or (string-prefix? "* " line)
                    (string-prefix? " * " line))
                `(span (@ (class "line commit changelog")) ,line))
               ((string-prefix? "diff --git" line)
                `(span (@ (class "line diff file")) ,line))
               ((string-prefix? "--8<---------------cut here" line)
                "")
               (else
                `(span (@ (class "line")) ,line)))))
         (if (eq? new-context context)
             (values (cons (add-block-line! block formatted-line)
                           other-blocks)
                     context)
             (values (cons (make-block new-context (list formatted-line))
                           blocks)
                     new-context))))))))

(define (prettify text)
  "Read each line of TEXT and apply PROCESS to it."
  (let ((res (fold (lambda (line acc)
                     (call-with-values
                         (lambda ()
                           (process line
                                    (cadr (memq #:blocks acc))
                                    (cadr (memq #:context acc))))
                       (lambda (new-blocks new-context)
                         `(#:blocks ,new-blocks #:context ,new-context))))
                   (list #:blocks (list (make-block 'text '()))
                         #:context 'text)
                   (string-split text #\newline))))
    (map (lambda (block)
           (if (eq? 'text (block-type block))
               `(div (@ (class ,(format #f "block ~a" (block-type block))))
                     ,(block-lines block))
               `(details (@ (class ,(format #f "block ~a" (block-type block)))
                            (open "open"))
                         (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
                                           (length (block-raw-lines block))))
                         ,(block-lines block))))
         (reverse (cadr (memq #:blocks res))))))

(define colors
  (circular-list "#8dd3c7" "#bebada" "#fb8072"
                 "#80b1d3" "#fdb462" "#b3de69"
                 "#fccde5" "#d9d9d9" "#bc80bd"
                 "#ccebc5" "#ffed6f"))

(define (avatar-color who participants)
  (or (and=> (assoc-ref (zip participants colors) who)
             first)
      (first colors)))

(define (content-type->css-class value)
  "Convert a content-type header value to a CSS class name."
  (string-append (symbol->string (assoc-ref value 'type))
                 "-"
                 (symbol->string (assoc-ref value 'subtype))))

;; https://icons.getbootstrap.com/icons/download/
(define download-icon
  '(svg (@ (class "bi bi-download")
           (width "1em")
           (height "1em")
           (viewBox "0 0 16 16")
           (fill "currentColor")
           (xmlns "http://www.w3.org/2000/svg"))
        (title "Download")
        (path (@ (fill-rule "evenodd")
                 (clip-rule "evenodd")
                 (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
        (path (@ (fill-rule "evenodd")
                 (clip-rule "evenodd")
                 (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
        (path (@ (fill-rule "evenodd")
                 (clip-rule "evenodd")
                 (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))

(define (display-message-body bug-num message-number 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)
    (define (attachment-url)
      (string-append "/issue/"
                     (number->string bug-num)
                     "/attachment/"
                     (number->string message-number)
                     "/" (string-join (map number->string path) "/")))
    (let* ((content-type (assoc-ref headers 'content-type))
           (html?
            (and content-type
                 (eq? 'html (assoc-ref content-type 'subtype))))
           (attachment?
            (and (and=> (assoc-ref headers 'content-disposition)
                        (cut assoc-ref <> 'type))
                 content-type
                 (assoc-ref content-type 'type)))
           (binary-attachment? (and attachment?
                                    (member (assoc-ref content-type 'type)
                                            '(application image video))))
           (attachment-name
            (or (and=> (assoc-ref headers 'content-disposition)
                       (cut assoc-ref <> 'filename))
                "file")))
      (cond
       ((or html? binary-attachment?)
        `(div (@ (class "attachment"))
              "Attachment: "
              (a (@ (href ,(attachment-url))) ,attachment-name)))
       ((string-suffix? ".scm" attachment-name)
        `(div (@ (class "multipart scheme"))
              (div (@ (class "download-part"))
                   (a (@ (href ,(attachment-url)))
                      ,download-icon))
              ,(highlights->sxml (highlight lex-scheme body))))
       (else
        `(div (@ (class ,(string-join
                          (list "multipart" (or (and content-type
                                                     (content-type->css-class content-type))
                                                "")))))
              (div (@ (class "download-part"))
                   (a (@ (href ,(attachment-url)))
                      ,download-icon))
              ,(prettify body))))))
  (define (display-mime-entity entity . path)
    (match entity
      (($ <mime-entity> headers (? string? body))
       (apply display-multipart-chunk `(,headers ,body ,path)))
      ;; Message parts can be nested.
      (($ <mime-entity> headers (? list? sub-parts))
       (map (lambda (part sub-part-num)
              (apply display-mime-entity part
                     (append path (list sub-part-num))))
            sub-parts
            (iota (length sub-parts))))
      ;; XXX: Sometimes we get an unparseable bytevector.  Convert it
      ;; when that happens.
      (($ <mime-entity> headers (? bytevector? raw))
       (apply display-multipart-chunk
              `(,headers
                ,(bytevector->string raw "ISO-8859-1")
                ,path)))))
  (cond
   ((multipart-message? message)
    (let ((parts (email-body message)))
      (map (lambda (part part-num)
             (display-mime-entity part part-num))
           parts
           (iota (length parts)))))
   ;; Regular message with a simple body.
   (else
    (display-mime-entity
     (make-mime-entity (email-headers message)
                       (email-body message))))))

(define (time->string time)
  "Return a string representing TIME in a concise, human-readable way."
  (define seconds
    (time-second
     (if (date? time)
         (date->time-utc time)
         time)))

  (define now*
    (current-time time-utc))

  (define now
    (time-second now*))

  (define elapsed
    (- now seconds))

  (cond ((< elapsed 120)
         "seconds ago")
        ((< elapsed 7200)
         (let ((minutes (inexact->exact
                         (round (/ elapsed 60)))))
           (format #f "~a minutes ago" minutes)))
        ((< elapsed (* 48 3600))
         (let ((hours (inexact->exact
                       (round (/ elapsed 3600)))))
           (format #f "~a hours ago" hours)))
        ((< elapsed (* 3600 24 7))
         (let ((days (inexact->exact
                      (round (/ elapsed 3600 24)))))
           (format #f "~a days ago" days)))
        (else
         (let* ((time    (make-time time-utc 0 seconds))
                (date    (time-utc->date time))
                (year    (date-year date))
                (current (date-year (time-utc->date now*)))
                (format  (if (= year current)
                             "~e ~b ~H:~M ~z"
                             "~e ~b ~Y ~H:~M")))
           (string-append "on " (date->string date format))))))