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 # #) ;; (ADR # #) @@ -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