Create vcarded module and egg
This commit is contained in:
parent
1e202b3c55
commit
6c744928f8
|
|
@ -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
259
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 <https://www.gnu.org/licenses/>.
|
||||
|
||||
(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 #<procedure> #<procedure>)
|
||||
;; (ADR #<procedure> #<procedure>)
|
||||
;; …)
|
||||
;; 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 #<procedure> #<procedure>)
|
||||
;; (ADR #<procedure> #<procedure>)
|
||||
;; …)
|
||||
;; 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))))
|
||||
|
|
|
|||
Ŝarĝante…
Reference in New Issue