chicken-vcarded/vcarded.scm

;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
;;
;; 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 <https://www.gnu.org/licenses/>.


(import
  scheme
  (chicken io)
  srfi-1
  srfi-13
  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 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))))


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


;; 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.”
(define (read-vcard)
  (let [(element (read-vcard-element))]
    (if (not (eof-object? (peek-char)))
        (append (list element) (read-vcard))
        element)))


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