diff --git a/vcarded.scm b/vcarded.scm index f9769c3..94e72ab 100644 --- a/vcarded.scm +++ b/vcarded.scm @@ -30,6 +30,162 @@ (srfi 207) (prefix uri-common uri:)) + + ;;; ~ Macros ~ + + ;; Ignore whatever conditions the expression might return; just return the + ;; default value in that case. + ;; (ignore-error (+ 1 "seven") 3) → 3 + (define-syntax ignore-error + (syntax-rules () + ((ignore-error expr default) + (condition-case expr (var () default))))) + + + + ;;; ~ Exports ~ + + ;; 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. + ;; + ;; The format of a cell is: + ;; (PROPERTY-SYMBOL (ATTRIBUTE-STR …) PROPERTY-VALUE) + ;; + ;; PROPERTY-VALUE might be a string, a uri-common URI, an srfi-19 datetime, + ;; an srfi-4 bytevector (u8vector), or a list of values. + ;; + ;; The type of the value follows logically from the vCard specification’s + ;; type for that property — URI properties are a uri-common URI and NICKNAME + ;; is a list of strings, for example. + ;; + ;; But there is one notable exception: `data`-URIs are parsed into bytevectors + ;; for convenience, as these are often used to encode profile pictures. + ;; + ;; Anyway, here is an example vCard alist made by this function: + ;; ((BEGIN () "VCARD") + ;; (VERSION () "3.0") + ;; (FN () "Birdie Johnson") + ;; (NICKNAME () ("Bird" "Gal" "Tweety")) + ;; (TEL ("type=home") #) + ;; (END () "VCARD")) + (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)) + (list element)))) + + + ;; Writes a vCard’s parsed alist to the output port as a string. + ;; Defaults to (current-output-port). + ;; + ;; I wish I had more to say, especially compared to READ-VCARD’s essay-long + ;; description, but unfortunately I’m coming up empty! =w=, + (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)) + + + + ;;; ~ vCard parsing [string→alist] ~ + + ;; 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)))]))) + + + ;; 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) + (let* [(prop-value-strings (split-vcard-line line)) + (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)) + (parse-vcard-value property value-elements)))) + + + ;; Splits a line into a cons of the property-string and value-string. + ;; … basically splits the string along the first unescaped colon (:). + ;; "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad") + (define (split-vcard-line line) + (let [(split (string-split-unescaped line ":"))] + (cons (car split) + (string-join (cdr split) ":")))) + + + ;; 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 + (list (ignore-error (apply (car parser-and-unparser-funcs) + (list elements)) + elements)) + (list elements)))) + + + + ;;; ~ vCard serialization [alist→string] ~ + + ;; 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))) + + + + ;;; ~ Property-value parsers ~ ;; List of all properties with semicoloned-structured strings. (define vcard-semicoloned-properties @@ -69,7 +225,6 @@ (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)) @@ -157,9 +312,9 @@ datetime)))) vcard-datetime-properties) (map (lambda (csv-prop) - (list csv-prop - (lambda (str) (string-split-unescaped str ",")) - (lambda (csv-list) (string-join csv-list ",")))) + (list csv-prop + (lambda (str) (string-split-unescaped str ",") + (lambda (csv-list) (string-join csv-list ","))))) vcard-csv-properties) (map (lambda (semicolon-prop) (list semicolon-prop @@ -168,22 +323,32 @@ vcard-semicoloned-properties))) - ;; Splits a line into a cons of the property-string and value-string. - ;; … basically splits the string along the first unescaped colon (:). - ;; "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad") - (define (split-vcard-line line) - (let [(split (string-split-unescaped line ":"))] - (cons (car split) - (string-join (cdr split) ":")))) + + ;;; ~ General utilities ~ ^^ + + ;; 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)) + "")) - ;; Ignore whatever conditions the expression might return; just return the - ;; default value in that case. - ;; (ignore-error (+ 1 "seven") 3) → 3 - (define-syntax ignore-error - (syntax-rules () - ((ignore-error expr default) - (condition-case expr (var () default))))) + ;; 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)))) ;; Splits a string along a delimiter; while not splitting along @@ -202,136 +367,5 @@ (string-concatenate (list substr delimiter))) #f) (and (set! appendee "") substr)))) - (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) - (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 - (list (ignore-error (apply (car parser-and-unparser-funcs) - (list elements)) - elements)) - (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) - (let* [(prop-value-strings (split-vcard-line line)) - (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)) - (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)) - (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)))]))) - - - ;; 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))))) + (string-split string delimiter))))))