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


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