Add syntax highlighting for Scheme files.

5 files changed, 64 insertions, 14 deletions

diff --git a/assets/css/code.css b/assets/css/code.css
new file mode 100644
index 0000000..c308845
--- /dev/null
+++ b/assets/css/code.css
@@ -0,0 +1,33 @@
+/* Syntax highlighting code, by David Thompson, borrowed
+   from:
+     https://git.dthompson.us/blog.git/blob_plain/refs/heads/haunt-migration:/css/dthompson.css
+   David Thompson gives permission for this to be GPLv3+ and CC BY-SA 4.0
+
+   Modified significantly since.
+*/
+
+
+.syntax-special, .syntax-element {
+    color: #856;
+    font-weight: bold;
+}
+
+.syntax-symbol {
+    color: #423;
+}
+
+.syntax-string {
+    color: #484;
+}
+
+.syntax-keyword, .syntax-attribute {
+    color: #921;
+}
+
+.syntax-comment {
+    color: #666;
+}
+
+.syntax-open, .syntax-close {
+    color: #688;
+}
diff --git a/assets/css/screen.css b/assets/css/screen.css
index 79dd0a3..d26f91e 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -151,6 +151,10 @@ table {
 .multipart.text-x-patch {
 }
 
+.multipart.scheme {
+    white-space: pre-wrap;
+}
+
 .attachment:before {
     background-image: url('/img/file.svg');
     background-size: 1rem;
diff --git a/guix.scm b/guix.scm
index b0907dc..19aa606 100644
--- a/guix.scm
+++ b/guix.scm
@@ -135,6 +135,7 @@ Debbugs bug tracker's SOAP service.")
   (build-system gnu-build-system)
   (inputs
    `(("guile-debbugs" ,guile-debbugs-next)
+     ("guile-syntax-highlight" ,guile-syntax-highlight)
      ("mailutils" ,mailutils-next)
      ("guile" ,guile-2.2.4)))
   (native-inputs
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 91c9809..5977161 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -66,7 +66,12 @@
                (@ (rel "stylesheet")
                   (media "screen")
                   (type "text/css")
-                  (href "/css/screen.css"))))
+                  (href "/css/screen.css")))
+              (link
+               (@ (rel "stylesheet")
+                  (media "screen")
+                  (type "text/css")
+                  (href "/css/code.css"))))
              (body ,@body)))
     #:extra-headers ,extra-headers))
 
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index ce2827e..9547f4b 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -20,6 +20,8 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (syntax-highlight)
+  #:use-module (syntax-highlight scheme)
   #:use-module (debbugs email)
   #:use-module (mumi messages)
   #:export (prettify
@@ -111,23 +113,28 @@ BUG-NUM), even when it is a multipart message."
                  (string-contains type "application")
                  (first (assoc-ref headers "content-disposition"))))
            (attachment-name
-            (or (and=> binary-attachment?
+            (or (and=> (assoc-ref headers "content-disposition")
                        (lambda (value)
-                         (and=> (string-match "filename=([^ ;]+)" value)
+                         (and=> (string-match "filename=([^ ;]+)" (first 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
+       (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)))
+       ((string-suffix? ".scm" attachment-name)
+        `(div (@ (class "multipart scheme"))
+              ,(highlights->sxml (highlight lex-scheme body))))
+       (else
+        `(div (@ (class ,(string-join `("multipart" ,(or type "")))))
+              ,(prettify body))))))
   (cond
    ((multipart-message? message)
     => (lambda (attributes)