From 6c744928f89c18504995c49c95b87e7b4a71cf0e Mon Sep 17 00:00:00 2001 From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com> Date: Wed, 7 Feb 2024 00:44:46 -0600 Subject: [PATCH] Create vcarded module and egg --- vcarded.egg | 8 ++ vcarded.scm | 259 ++++++++++++++++++++++++++-------------------------- 2 files changed, 140 insertions(+), 127 deletions(-) create mode 100644 vcarded.egg diff --git a/vcarded.egg b/vcarded.egg new file mode 100644 index 0000000..77caefd --- /dev/null +++ b/vcarded.egg @@ -0,0 +1,8 @@ +;; -*- Scheme -*- +((synopsis "Simple vCard parser.") + (author "Jaidyn Ann") + (category net) + (license "GPLv3") + (dependencies srfi-1 srfi-13 srfi-130 uri-common) + (components + (extension vcarded))) diff --git a/vcarded.scm b/vcarded.scm index f277419..6f9d062 100644 --- a/vcarded.scm +++ b/vcarded.scm @@ -13,161 +13,166 @@ ;; 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 io) - srfi-1 - srfi-13 - srfi-130 - (prefix uri-common uri:)) + (import + scheme + (chicken base) + (chicken condition) + (chicken io) + srfi-1 + srfi-13 + srfi-19 + srfi-130 + (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 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 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 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)) + ;; 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)))) + ;; 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)))) -;; 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 - (lambda strs (or (uri:uri-reference (string-join strs ";")) - (string-join sts ";"))) - (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")))) - 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))) + ;; 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 + (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) + (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) ":")))) + ;; 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))))) + ;; 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))))) + ;; 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-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)))) + (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)))) + ;; 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.” -(define (read-vcard) - (let [(element (read-vcard-element))] - (if (not (eof-object? (peek-char))) - (append (list element) (read-vcard)) - (list element)))) + ;; 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. -(define (read-vcard-element) - (parse-vcard-line (read-folded-line))) + ;; 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) - (let [(line (read-line))] - (if (eq? (peek-char) #\space) - (string-concatenate - (list line - (string-drop (read-folded-line) 1))) - 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) + (let [(line (read-line))] + (if (eq? (peek-char) #\space) + (string-concatenate + (list line + (string-drop (read-folded-line) 1))) + line))))