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)
  (chicken irregex)
  srfi-1
  srfi-13
  srfi-130
  (prefix uri-common uri:))


(define (uri->string uri-or-str)
  (list
   (list
    (if (uri:uri? uri-or-str)
        (uri:uri->string uri-or-str)
        uri-or-str))))


(define (string->uri . strs)
  (list
   (list
    (if (and (not (null? strs))
             (string? (car strs)))
        (uri:uri-reference (string-join strs ";"))
        strs))))


(define (csv-string->list str)
  (list
   (list
    (string-split str ","))))


(define (list->csv-string list)
  (list
   (list
    (string-join list ","))))


(define vcard-value-parsers
  (list
   (list 'PHOTO string->uri uri->string)
   (list 'LOGO string->uri uri->string)
   (list 'MEMBER string->uri uri->string)
   (list 'SOUND string->uri uri->string)
   (list 'UID string->uri uri->string)
   (list 'URL string->uri uri->string)
   (list 'KEY string->uri uri->string)
   (list 'FBURL string->uri uri->string)
   (list 'CALADRURI string->uri uri->string)
   (list 'CALURI string->uri uri->string)
   (list 'RELATED string->uri uri->string)
   (list 'CATEGORIES csv-string->list list->csv-string)
   (list 'IMPP string->uri uri->string)
   (list 'GEO string->uri uri->string)))


;; Splits a string into a list of CRLF’d lines.
(define (unlines lines)
  (string-join lines "\r\n"))


;; Splits a string into a list of CRLF’d lines.
(define (lines string)
  (remove string-null? (string-split string "\r\n")))


;; 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 (irregex-extract "(\\\\:|[^:])*" line))]
    (if (>= (length split) 2)
        (cons
         (car split)
         ;; Drop the value’s first char (redundant “:”) and concatenate the
         ;; rest of the string-parts which were erroneously split along “:”.
         (string-drop (reduce-right
                       (lambda (a b) (string-concatenate (list a ":" b)))
                       "" (cdr split))
                      1))
        #f)))


;; Splits a key or value-element into its (potentially multiple) parameters.
;; … basically just splits along non-escaped semi-colons.
;;    "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom")
(define (split-vcard-element key-or-value)
  (let [(appendee "")]
    (remove
     not
     (map (lambda (str)
            (let [(str (string-concatenate `(,appendee ,str)))]
              (if (and (not (string-null? str))
                       (eq? (last (string->list str))
                            #\\))
                  (and (set! appendee (string-concatenate `(,str ";")))
                       #f)
                  (and (set! appendee "") str))))
          (string-split key-or-value ";")))))


(define (parse-vcard-prop property elements)
  (list
   (append (list property)
           elements)))


(define (parse-vcard-value prop elements)
  (print "CHECKING" prop)
  (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
    (if parser-and-unparser-funcs
        (apply (car parser-and-unparser-funcs) 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 (split-vcard-element (car prop-value-strings)))
         (value-elements (split-vcard-element (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)))