Add WRITE-VCARD function to complement READ-VCARD

… with a somewhat naïve check. Also, also count
horizontal-tab characters as starters of folded
lines (as per spec).

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)))

vcarded.scm

@@ -14,17 +14,20 @@
 ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
 
 (module vcarded
-    (read-vcard)
+    (read-vcard write-vcard)
 
   (import
     scheme
     (chicken base)
     (chicken condition)
     (chicken io)
-    srfi-1
+    (chicken irregex)
-    srfi-13
+    (srfi 1)
-    srfi-19
+    (srfi 4)
-    srfi-130
+    (srfi 13)
+    (srfi 19)
+    (srfi 130)
+    (srfi 207)
     (prefix uri-common uri:))
 
 
@@ -61,6 +64,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,15 +141,16 @@
     (append
      (map (lambda (uri-prop)
             (list uri-prop
-                  (lambda strs (or (uri:uri-reference (string-join strs ";"))
+                  parse-uri-prop-value
-                                   (string-join strs ";")))
+                  serialize-uri-prop-value))
-                  (lambda (url) (uri:uri->string url))))
           vcard-url-properties)
      (map (lambda (date-prop)
             (list date-prop
                   string->any-date
                   (lambda (datetime)
-                    (date->string datetime "~Y~m~dT~H~M~S~z"))))
+                    (if (date? datetime)
+                        (date->string datetime "~Y~m~dT~H~M~S~z")
+                        datetime))))
           vcard-datetime-properties)
      (map (lambda (csv-prop)
              (list csv-prop
@@ -129,11 +201,17 @@
             (string-split string delimiter)))))
 
 
-  (define (parse-vcard-prop property elements)
+  ;; Given a vCard property and its values (e.g., “VERSION” and “3.0”),
+  ;; parse them into a list.
+  ;;    "EMAIL;TYPE=home" "mom@dad.com" → '(EMAIL ("TYPE=home") "mom@dad.com")
+  (define (parse-vcard-property property elements)
     (append (list property)
             (list elements)))
 
 
+  ;; Given the value(s) of a vCard element’s value string(s), returned a
+  ;; parsed object.
+  ;;    'BIRTHDAY "2024-01-02T00:00:00" → #@2024-01-02T00:00:00-0600
   (define (parse-vcard-value prop elements)
     (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
       (if parser-and-unparser-funcs
@@ -143,6 +221,30 @@
           (list elements))))
 
 
+  ;; With an element of a parsed vCard alist, serialize it (back) into a
+  ;; string.
+  (define (serialize-vcard-element element)
+    (let [(property (string-join
+                     (append (list (symbol->string (car element)))
+                             (second element)) ";"))
+          (value (serialize-vcard-value (car element) (last element)))]
+      (string-join (list property value) ":")))
+
+
+  ;; Serialize the value of a vCard property (from a parsed vCard alist)
+  ;; into a string.
+  (define (serialize-vcard-value prop value)
+   (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
+     (if parser-and-unparser-funcs
+         (apply (cadr parser-and-unparser-funcs) (list value))
+         value)))
+
+
+  ;; Serialize a vCard parsed-alist into a set of line-strings, once more.
+  (define (serialized-vcard vcard-alist)
+    (map serialize-vcard-element vcard-alist))
+
+
   ;; Parse a line of a vcard file into an alist-friendly format:
   ;;    (KEY ("keyprop1=d" "keyprop2=b") "VALUE" ("valprop1=a" "valprop2=b"))
   (define (parse-vcard-line line)
@@ -150,29 +252,82 @@
            (prop-elements (string-split-unescaped (car prop-value-strings) ";"))
            (value-elements (cdr prop-value-strings))
            (property (string->symbol (string-upcase (car prop-elements))))]
-      (append (parse-vcard-prop property (cdr prop-elements))
+      (append (parse-vcard-property property (cdr prop-elements))
               (parse-vcard-value property value-elements))))
 
 
-  ;; Reader thunk. Read/parse an entire vcard into a “vcard alist.”
+  ;; Reader thunk. Read/parse an entire vCard into a “vCard alist.”
-  (define (read-vcard)
+  ;; vCard is read from an optional PORT, defaulting to (current-input-port).
-    (let [(element (read-vcard-element))]
+  ;; Ignore the IGNORED parameter.
-      (if (not (eof-object? (peek-char)))
+  (define (read-vcard #!optional (port (current-input-port)) (ignored #t))
-          (append (list element) (read-vcard))
+    (let* [(first-element? ignored)
+           (element (read-vcard-element port first-element?))]
+      (if (not (eof-object? (peek-char port)))
+          (append (list element) (read-vcard port #f))
           (list element))))
 
 
-  ;; Read a single unfolded line into a vcard “element” list.
+
-  (define (read-vcard-element)
+  ;; Read a single unfolded line into a vCard “element” list.
-    (parse-vcard-line (read-folded-line)))
+  ;; The optional FIRST-ELEMENT? argument simply makes sure the next line is a
+  ;; BEGIN:VCARD element (as the first element in any valid vCard file should
+  ;; be. It is used internally by READ-VCARD.
+  (define (read-vcard-element #!optional (port (current-input-port)) (first-element? #f))
+    (let* [(line (read-folded-line (if first-element? 100 #f) port))]
+      (cond
+       ;; Ignore blank lines, they’re not doing anyone any harm!
+       [(or (string-null? line)
+            (irregex-search "^[[:whitespace:]]+$" line))
+        (read-vcard-element port first-element?)]
+       ;; If we’ve previously established this is a vCard stream we’re dealing
+       ;; with, just go ahead and parse. If we haven’t established that, make
+       ;; sure it’s a BEGIN:VCARD line first.
+       [(or (not first-element?)
+            (and first-element?
+                 (string-contains line "BEGIN")
+                 (string-contains line "VCARD")))
+        (parse-vcard-line line)]
+       ;; If we’re still making sure the file is vCard, and the first non-blank
+       ;; line *isn’t* a BEGIN:VCARD line, then the file probably isn’t a vCard.
+       [#t
+        (signal
+         (condition '(exn location vcarded message
+                          "Not a valid vCard file.")
+                    '(file)
+                    '(vcard)))])))
 
 
   ;; Reader-thunk. Read a “logical” folded-line, where a line beginning with a
   ;; space is a continuation of the previous line — like with vcards.
-  (define (read-folded-line)
+  (define (read-folded-line #!optional (limit 100) (port (current-input-port)))
-    (let [(line (read-line))]
+    (if (not (eof-object? (peek-char port)))
-      (if (eq? (peek-char) #\space)
+      (let [(line (read-line port limit))]
-          (string-concatenate
+        (if (or (eq? (peek-char port) #\space)
-           (list line
+                (eq? (peek-char port) #\tab))
-                 (string-drop (read-folded-line) 1)))
+            (string-concatenate
-          line))))
+             (list line
+                   (string-drop (read-folded-line limit port) 1)))
+            line))
+      ""))
+
+
+  ;; Writes a vCard alist to the output port as a string.
+  ;; Defaults to (current-output-port).
+  (define (write-vcard vcard-alist #!optional (port (current-output-port)))
+    (for-each (lambda (element)
+                (write-string (serialize-vcard-element element) #f port)
+                (write-char #\return port)
+                (write-char #\newline port))
+         vcard-alist))
+
+
+  ;; Split a STRING into strings of a size of (at most) LENGTH signs.
+  ;;    ("ÁPPLE" 2) → '("ÁP" "PL" "E")
+  (define (string-split-by-lengths string length)
+    (append (list (if (<= (string-length string) length)
+                      string
+                      (substring string 0 length)))
+            (if (<= (string-length string) length)
+                '()
+                (string-split-by-lengths (substring string length) length)))))
+