jadedctrl/ chicken-vcarded
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Create vcarded module and egg

This commit is contained in:
Jaidyn Ann 2024-02-07 00:44:46 -06:00
parent 1e202b3c55
commit 6c744928f8
2 changed files with 140 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
vcarded.egg Normal file
View File

@ -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)))

259
vcarded.scm
View File

@ -13,161 +13,166 @@
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(module vcarded
(read-vcard)
(import (import
scheme scheme
(chicken io) (chicken base)
srfi-1 (chicken condition)
srfi-13 (chicken io)
srfi-130 srfi-1
(prefix uri-common uri:)) srfi-13
srfi-19
srfi-130
(prefix uri-common uri:))
;; List of all properties with semicoloned-structured strings. ;; List of all properties with semicoloned-structured strings.
(define vcard-semicoloned-properties (define vcard-semicoloned-properties
'(ADR CLIENTPIDMAP GENDER N)) '(ADR CLIENTPIDMAP GENDER N))
;; List of all properties with datetime values. ;; List of all properties with datetime values.
(define vcard-datetime-properties (define vcard-datetime-properties
'(ANNIVERSARY BDAY REV)) '(ANNIVERSARY BDAY REV))
;; List of all properties with multiple comma-separated values. ;; List of all properties with multiple comma-separated values.
(define vcard-csv-properties (define vcard-csv-properties
'(CATEGORIES NICKNAME)) '(CATEGORIES NICKNAME))
;; List of all URL-type vcard properties. ;; List of all URL-type vcard properties.
(define vcard-url-properties (define vcard-url-properties
'(CALADRURI CALURI FBURL GEO IMPP '(CALADRURI CALURI FBURL GEO IMPP
KEY LOGO MEMBER PHOTO RELATED KEY LOGO MEMBER PHOTO RELATED
SOUND SOURCE TEL UID URL)) SOUND SOURCE TEL UID URL))
;; Should parse any truncated & reduced-accuracy ISO 8601 datetime. ;; Should parse any truncated & reduced-accuracy ISO 8601 datetime.
;; … right now, it only parses a few possibilities. ;; … right now, it only parses a few possibilities.
(define (string->any-date str) (define (string->any-date str)
(let* [(ymd "~Y~m~d") (let* [(ymd "~Y~m~d")
(hms "~H~M~S") (hms "~H~M~S")
(ymd-hms (string-join (list ymd hms) "T"))] (ymd-hms (string-join (list ymd hms) "T"))]
(or (ignore-error (string->date str ymd-hms) #f) (or (ignore-error (string->date str ymd-hms) #f)
(ignore-error (string->date str ymd) #f) (ignore-error (string->date str ymd) #f)
(ignore-error (string->date str hms) #f)))) (ignore-error (string->date str hms) #f))))
;; A list of the parser/serializer functions for each vcard property. ;; A list of the parser/serializer functions for each vcard property.
;; ((TEL #<procedure> #<procedure>) ;; ((TEL #<procedure> #<procedure>)
;; (ADR #<procedure> #<procedure>) ;; (ADR #<procedure> #<procedure>)
;; …) ;; …)
;; TODO: Add a parser for the TZ [timezone] property. ;; TODO: Add a parser for the TZ [timezone] property.
(define vcard-value-parsers (define vcard-value-parsers
(append (append
(map (lambda (uri-prop) (map (lambda (uri-prop)
(list uri-prop (list uri-prop
(lambda strs (or (uri:uri-reference (string-join strs ";")) (lambda strs (or (uri:uri-reference (string-join strs ";"))
(string-join sts ";"))) (string-join strs ";")))
(lambda (url) (uri:uri->string url)))) (lambda (url) (uri:uri->string url))))
vcard-url-properties) vcard-url-properties)
(map (lambda (date-prop) (map (lambda (date-prop)
(list date-prop (list date-prop
string->any-date string->any-date
(lambda (datetime) (lambda (datetime)
(date->string datetime "~Y~m~dT~H~M~S~z")))) (date->string datetime "~Y~m~dT~H~M~S~z"))))
vcard-datetime-properties) vcard-datetime-properties)
(map (lambda (csv-prop) (map (lambda (csv-prop)
(list csv-prop (list csv-prop
(lambda (str) (string-split-unescaped str ",")) (lambda (str) (string-split-unescaped str ","))
(lambda (csv-list) (string-join csv-list ",")))) (lambda (csv-list) (string-join csv-list ","))))
vcard-csv-properties) vcard-csv-properties)
(map (lambda (semicolon-prop) (map (lambda (semicolon-prop)
(list semicolon-prop (list semicolon-prop
(lambda (str) (string-split-unescaped str ";")) (lambda (str) (string-split-unescaped str ";"))
(lambda (sc-list) (string-join sc-list ";")))) (lambda (sc-list) (string-join sc-list ";"))))
vcard-semicoloned-properties))) vcard-semicoloned-properties)))
;; Splits a line into a cons of the property-string and value-string. ;; Splits a line into a cons of the property-string and value-string.
;; … basically splits the string along the first unescaped colon (:). ;; … basically splits the string along the first unescaped colon (:).
;; "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad") ;; "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad")
(define (split-vcard-line line) (define (split-vcard-line line)
(let [(split (string-split-unescaped line ":"))] (let [(split (string-split-unescaped line ":"))]
(cons (car split) (cons (car split)
(string-join (cdr split) ":")))) (string-join (cdr split) ":"))))
;; Ignore whatever conditions the expression might return; just return the ;; Ignore whatever conditions the expression might return; just return the
;; default value in that case. ;; default value in that case.
;; (ignore-error (+ 1 "seven") 3) → 3 ;; (ignore-error (+ 1 "seven") 3) → 3
(define-syntax ignore-error (define-syntax ignore-error
(syntax-rules () (syntax-rules ()
((ignore-error expr default) ((ignore-error expr default)
(condition-case expr (var () default))))) (condition-case expr (var () default)))))
;; Splits a string along a delimiter; while not splitting along ;; Splits a string along a delimiter; while not splitting along
;; backslash-escaped delimiters. With “;” as the delimiter: ;; backslash-escaped delimiters. With “;” as the delimiter:
;; "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom") ;; "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom")
(define (string-split-unescaped string delimiter) (define (string-split-unescaped string delimiter)
(let [(appendee "")] (let [(appendee "")]
(remove (remove
not not
(map (lambda (substr) (map (lambda (substr)
(let [(substr (string-concatenate (list appendee substr)))] (let [(substr (string-concatenate (list appendee substr)))]
(if (and (not (string-null? substr)) (if (and (not (string-null? substr))
(eq? (last (string->list substr)) (eq? (last (string->list substr))
#\\)) #\\))
(and (set! appendee (and (set! appendee
(string-concatenate (list substr delimiter))) (string-concatenate (list substr delimiter)))
#f) #f)
(and (set! appendee "") substr)))) (and (set! appendee "") substr))))
(string-split string delimiter))))) (string-split string delimiter)))))
(define (parse-vcard-prop property elements) (define (parse-vcard-prop property elements)
(append (list property) (append (list property)
(list elements))) (list elements)))
(define (parse-vcard-value prop elements) (define (parse-vcard-value prop elements)
(let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))] (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
(if parser-and-unparser-funcs (if parser-and-unparser-funcs
(list (ignore-error (apply (car parser-and-unparser-funcs) (list (ignore-error (apply (car parser-and-unparser-funcs)
(list elements)) (list elements))
elements)) elements))
(list elements)))) (list elements))))
;; Parse a line of a vcard file into an alist-friendly format: ;; Parse a line of a vcard file into an alist-friendly format:
;; (KEY ("keyprop1=d" "keyprop2=b") "VALUE" ("valprop1=a" "valprop2=b")) ;; (KEY ("keyprop1=d" "keyprop2=b") "VALUE" ("valprop1=a" "valprop2=b"))
(define (parse-vcard-line line) (define (parse-vcard-line line)
(let* [(prop-value-strings (split-vcard-line line)) (let* [(prop-value-strings (split-vcard-line line))
(prop-elements (string-split-unescaped (car prop-value-strings) ";")) (prop-elements (string-split-unescaped (car prop-value-strings) ";"))
(value-elements (cdr prop-value-strings)) (value-elements (cdr prop-value-strings))
(property (string->symbol (string-upcase (car prop-elements))))] (property (string->symbol (string-upcase (car prop-elements))))]
(append (parse-vcard-prop property (cdr prop-elements)) (append (parse-vcard-prop property (cdr prop-elements))
(parse-vcard-value property value-elements)))) (parse-vcard-value property value-elements))))
;; Reader thunk. Read/parse an entire vcard into a “vcard alist.” ;; Reader thunk. Read/parse an entire vcard into a “vcard alist.”
(define (read-vcard) (define (read-vcard)
(let [(element (read-vcard-element))] (let [(element (read-vcard-element))]
(if (not (eof-object? (peek-char))) (if (not (eof-object? (peek-char)))
(append (list element) (read-vcard)) (append (list element) (read-vcard))
(list element)))) (list element))))
;; Read a single unfolded line into a vcard “element” list. ;; Read a single unfolded line into a vcard “element” list.
(define (read-vcard-element) (define (read-vcard-element)
(parse-vcard-line (read-folded-line))) (parse-vcard-line (read-folded-line)))
;; Reader-thunk. Read a “logical” folded-line, where a line beginning with a ;; Reader-thunk. Read a “logical” folded-line, where a line beginning with a
;; space is a continuation of the previous line — like with vcards. ;; space is a continuation of the previous line — like with vcards.
(define (read-folded-line) (define (read-folded-line)
(let [(line (read-line))] (let [(line (read-line))]
(if (eq? (peek-char) #\space) (if (eq? (peek-char) #\space)
(string-concatenate (string-concatenate
(list line (list line
(string-drop (read-folded-line) 1))) (string-drop (read-folded-line) 1)))
line))) line))))