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/>.

(module vcarded
    (read-vcard)

  (import
    scheme
    (chicken base)
    (chicken condition)
    (chicken io)
    (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 #<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
                  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.”
  (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)))


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