From ce42ed14891014e8be344fde7e3e25a2b26c150a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 9 Aug 2021 23:35:20 +0200
Subject: Render attachements to HTML frontend.

---
 module/calp/html/vcomponent.scm | 52 +++++++++++++++++++++++++++++++++++++++++
 module/calp/server/routes.scm   | 21 +++++++++++++++++
 2 files changed, 73 insertions(+)

(limited to 'module/calp')

diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index 1f51e40f..4421a08e 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -2,7 +2,9 @@
   :use-module (calp util)
   :use-module (vcomponent)
   :use-module (srfi srfi-1)
+  :use-module (srfi srfi-26)
   :use-module (srfi srfi-41)
+  :use-module ((rnrs io ports) :select (put-bytevector))
   :use-module (datetime)
   :use-module ((text util) :select (add-enumeration-punctuation))
   :use-module ((web uri-query) :select (encode-query-parameters))
@@ -10,6 +12,8 @@
   :use-module ((calp html config) :select (edit-mode debug))
   :use-module ((calp html components) :select (btn tabset form with-label))
   :use-module ((calp util color) :select (calculate-fg-color))
+  :use-module ((crypto) :select (sha256 checksum->string))
+  :use-module ((xdg basedir) :prefix xdg-)
   :use-module ((vcomponent recurrence internal) :prefix #{rrule:}#)
   :use-module ((vcomponent datetime output)
                :select (fmt-time-span
@@ -116,6 +120,54 @@
                            (data-property "description"))
                          ,(format-description ev it)))
 
+          ,@(awhen (prop* ev 'ATTACH)
+                   ;; attach satisfies @code{vline?}
+                   (for attach in it
+                        (if (and=> (param attach 'VALUE)
+                                   (lambda (p) (string=? "BINARY" (car p))))
+                            ;; Binary data
+                            ;; TODO guess datatype if FMTTYPE is missing
+                            (awhen (and=> (param attach 'FMTTYPE)
+                                          (lambda (it) (string-split
+                                                   (car it) #\/)))
+                                   ;; TODO other file formats
+                                   (when (string=? "image" (car it))
+                                     (let* ((chk (-> (value attach)
+                                                     sha256
+                                                     checksum->string))
+                                            (dname
+                                             (path-append (xdg-runtime-dir)
+                                                          "calp-data" "images"))
+                                            (filename (-> dname
+                                                          (path-append chk)
+                                                          ;; TODO second part of mimetypes
+                                                          ;; doesn't always result in a valid
+                                                          ;; file extension.
+                                                          ;; Take a look in mime.types.
+                                                          (string-append "." (cadr it)))))
+                                       (unless (file-exists? filename)
+                                         ;; TODO handle tmp directory globaly
+                                         (mkdir (dirname dname))
+                                         (mkdir dname)
+                                         (call-with-output-file filename
+                                           (lambda (port)
+                                             (put-bytevector port (value attach)))))
+                                       (let ((link (path-append
+                                                    "/tmpfiles"
+                                                    ;; TODO better mimetype to extension
+                                                    (string-append chk "." (cadr it)))))
+                                         `(a (@ (href ,link))
+                                             (img (@ (class "attach")
+                                                     (src ,link))))))))
+                            ;; URI
+                            (cond ((and=> (param attach 'FMTTYPE)
+                                          (compose (cut string= <> "image" 0 5) car))
+                                   `(img (@ (class "attach")
+                                            (src ,(value attach)))))
+                                  (else `(a (@ (class "attach")
+                                               (href ,(value attach)))
+                                            ,(value attach)))))))
+
           ;; TODO add bind once I figure out how to bind lists
           ,(awhen (prop ev 'CATEGORIES)
                   `(div (@ (class "categories"))
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index 95488fc9..b024ed4f 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -17,6 +17,8 @@
   :use-module (sxml xpath)
   :use-module (sxml namespace)
 
+  :use-module ((rnrs io ports) :select (get-bytevector-all))
+  :use-module ((xdg basedir) :prefix xdg-)
 
   :use-module ((calp html util) :select (html-unattr))
 
@@ -436,6 +438,25 @@
          (sxml->html-string
           (directory-table (path-append "static" *)))))
 
+   ;; This is almost the same as /static/, but with the difference that
+   ;; we produce these images during runtime
+   (GET "/tmpfiles/:*{.*}.:ext" (* ext)
+        ;; Actually parsing /etc/mime.types would be better.
+        (define mime
+          (case (string->symbol (string-downcase ext))
+            [(png) "png"]
+            [(jpg jpeg) "jpeg"]
+            [(gif) "gif"]
+            [else ext]))
+
+        (return
+         `((content-type ,(string->symbol (string-append "image/" mime))))
+         ;; TODO handle tmp directory globaly
+         (call-with-input-file (path-append (xdg-runtime-dir)
+                                            "calp-data" "images"
+                                            (string-append * "." ext))
+           get-bytevector-all)))
+
 
    (GET "/count" ()
         ;; (sleep 1)
-- 
cgit v1.2.3