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 write-vcard)

  (import
    scheme
    (chicken base)
    (chicken condition)
    (chicken io)
    (chicken irregex)
    (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)
                    (if (date? datetime)
                        (date->string datetime "~Y~m~dT~H~M~S~z")
                        datetime))))
          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)))))


  ;; Given a vCard property and its values (e.g., “VERSION” and “3.0”),
  ;; parse them into a list.
  ;;    "EMAIL;TYPE=home" "mom@dad.com" → '(EMAIL ("TYPE=home") "mom@dad.com")
  (define (parse-vcard-property property elements)
    (append (list property)
            (list elements)))


  ;; Given the value(s) of a vCard element’s value string(s), returned a
  ;; parsed object.
  ;;    'BIRTHDAY "2024-01-02T00:00:00" → #@2024-01-02T00:00:00-0600
  (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))))


  ;; With an element of a parsed vCard alist, serialize it (back) into a
  ;; string.
  (define (serialize-vcard-element element)
    (let [(property (string-join
                     (append (list (symbol->string (car element)))
                             (second element)) ";"))
          (value (serialize-vcard-value (car element) (last element)))]
      (string-join (list property value) ":")))


  ;; Serialize the value of a vCard property (from a parsed vCard alist)
  ;; into a string.
  (define (serialize-vcard-value prop value)
   (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
     (if parser-and-unparser-funcs
         (apply (cadr parser-and-unparser-funcs) (list value))
         value)))


  ;; Serialize a vCard parsed-alist into a set of line-strings, once more.
  (define (serialized-vcard vcard-alist)
    (map serialize-vcard-element vcard-alist))


  ;; 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-property property (cdr prop-elements))
              (parse-vcard-value property value-elements))))


  ;; Reader thunk. Read/parse an entire vCard into a “vCard alist.”
  ;; vCard is read from an optional PORT, defaulting to (current-input-port).
  ;; Ignore the IGNORED parameter.
  (define (read-vcard #!optional (port (current-input-port)) (ignored #t))
    (let* [(first-element? ignored)
           (element (read-vcard-element port first-element?))]
      (if (not (eof-object? (peek-char port)))
          (append (list element) (read-vcard port #f))
          (list element))))



  ;; Read a single unfolded line into a vCard “element” list.
  ;; The optional FIRST-ELEMENT? argument simply makes sure the next line is a
  ;; BEGIN:VCARD element (as the first element in any valid vCard file should
  ;; be. It is used internally by READ-VCARD.
  (define (read-vcard-element #!optional (port (current-input-port)) (first-element? #f))
    (let* [(line (read-folded-line (if first-element? 100 #f) port))]
      (cond
       ;; Ignore blank lines, they’re not doing anyone any harm!
       [(or (string-null? line)
            (irregex-search "^[[:whitespace:]]+$" line))
        (read-vcard-element port first-element?)]
       ;; If we’ve previously established this is a vCard stream we’re dealing
       ;; with, just go ahead and parse. If we haven’t established that, make
       ;; sure it’s a BEGIN:VCARD line first.
       [(or (not first-element?)
            (and first-element?
                 (string-contains line "BEGIN")
                 (string-contains line "VCARD")))
        (parse-vcard-line line)]
       ;; If we’re still making sure the file is vCard, and the first non-blank
       ;; line *isn’t* a BEGIN:VCARD line, then the file probably isn’t a vCard.
       [#t
        (signal
         (condition '(exn location vcarded message
                          "Not a valid vCard file.")
                    '(file)
                    '(vcard)))])))


  ;; 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 #!optional (limit 100) (port (current-input-port)))
    (if (not (eof-object? (peek-char port)))
      (let [(line (read-line port limit))]
        (if (or (eq? (peek-char port) #\space)
                (eq? (peek-char port) #\tab))
            (string-concatenate
             (list line
                   (string-drop (read-folded-line limit port) 1)))
            line))
      ""))


  ;; Writes a vCard alist to the output port as a string.
  ;; Defaults to (current-output-port).
  (define (write-vcard vcard-alist #!optional (port (current-output-port)))
    (for-each (lambda (element)
                (write-string (serialize-vcard-element element) #f port)
                (write-char #\return port)
                (write-char #\newline port))
         vcard-alist))


  ;; Split a STRING into strings of a size of (at most) LENGTH signs.
  ;;    ("ÁPPLE" 2) → '("ÁP" "PL" "E")
  (define (string-split-by-lengths string length)
    (append (list (if (<= (string-length string) length)
                      string
                      (substring string 0 length)))
            (if (<= (string-length string) length)
                '()
                (string-split-by-lengths (substring string length) length)))))