From 5de1c57b1808487e22502db5d32ec11578ee620b Mon Sep 17 00:00:00 2001
From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com>
Date: Sun, 11 Feb 2024 09:22:07 -0600
Subject: [PATCH] Parse data URIs into bytevector+mimetype lists

---
 vcarded.egg |  2 +-
 vcarded.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 77 insertions(+), 8 deletions(-)

diff --git a/vcarded.egg b/vcarded.egg
index 77caefd..e0873ae 100644
--- a/vcarded.egg
+++ b/vcarded.egg
@@ -3,6 +3,6 @@
  (author "Jaidyn Ann")
  (category net)
  (license "GPLv3")
- (dependencies srfi-1 srfi-13 srfi-130 uri-common)
+ (dependencies srfi-1 srfi-4 srfi-13 srfi-19 srfi-130 srfi-207 uri-common)
  (components
   (extension vcarded)))
diff --git a/vcarded.scm b/vcarded.scm
index 6f9d062..2b41b58 100644
--- a/vcarded.scm
+++ b/vcarded.scm
@@ -21,10 +21,12 @@
     (chicken base)
     (chicken condition)
     (chicken io)
-    srfi-1
-    srfi-13
-    srfi-19
-    srfi-130
+    (srfi 1)
+    (srfi 4)
+    (srfi 13)
+    (srfi 19)
+    (srfi 130)
+    (srfi 207)
     (prefix uri-common uri:))
 
 
@@ -61,6 +63,74 @@
           (ignore-error (string->date str hms) #f))))
 
 
+  ;; Parse a string into a URI object.
+  (define (string->uri string)
+    (uri:uri-reference string))
+
+
+  ;; Parse a data URI’s contents into a list containing the mimetype (string)
+  ;; and bytevector contents (u8vector).
+  ;;    "data:text/plain;base64,ZGFk" → ("text/plain;base64" #u8(100 97 100))
+  (define (data-uri-str->bytevector uri)
+    (let* [(str (string-drop uri (string-length "data:")))
+           (split (string-split str ","))
+           (mimetype (car split))
+           (contents (string-join (cdr split) ","))]
+      (list
+       mimetype
+       (if (string-contains mimetype "base64")
+           (base64->bytevector contents)
+           (list->u8vector
+            (map char->integer
+                 (string->list contents)))))))
+
+
+  ;; Given a bytevector and according mimetype, return the associated
+  ;; data-URI.
+  ;;    "text/plain;base64" #u8(100 97 100) → "data:text/plain;base64,ZGFk"
+  (define (bytevector->data-uri-str mimetype bytevector)
+    (string-concatenate
+     (list
+      "data:"
+      mimetype
+      ","
+      (if (string-contains mimetype "base64")
+          (bytevector->base64 bytevector)
+          (list->string
+           (map integer->char
+                (u8vector->list bytevector)))))))
+
+
+  ;; Given a URI property’s value string(s) (like PHOTO or URL), return either
+  ;; a URI (if URI is valid), string (if invalid), or u8vector/bytevector (if
+  ;; data-URI).
+  (define (parse-uri-prop-value . strings)
+    (let* [(str (string-join strings ";"))
+           ;; We parse data URIs ourselves; so let’s not be redundant.
+           (uri (if (not (string-prefix? "data:" str))
+                    (string->uri str)))]
+      (cond
+       [(string-prefix? "data:" str)
+        (data-uri-str->bytevector str)]
+       [(not (uri:uri? uri))
+        str]
+       [#t
+        uri])))
+
+
+  ;; Given a parsed URI property’s value, serialize back into the original
+  ;; string-form… as best we can.
+  (define (serialize-uri-prop-value value)
+    (cond [(uri:uri? value)
+           (uri:uri->string value)]
+          [(list? value)
+           (bytevector->data-uri-str (car value) (cadr value))]
+          [(string? value)
+           value]
+          [#t
+           ""]))
+
+
   ;; A list of the parser/serializer functions for each vcard property.
   ;;    ((TEL #<procedure> #<procedure>)
   ;;     (ADR #<procedure> #<procedure>)
@@ -70,9 +140,8 @@
     (append
      (map (lambda (uri-prop)
             (list uri-prop
-                  (lambda strs (or (uri:uri-reference (string-join strs ";"))
-                                   (string-join strs ";")))
-                  (lambda (url) (uri:uri->string url))))
+                  parse-uri-prop-value
+                  serialize-uri-prop-value))
           vcard-url-properties)
      (map (lambda (date-prop)
             (list date-prop