src/sigil/caldav/ical.sgl

1;;; (sigil caldav ical) - iCalendar Parser and Generator

2;;;

3;;; Parses and generates iCalendar (RFC 5545) data. Provides an

4;;; ical-event struct for working with calendar events, and basic

5;;; recurrence expansion for DAILY, WEEKLY, and MONTHLY rules.

7(define-library (sigil caldav ical)

8 (import (sigil core)

9 (sigil math)

10 (sigil string)

11 (sigil struct)

12 (sigil crypto)

13 (sigil time))

15 (export

16 ;; Event struct

17 ical-event ical-event?

18 ical-event-uid ical-event-summary ical-event-description

19 ical-event-dtstart ical-event-dtend ical-event-location

20 ical-event-status ical-event-organizer ical-event-attendees

21 ical-event-created ical-event-last-modified

22 ical-event-all-day? ical-event-url ical-event-rrule

23 ical-event-recurrence-id

24 ical-event-calendar-name set-ical-event-calendar-name!

25 ical-event-timezone set-ical-event-timezone!

26 set-ical-event-summary! set-ical-event-description!

27 set-ical-event-dtstart! set-ical-event-dtend!

28 set-ical-event-location! set-ical-event-status!

29 set-ical-event-organizer! set-ical-event-attendees!

30 set-ical-event-url! set-ical-event-rrule!

32 ;; Attendee helpers

33 ical-attendee

34 ical-attendee-email

36 ;; Parsing and generation

37 ical-parse

38 ical-generate

39 generate-event-uid

41 ;; Date/time conversion

42 parse-ical-datetime

43 format-ical-datetime

44 format-ical-local-datetime

45 parse-ical-date

46 format-ical-date

48 ;; Recurrence

49 ical-expand-recurrence)

51 (begin

53 ;; ============================================================

54 ;; Event Struct

55 ;; ============================================================

57 (define-struct ical-event

58 (uid default: "unknown" mutable: #t)

59 (summary default: "" mutable: #t)

60 (description default: #f mutable: #t)

61 (dtstart default: #f mutable: #t)

62 (dtend default: #f mutable: #t)

63 (location default: #f mutable: #t)

64 (status default: #f mutable: #t)

65 (organizer default: #f mutable: #t)

66 (attendees default: '() mutable: #t)

67 (created default: #f mutable: #t)

68 (last-modified default: #f mutable: #t)

69 (all-day? default: #f mutable: #t)

70 (url default: #f mutable: #t)

71 (rrule default: #f mutable: #t)

72 (recurrence-id default: #f mutable: #t)

73 (calendar-name default: #f mutable: #t)

74 (timezone default: #f mutable: #t))

77 ;; ============================================================

78 ;; UTC Date/Time Conversion

79 ;; ============================================================

80 ;;

81 ;; Direct UTC <-> Unix timestamp conversion without localtime/mktime

82 ;; to avoid timezone issues.

84 (define (leap-year? y)

85 (and (zero? (modulo y 4))

86 (or (not (zero? (modulo y 100)))

87 (zero? (modulo y 400)))))

89 (define month-days #(0 31 28 31 30 31 30 31 31 30 31 30 31))

91 (define (days-in-month y m)

92 (if (and (= m 2) (leap-year? y))

93 29

94 (vector-ref month-days m)))

96 ;; Days from epoch (1970-01-01) to the start of a given year

97 (define (days-to-year y)

98 (let ((y1 (- y 1)))

99 (- (+ (* 365 (- y 1970))

100 (quotient y1 4)

101 (- (quotient y1 100))

102 (quotient y1 400))

103 ;; Subtract leap day counts for years before 1970

104 (+ (quotient 1969 4)

105 (- (quotient 1969 100))

106 (quotient 1969 400)))))

107

108 ;; Convert UTC year/month/day/hour/minute/second to Unix timestamp

109 (define (utc->timestamp y mo d h mi s)

110 (let loop ((m 1) (days (days-to-year y)))

111 (if (>= m mo)

112 (+ (* (+ days (- d 1)) 86400)

113 (* h 3600)

114 (* mi 60)

115 s)

116 (loop (+ m 1) (+ days (days-in-month y m))))))

117

118 ;; Convert Unix timestamp to UTC components (year month day hour minute second)

119 (define (timestamp->utc ts)

120 (let* ((total-days (quotient ts 86400))

121 (day-seconds (modulo ts 86400))

122 (h (quotient day-seconds 3600))

123 (mi (quotient (modulo day-seconds 3600) 60))

124 (s (modulo day-seconds 60)))

125 ;; Find year

126 (let year-loop ((y 1970) (remaining total-days))

127 (let ((year-days (if (leap-year? y) 366 365)))

128 (if (< remaining year-days)

129 ;; Find month

130 (let month-loop ((m 1) (r remaining))

131 (let ((md (days-in-month y m)))

132 (if (< r md)

133 (list y m (+ r 1) h mi s)

134 (month-loop (+ m 1) (- r md)))))

135 (year-loop (+ y 1) (- remaining year-days)))))))

136

137 ;;; Parse an iCalendar datetime string to a Unix timestamp.

138 ;;;

139 ;;; UTC datetimes (Z suffix) are interpreted as UTC.

140 ;;; Local datetimes (no Z) are interpreted in the given timezone,

141 ;;; or the system timezone if no timezone is provided.

142 ;;;

143 ;;; ```scheme

144 ;;; (parse-ical-datetime "20240315T090000Z") ; => UTC 09:00

145 ;;; (parse-ical-datetime "20240315T090000") ; => local 09:00

146 ;;; (parse-ical-datetime "20240315T090000" "America/New_York") ; => Eastern 09:00

147 ;;; ```

148 (define (parse-ical-datetime str . rest)

149 (: string? -> number?)

150 (let* ((tz (if (null? rest) #f (car rest)))

151 (utc? (string-ends-with? str "Z"))

152 (y (string->number (substring str 0 4)))

153 (mo (string->number (substring str 4 6)))

154 (d (string->number (substring str 6 8)))

155 (h (string->number (substring str 9 11)))

156 (mi (string->number (substring str 11 13)))

157 (s (string->number (substring str 13 15))))

158 (cond

159 (utc?

160 (utc->timestamp y mo d h mi s))

161 (tz

162 ;; Use the event's timezone for correct cross-timezone parsing

163 (list->time-in-tz (list s mi h d mo y) tz))

164 (else

165 ;; Local time: delegate to mktime for correct DST handling

166 (list->time (list s mi h d mo y))))))

167

168 ;;; Parse an iCalendar date string to a Unix timestamp.

169 ;;;

170 ;;; Returns midnight UTC on the given date.

171 ;;;

172 ;;; ```scheme

173 ;;; (parse-ical-date "20240315") ; => 1710460800

174 ;;; ```

175 (define (parse-ical-date str)

176 (: string? -> number?)

177 (let ((y (string->number (substring str 0 4)))

178 (mo (string->number (substring str 4 6)))

179 (d (string->number (substring str 6 8))))

180 (utc->timestamp y mo d 0 0 0)))

181

182 ;;; Format a Unix timestamp as an iCalendar UTC datetime string.

183 ;;;

184 ;;; ```scheme

185 ;;; (format-ical-datetime 1710493200) ; => "20240315T090000Z"

186 ;;; ```

187 (define (format-ical-datetime ts)

188 (: number? -> string?)

189 (let ((parts (timestamp->utc ts)))

190 (string-append (pad-digits (list-ref parts 0) 4)

191 (pad-digits (list-ref parts 1) 2)

192 (pad-digits (list-ref parts 2) 2)

193 "T"

194 (pad-digits (list-ref parts 3) 2)

195 (pad-digits (list-ref parts 4) 2)

196 (pad-digits (list-ref parts 5) 2)

197 "Z")))

198

199 ;;; Format a Unix timestamp as an iCalendar local datetime string.

200 ;;;

201 ;;; Uses the system timezone to produce local date/time components.

202 ;;; No Z suffix — intended for use with TZID parameters.

203 ;;;

204 ;;; ```scheme

205 ;;; (format-ical-local-datetime 1710493200) ; => "20240315T110000" (in EET)

206 ;;; ```

207 (define (format-ical-local-datetime ts)

208 (: number? -> string?)

209 (let* ((parts (time->list ts))

210 ;; time->list returns (second minute hour day month year ...)

211 (s (list-ref parts 0))

212 (mi (list-ref parts 1))

213 (h (list-ref parts 2))

214 (d (list-ref parts 3))

215 (mo (list-ref parts 4))

216 (y (list-ref parts 5)))

217 (string-append (pad-digits y 4)

218 (pad-digits mo 2)

219 (pad-digits d 2)

220 "T"

221 (pad-digits h 2)

222 (pad-digits mi 2)

223 (pad-digits s 2))))

224

225 ;;; Format a Unix timestamp as an iCalendar date string.

226 ;;;

227 ;;; ```scheme

228 ;;; (format-ical-date 1710460800) ; => "20240315"

229 ;;; ```

230 (define (format-ical-date ts)

231 (: number? -> string?)

232 (let ((parts (timestamp->utc ts)))

233 (string-append (pad-digits (list-ref parts 0) 4)

234 (pad-digits (list-ref parts 1) 2)

235 (pad-digits (list-ref parts 2) 2))))

236

237 (define (pad-digits n width)

238 (let ((s (number->string n)))

239 (if (< (string-length s) width)

240 (string-append (string-repeat "0" (- width (string-length s))) s)

241 s)))

242

243

244 ;; ============================================================

245 ;; iCalendar Parser

246 ;; ============================================================

247

248 ;; Unfold iCalendar line continuations.

249 ;; Lines starting with a space or tab are continuations of the previous line.

250 (define (unfold-lines text)

251 (let ((lines (string-split text "\n")))

252 (let loop ((remaining lines) (current #f) (result '()))

253 (if (null? remaining)

254 (reverse (if current (cons current result) result))

255 (let ((line (car remaining)))

256 ;; Strip trailing \r

257 (let ((line (if (and (> (string-length line) 0)

258 (char=? (string-ref line (- (string-length line) 1)) #\return))

259 (substring line 0 (- (string-length line) 1))

260 line)))

261 (cond

262 ;; Continuation line (starts with space or tab)

263 ((and (> (string-length line) 0)

264 current

265 (or (char=? (string-ref line 0) #\space)

266 (char=? (string-ref line 0) #\tab)))

267 (loop (cdr remaining)

268 (string-append current (substring line 1 (string-length line)))

269 result))

270 ;; New line

271 (else

272 (loop (cdr remaining)

273 line

274 (if current (cons current result) result))))))))))

275

276 ;; Parse a content line into (name params value)

277 ;; A content line has the form: NAME;PARAM1=VAL1;PARAM2=VAL2:VALUE

278 ;; or simply: NAME:VALUE

279 (define (parse-content-line line)

280 (let ((colon-pos (find-property-colon line)))

281 (if colon-pos

282 (let* ((before (substring line 0 colon-pos))

283 (value (substring line (+ colon-pos 1) (string-length line)))

284 (semi-pos (string-find before ";")))

285 (if semi-pos

286 (list (string-upcase (substring before 0 semi-pos))

287 (substring before (+ semi-pos 1) (string-length before))

288 value)

289 (list (string-upcase before) "" value)))

290 (list line "" ""))))

291

292 ;; Find the colon separating property name/params from value.

293 ;; Must skip colons inside quoted parameter values.

294 (define (find-property-colon line)

295 (let ((len (string-length line)))

296 (let loop ((i 0) (in-quotes? #f))

297 (if (>= i len)

298 #f

299 (let ((c (string-ref line i)))

300 (cond

301 ((char=? c #\") (loop (+ i 1) (not in-quotes?)))

302 ((and (char=? c #\:) (not in-quotes?)) i)

303 (else (loop (+ i 1) in-quotes?))))))))

304

305 ;; Parse a DTSTART or DTEND property, checking params for VALUE=DATE.

306 ;; RFC 5545 requires local-form datetimes to be interpreted in the

307 ;; accompanying TZID, not the system timezone.

308 (define (parse-dt-value params value)

309 (if (string-contains? (string-upcase params) "VALUE=DATE")

310 (cons (parse-ical-date value) #t)

311 (let ((tzid (extract-tzid params)))

312 (cons (parse-ical-datetime value tzid) #f))))

313

314 ;; Extract TZID value from parameter string, e.g. "TZID=Europe/Athens"

315 (define (extract-tzid params)

316 (if (and (string? params)

317 (string-contains? (string-upcase params) "TZID="))

318 (let* ((upper (string-upcase params))

319 (pos (string-find upper "TZID="))

320 (rest (substring params (+ pos 5) (string-length params)))

321 (semi (string-find rest ";")))

322 (if semi

323 (substring rest 0 semi)

324 rest))

325 #f))

326

327 ;; Extract a mailto: address, or return the raw value

328 (define (parse-cal-address value)

329 (if (string-starts-with? (string-downcase value) "mailto:")

330 (substring value 7 (string-length value))

331 value))

332

333 ;;; Create an attendee dict for use in ical-event attendees lists.

334 ;;;

335 ;;; ```scheme

336 ;;; (ical-attendee "[email protected]")

337 ;;; (ical-attendee "[email protected]" name: "Bob Smith")

338 ;;; ```

339 (define (ical-attendee email (keys: (name #f) (partstat "NEEDS-ACTION") (rsvp #t) (role "REQ-PARTICIPANT")))

340 (: string? (name: (maybe string?)) (partstat: string?) (rsvp: boolean?) (role: string?) -> dict?)

341 (let ((d (dict email: email partstat: partstat rsvp: rsvp role: role)))

342 (if name (dict-set d name: name) d)))

343

344 ;; Get the email from an attendee (string or dict)

345 (define (ical-attendee-email att)

346 (if (string? att) att (dict-ref att email:)))

347

348 ;; Parse iCal parameter string into an alist of key-value pairs.

349 ;; Input: "CN=Bob Smith;PARTSTAT=NEEDS-ACTION;RSVP=TRUE"

350 (define (parse-ical-params params-str)

351 (if (or (not params-str) (string=? params-str ""))

352 '()

353 (let ((parts (string-split params-str ";")))

354 (filter-map

355 (lambda (part)

356 (let ((eq-pos (string-find part "=")))

357 (if eq-pos

358 (cons (string-upcase (substring part 0 eq-pos))

359 (substring part (+ eq-pos 1) (string-length part)))

360 #f)))

361 parts))))

362

363 ;; Build an attendee dict from parsed iCal params and mailto value

364 (define (build-attendee params value)

365 (let* ((email (parse-cal-address value))

366 (param-alist (parse-ical-params params))

367 (cn (let ((p (assoc "CN" param-alist)))

368 (if p (cdr p) #f)))

369 (partstat (let ((p (assoc "PARTSTAT" param-alist)))

370 (if p (cdr p) #f)))

371 (rsvp (let ((p (assoc "RSVP" param-alist)))

372 (if p (equal? (string-upcase (cdr p)) "TRUE") #f)))

373 (role (let ((p (assoc "ROLE" param-alist)))

374 (if p (cdr p) #f)))

375 (d (dict email: email)))

376 (let* ((d (if cn (dict-set d name: cn) d))

377 (d (if partstat (dict-set d partstat: partstat) d))

378 (d (if rsvp (dict-set d rsvp: rsvp) d))

379 (d (if role (dict-set d role: role) d)))

380 d)))

381

382 ;;; Parse an iCalendar string into a list of ical-event structs.

383 ;;;

384 ;;; Extracts all VEVENT components from the VCALENDAR. Properties

385 ;;; not directly mapped to struct fields are ignored.

386 ;;;

387 ;;; ```scheme

388 ;;; (define events (ical-parse ical-string))

389 ;;; (ical-event-summary (car events)) ; => "Team Meeting"

390 ;;; ```

391 (define (ical-parse text)

392 (: string? -> list?)

393 (let ((lines (unfold-lines text)))

394 (let loop ((remaining lines) (in-event? #f) (props '()) (events '()))

395 (if (null? remaining)

396 (reverse events)

397 (let* ((parsed (parse-content-line (car remaining)))

398 (name (car parsed))

399 (params (cadr parsed))

400 (value (caddr parsed)))

401 (cond

402 ((equal? name "BEGIN")

403 (if (equal? (string-upcase value) "VEVENT")

404 (loop (cdr remaining) #t '() events)

405 (loop (cdr remaining) in-event? props events)))

406 ((and in-event? (equal? name "END")

407 (equal? (string-upcase value) "VEVENT"))

408 (loop (cdr remaining) #f '()

409 (cons (build-event props) events)))

410 (in-event?

411 (loop (cdr remaining) #t

412 (cons (list name params value) props)

413 events))

414 (else

415 (loop (cdr remaining) in-event? props events))))))))

416

417 ;; Build an ical-event from a list of (name params value) property triples

418 (define (build-event props)

419 (let ((ev (ical-event uid: "unknown")))

420 (for-each

421 (lambda (prop)

422 (let ((name (car prop))

423 (params (cadr prop))

424 (value (caddr prop)))

425 (cond

426 ((equal? name "UID")

427 (set-ical-event-uid! ev value))

428 ((equal? name "SUMMARY")

429 (set-ical-event-summary! ev value))

430 ((equal? name "DESCRIPTION")

431 (set-ical-event-description! ev value))

432 ((equal? name "DTSTART")

433 (let ((dt (parse-dt-value params value)))

434 (set-ical-event-dtstart! ev (car dt))

435 (when (cdr dt)

436 (set-ical-event-all-day?! ev #t))

437 (let ((tzid (extract-tzid params)))

438 (when tzid

439 (set-ical-event-timezone! ev tzid)))))

440 ((equal? name "DTEND")

441 (let ((dt (parse-dt-value params value)))

442 (set-ical-event-dtend! ev (car dt))))

443 ((equal? name "LOCATION")

444 (set-ical-event-location! ev value))

445 ((equal? name "STATUS")

446 (set-ical-event-status! ev value))

447 ((equal? name "ORGANIZER")

448 (set-ical-event-organizer! ev (parse-cal-address value)))

449 ((equal? name "ATTENDEE")

450 (set-ical-event-attendees! ev

451 (cons (build-attendee params value)

452 (ical-event-attendees ev))))

453 ((equal? name "CREATED")

454 (set-ical-event-created! ev (parse-ical-datetime value)))

455 ((equal? name "LAST-MODIFIED")

456 (set-ical-event-last-modified! ev (parse-ical-datetime value)))

457 ((equal? name "RRULE")

458 (set-ical-event-rrule! ev value))

459 ((equal? name "RECURRENCE-ID")

460 (let ((dt (parse-dt-value params value)))

461 (set-ical-event-recurrence-id! ev (car dt)))))))

462 props)

463 ev))

464

465

466 ;; ============================================================

467 ;; iCalendar Generator

468 ;; ============================================================

469

470 ;; Fold a long content line at 75 octets per RFC 5545

471 (define (fold-line line)

472 (if (<= (string-length line) 75)

473 line

474 (let loop ((remaining line) (parts '()))

475 (if (<= (string-length remaining) 75)

476 (string-join (reverse (cons remaining parts)) "\r\n ")

477 (loop (substring remaining 75 (string-length remaining))

478 (cons (substring remaining 0 75) parts))))))

479

480 ;; Emit a content line, folded if necessary

481 (define (emit-line name value)

482 (fold-line (string-append name ":" value)))

483

484 ;;; Generate an iCalendar string from an ical-event struct.

485 ;;;

486 ;;; Produces a complete VCALENDAR containing a single VEVENT.

487 ;;;

488 ;;; ```scheme

489 ;;; (define ics (ical-generate event))

490 ;;; ;; => "BEGIN:VCALENDAR\r\nVERSION:2.0\r\n..."

491 ;;; ```

492 (define (ical-generate event)

493 (: ical-event? -> string?)

494 (let ((lines '()))

495 (define (add! line) (set! lines (cons line lines)))

496

497 (add! "BEGIN:VCALENDAR")

498 (add! "VERSION:2.0")

499 (add! "PRODID:-//Sigil//CalDAV Client//EN")

500 (add! "BEGIN:VEVENT")

501 (add! (emit-line "UID" (ical-event-uid event)))

502

503 ;; Date/time

504 (let ((tz (ical-event-timezone event)))

505 (when (ical-event-dtstart event)

506 (cond

507 ((ical-event-all-day? event)

508 (add! (emit-line "DTSTART;VALUE=DATE"

509 (format-ical-date (ical-event-dtstart event)))))

510 (tz

511 (add! (emit-line (string-append "DTSTART;TZID=" tz)

512 (format-ical-local-datetime (ical-event-dtstart event)))))

513 (else

514 (add! (emit-line "DTSTART"

515 (format-ical-datetime (ical-event-dtstart event)))))))

516 (when (ical-event-dtend event)

517 (cond

518 ((ical-event-all-day? event)

519 (add! (emit-line "DTEND;VALUE=DATE"

520 (format-ical-date (ical-event-dtend event)))))

521 (tz

522 (add! (emit-line (string-append "DTEND;TZID=" tz)

523 (format-ical-local-datetime (ical-event-dtend event)))))

524 (else

525 (add! (emit-line "DTEND"

526 (format-ical-datetime (ical-event-dtend event))))))))

527

528 ;; Text properties

529 (when (not (string-empty? (ical-event-summary event)))

530 (add! (emit-line "SUMMARY" (ical-event-summary event))))

531 (when (ical-event-description event)

532 (add! (emit-line "DESCRIPTION" (ical-event-description event))))

533 (when (ical-event-location event)

534 (add! (emit-line "LOCATION" (ical-event-location event))))

535 (when (ical-event-status event)

536 (add! (emit-line "STATUS" (ical-event-status event))))

537

538 ;; People

539 (when (ical-event-organizer event)

540 (add! (emit-line "ORGANIZER"

541 (string-append "mailto:" (ical-event-organizer event)))))

542 (for-each

543 (lambda (attendee)

544 (if (string? attendee)

545 ;; Plain email string (backward compat)

546 (add! (emit-line "ATTENDEE"

547 (string-append "mailto:" attendee)))

548 ;; Dict with parameters

549 (let* ((email (dict-ref attendee email:))

550 (params '())

551 (_ (let ((v (dict-ref attendee role: #f)))

552 (when v (set! params (cons (string-append "ROLE=" v) params)))))

553 (_ (let ((v (dict-ref attendee rsvp: #f)))

554 (when v (set! params (cons "RSVP=TRUE" params)))))

555 (_ (let ((v (dict-ref attendee partstat: #f)))

556 (when v (set! params (cons (string-append "PARTSTAT=" v) params)))))

557 (_ (let ((v (dict-ref attendee name: #f)))

558 (when v (set! params (cons (string-append "CN=" v) params)))))

559 (prop-name (if (null? params)

560 "ATTENDEE"

561 (string-append "ATTENDEE;" (string-join params ";")))))

562 (add! (emit-line prop-name

563 (string-append "mailto:" email))))))

564 (ical-event-attendees event))

565

566 ;; Timestamps

567 (when (ical-event-created event)

568 (add! (emit-line "CREATED"

569 (format-ical-datetime (ical-event-created event)))))

570 (when (ical-event-last-modified event)

571 (add! (emit-line "LAST-MODIFIED"

572 (format-ical-datetime (ical-event-last-modified event)))))

573

574 ;; Recurrence

575 (when (ical-event-rrule event)

576 (add! (emit-line "RRULE" (ical-event-rrule event))))

577 (when (ical-event-recurrence-id event)

578 (add! (emit-line "RECURRENCE-ID"

579 (format-ical-datetime (ical-event-recurrence-id event)))))

580

581 (add! "END:VEVENT")

582 (add! "END:VCALENDAR")

583

584 (string-join (reverse lines) "\r\n")))

585

586

587 ;; ============================================================

588 ;; UID Generation

589 ;; ============================================================

590

591 ;;; Generate a unique event UID string.

592 ;;;

593 ;;; Produces a UUID-like identifier suitable for iCalendar UID fields.

594 ;;;

595 ;;; ```scheme

596 ;;; (generate-event-uid) ; => "a1b2c3d4-e5f6-7890-abcd-ef1234567890"

597 ;;; ```

598 (define (generate-event-uid)

599 (: -> string?)

600 (let ((bytes (random-bytes 16)))

601 (string-append

602 (bytes->hex bytes 0 4) "-"

603 (bytes->hex bytes 4 6) "-"

604 (bytes->hex bytes 6 8) "-"

605 (bytes->hex bytes 8 10) "-"

606 (bytes->hex bytes 10 16))))

607

608 (define (byte->hex b)

609 (let ((s (number->string b 16)))

610 (if (< (string-length s) 2)

611 (string-append "0" s)

612 s)))

613

614 (define (bytes->hex bv start end)

615 (let loop ((i start) (acc ""))

616 (if (>= i end)

617 acc

618 (loop (+ i 1)

619 (string-append acc (byte->hex (bytevector-u8-ref bv i)))))))

620

621

622 ;; ============================================================

623 ;; Recurrence Expansion

624 ;; ============================================================

625

626 ;; Parse an RRULE string into a dict-like alist

627 ;; e.g. "FREQ=WEEKLY;BYDAY=MO,WE,FR;COUNT=10"

628 (define (parse-rrule rrule-str)

629 (let ((parts (string-split rrule-str ";")))

630 (map (lambda (part)

631 (let ((eq-pos (string-find part "=")))

632 (if eq-pos

633 (cons (substring part 0 eq-pos)

634 (substring part (+ eq-pos 1) (string-length part)))

635 (cons part ""))))

636 parts)))

637

638 (define (rrule-ref rrule key)

639 (let ((pair (assoc key rrule)))

640 (if pair (cdr pair) #f)))

641

642 ;; Day-of-week abbreviation to number (0=Sunday)

643 (define (day-abbrev->number abbrev)

644 (cond

645 ((equal? abbrev "SU") 0)

646 ((equal? abbrev "MO") 1)

647 ((equal? abbrev "TU") 2)

648 ((equal? abbrev "WE") 3)

649 ((equal? abbrev "TH") 4)

650 ((equal? abbrev "FR") 5)

651 ((equal? abbrev "SA") 6)

652 (else #f)))

653

654 ;; Get the day of week (0=Sunday) for a Unix timestamp.

655 ;; Operates on the UTC value directly; for TZID-tagged events, callers

656 ;; should pass a wall-as-UTC instant via wall->wall-as-utc so the local

657 ;; calendar day is what gets classified.

658 (define (timestamp-weekday ts)

659 ;; 1970-01-01 was a Thursday (4)

660 (modulo (+ (quotient ts 86400) 4) 7))

661

662 ;; Add N days to a timestamp (UTC arithmetic).

663 (define (add-days ts n)

664 (+ ts (* n 86400)))

665

666 ;; Add N months to a UTC date, keeping the same day (clamped to month end)

667 (define (add-months ts n)

668 (let* ((parts (timestamp->utc ts))

669 (y (list-ref parts 0))

670 (m (list-ref parts 1))

671 (d (list-ref parts 2))

672 (h (list-ref parts 3))

673 (mi (list-ref parts 4))

674 (s (list-ref parts 5))

675 (total-months (+ (* y 12) (- m 1) n))

676 (new-y (quotient total-months 12))

677 (new-m (+ (modulo total-months 12) 1))

678 (max-d (days-in-month new-y new-m))

679 (new-d (min d max-d)))

680 (utc->timestamp new-y new-m new-d h mi s)))

681

682 ;; ----------------------------------------------------------------

683 ;; TZID-aware date arithmetic

684 ;;

685 ;; Recurring events tagged with a TZID anchor each occurrence to a

686 ;; fixed wall-clock in that tz. Walking the recurrence by adding

687 ;; 86400-second multiples in UTC drifts the wall-clock by the DST

688 ;; shift across spring/fall transitions. The helpers below walk by

689 ;; wall-clock components in the tz and re-resolve to UTC at each

690 ;; step via list->time-in-tz so the OS zoneinfo provides the

691 ;; correct offset for the occurrence's actual fire date.

692 ;;

693 ;; The conversion utc-instant->wall uses a single round-trip

694 ;; through list->time-in-tz to derive wall components without

695 ;; needing a `time->list-in-tz` native. The math:

696 ;; sys-wall = decompose(ts + sys-offset(ts))

697 ;; try-ts = compose(sys-wall, tz) ; treats sys-wall as wall-in-tz

698 ;; delta = try-ts - ts ; = sys-offset - tz-offset

699 ;; wall-in-tz = decompose((ts - delta) + sys-offset(ts - delta))

700 ;; = decompose(ts + tz-offset(ts)) QED

701 ;; ----------------------------------------------------------------

702

703 ;; Take the first 6 components of (time->list ts) — (s mi h d mo y).

704 (define (time-wall-components ts)

705 (let ((parts (time->list ts)))

706 (list (list-ref parts 0) (list-ref parts 1) (list-ref parts 2)

707 (list-ref parts 3) (list-ref parts 4) (list-ref parts 5))))

708

709 ;; Decompose a UTC instant into (s mi h d mo y) as observed in tz.

710 (define (utc-instant->wall ts tz)

711 (if (not tz)

712 (time-wall-components ts)

713 (let* ((sys-wall (time-wall-components ts))

714 (try-ts (list->time-in-tz sys-wall tz))

715 (delta (- try-ts ts)))

716 (time-wall-components (- ts delta)))))

717

718 ;; Wall-clock (s mi h d mo y) -> Unix instant whose decomposition

719 ;; in 'utc->timestamp' would give those components. Used as a

720 ;; canonical key for date arithmetic — the "wall instant" is

721 ;; not a real UTC instant, just a positional encoding of the

722 ;; wall-clock that lets us add days/weeks/months with the

723 ;; existing arithmetic.

724 (define (wall-as-utc-instant wall)

725 (utc->timestamp (list-ref wall 5) (list-ref wall 4) (list-ref wall 3)

726 (list-ref wall 2) (list-ref wall 1) (list-ref wall 0)))

727

728 ;; Inverse of wall-as-utc-instant: decompose to (s mi h d mo y).

729 (define (utc-instant->wall-components t)

730 (let ((parts (timestamp->utc t)))

731 (list (list-ref parts 5) (list-ref parts 4) (list-ref parts 3)

732 (list-ref parts 2) (list-ref parts 1) (list-ref parts 0))))

733

734 ;; Resolve wall components in tz back to a real UTC instant.

735 (define (wall->utc wall tz)

736 (if tz

737 (list->time-in-tz wall tz)

738 (list->time wall)))

739

740 ;; TZID-aware add-days. Returns a real UTC instant whose wall-clock

741 ;; in tz is the master's wall-clock advanced by n calendar days.

742 (define (add-days-in-tz ts n tz)

743 (if (not tz)

744 (add-days ts n)

745 (let* ((wall (utc-instant->wall ts tz))

746 (anchor (wall-as-utc-instant wall))

747 (advanced (+ anchor (* n 86400)))

748 (new-wall (utc-instant->wall-components advanced)))

749 (wall->utc new-wall tz))))

750

751 ;; TZID-aware add-months. Same idea, calendar-month math on the wall.

752 (define (add-months-in-tz ts n tz)

753 (if (not tz)

754 (add-months ts n)

755 (let* ((wall (utc-instant->wall ts tz))

756 (s (list-ref wall 0))

757 (mi (list-ref wall 1))

758 (h (list-ref wall 2))

759 (d (list-ref wall 3))

760 (mo (list-ref wall 4))

761 (y (list-ref wall 5))

762 (total-months (+ (* y 12) (- mo 1) n))

763 (new-y (quotient total-months 12))

764 (new-mo (+ (modulo total-months 12) 1))

765 (max-d (days-in-month new-y new-mo))

766 (new-d (min d max-d)))

767 (wall->utc (list s mi h new-d new-mo new-y) tz))))

768

769 ;; Day-of-week for a real UTC instant as observed in tz.

770 (define (timestamp-weekday-in-tz ts tz)

771 (if (not tz)

772 (timestamp-weekday ts)

773 (timestamp-weekday (wall-as-utc-instant (utc-instant->wall ts tz)))))

774

775 ;;; Expand a recurring event into individual occurrences within a date range.

776 ;;;

777 ;;; Supports FREQ=DAILY, FREQ=WEEKLY (with BYDAY), and FREQ=MONTHLY

778 ;;; (with BYMONTHDAY). Honors COUNT and UNTIL limits. INTERVAL defaults

779 ;;; to 1 if not specified.

780 ;;;

781 ;;; Returns a list of ical-event copies with adjusted dtstart/dtend

782 ;;; and recurrence-id set to the original dtstart.

783 ;;;

784 ;;; ```scheme

785 ;;; (define weekly (ical-event uid: "1" summary: "Standup"

786 ;;; dtstart: 1710489600 dtend: 1710493200

787 ;;; rrule: "FREQ=WEEKLY;BYDAY=MO,WE,FR;COUNT=6"))

788 ;;; (length (ical-expand-recurrence weekly

789 ;;; start: 1710489600 end: 1711699200))

790 ;;; ```

791 (define (ical-expand-recurrence event (keys: (start #f) (end #f)))

792 (: ical-event? (start: (maybe number?)) (end: (maybe number?)) -> list?)

793 (let ((rrule-str (ical-event-rrule event)))

794 (if (not rrule-str)

795 (list event)

796 (let* ((rrule (parse-rrule rrule-str))

797 (freq (rrule-ref rrule "FREQ"))

798 (interval (let ((v (rrule-ref rrule "INTERVAL")))

799 (if v (string->number v) 1)))

800 (count (let ((v (rrule-ref rrule "COUNT")))

801 (if v (string->number v) #f)))

802 (until (let ((v (rrule-ref rrule "UNTIL")))

803 (if v (parse-ical-datetime v) #f)))

804 (ev-start (ical-event-dtstart event))

805 (duration (if (ical-event-dtend event)

806 (- (ical-event-dtend event) ev-start)

807 3600))

808 ;; All-day events have date-only DTSTART (no TZID

809 ;; semantics); UTC-anchored events ignore TZID by spec.

810 ;; Only honor the tz for timed events whose DTSTART

811 ;; carried a TZID parameter.

812 (tz (and (not (ical-event-all-day? event))

813 (ical-event-timezone event))))

814 (cond

815 ((equal? freq "DAILY")

816 (expand-daily event ev-start duration interval count until start end tz))

817 ((equal? freq "WEEKLY")

818 (let ((byday (rrule-ref rrule "BYDAY")))

819 (expand-weekly event ev-start duration interval count until

820 (if byday (string-split byday ",") '())

821 start end tz)))

822 ((equal? freq "MONTHLY")

823 (expand-monthly event ev-start duration interval count until start end tz))

824 (else (list event)))))))

825

826 ;; Clone an event with a new dtstart/dtend

827 (define (clone-event event new-start duration)

828 (let ((ev (ical-event

829 uid: (ical-event-uid event)

830 summary: (ical-event-summary event)

831 description: (ical-event-description event)

832 dtstart: new-start

833 dtend: (+ new-start duration)

834 location: (ical-event-location event)

835 status: (ical-event-status event)

836 organizer: (ical-event-organizer event)

837 attendees: (ical-event-attendees event)

838 all-day?: (ical-event-all-day? event)

839 url: (ical-event-url event)

840 rrule: (ical-event-rrule event)

841 recurrence-id: new-start

842 calendar-name: (ical-event-calendar-name event)

843 timezone: (ical-event-timezone event))))

844 ev))

845

846 ;; Check if a timestamp is within the query range

847 (define (in-range? ts start end)

848 (and (or (not start) (>= ts start))

849 (or (not end) (< ts end))))

850

851 ;; Maximum instances to generate (safety limit)

852 (define MAX-INSTANCES 1000)

853

854 (define (expand-daily event ev-start duration interval count until range-start range-end tz)

855 (let loop ((ts ev-start) (n 0) (results '()))

856 (cond

857 ((and count (>= n count)) (reverse results))

858 ((and until (> ts until)) (reverse results))

859 ((and range-end (> ts range-end)) (reverse results))

860 ((>= n MAX-INSTANCES) (reverse results))

861 (else

862 (let ((next (add-days-in-tz ts interval tz)))

863 (if (in-range? ts range-start range-end)

864 (loop next (+ n 1) (cons (clone-event event ts duration) results))

865 (loop next (+ n 1) results)))))))

866

867 (define (expand-weekly event ev-start duration interval count until byday range-start range-end tz)

868 (let ((target-days (if (null? byday)

869 (list (timestamp-weekday-in-tz ev-start tz))

870 (let loop ((rest byday) (acc '()))

871 (if (null? rest)

872 (reverse acc)

873 (let ((n (day-abbrev->number (car rest))))

874 (loop (cdr rest)

875 (if n (cons n acc) acc))))))))

876 (let loop ((ts ev-start) (n 0) (results '()))

877 (cond

878 ((and count (>= n count)) (reverse results))

879 ((and until (> ts until)) (reverse results))

880 ((and range-end (> ts range-end)) (reverse results))

881 ((>= n MAX-INSTANCES) (reverse results))

882 (else

883 ;; Walk day by day within each week period

884 (let week-loop ((day-ts ts) (day-offset 0) (n n) (results results))

885 (cond

886 ((>= day-offset 7)

887 ;; Move to next week (skip by interval)

888 (loop (add-days-in-tz ts (* interval 7) tz) n results))

889 ((and count (>= n count)) (reverse results))

890 ((and until (> day-ts until)) (reverse results))

891 ((and range-end (> day-ts range-end)) (reverse results))

892 (else

893 (if (memv (timestamp-weekday-in-tz day-ts tz) target-days)

894 (if (in-range? day-ts range-start range-end)

895 (week-loop (add-days-in-tz day-ts 1 tz) (+ day-offset 1) (+ n 1)

896 (cons (clone-event event day-ts duration) results))

897 (week-loop (add-days-in-tz day-ts 1 tz) (+ day-offset 1) (+ n 1) results))

898 (week-loop (add-days-in-tz day-ts 1 tz) (+ day-offset 1) n results))))))))))

899

900 (define (expand-monthly event ev-start duration interval count until range-start range-end tz)

901 (let loop ((ts ev-start) (month-offset 0) (n 0) (results '()))

902 (cond

903 ((and count (>= n count)) (reverse results))

904 ((and until (> ts until)) (reverse results))

905 ((and range-end (> ts range-end)) (reverse results))

906 ((>= n MAX-INSTANCES) (reverse results))

907 (else

908 (if (in-range? ts range-start range-end)

909 (loop (add-months-in-tz ev-start (+ month-offset interval) tz)

910 (+ month-offset interval) (+ n 1)

911 (cons (clone-event event ts duration) results))

912 (loop (add-months-in-tz ev-start (+ month-offset interval) tz)

913 (+ month-offset interval) (+ n 1)

914 results))))))

915

916 ))