From 1f2a095f4def16fb6ccec83383295d87a7f75bde Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Jun 2022 23:36:00 +0200 Subject: Minor cleanup in fmt-single-event. --- module/calp/html/vcomponent.scm | 99 +++++++++++++++++++++++------------------ 1 file changed, 55 insertions(+), 44 deletions(-) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 4e54de89..4f94cd94 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -50,6 +50,16 @@ (warning (_ "~a on formatting description, ~s") err args) str)))) +;; TODO replace with propper mimetype parser +(define (mimetype-extension mimetype) + ((@ (ice-9 match) match) mimetype + ('() "unknown") + ('("image" "png") "png") + ('("image" "jpg") "jpg") + ('("image" "jpeg") "jpg") + ('("image" "gif") "gif") + )) + ;; used by search view (define-public (compact-event-list list) @@ -156,50 +166,51 @@ ,@(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) - (lambda (p) (string=? (car p) "image" 0 5))) - `(img (@ (class "attach") - (src ,(value attach))))) - (else `(a (@ (class "attach") - (href ,(value attach))) - ,(value attach))))))) + (case (and=> (param attach 'VALUE) (compose string->symbol car)) + ((BINARY) + ;; TODO guess datatype if FMTTYPE is missing + (let ((fmt-type (and=> (param attach 'FMTTYPE) + (lambda (p) (string-split (car p) #\/))))) + ;; TODO other file formats + (cond ((and fmt-type + (not (null? fmt-type)) + (string=? "image" (car fmt-type))) + (let* ((chk (-> (value attach) + sha256 + checksum->string)) + (dname (path-append (xdg-runtime-dir) + "calp-data" "images")) + (filename (-> dname + (path-append chk) + (string-append "." (mimetype-extension fmt-type))))) + (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" (string-append chk "." (mimetype-extension fmt-type))))) + `(a (@ (href ,link)) + (img (@ (class "attach") + (src ,link))))))) + (else `(pre "As of yet unsupported file format" ,fmt-type))))) + ((URI) + (let ((fmt-type (and=> (param attach 'FMTTYPE) + (lambda (p) (string-split (car p) #\/))))) + (cond ((and fmt-type + (not (null? fmt-type)) + (string=? "image" (car fmt-type))) + `(img (@ (class "attach") + (src ,(value attach))))) + (else `(a (@ (class "attach") + (href ,(value attach))) + ,(value attach)))))) + + ;; Neither BINARY nor URI + (else (scm-error 'misc-error "fmt-single-event" + "Unknown attachement type ~s, expected BINARY or UID" + (list (and=> (param attach 'VALUE) car)) + #f))))) ,(awhen (prop ev 'CATEGORIES) `(div (@ (class "categories")) -- cgit v1.2.3