;; Copyright © 2024 Jaidyn Ann ;; ;; This program is free software: you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation, either version 3 of ;; the License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . (module vcarded (read-vcard) (import scheme (chicken base) (chicken condition) (chicken io) (chicken irregex) (srfi 1) (srfi 4) (srfi 13) (srfi 19) (srfi 130) (srfi 207) (prefix uri-common uri:)) ;; List of all properties with semicoloned-structured strings. (define vcard-semicoloned-properties '(ADR CLIENTPIDMAP GENDER N)) ;; List of all properties with datetime values. (define vcard-datetime-properties '(ANNIVERSARY BDAY REV)) ;; List of all properties with multiple comma-separated values. (define vcard-csv-properties '(CATEGORIES NICKNAME)) ;; List of all URL-type vcard properties. (define vcard-url-properties '(CALADRURI CALURI FBURL GEO IMPP KEY LOGO MEMBER PHOTO RELATED SOUND SOURCE TEL UID URL)) ;; Should parse any truncated & reduced-accuracy ISO 8601 datetime. ;; … right now, it only parses a few possibilities. (define (string->any-date str) (let* [(ymd "~Y~m~d") (hms "~H~M~S") (ymd-hms (string-join (list ymd hms) "T"))] (or (ignore-error (string->date str ymd-hms) #f) (ignore-error (string->date str ymd) #f) (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 # #) ;; …) ;; TODO: Add a parser for the TZ [timezone] property. (define vcard-value-parsers (append (map (lambda (uri-prop) (list uri-prop parse-uri-prop-value serialize-uri-prop-value)) 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")))) vcard-datetime-properties) (map (lambda (csv-prop) (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 (lambda (str) (string-split-unescaped str ";")) (lambda (sc-list) (string-join sc-list ";")))) 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) ":")))) ;; 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))))) ;; Splits a string along a delimiter; while not splitting along ;; backslash-escaped delimiters. With “;” as the delimiter: ;; "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom") (define (string-split-unescaped string delimiter) (let [(appendee "")] (remove not (map (lambda (substr) (let [(substr (string-concatenate (list appendee substr)))] (if (and (not (string-null? substr)) (eq? (last (string->list substr)) #\\)) (and (set! appendee (string-concatenate (list substr delimiter))) #f) (and (set! appendee "") substr)))) (string-split string delimiter))))) (define (parse-vcard-prop property elements) (append (list property) (list elements))) (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)))) ;; 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-prop property (cdr prop-elements)) (parse-vcard-value property value-elements)))) ;; Reader thunk. Read/parse an entire vCard into a “vCard alist.” ;; Ignore the IGNORED parameter. (define (read-vcard . ignored) (let* [(first-element? (optional ignored #t)) (element (read-vcard-element first-element?))] (if (not (eof-object? (peek-char))) (append (list element) (read-vcard #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 . first-element?) (let* [(first-element? (optional first-element? #f)) (line (read-folded-line (if first-element? 100 #f)))] (cond ;; Ignore blank lines, they’re not doing anyone any harm! [(or (string-null? line) (irregex-search "^[[:whitespace:]]+$" line)) (read-vcard-element 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 (read-folded-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) (let [(line (read-line (current-input-port) limit))] (if (or (eq? (peek-char) #\space) (eq? (peek-char) #\tab)) (string-concatenate (list line (string-drop (read-folded-line) 1))) line))))