vcarded.egg

@@ -3,6 +3,6 @@
  (author "Jaidyn Ann")
  (category net)
  (license "GPLv3")
- (dependencies srfi-1 srfi-4 srfi-13 srfi-19 srfi-130 srfi-207 uri-common)
+ (dependencies srfi-1 srfi-13 srfi-130 uri-common)
  (components
   (extension vcarded)))

vcarded.scm

@@ -14,20 +14,17 @@
 ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
 
 (module vcarded
-    (read-vcard write-vcard)
+    (read-vcard)
 
   (import
     scheme
     (chicken base)
     (chicken condition)
     (chicken io)
-    (chicken irregex)
-    (srfi 1)
-    (srfi 4)
-    (srfi 13)
-    (srfi 19)
-    (srfi 130)
-    (srfi 207)
+    srfi-1
+    srfi-13
+    srfi-19
+    srfi-130
     (prefix uri-common uri:))
 
 
@@ -64,74 +61,6 @@
           (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>)
@@ -141,16 +70,15 @@
     (append
      (map (lambda (uri-prop)
             (list uri-prop
-                  parse-uri-prop-value
-                  serialize-uri-prop-value))
+                  (lambda strs (or (uri:uri-reference (string-join strs ";"))
+                                   (string-join strs ";")))
+                  (lambda (url) (uri:uri->string url))))
           vcard-url-properties)
      (map (lambda (date-prop)
             (list date-prop
                   string->any-date
                   (lambda (datetime)
-                    (if (date? datetime)
-                        (date->string datetime "~Y~m~dT~H~M~S~z")
-                        datetime))))
+                    (date->string datetime "~Y~m~dT~H~M~S~z"))))
           vcard-datetime-properties)
      (map (lambda (csv-prop)
              (list csv-prop
@@ -201,17 +129,11 @@
             (string-split string delimiter)))))
 
 
-  ;; 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)
+  (define (parse-vcard-prop 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
@@ -221,30 +143,6 @@
           (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)
@@ -252,82 +150,29 @@
            (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-property property (cdr prop-elements))
+      (append (parse-vcard-prop property (cdr prop-elements))
               (parse-vcard-value property value-elements))))
 
 
-  ;; Reader thunk. Read/parse an entire vCard into a “vCard alist.”
-  ;; vCard is read from an optional PORT, defaulting to (current-input-port).
-  ;; Ignore the IGNORED parameter.
-  (define (read-vcard #!optional (port (current-input-port)) (ignored #t))
-    (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))
+  ;; Reader thunk. Read/parse an entire vcard into a “vcard alist.”
+  (define (read-vcard)
+    (let [(element (read-vcard-element))]
+      (if (not (eof-object? (peek-char)))
+          (append (list element) (read-vcard))
           (list element))))
 
 
-
-  ;; Read a single unfolded line into a vCard “element” list.
-  ;; 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)))])))
+  ;; Read a single unfolded line into a vcard “element” list.
+  (define (read-vcard-element)
+    (parse-vcard-line (read-folded-line)))
 
 
   ;; 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 #!optional (limit 100) (port (current-input-port)))
-    (if (not (eof-object? (peek-char port)))
-      (let [(line (read-line port limit))]
-        (if (or (eq? (peek-char port) #\space)
-                (eq? (peek-char port) #\tab))
-            (string-concatenate
-             (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)))))
-
+  (define (read-folded-line)
+    (let [(line (read-line))]
+      (if (eq? (peek-char) #\space)
+          (string-concatenate
+           (list line
+                 (string-drop (read-folded-line) 1)))
+          line))))