rose-ash/lib/events/ical.sx

;; lib/events/ical.sx — iCalendar (RFC 5545) export.
;;
;; Serializes events to VEVENT / VCALENDAR text so a rose-ash calendar can be
;; imported by any standard client (Google/Apple/Outlook). Datetimes are UTC
;; epoch-minutes, emitted as basic-format UTC stamps (YYYYMMDDTHHMM00Z). The
;; full RRULE / EXDATE / RDATE model maps directly to the standard properties.
;;
;; Export is line-oriented: `ev/event->ical-lines` returns the VEVENT as a list
;; of content lines (no folding/CRLF — easy to assert on); `ev/ical-render`
;; joins lines with CRLF, the on-the-wire format. Requires calendar.sx.

;; ---- formatting helpers ----

(define ev-ical-pad2 (fn (n) (if (< n 10) (str "0" n) (str n))))

(define
  ev-ical-pad4
  (fn
    (n)
    (cond
      ((< n 10) (str "000" n))
      ((< n 100) (str "00" n))
      ((< n 1000) (str "0" n))
      (else (str n)))))

(define
  ev-ical-nth
  (fn
    (xs i)
    (if
      (= i 0)
      (first xs)
      (ev-ical-nth (rest xs) (- i 1)))))

(define
  ev-ical-join
  (fn
    (parts sep)
    (if
      (empty? parts)
      ""
      (reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))

;; An epoch-minute as an iCal basic-format stamp (no zone suffix).
(define
  ev-ical-dt-stamp
  (fn
    (t)
    (let
      ((civ (ev-dt->civil t)) (tod (ev-dt-tod t)))
      (str
        (ev-ical-pad4 (ev-civ-y civ))
        (ev-ical-pad2 (ev-civ-m civ))
        (ev-ical-pad2 (ev-civ-d civ))
        "T"
        (ev-ical-pad2 (quotient tod 60))
        (ev-ical-pad2 (modulo tod 60))
        "00"))))

;; A UTC epoch-minute as a UTC stamp (trailing Z).
(define ev-ical-dt (fn (t) (str (ev-ical-dt-stamp t) "Z")))

;; A local epoch-minute as a floating/local stamp (no Z) — used with TZID.
(define ev-ical-dt-local ev-ical-dt-stamp)

;; A UTC offset in minutes as "+HHMM" / "-HHMM".
(define
  ev-ical-offset
  (fn
    (mins)
    (let
      ((a (abs mins)))
      (str
        (if (< mins 0) "-" "+")
        (ev-ical-pad2 (quotient a 60))
        (ev-ical-pad2 (modulo a 60))))))

;; A duration in minutes as an iCal DURATION value (PT#H#M).
(define
  ev-ical-duration
  (fn
    (mins)
    (let
      ((h (quotient mins 60)) (m (modulo mins 60)))
      (cond
        ((and (> h 0) (> m 0)) (str "PT" h "H" m "M"))
        ((> h 0) (str "PT" h "H"))
        (else (str "PT" m "M"))))))

(define
  ev-ical-wd
  (fn (w) (ev-ical-nth (list "MO" "TU" "WE" "TH" "FR" "SA" "SU") w)))

(define
  ev-ical-freq
  (fn
    (f)
    (cond
      ((= f :daily) "DAILY")
      ((= f :weekly) "WEEKLY")
      ((= f :monthly) "MONTHLY")
      (else "DAILY"))))

;; One BYDAY token: a weekly weekday number -> "MO"; a monthly ordinal weekday
;; {:ord :wd} -> "2TU" / "-1FR".
(define
  ev-ical-byday-token
  (fn
    (e)
    (if
      (dict? e)
      (str (get e :ord) (ev-ical-wd (get e :wd)))
      (ev-ical-wd e))))

;; UNTIL converter: per RFC 5545, even a TZID DTSTART requires UNTIL in UTC, so
;; a tz event converts its (local) UNTIL to UTC; a non-tz event passes through.
(define
  ev-ical-conv
  (fn
    (event)
    (let
      ((tz (get event :tz)))
      (if (nil? tz) (fn (t) t) (fn (t) (ev-tz-local->utc tz t))))))

;; ---- VTIMEZONE ----
;; A tz event exports DTSTART;TZID=<name>:<local time> and the VCALENDAR carries
;; a VTIMEZONE block defining the zone's DST rules, so a client recurs at a
;; fixed WALL-CLOCK time (DST-correct) rather than fixed UTC.

;; A DST transition rule -> "FREQ=YEARLY;BYMONTH=<m>;BYDAY=<ord><WD>".
(define
  ev-ical-vtz-rrule
  (fn
    (rule)
    (str
      "FREQ=YEARLY;BYMONTH="
      (get rule :month)
      ";BYDAY="
      (get rule :ord)
      (ev-ical-wd (get rule :wd)))))

;; The transition's DTSTART (local time of the FROM offset) in a reference year.
(define
  ev-ical-vtz-dtstart
  (fn
    (rule from-offset)
    (let
      ((day (ev-resolve-nth-weekday 1970 (get rule :month) (get rule :ord) (get rule :wd))))
      (ev-ical-dt-local
        (+ (* (ev-days-from-civil 1970 (get rule :month) day) 1440)
          (get rule :time)
          from-offset)))))

;; The VTIMEZONE content lines for a zone (DAYLIGHT + STANDARD for :dst; a
;; single STANDARD for :fixed).
(define
  ev-ical-vtimezone
  (fn
    (tz)
    (if
      (= (get tz :kind) :dst)
      (let
        ((std (get tz :std-offset))
          (dst (get tz :dst-offset))
          (sr (get tz :dst-start))
          (er (get tz :dst-end)))
        (list
          "BEGIN:VTIMEZONE"
          (str "TZID:" (get tz :name))
          "BEGIN:DAYLIGHT"
          (str "DTSTART:" (ev-ical-vtz-dtstart sr std))
          (str "TZOFFSETFROM:" (ev-ical-offset std))
          (str "TZOFFSETTO:" (ev-ical-offset dst))
          (str "RRULE:" (ev-ical-vtz-rrule sr))
          "END:DAYLIGHT"
          "BEGIN:STANDARD"
          (str "DTSTART:" (ev-ical-vtz-dtstart er dst))
          (str "TZOFFSETFROM:" (ev-ical-offset dst))
          (str "TZOFFSETTO:" (ev-ical-offset std))
          (str "RRULE:" (ev-ical-vtz-rrule er))
          "END:STANDARD"
          "END:VTIMEZONE"))
      (list
        "BEGIN:VTIMEZONE"
        (str "TZID:" (get tz :name))
        "BEGIN:STANDARD"
        "DTSTART:19700101T000000"
        (str "TZOFFSETFROM:" (ev-ical-offset (get tz :offset)))
        (str "TZOFFSETTO:" (ev-ical-offset (get tz :offset)))
        "END:STANDARD"
        "END:VTIMEZONE"))))

;; ---- RRULE ----
(define
  ev-ical-rrule
  (fn
    (rrule conv)
    (let
      ((parts (list (str "FREQ=" (ev-ical-freq (get rrule :freq))))))
      (begin
        (when
          (and
            (not (nil? (get rrule :interval)))
            (> (get rrule :interval) 1))
          (append! parts (str "INTERVAL=" (get rrule :interval))))
        (when
          (not (nil? (get rrule :count)))
          (append! parts (str "COUNT=" (get rrule :count))))
        (when
          (not (nil? (get rrule :until)))
          (append! parts (str "UNTIL=" (ev-ical-dt (conv (get rrule :until))))))
        (when
          (not (nil? (get rrule :byday)))
          (append!
            parts
            (str
              "BYDAY="
              (ev-ical-join (map ev-ical-byday-token (get rrule :byday)) ","))))
        (when
          (not (nil? (get rrule :bymonthday)))
          (append!
            parts
            (str
              "BYMONTHDAY="
              (ev-ical-join
                (map (fn (d) (str d)) (get rrule :bymonthday))
                ","))))
        (str "RRULE:" (ev-ical-join parts ";"))))))

;; ---- VEVENT / VCALENDAR ----

;; The VEVENT content lines for an event (list of strings). A tz event uses
;; DTSTART;TZID=<name>:<local> (matched by a VTIMEZONE at the VCALENDAR level)
;; with EXDATE/RDATE in the same TZID-local form; UNTIL is always UTC. A non-tz
;; event uses UTC `Z` stamps throughout.
(define
  ev/event->ical-lines
  (fn
    (event)
    (let
      ((lines (list "BEGIN:VEVENT"))
        (conv (ev-ical-conv event))
        (tz (get event :tz)))
      (let
        ((dtparam (if (nil? tz) "" (str ";TZID=" (get tz :name))))
          (fmt (if (nil? tz) ev-ical-dt ev-ical-dt-local)))
        (begin
          (append! lines (str "UID:" (get event :id)))
          (append! lines (str "SUMMARY:" (get event :id)))
          (append! lines (str "DTSTART" dtparam ":" (fmt (get event :dtstart))))
          (append!
            lines
            (str "DURATION:" (ev-ical-duration (get event :duration))))
          (when
            (not (nil? (get event :rrule)))
            (append! lines (ev-ical-rrule (get event :rrule) conv)))
          (when
            (and
              (not (nil? (get event :exdate)))
              (> (len (get event :exdate)) 0))
            (append!
              lines
              (str
                "EXDATE"
                dtparam
                ":"
                (ev-ical-join (map fmt (get event :exdate)) ","))))
          (when
            (and
              (not (nil? (get event :rdate)))
              (> (len (get event :rdate)) 0))
            (append!
              lines
              (str
                "RDATE"
                dtparam
                ":"
                (ev-ical-join (map fmt (get event :rdate)) ","))))
          (append! lines "END:VEVENT")
          lines)))))

;; Collect the distinct timezones used by a list of events (by :name).
(define
  ev-ical-distinct-tzs
  (fn
    (events)
    (reduce
      (fn
        (acc ev)
        (let
          ((tz (get ev :tz)))
          (if
            (or (nil? tz) (ev-ical-tz-seen? acc (get tz :name)))
            acc
            (append acc (list tz)))))
      (list)
      events)))

(define
  ev-ical-tz-seen?
  (fn
    (tzs name)
    (cond
      ((empty? tzs) false)
      ((= (get (first tzs) :name) name) true)
      (else (ev-ical-tz-seen? (rest tzs) name)))))

;; A full VCALENDAR (list of content lines): a VTIMEZONE block for each distinct
;; zone the events reference, then every VEVENT.
(define
  ev/events->ical-lines
  (fn
    (events)
    (let
      ((lines (list "BEGIN:VCALENDAR" "VERSION:2.0" "PRODID:-//rose-ash//events-on-sx//EN")))
      (begin
        (for-each
          (fn
            (tz)
            (for-each (fn (l) (append! lines l)) (ev-ical-vtimezone tz)))
          (ev-ical-distinct-tzs events))
        (for-each
          (fn
            (ev)
            (for-each (fn (l) (append! lines l)) (ev/event->ical-lines ev)))
          events)
        (append! lines "END:VCALENDAR")
        lines))))

;; Render content lines to the on-the-wire iCalendar text (CRLF-separated).
(define ev/ical-render (fn (lines) (ev-ical-join lines "\r\n")))

;; ---- import (parse VEVENT/VCALENDAR back into events) ----
;; Inverse of the export above: parse iCalendar content lines into event dicts
;; (ev-event-full shape). Capacity is not an iCal property, so imported events
;; default to capacity 0 — set it after import if needed.

;; "20260601T180000Z" -> UTC epoch-minutes.
(define
  ev-ical-parse-dt
  (fn
    (s)
    (ev-dt
      (string->number (substring s 0 4))
      (string->number (substring s 4 6))
      (string->number (substring s 6 8))
      (string->number (substring s 9 11))
      (string->number (substring s 11 13)))))

;; "30M" / "" -> minutes.
(define
  ev-ical-parse-min
  (fn
    (s)
    (if (= (string-length s) 0) 0 (string->number (first (split s "M"))))))

;; "PT1H30M" / "PT1H" / "PT30M" -> minutes.
(define
  ev-ical-parse-duration
  (fn
    (s)
    (let
      ((body (substring s 2 (string-length s))))
      (let
        ((hparts (split body "H")))
        (if
          (> (len hparts) 1)
          (+ (* 60 (string->number (first hparts))) (ev-ical-parse-min (first (rest hparts))))
          (ev-ical-parse-min body))))))

(define
  ev-ical-wd->num
  (fn
    (tok)
    (cond
      ((= tok "MO") 0)
      ((= tok "TU") 1)
      ((= tok "WE") 2)
      ((= tok "TH") 3)
      ((= tok "FR") 4)
      ((= tok "SA") 5)
      ((= tok "SU") 6)
      (else 0))))

;; "MO" -> 0 ; "2TU" -> {:ord 2 :wd 1} ; "-1FR" -> {:ord -1 :wd 4}
(define
  ev-ical-parse-byday-token
  (fn
    (tok)
    (let
      ((n (string-length tok)))
      (if
        (= n 2)
        (ev-ical-wd->num tok)
        {:ord (string->number (substring tok 0 (- n 2)))
          :wd (ev-ical-wd->num (substring tok (- n 2) n))}))))

(define
  ev-ical-parse-freq
  (fn
    (v)
    (cond
      ((= v "DAILY") :daily)
      ((= v "WEEKLY") :weekly)
      ((= v "MONTHLY") :monthly)
      (else :daily))))

;; "FREQ=WEEKLY;INTERVAL=2;UNTIL=...;BYDAY=MO,WE" -> rrule dict.
(define
  ev-ical-parse-rrule
  (fn
    (val)
    (let
      ((rr {}))
      (begin
        (for-each
          (fn
            (p)
            (let
              ((kv (split p "=")))
              (let
                ((k (first kv)) (v (first (rest kv))))
                (cond
                  ((= k "FREQ") (dict-set! rr :freq (ev-ical-parse-freq v)))
                  ((= k "INTERVAL") (dict-set! rr :interval (string->number v)))
                  ((= k "COUNT") (dict-set! rr :count (string->number v)))
                  ((= k "UNTIL") (dict-set! rr :until (ev-ical-parse-dt v)))
                  ((= k "BYDAY") (dict-set! rr :byday (map ev-ical-parse-byday-token (split v ","))))
                  ((= k "BYMONTHDAY") (dict-set! rr :bymonthday (map string->number (split v ","))))
                  (else nil)))))
          (split val ";"))
        rr))))

;; Parse a VEVENT's content lines into an event dict.
(define
  ev/ical-lines->event
  (fn
    (lines)
    (let
      ((ev {:capacity 0 :rrule nil}) (exd (list)) (rd (list)))
      (begin
        (for-each
          (fn
            (line)
            (let
              ((kv (split line ":")))
              (when
                (> (len kv) 1)
                (let
                  ;; strip any property parameters (e.g. ";TZID=...") from the key
                  ((k (first (split (first kv) ";"))) (v (first (rest kv))))
                  (cond
                    ((= k "UID") (dict-set! ev :id (string->symbol v)))
                    ((= k "DTSTART") (dict-set! ev :dtstart (ev-ical-parse-dt v)))
                    ((= k "DURATION") (dict-set! ev :duration (ev-ical-parse-duration v)))
                    ((= k "RRULE") (dict-set! ev :rrule (ev-ical-parse-rrule v)))
                    ((= k "EXDATE") (set! exd (map ev-ical-parse-dt (split v ","))))
                    ((= k "RDATE") (set! rd (map ev-ical-parse-dt (split v ","))))
                    (else nil))))))
          lines)
        (dict-set! ev :exdate exd)
        (dict-set! ev :rdate rd)
        ev))))

;; Split a VCALENDAR line list into per-VEVENT line groups.
(define
  ev-ical-group-vevents
  (fn
    (lines cur in acc)
    (cond
      ((empty? lines) acc)
      ((= (first lines) "BEGIN:VEVENT") (ev-ical-group-vevents (rest lines) (list) true acc))
      ((= (first lines) "END:VEVENT") (ev-ical-group-vevents (rest lines) (list) false (append acc (list cur))))
      (in (ev-ical-group-vevents (rest lines) (append cur (list (first lines))) true acc))
      (else (ev-ical-group-vevents (rest lines) cur false acc)))))

;; Parse a VCALENDAR line list into a list of events.
(define
  ev/parse-vcalendar
  (fn
    (lines)
    (map ev/ical-lines->event (ev-ical-group-vevents lines (list) false (list)))))