Commit568a9a36Recorded2 Mar 2026Repositorysigil-caldav
Add CalDAV calendar client package (sigil-caldav)
Message
New package providing a CalDAV (RFC 4791) client for interacting with calendar servers like Fastmail, Nextcloud, and Radicale. Includes iCalendar (RFC 5545) parsing and generation with basic recurrence expansion for DAILY, WEEKLY, and MONTHLY rules.
Modules: - (sigil caldav client) - connection, auth, discovery, WebDAV transport - (sigil caldav ical) - iCalendar parser/generator, UTC datetime handling - (sigil caldav calendar) - calendar listing, creation, deletion - (sigil caldav event) - event CRUD with time-range queries - (sigil caldav) - umbrella re-export module
Changed
CHANGELOG.md | 5 ++
package.sgl | 18 +++++
src/sigil/caldav.sgl | 77 +++++++++++++++++++
src/sigil/caldav/calendar.sgl | 164 ++++++++++++++++++++++++++++++++++++++++
src/sigil/caldav/client.sgl | 314 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/caldav/event.sgl | 241 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/caldav/ical.sgl | 666 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-caldav.sgl | 316 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8 files changed, 1801 insertions(+)Diff
CHANGELOG.mdadded
@@ -0,0 +1,5 @@
+1
# sigil-caldav+2
+3
## 0.8.0+4
+5
- Initial release with CalDAV client, iCalendar parsing/generation, calendar and event operationspackage.sgladded
@@ -0,0 +1,18 @@
+1
;;; sigil-caldav - CalDAV Calendar Client Library+2
;;;+3
;;; Provides a CalDAV (RFC 4791) client for interacting with+4
;;; calendar servers like Fastmail, Nextcloud, and Radicale.+5
+6
(package+7
name: "sigil-caldav"+8
version: "0.8.0"+9
description: "CalDAV calendar client library for Sigil"+10
url: "https://codeberg.org/sigil/sigil"+11
license: "BSD-3-Clause"+12
authors: (list "David Wilson <[email protected]>")+13
+14
dependencies: (list+15
(from-workspace name: "sigil-stdlib")+16
(from-workspace name: "sigil-http")+17
(from-workspace name: "sigil-sxml")+18
(from-workspace name: "sigil-crypto")))src/sigil/caldav.sgladded
@@ -0,0 +1,77 @@
+1
;;; (sigil caldav) - CalDAV Calendar Client Library+2
;;;+3
;;; Provides a CalDAV (RFC 4791) client for interacting with calendar+4
;;; servers like Fastmail, Nextcloud, and Radicale. Includes iCalendar+5
;;; (RFC 5545) parsing and generation with basic recurrence expansion.+6
;;;+7
;;; ```scheme+8
;;; (import (sigil caldav))+9
;;;+10
;;; (define client (caldav-connect+11
;;; url: "https://caldav.fastmail.com"+12
;;; username: "[email protected]"+13
;;; password: "app-password"))+14
;;;+15
;;; ;; List calendars+16
;;; (map (lambda (c) (dict-ref c name:))+17
;;; (caldav-calendars client))+18
;;;+19
;;; ;; Query this week's events+20
;;; (define cal (car (caldav-calendars client)))+21
;;; (caldav-events client+22
;;; calendar-href: (dict-ref cal href:)+23
;;; start: (current-second)+24
;;; end: (+ (current-second) (* 7 86400)))+25
;;;+26
;;; ;; Create an event+27
;;; (caldav-event-create! client+28
;;; calendar-href: (dict-ref cal href:)+29
;;; summary: "Meeting with Alice"+30
;;; dtstart: 1710493200+31
;;; dtend: 1710496800+32
;;; description: "Discuss project roadmap")+33
;;; ```+34
+35
(define-library (sigil caldav)+36
(import (sigil caldav client)+37
(sigil caldav ical)+38
(sigil caldav calendar)+39
(sigil caldav event))+40
+41
(export+42
;; Client (from sigil caldav client)+43
caldav-client caldav-client?+44
caldav-client-base-url caldav-client-auth-header+45
caldav-client-principal-url caldav-client-calendar-home+46
caldav-connect+47
+48
;; iCalendar (from sigil caldav ical)+49
ical-event ical-event?+50
ical-event-uid ical-event-summary ical-event-description+51
ical-event-dtstart ical-event-dtend ical-event-location+52
ical-event-status ical-event-organizer ical-event-attendees+53
ical-event-created ical-event-last-modified+54
ical-event-all-day? ical-event-url ical-event-rrule+55
ical-event-recurrence-id+56
set-ical-event-summary! set-ical-event-description!+57
set-ical-event-dtstart! set-ical-event-dtend!+58
set-ical-event-location! set-ical-event-status!+59
set-ical-event-url! set-ical-event-rrule!+60
ical-parse ical-generate+61
generate-event-uid+62
parse-ical-datetime format-ical-datetime+63
parse-ical-date format-ical-date+64
ical-expand-recurrence+65
+66
;; Calendar (from sigil caldav calendar)+67
caldav-calendars+68
caldav-calendar-by-name+69
caldav-calendar-create!+70
caldav-calendar-delete!+71
+72
;; Event (from sigil caldav event)+73
caldav-events+74
caldav-event-get+75
caldav-event-create!+76
caldav-event-update!+77
caldav-event-delete!))src/sigil/caldav/calendar.sgladded
@@ -0,0 +1,164 @@
+1
;;; (sigil caldav calendar) - Calendar Listing and Management+2
;;;+3
;;; List, find, create, and delete calendars on a CalDAV server.+4
+5
(define-library (sigil caldav calendar)+6
(import (sigil core)+7
(sigil string)+8
(sigil sxml)+9
(sigil http client)+10
(sigil caldav client))+11
+12
(export+13
caldav-calendars+14
caldav-calendar-by-name+15
caldav-calendar-create!+16
caldav-calendar-delete!)+17
+18
(begin+19
+20
;; ============================================================+21
;; Calendar Listing+22
;; ============================================================+23
+24
;;; List all calendars on the server.+25
;;;+26
;;; Returns a list of dicts with keys: `href:`, `name:`,+27
;;; `description:`, `color:`, `ctag:`.+28
;;;+29
;;; ```scheme+30
;;; (define cals (caldav-calendars client))+31
;;; (map (lambda (c) (dict-ref c name:)) cals)+32
;;; ```+33
(define (caldav-calendars client)+34
(: caldav-client? -> list?)+35
(let* ((home (caldav-client-calendar-home client))+36
(response (caldav-propfind client home+37
'(d:propfind (@ (xmlns:d "DAV:")+38
(xmlns:cal "urn:ietf:params:caldav")+39
(xmlns:cs "http://calendarserver.org/ns/")+40
(xmlns:ic "http://apple.com/ns/ical/"))+41
(d:prop+42
(d:displayname)+43
(d:resourcetype)+44
(cal:calendar-description)+45
(ic:calendar-color)+46
(cs:getctag)))+47
depth: "1"))+48
(entries (parse-multistatus response)))+49
;; Filter to only calendar collections (have d:resourcetype+50
;; containing cal:calendar), and skip the home collection itself+51
(let loop ((remaining entries) (calendars '()))+52
(if (null? remaining)+53
(reverse calendars)+54
(let ((entry (car remaining)))+55
(if (calendar-resource? entry)+56
(loop (cdr remaining)+57
(cons (normalize-calendar entry) calendars))+58
(loop (cdr remaining) calendars)))))))+59
+60
;; Check if a multistatus entry represents a calendar collection+61
(define (calendar-resource? entry)+62
(let ((rt (dict-ref entry (string->keyword "d:resourcetype") #f)))+63
(and rt (pair? rt)+64
(let loop ((items rt))+65
(cond+66
((null? items) #f)+67
((and (pair? (car items))+68
(let ((tag (symbol->string (car (car items)))))+69
(or (equal? tag "cal:calendar")+70
(string-contains? tag "calendar"))))+71
#t)+72
(else (loop (cdr items))))))))+73
+74
;; Normalize a multistatus entry into a clean calendar dict+75
(define (normalize-calendar entry)+76
(dict+77
href: (dict-ref entry href: "")+78
name: (or (dict-ref entry (string->keyword "d:displayname") #f) "")+79
description: (dict-ref entry (string->keyword "cal:calendar-description") #f)+80
color: (dict-ref entry (string->keyword "ic:calendar-color") #f)+81
ctag: (dict-ref entry (string->keyword "cs:getctag") #f)))+82
+83
+84
;; ============================================================+85
;; Calendar Lookup+86
;; ============================================================+87
+88
;;; Find a calendar by display name.+89
;;;+90
;;; Returns the calendar dict, or `#f` if not found.+91
;;;+92
;;; ```scheme+93
;;; (caldav-calendar-by-name client "Work")+94
;;; ;; => #{ href: "/dav/calendars/..." name: "Work" ... }+95
;;; ```+96
(define (caldav-calendar-by-name client name)+97
(: caldav-client? string? -> any?)+98
(let loop ((calendars (caldav-calendars client)))+99
(cond+100
((null? calendars) #f)+101
((equal? (dict-ref (car calendars) name: #f) name)+102
(car calendars))+103
(else (loop (cdr calendars))))))+104
+105
+106
;; ============================================================+107
;; Calendar Management+108
;; ============================================================+109
+110
;;; Create a new calendar on the server.+111
;;;+112
;;; Returns the href of the new calendar.+113
;;;+114
;;; ```scheme+115
;;; (caldav-calendar-create! client "Projects"+116
;;; description: "Project deadlines")+117
;;; ```+118
(define (caldav-calendar-create! client name+119
(keys: (description #f) (color #f)))+120
(: caldav-client? string? (description: (maybe string?)) (color: (maybe string?)) -> string?)+121
(let* ((slug (string-downcase (string-replace name " " "-")))+122
(cal-url (string-append (caldav-client-calendar-home client)+123
slug "/"))+124
(body (string-append+125
"<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"+126
(sxml->xml+127
`(cal:mkcalendar (@ (xmlns:d "DAV:")+128
(xmlns:cal "urn:ietf:params:caldav"))+129
(d:set+130
(d:prop+131
(d:displayname ,name)+132
,@(if description+133
`((cal:calendar-description ,description))+134
'())))))))+135
(response (http-request 'MKCALENDAR+136
(resolve-url (caldav-client-base-url client) cal-url)+137
headers: (dict+138
authorization: (caldav-client-auth-header client)+139
content-type: "application/xml; charset=utf-8")+140
body: body)))+141
(unless response+142
(error "caldav-calendar-create!: request failed"))+143
(let ((status (http-response-status response)))+144
(unless (or (= status 201) (= status 204))+145
(error "caldav-calendar-create!: unexpected status" status)))+146
cal-url))+147
+148
;;; Delete a calendar from the server.+149
;;;+150
;;; The `calendar-href` is the href from a calendar dict.+151
;;;+152
;;; ```scheme+153
;;; (caldav-calendar-delete! client "/dav/calendars/user/projects/")+154
;;; ```+155
(define (caldav-calendar-delete! client calendar-href)+156
(: caldav-client? string? -> void?)+157
(let ((response (caldav-delete-resource client calendar-href)))+158
(unless response+159
(error "caldav-calendar-delete!: request failed"))+160
(let ((status (http-response-status response)))+161
(unless (or (= status 200) (= status 204))+162
(error "caldav-calendar-delete!: unexpected status" status)))))+163
+164
))src/sigil/caldav/client.sgladded
@@ -0,0 +1,314 @@
+1
;;; (sigil caldav client) - CalDAV Client Core+2
;;;+3
;;; Handles CalDAV server discovery, authentication, and provides+4
;;; the WebDAV transport layer (PROPFIND, REPORT, PUT, DELETE) for+5
;;; all CalDAV operations.+6
+7
(define-library (sigil caldav client)+8
(import (sigil core)+9
(sigil string)+10
(sigil struct)+11
(sigil crypto)+12
(sigil http client)+13
(sigil sxml)+14
(sigil sxml reader))+15
+16
(export+17
;; Client struct+18
caldav-client caldav-client?+19
caldav-client-base-url caldav-client-auth-header+20
caldav-client-principal-url caldav-client-calendar-home+21
+22
;; Connection+23
caldav-connect+24
+25
;; Transport (used by calendar.sgl and event.sgl)+26
caldav-propfind+27
caldav-report+28
caldav-put+29
caldav-delete-resource+30
parse-multistatus+31
resolve-url)+32
+33
(begin+34
+35
;; ============================================================+36
;; Client Record+37
;; ============================================================+38
+39
(define-struct caldav-client+40
(base-url string?)+41
(auth-header string?)+42
(principal-url default: #f mutable: #t)+43
(calendar-home default: #f mutable: #t))+44
+45
+46
;; ============================================================+47
;; URL Resolution+48
;; ============================================================+49
+50
;; Resolve a potentially relative href against a base URL+51
(define (resolve-url base-url href)+52
(cond+53
;; Already absolute+54
((string-starts-with? href "http://") href)+55
((string-starts-with? href "https://") href)+56
;; Relative path - combine with base+57
(else+58
(let ((parsed (parse-url base-url)))+59
(let ((port (url-port parsed))+60
(scheme (url-scheme parsed)))+61
(string-append scheme "://"+62
(url-host parsed)+63
(if (and port+64
(not (and (equal? scheme "https") (= port 443)))+65
(not (and (equal? scheme "http") (= port 80))))+66
(string-append ":" (number->string port))+67
"")+68
(if (string-starts-with? href "/")+69
href+70
(string-append "/" href))))))))+71
+72
+73
;; ============================================================+74
;; WebDAV Transport+75
;; ============================================================+76
+77
;; Common headers for CalDAV requests+78
(define (auth-headers client (keys: (content-type "application/xml; charset=utf-8")+79
(depth #f)))+80
(let ((h (dict authorization: (caldav-client-auth-header client)+81
content-type: content-type)))+82
(if depth+83
(dict-set h depth: depth)+84
h)))+85
+86
;;; Send a PROPFIND request and return parsed SXML response.+87
;;;+88
;;; The body should be an SXML tree for the PROPFIND XML body.+89
;;; Returns the parsed XML response as SXML.+90
(define (caldav-propfind client url body (keys: (depth "0")))+91
(: caldav-client? string? any? (depth: string?) -> any?)+92
(let* ((xml-body (string-append "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"+93
(sxml->xml body)))+94
(response (http-request 'PROPFIND+95
(resolve-url (caldav-client-base-url client) url)+96
headers: (auth-headers client depth: depth)+97
body: xml-body)))+98
(unless response+99
(error "caldav-propfind: request failed" url))+100
(let ((status (http-response-status response)))+101
(unless (= status 207)+102
(error "caldav-propfind: unexpected status" status url))+103
(xml->sxml (http-response-body response)))))+104
+105
;;; Send a REPORT request and return parsed SXML response.+106
(define (caldav-report client url body (keys: (depth "1")))+107
(: caldav-client? string? any? (depth: string?) -> any?)+108
(let* ((xml-body (string-append "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"+109
(sxml->xml body)))+110
(response (http-request 'REPORT+111
(resolve-url (caldav-client-base-url client) url)+112
headers: (auth-headers client depth: depth)+113
body: xml-body)))+114
(unless response+115
(error "caldav-report: request failed" url))+116
(let ((status (http-response-status response)))+117
(unless (= status 207)+118
(error "caldav-report: unexpected status" status url))+119
(xml->sxml (http-response-body response)))))+120
+121
;;; PUT a resource (iCalendar data) to a CalDAV URL.+122
;;;+123
;;; Returns the HTTP response.+124
(define (caldav-put client url body (keys: (content-type "text/calendar; charset=utf-8")+125
(if-none-match #f)))+126
(: caldav-client? string? string? (content-type: string?) (if-none-match: any?) -> any?)+127
(let ((headers (auth-headers client content-type: content-type)))+128
(let ((headers (if if-none-match+129
(dict-set headers if-none-match: if-none-match)+130
headers)))+131
(http-request 'PUT+132
(resolve-url (caldav-client-base-url client) url)+133
headers: headers+134
body: body))))+135
+136
;;; DELETE a resource from a CalDAV server.+137
(define (caldav-delete-resource client url)+138
(: caldav-client? string? -> any?)+139
(http-request 'DELETE+140
(resolve-url (caldav-client-base-url client) url)+141
headers: (dict authorization: (caldav-client-auth-header client))))+142
+143
+144
;; ============================================================+145
;; Multistatus Response Parsing+146
;; ============================================================+147
+148
;;; Parse a 207 Multi-Status SXML response into a list of entries.+149
;;;+150
;;; Each entry is a dict with `href:` and property values extracted+151
;;; from successful (200) propstat responses.+152
(define (parse-multistatus sxml)+153
(: list? -> list?)+154
(let ((responses (find-elements sxml 'd:response)))+155
(map parse-response-element responses)))+156
+157
;; Parse a single d:response element into a dict+158
(define (parse-response-element response)+159
(let* ((href (or (find-text-content response 'd:href) ""))+160
(propstats (find-elements response 'd:propstat))+161
(props (dict href: href)))+162
;; Only extract properties from successful propstats+163
(let loop ((remaining propstats) (props props))+164
(if (null? remaining)+165
props+166
(let* ((ps (car remaining))+167
(status-text (or (find-text-content ps 'd:status) "")))+168
(if (string-contains? status-text "200")+169
(let ((prop-elem (find-element ps 'd:prop)))+170
(if prop-elem+171
(loop (cdr remaining)+172
(extract-properties prop-elem props))+173
(loop (cdr remaining) props)))+174
(loop (cdr remaining) props)))))))+175
+176
;; Extract property values from a d:prop element into a dict+177
(define (extract-properties prop-elem props)+178
(let loop ((children (sxml-content prop-elem)) (props props))+179
(if (null? children)+180
props+181
(let ((child (car children)))+182
(if (sxml-element? child)+183
(let* ((tag (symbol->string (sxml-tag child)))+184
(key (string->keyword tag))+185
(value (element-value child)))+186
(loop (cdr children)+187
(dict-set props key value)))+188
(loop (cdr children) props))))))+189
+190
;; Get the value of an element: text content or the element itself+191
;; for complex children+192
(define (element-value elem)+193
(let ((content (sxml-content elem)))+194
(cond+195
((null? content) "")+196
((and (= (length content) 1) (string? (car content)))+197
(car content))+198
(else content))))+199
+200
;; Find all child elements with a given tag at any depth+201
(define (find-elements sxml tag)+202
(let ((results '()))+203
(define (walk node)+204
(when (and (pair? node) (sxml-element? node))+205
(when (eq? (sxml-tag node) tag)+206
(set! results (cons node results)))+207
(for-each walk (sxml-content node))))+208
(walk sxml)+209
(reverse results)))+210
+211
;; Find the first child element with a given tag+212
(define (find-element sxml tag)+213
(let ((results (find-elements sxml tag)))+214
(if (null? results) #f (car results))))+215
+216
;; Find the text content of the first element with a given tag+217
(define (find-text-content sxml tag)+218
(let ((elem (find-element sxml tag)))+219
(and elem+220
(let ((content (sxml-content elem)))+221
(and (pair? content)+222
(string? (car content))+223
(car content))))))+224
+225
+226
;; ============================================================+227
;; Discovery+228
;; ============================================================+229
+230
;;; Connect to a CalDAV server and discover endpoints.+231
;;;+232
;;; Performs CalDAV service discovery: finds the user's principal+233
;;; URL and calendar home set. Authenticates with HTTP Basic+234
;;; (username + password) or Bearer token.+235
;;;+236
;;; ```scheme+237
;;; (caldav-connect+238
;;; url: "https://caldav.fastmail.com"+239
;;; username: "[email protected]"+240
;;; password: "app-password")+241
;;;+242
;;; (caldav-connect+243
;;; url: "https://caldav.example.com"+244
;;; token: "bearer-token-here")+245
;;; ```+246
(define (caldav-connect (keys: (url #f) (username #f) (password #f) (token #f)))+247
(: (url: string?) (username: any?) (password: any?) (token: any?) -> caldav-client?)+248
(unless url+249
(error "caldav-connect: url: is required"))+250
(unless (or token (and username password))+251
(error "caldav-connect: token: or username: + password: required"))+252
+253
(let* ((auth-header (if token+254
(string-append "Bearer " token)+255
(string-append "Basic "+256
(base64-encode+257
(string-append username ":" password)))))+258
(client (caldav-client+259
base-url: url+260
auth-header: auth-header)))+261
+262
;; Step 1: Find current-user-principal+263
(let* ((principal-response+264
(caldav-propfind client url+265
'(d:propfind (@ (xmlns:d "DAV:"))+266
(d:prop (d:current-user-principal)))))+267
(entries (parse-multistatus principal-response))+268
(principal-href+269
(and (pair? entries)+270
(let ((prop (dict-ref (car entries)+271
(string->keyword "d:current-user-principal") #f)))+272
(and prop (pair? prop)+273
(find-text-in-tree prop))))))+274
(unless principal-href+275
(error "caldav-connect: could not discover principal URL"))+276
(set-caldav-client-principal-url! client+277
(resolve-url url principal-href))+278
+279
;; Step 2: Find calendar-home-set+280
(let* ((home-response+281
(caldav-propfind client+282
(caldav-client-principal-url client)+283
'(d:propfind (@ (xmlns:d "DAV:")+284
(xmlns:cal "urn:ietf:params:caldav"))+285
(d:prop (cal:calendar-home-set)))))+286
(home-entries (parse-multistatus home-response))+287
(home-href+288
(and (pair? home-entries)+289
(let ((prop (dict-ref (car home-entries)+290
(string->keyword "cal:calendar-home-set") #f)))+291
(and prop (pair? prop)+292
(find-text-in-tree prop))))))+293
(unless home-href+294
(error "caldav-connect: could not discover calendar home"))+295
(set-caldav-client-calendar-home! client+296
(resolve-url url home-href))+297
+298
client))))+299
+300
;; Find the first text string in a nested SXML tree+301
;; Used to extract href text from nested elements like+302
;; (d:current-user-principal (d:href "/principal/"))+303
(define (find-text-in-tree tree)+304
(cond+305
((string? tree) tree)+306
((pair? tree)+307
(let loop ((items tree))+308
(if (null? items)+309
#f+310
(or (find-text-in-tree (car items))+311
(loop (cdr items))))))+312
(else #f)))+313
+314
))src/sigil/caldav/event.sgladded
@@ -0,0 +1,241 @@
+1
;;; (sigil caldav event) - Event CRUD Operations+2
;;;+3
;;; Query, read, create, update, and delete calendar events+4
;;; on a CalDAV server.+5
+6
(define-library (sigil caldav event)+7
(import (sigil core)+8
(sigil string)+9
(sigil http client)+10
(sigil caldav client)+11
(sigil caldav ical))+12
+13
(export+14
caldav-events+15
caldav-event-get+16
caldav-event-create!+17
caldav-event-update!+18
caldav-event-delete!)+19
+20
(begin+21
+22
;; ============================================================+23
;; Event Querying+24
;; ============================================================+25
+26
;;; Query events from a calendar, optionally filtered by date range.+27
;;;+28
;;; Returns a list of ical-event structs with `url:` populated.+29
;;; Pass `start:` and `end:` as Unix timestamps to filter by time.+30
;;; Set `expand-recurrence?:` to `#t` to expand recurring events.+31
;;;+32
;;; ```scheme+33
;;; (caldav-events client+34
;;; calendar-href: "/dav/calendars/user/default/"+35
;;; start: 1710460800+36
;;; end: 1711065600)+37
;;; ```+38
(define (caldav-events client+39
(keys: (calendar-href #f) (start #f) (end #f)+40
(expand-recurrence? #f)))+41
(: caldav-client? (calendar-href: string?) (start: (maybe number?))+42
(end: (maybe number?)) (expand-recurrence?: boolean?) -> list?)+43
(unless calendar-href+44
(error "caldav-events: calendar-href: is required"))+45
+46
(let* ((time-range-filter+47
(if (or start end)+48
`((cal:time-range+49
(@ ,@(if start+50
`((start ,(format-ical-datetime start)))+51
'())+52
,@(if end+53
`((end ,(format-ical-datetime end)))+54
'()))))+55
'()))+56
(body `(cal:calendar-query+57
(@ (xmlns:d "DAV:")+58
(xmlns:cal "urn:ietf:params:caldav"))+59
(d:prop+60
(d:getetag)+61
(cal:calendar-data))+62
(cal:filter+63
(cal:comp-filter (@ (name "VCALENDAR"))+64
(cal:comp-filter (@ (name "VEVENT"))+65
,@time-range-filter)))))+66
(response (caldav-report client calendar-href body))+67
(entries (parse-multistatus response)))+68
(let ((events (extract-events-from-entries entries client)))+69
(if expand-recurrence?+70
(expand-all-events events start end)+71
events))))+72
+73
;; Extract ical-event structs from multistatus entries+74
(define (extract-events-from-entries entries client)+75
(let loop ((remaining entries) (events '()))+76
(if (null? remaining)+77
(reverse events)+78
(let* ((entry (car remaining))+79
(href (dict-ref entry href: #f))+80
(cal-data (dict-ref entry+81
(string->keyword "cal:calendar-data") #f)))+82
(if (and href cal-data (string? cal-data))+83
(let ((parsed (ical-parse cal-data)))+84
;; Set URL on each event+85
(for-each+86
(lambda (ev)+87
(set-ical-event-url! ev+88
(resolve-url (caldav-client-base-url client) href)))+89
parsed)+90
(loop (cdr remaining) (append (reverse parsed) events)))+91
(loop (cdr remaining) events))))))+92
+93
;; Expand recurrence for all events that have RRULE+94
(define (expand-all-events events start end)+95
(let loop ((remaining events) (result '()))+96
(if (null? remaining)+97
(reverse result)+98
(let ((ev (car remaining)))+99
(if (ical-event-rrule ev)+100
(loop (cdr remaining)+101
(append (reverse (ical-expand-recurrence ev+102
start: start end: end))+103
result))+104
(loop (cdr remaining) (cons ev result)))))))+105
+106
+107
;; ============================================================+108
;; Single Event Access+109
;; ============================================================+110
+111
;;; Get a single event by its URL.+112
;;;+113
;;; Returns an ical-event struct, or `#f` if not found.+114
;;;+115
;;; ```scheme+116
;;; (caldav-event-get client event-url)+117
;;; ```+118
(define (caldav-event-get client event-url)+119
(: caldav-client? string? -> any?)+120
(let ((response (http-get+121
(resolve-url (caldav-client-base-url client) event-url)+122
headers: (dict+123
authorization: (caldav-client-auth-header client)))))+124
(if (and response (= (http-response-status response) 200))+125
(let ((events (ical-parse (http-response-body response))))+126
(when (pair? events)+127
(set-ical-event-url! (car events)+128
(resolve-url (caldav-client-base-url client) event-url)))+129
(if (pair? events) (car events) #f))+130
#f)))+131
+132
+133
;; ============================================================+134
;; Event Creation+135
;; ============================================================+136
+137
;;; Create a new calendar event.+138
;;;+139
;;; Returns the created ical-event struct with its URL populated.+140
;;;+141
;;; ```scheme+142
;;; (caldav-event-create! client+143
;;; calendar-href: "/dav/calendars/user/default/"+144
;;; summary: "Team Meeting"+145
;;; dtstart: 1710493200+146
;;; dtend: 1710496800+147
;;; description: "Weekly sync"+148
;;; location: "Conference Room A")+149
;;; ```+150
(define (caldav-event-create! client+151
(keys: (calendar-href #f)+152
(summary "")+153
(dtstart #f)+154
(dtend #f)+155
(description #f)+156
(location #f)+157
(status #f)+158
(all-day? #f)+159
(rrule #f)))+160
(: caldav-client? (calendar-href: string?) (summary: string?)+161
(dtstart: number?) (dtend: (maybe number?))+162
(description: (maybe string?)) (location: (maybe string?))+163
(status: (maybe string?)) (all-day?: boolean?)+164
(rrule: (maybe string?)) -> ical-event?)+165
(unless calendar-href+166
(error "caldav-event-create!: calendar-href: is required"))+167
(unless dtstart+168
(error "caldav-event-create!: dtstart: is required"))+169
+170
(let* ((uid (generate-event-uid))+171
(event (ical-event+172
uid: uid+173
summary: summary+174
dtstart: dtstart+175
dtend: dtend+176
description: description+177
location: location+178
status: status+179
all-day?: all-day?+180
rrule: rrule))+181
(ical-text (ical-generate event))+182
(event-url (string-append calendar-href uid ".ics"))+183
(response (caldav-put client event-url ical-text+184
if-none-match: "*")))+185
(unless response+186
(error "caldav-event-create!: request failed"))+187
(let ((resp-status (http-response-status response)))+188
(unless (or (= resp-status 201) (= resp-status 204))+189
(error "caldav-event-create!: unexpected status" resp-status)))+190
(set-ical-event-url! event+191
(resolve-url (caldav-client-base-url client) event-url))+192
event))+193
+194
+195
;; ============================================================+196
;; Event Update+197
;; ============================================================+198
+199
;;; Update an existing event on the server.+200
;;;+201
;;; Takes a modified ical-event struct (with its url: set) and+202
;;; PUTs the updated iCalendar data to the server.+203
;;;+204
;;; ```scheme+205
;;; (set-ical-event-summary! event "Updated Meeting")+206
;;; (caldav-event-update! client event)+207
;;; ```+208
(define (caldav-event-update! client event)+209
(: caldav-client? ical-event? -> ical-event?)+210
(let ((event-url (ical-event-url event)))+211
(unless event-url+212
(error "caldav-event-update!: event has no URL"))+213
(let* ((ical-text (ical-generate event))+214
(response (caldav-put client event-url ical-text)))+215
(unless response+216
(error "caldav-event-update!: request failed"))+217
(let ((resp-status (http-response-status response)))+218
(unless (or (= resp-status 200) (= resp-status 204))+219
(error "caldav-event-update!: unexpected status" resp-status)))+220
event)))+221
+222
+223
;; ============================================================+224
;; Event Deletion+225
;; ============================================================+226
+227
;;; Delete an event from the server.+228
;;;+229
;;; ```scheme+230
;;; (caldav-event-delete! client (ical-event-url event))+231
;;; ```+232
(define (caldav-event-delete! client event-url)+233
(: caldav-client? string? -> void?)+234
(let ((response (caldav-delete-resource client event-url)))+235
(unless response+236
(error "caldav-event-delete!: request failed"))+237
(let ((status (http-response-status response)))+238
(unless (or (= status 200) (= status 204))+239
(error "caldav-event-delete!: unexpected status" status)))))+240
+241
))src/sigil/caldav/ical.sgladded
@@ -0,0 +1,666 @@
+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.+6
+7
(define-library (sigil caldav ical)+8
(import (sigil core)+9
(sigil math)+10
(sigil string)+11
(sigil struct)+12
(sigil crypto))+13
+14
(export+15
;; Event struct+16
ical-event ical-event?+17
ical-event-uid ical-event-summary ical-event-description+18
ical-event-dtstart ical-event-dtend ical-event-location+19
ical-event-status ical-event-organizer ical-event-attendees+20
ical-event-created ical-event-last-modified+21
ical-event-all-day? ical-event-url ical-event-rrule+22
ical-event-recurrence-id+23
set-ical-event-summary! set-ical-event-description!+24
set-ical-event-dtstart! set-ical-event-dtend!+25
set-ical-event-location! set-ical-event-status!+26
set-ical-event-url! set-ical-event-rrule!+27
+28
;; Parsing and generation+29
ical-parse+30
ical-generate+31
generate-event-uid+32
+33
;; Date/time conversion+34
parse-ical-datetime+35
format-ical-datetime+36
parse-ical-date+37
format-ical-date+38
+39
;; Recurrence+40
ical-expand-recurrence)+41
+42
(begin+43
+44
;; ============================================================+45
;; Event Struct+46
;; ============================================================+47
+48
(define-struct ical-event+49
(uid default: "unknown" mutable: #t)+50
(summary default: "" mutable: #t)+51
(description default: #f mutable: #t)+52
(dtstart default: #f mutable: #t)+53
(dtend default: #f mutable: #t)+54
(location default: #f mutable: #t)+55
(status default: #f mutable: #t)+56
(organizer default: #f mutable: #t)+57
(attendees default: '() mutable: #t)+58
(created default: #f mutable: #t)+59
(last-modified default: #f mutable: #t)+60
(all-day? default: #f mutable: #t)+61
(url default: #f mutable: #t)+62
(rrule default: #f mutable: #t)+63
(recurrence-id default: #f mutable: #t))+64
+65
+66
;; ============================================================+67
;; UTC Date/Time Conversion+68
;; ============================================================+69
;;+70
;; Direct UTC <-> Unix timestamp conversion without localtime/mktime+71
;; to avoid timezone issues.+72
+73
(define (leap-year? y)+74
(and (zero? (modulo y 4))+75
(or (not (zero? (modulo y 100)))+76
(zero? (modulo y 400)))))+77
+78
(define month-days #(0 31 28 31 30 31 30 31 31 30 31 30 31))+79
+80
(define (days-in-month y m)+81
(if (and (= m 2) (leap-year? y))+82
29+83
(vector-ref month-days m)))+84
+85
;; Days from epoch (1970-01-01) to the start of a given year+86
(define (days-to-year y)+87
(let ((y1 (- y 1)))+88
(- (+ (* 365 (- y 1970))+89
(quotient y1 4)+90
(- (quotient y1 100))+91
(quotient y1 400))+92
;; Subtract leap day counts for years before 1970+93
(+ (quotient 1969 4)+94
(- (quotient 1969 100))+95
(quotient 1969 400)))))+96
+97
;; Convert UTC year/month/day/hour/minute/second to Unix timestamp+98
(define (utc->timestamp y mo d h mi s)+99
(let loop ((m 1) (days (days-to-year y)))+100
(if (>= m mo)+101
(+ (* (+ days (- d 1)) 86400)+102
(* h 3600)+103
(* mi 60)+104
s)+105
(loop (+ m 1) (+ days (days-in-month y m))))))+106
+107
;; Convert Unix timestamp to UTC components (year month day hour minute second)+108
(define (timestamp->utc ts)+109
(let* ((total-days (quotient ts 86400))+110
(day-seconds (modulo ts 86400))+111
(h (quotient day-seconds 3600))+112
(mi (quotient (modulo day-seconds 3600) 60))+113
(s (modulo day-seconds 60)))+114
;; Find year+115
(let year-loop ((y 1970) (remaining total-days))+116
(let ((year-days (if (leap-year? y) 366 365)))+117
(if (< remaining year-days)+118
;; Find month+119
(let month-loop ((m 1) (r remaining))+120
(let ((md (days-in-month y m)))+121
(if (< r md)+122
(list y m (+ r 1) h mi s)+123
(month-loop (+ m 1) (- r md)))))+124
(year-loop (+ y 1) (- remaining year-days)))))))+125
+126
;;; Parse an iCalendar datetime string to a Unix timestamp.+127
;;;+128
;;; Supports both UTC datetimes (with Z suffix) and local datetimes.+129
;;; Local datetimes are interpreted as UTC.+130
;;;+131
;;; ```scheme+132
;;; (parse-ical-datetime "20240315T090000Z") ; => 1710493200+133
;;; (parse-ical-datetime "20240315T090000") ; => 1710493200+134
;;; ```+135
(define (parse-ical-datetime str)+136
(: string? -> number?)+137
(let ((y (string->number (substring str 0 4)))+138
(mo (string->number (substring str 4 6)))+139
(d (string->number (substring str 6 8)))+140
(h (string->number (substring str 9 11)))+141
(mi (string->number (substring str 11 13)))+142
(s (string->number (substring str 13 15))))+143
(utc->timestamp y mo d h mi s)))+144
+145
;;; Parse an iCalendar date string to a Unix timestamp.+146
;;;+147
;;; Returns midnight UTC on the given date.+148
;;;+149
;;; ```scheme+150
;;; (parse-ical-date "20240315") ; => 1710460800+151
;;; ```+152
(define (parse-ical-date str)+153
(: string? -> number?)+154
(let ((y (string->number (substring str 0 4)))+155
(mo (string->number (substring str 4 6)))+156
(d (string->number (substring str 6 8))))+157
(utc->timestamp y mo d 0 0 0)))+158
+159
;;; Format a Unix timestamp as an iCalendar UTC datetime string.+160
;;;+161
;;; ```scheme+162
;;; (format-ical-datetime 1710493200) ; => "20240315T090000Z"+163
;;; ```+164
(define (format-ical-datetime ts)+165
(: number? -> string?)+166
(let ((parts (timestamp->utc ts)))+167
(string-append (pad-digits (list-ref parts 0) 4)+168
(pad-digits (list-ref parts 1) 2)+169
(pad-digits (list-ref parts 2) 2)+170
"T"+171
(pad-digits (list-ref parts 3) 2)+172
(pad-digits (list-ref parts 4) 2)+173
(pad-digits (list-ref parts 5) 2)+174
"Z")))+175
+176
;;; Format a Unix timestamp as an iCalendar date string.+177
;;;+178
;;; ```scheme+179
;;; (format-ical-date 1710460800) ; => "20240315"+180
;;; ```+181
(define (format-ical-date ts)+182
(: number? -> string?)+183
(let ((parts (timestamp->utc ts)))+184
(string-append (pad-digits (list-ref parts 0) 4)+185
(pad-digits (list-ref parts 1) 2)+186
(pad-digits (list-ref parts 2) 2))))+187
+188
(define (pad-digits n width)+189
(let ((s (number->string n)))+190
(if (< (string-length s) width)+191
(string-append (string-repeat "0" (- width (string-length s))) s)+192
s)))+193
+194
+195
;; ============================================================+196
;; iCalendar Parser+197
;; ============================================================+198
+199
;; Unfold iCalendar line continuations.+200
;; Lines starting with a space or tab are continuations of the previous line.+201
(define (unfold-lines text)+202
(let ((lines (string-split text "\n")))+203
(let loop ((remaining lines) (current #f) (result '()))+204
(if (null? remaining)+205
(reverse (if current (cons current result) result))+206
(let ((line (car remaining)))+207
;; Strip trailing \r+208
(let ((line (if (and (> (string-length line) 0)+209
(char=? (string-ref line (- (string-length line) 1)) #\return))+210
(substring line 0 (- (string-length line) 1))+211
line)))+212
(cond+213
;; Continuation line (starts with space or tab)+214
((and (> (string-length line) 0)+215
current+216
(or (char=? (string-ref line 0) #\space)+217
(char=? (string-ref line 0) #\tab)))+218
(loop (cdr remaining)+219
(string-append current (substring line 1 (string-length line)))+220
result))+221
;; New line+222
(else+223
(loop (cdr remaining)+224
line+225
(if current (cons current result) result))))))))))+226
+227
;; Parse a content line into (name params value)+228
;; A content line has the form: NAME;PARAM1=VAL1;PARAM2=VAL2:VALUE+229
;; or simply: NAME:VALUE+230
(define (parse-content-line line)+231
(let ((colon-pos (find-property-colon line)))+232
(if colon-pos+233
(let* ((before (substring line 0 colon-pos))+234
(value (substring line (+ colon-pos 1) (string-length line)))+235
(semi-pos (string-find before ";")))+236
(if semi-pos+237
(list (string-upcase (substring before 0 semi-pos))+238
(substring before (+ semi-pos 1) (string-length before))+239
value)+240
(list (string-upcase before) "" value)))+241
(list line "" ""))))+242
+243
;; Find the colon separating property name/params from value.+244
;; Must skip colons inside quoted parameter values.+245
(define (find-property-colon line)+246
(let ((len (string-length line)))+247
(let loop ((i 0) (in-quotes? #f))+248
(if (>= i len)+249
#f+250
(let ((c (string-ref line i)))+251
(cond+252
((char=? c #\") (loop (+ i 1) (not in-quotes?)))+253
((and (char=? c #\:) (not in-quotes?)) i)+254
(else (loop (+ i 1) in-quotes?))))))))+255
+256
;; Parse a DTSTART or DTEND property, checking params for VALUE=DATE+257
(define (parse-dt-value params value)+258
(if (string-contains? (string-upcase params) "VALUE=DATE")+259
(cons (parse-ical-date value) #t)+260
(cons (parse-ical-datetime value) #f)))+261
+262
;; Extract a mailto: address, or return the raw value+263
(define (parse-cal-address value)+264
(if (string-starts-with? (string-downcase value) "mailto:")+265
(substring value 7 (string-length value))+266
value))+267
+268
;;; Parse an iCalendar string into a list of ical-event structs.+269
;;;+270
;;; Extracts all VEVENT components from the VCALENDAR. Properties+271
;;; not directly mapped to struct fields are ignored.+272
;;;+273
;;; ```scheme+274
;;; (define events (ical-parse ical-string))+275
;;; (ical-event-summary (car events)) ; => "Team Meeting"+276
;;; ```+277
(define (ical-parse text)+278
(: string? -> list?)+279
(let ((lines (unfold-lines text)))+280
(let loop ((remaining lines) (in-event? #f) (props '()) (events '()))+281
(if (null? remaining)+282
(reverse events)+283
(let* ((parsed (parse-content-line (car remaining)))+284
(name (car parsed))+285
(params (cadr parsed))+286
(value (caddr parsed)))+287
(cond+288
((equal? name "BEGIN")+289
(if (equal? (string-upcase value) "VEVENT")+290
(loop (cdr remaining) #t '() events)+291
(loop (cdr remaining) in-event? props events)))+292
((and in-event? (equal? name "END")+293
(equal? (string-upcase value) "VEVENT"))+294
(loop (cdr remaining) #f '()+295
(cons (build-event props) events)))+296
(in-event?+297
(loop (cdr remaining) #t+298
(cons (list name params value) props)+299
events))+300
(else+301
(loop (cdr remaining) in-event? props events))))))))+302
+303
;; Build an ical-event from a list of (name params value) property triples+304
(define (build-event props)+305
(let ((ev (ical-event uid: "unknown")))+306
(for-each+307
(lambda (prop)+308
(let ((name (car prop))+309
(params (cadr prop))+310
(value (caddr prop)))+311
(cond+312
((equal? name "UID")+313
(set-ical-event-uid! ev value))+314
((equal? name "SUMMARY")+315
(set-ical-event-summary! ev value))+316
((equal? name "DESCRIPTION")+317
(set-ical-event-description! ev value))+318
((equal? name "DTSTART")+319
(let ((dt (parse-dt-value params value)))+320
(set-ical-event-dtstart! ev (car dt))+321
(when (cdr dt)+322
(set-ical-event-all-day?! ev #t))))+323
((equal? name "DTEND")+324
(let ((dt (parse-dt-value params value)))+325
(set-ical-event-dtend! ev (car dt))))+326
((equal? name "LOCATION")+327
(set-ical-event-location! ev value))+328
((equal? name "STATUS")+329
(set-ical-event-status! ev value))+330
((equal? name "ORGANIZER")+331
(set-ical-event-organizer! ev (parse-cal-address value)))+332
((equal? name "ATTENDEE")+333
(set-ical-event-attendees! ev+334
(cons (parse-cal-address value)+335
(ical-event-attendees ev))))+336
((equal? name "CREATED")+337
(set-ical-event-created! ev (parse-ical-datetime value)))+338
((equal? name "LAST-MODIFIED")+339
(set-ical-event-last-modified! ev (parse-ical-datetime value)))+340
((equal? name "RRULE")+341
(set-ical-event-rrule! ev value))+342
((equal? name "RECURRENCE-ID")+343
(let ((dt (parse-dt-value params value)))+344
(set-ical-event-recurrence-id! ev (car dt)))))))+345
props)+346
ev))+347
+348
+349
;; ============================================================+350
;; iCalendar Generator+351
;; ============================================================+352
+353
;; Fold a long content line at 75 octets per RFC 5545+354
(define (fold-line line)+355
(if (<= (string-length line) 75)+356
line+357
(let loop ((remaining line) (parts '()))+358
(if (<= (string-length remaining) 75)+359
(string-join (reverse (cons remaining parts)) "\r\n ")+360
(loop (substring remaining 75 (string-length remaining))+361
(cons (substring remaining 0 75) parts))))))+362
+363
;; Emit a content line, folded if necessary+364
(define (emit-line name value)+365
(fold-line (string-append name ":" value)))+366
+367
;;; Generate an iCalendar string from an ical-event struct.+368
;;;+369
;;; Produces a complete VCALENDAR containing a single VEVENT.+370
;;;+371
;;; ```scheme+372
;;; (define ics (ical-generate event))+373
;;; ;; => "BEGIN:VCALENDAR\r\nVERSION:2.0\r\n..."+374
;;; ```+375
(define (ical-generate event)+376
(: ical-event? -> string?)+377
(let ((lines '()))+378
(define (add! line) (set! lines (cons line lines)))+379
+380
(add! "BEGIN:VCALENDAR")+381
(add! "VERSION:2.0")+382
(add! "PRODID:-//Sigil//CalDAV Client//EN")+383
(add! "BEGIN:VEVENT")+384
(add! (emit-line "UID" (ical-event-uid event)))+385
+386
;; Date/time+387
(when (ical-event-dtstart event)+388
(if (ical-event-all-day? event)+389
(add! (emit-line "DTSTART;VALUE=DATE"+390
(format-ical-date (ical-event-dtstart event))))+391
(add! (emit-line "DTSTART"+392
(format-ical-datetime (ical-event-dtstart event))))))+393
(when (ical-event-dtend event)+394
(if (ical-event-all-day? event)+395
(add! (emit-line "DTEND;VALUE=DATE"+396
(format-ical-date (ical-event-dtend event))))+397
(add! (emit-line "DTEND"+398
(format-ical-datetime (ical-event-dtend event))))))+399
+400
;; Text properties+401
(when (not (string-empty? (ical-event-summary event)))+402
(add! (emit-line "SUMMARY" (ical-event-summary event))))+403
(when (ical-event-description event)+404
(add! (emit-line "DESCRIPTION" (ical-event-description event))))+405
(when (ical-event-location event)+406
(add! (emit-line "LOCATION" (ical-event-location event))))+407
(when (ical-event-status event)+408
(add! (emit-line "STATUS" (ical-event-status event))))+409
+410
;; People+411
(when (ical-event-organizer event)+412
(add! (emit-line "ORGANIZER"+413
(string-append "mailto:" (ical-event-organizer event)))))+414
(for-each+415
(lambda (attendee)+416
(add! (emit-line "ATTENDEE"+417
(string-append "mailto:" attendee))))+418
(ical-event-attendees event))+419
+420
;; Timestamps+421
(when (ical-event-created event)+422
(add! (emit-line "CREATED"+423
(format-ical-datetime (ical-event-created event)))))+424
(when (ical-event-last-modified event)+425
(add! (emit-line "LAST-MODIFIED"+426
(format-ical-datetime (ical-event-last-modified event)))))+427
+428
;; Recurrence+429
(when (ical-event-rrule event)+430
(add! (emit-line "RRULE" (ical-event-rrule event))))+431
(when (ical-event-recurrence-id event)+432
(add! (emit-line "RECURRENCE-ID"+433
(format-ical-datetime (ical-event-recurrence-id event)))))+434
+435
(add! "END:VEVENT")+436
(add! "END:VCALENDAR")+437
+438
(string-join (reverse lines) "\r\n")))+439
+440
+441
;; ============================================================+442
;; UID Generation+443
;; ============================================================+444
+445
;;; Generate a unique event UID string.+446
;;;+447
;;; Produces a UUID-like identifier suitable for iCalendar UID fields.+448
;;;+449
;;; ```scheme+450
;;; (generate-event-uid) ; => "a1b2c3d4-e5f6-7890-abcd-ef1234567890"+451
;;; ```+452
(define (generate-event-uid)+453
(: -> string?)+454
(let ((bytes (random-bytes 16)))+455
(string-append+456
(bytes->hex bytes 0 4) "-"+457
(bytes->hex bytes 4 6) "-"+458
(bytes->hex bytes 6 8) "-"+459
(bytes->hex bytes 8 10) "-"+460
(bytes->hex bytes 10 16))))+461
+462
(define (byte->hex b)+463
(let ((s (number->string b 16)))+464
(if (< (string-length s) 2)+465
(string-append "0" s)+466
s)))+467
+468
(define (bytes->hex bv start end)+469
(let loop ((i start) (acc ""))+470
(if (>= i end)+471
acc+472
(loop (+ i 1)+473
(string-append acc (byte->hex (bytevector-u8-ref bv i)))))))+474
+475
+476
;; ============================================================+477
;; Recurrence Expansion+478
;; ============================================================+479
+480
;; Parse an RRULE string into a dict-like alist+481
;; e.g. "FREQ=WEEKLY;BYDAY=MO,WE,FR;COUNT=10"+482
(define (parse-rrule rrule-str)+483
(let ((parts (string-split rrule-str ";")))+484
(map (lambda (part)+485
(let ((eq-pos (string-find part "=")))+486
(if eq-pos+487
(cons (substring part 0 eq-pos)+488
(substring part (+ eq-pos 1) (string-length part)))+489
(cons part ""))))+490
parts)))+491
+492
(define (rrule-ref rrule key)+493
(let ((pair (assoc key rrule)))+494
(if pair (cdr pair) #f)))+495
+496
;; Day-of-week abbreviation to number (0=Sunday)+497
(define (day-abbrev->number abbrev)+498
(cond+499
((equal? abbrev "SU") 0)Showing the first 500 of 667 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.
test/test-caldav.sgladded
@@ -0,0 +1,316 @@
+1
;;; Tests for CalDAV client library (offline, no live server needed)+2
+3
(import (sigil test)+4
(sigil string)+5
(sigil caldav ical)+6
(sigil caldav client)+7
(sigil sxml reader))+8
+9
+10
;; ============================================================+11
;; iCalendar DateTime Conversion+12
;; ============================================================+13
+14
(test-group "ical-datetime"+15
+16
(test "parses UTC datetime"+17
(let ((ts (parse-ical-datetime "20240315T090000Z")))+18
(assert-equal "20240315T090000Z" (format-ical-datetime ts))))+19
+20
(test "parses local datetime (treated as UTC)"+21
(let ((ts (parse-ical-datetime "20240315T090000")))+22
(assert-equal "20240315T090000Z" (format-ical-datetime ts))))+23
+24
(test "round-trips midnight"+25
(let ((ts (parse-ical-datetime "20240101T000000Z")))+26
(assert-equal "20240101T000000Z" (format-ical-datetime ts))))+27
+28
(test "round-trips end of day"+29
(let ((ts (parse-ical-datetime "20241231T235959Z")))+30
(assert-equal "20241231T235959Z" (format-ical-datetime ts))))+31
+32
(test "handles leap year date"+33
(let ((ts (parse-ical-datetime "20240229T120000Z")))+34
(assert-equal "20240229T120000Z" (format-ical-datetime ts))))+35
+36
(test "parses date-only"+37
(let ((ts (parse-ical-date "20240315")))+38
(assert-equal "20240315" (format-ical-date ts))))+39
+40
(test "round-trips date-only Jan 1"+41
(let ((ts (parse-ical-date "20240101")))+42
(assert-equal "20240101" (format-ical-date ts))))+43
+44
(test "round-trips date-only Dec 31"+45
(let ((ts (parse-ical-date "20241231")))+46
(assert-equal "20241231" (format-ical-date ts))))+47
+48
(test "known timestamp value"+49
;; 2024-03-15 09:00:00 UTC = 1710493200+50
(assert-equal 1710493200 (parse-ical-datetime "20240315T090000Z")))+51
+52
(test "epoch is correct"+53
(assert-equal 0 (parse-ical-datetime "19700101T000000Z"))))+54
+55
+56
;; ============================================================+57
;; iCalendar Parsing+58
;; ============================================================+59
+60
(define simple-ical+61
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART:20240315T090000Z\r\nDTEND:20240315T100000Z\r\nSUMMARY:Team Meeting\r\nEND:VEVENT\r\nEND:VCALENDAR")+62
+63
(define detailed-ical+64
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART:20240315T090000Z\r\nDTEND:20240315T100000Z\r\nSUMMARY:Project Review\r\nDESCRIPTION:Quarterly review of all projects\r\nLOCATION:Conference Room B\r\nSTATUS:CONFIRMED\r\nORGANIZER:mailto:[email protected]\r\nATTENDEE:mailto:[email protected]\r\nATTENDEE:mailto:[email protected]\r\nCREATED:20240301T120000Z\r\nLAST-MODIFIED:20240310T080000Z\r\nEND:VEVENT\r\nEND:VCALENDAR")+65
+66
(define allday-ical+67
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART;VALUE=DATE:20240315\r\nDTEND;VALUE=DATE:20240316\r\nSUMMARY:Company Holiday\r\nEND:VEVENT\r\nEND:VCALENDAR")+68
+69
(define folded-ical+70
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART:20240315T090000Z\r\nDTEND:20240315T100000Z\r\nSUMMARY:This is a very long summary that should be folded across\r\n multiple lines in the iCalendar format\r\nEND:VEVENT\r\nEND:VCALENDAR")+71
+72
(define multi-event-ical+73
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART:20240315T090000Z\r\nSUMMARY:Event One\r\nEND:VEVENT\r\nBEGIN:VEVENT\r\nUID:[email protected]\r\nDTSTART:20240316T140000Z\r\nSUMMARY:Event Two\r\nEND:VEVENT\r\nEND:VCALENDAR")+74
+75
(test-group "ical-parse"+76
+77
(test "parses simple event"+78
(let ((events (ical-parse simple-ical)))+79
(assert-equal 1 (length events))+80
(let ((ev (car events)))+81
(assert-equal "[email protected]" (ical-event-uid ev))+82
(assert-equal "Team Meeting" (ical-event-summary ev))+83
(assert-equal (parse-ical-datetime "20240315T090000Z") (ical-event-dtstart ev))+84
(assert-equal (parse-ical-datetime "20240315T100000Z") (ical-event-dtend ev))+85
(assert-false (ical-event-all-day? ev)))))+86
+87
(test "parses detailed event"+88
(let* ((events (ical-parse detailed-ical))+89
(ev (car events)))+90
(assert-equal "[email protected]" (ical-event-uid ev))+91
(assert-equal "Project Review" (ical-event-summary ev))+92
(assert-equal "Quarterly review of all projects" (ical-event-description ev))+93
(assert-equal "Conference Room B" (ical-event-location ev))+94
(assert-equal "CONFIRMED" (ical-event-status ev))+95
(assert-equal "[email protected]" (ical-event-organizer ev))+96
(assert-equal '("[email protected]" "[email protected]") (ical-event-attendees ev))+97
(assert-true (ical-event-created ev))+98
(assert-true (ical-event-last-modified ev))))+99
+100
(test "parses all-day event"+101
(let* ((events (ical-parse allday-ical))+102
(ev (car events)))+103
(assert-equal "[email protected]" (ical-event-uid ev))+104
(assert-equal "Company Holiday" (ical-event-summary ev))+105
(assert-true (ical-event-all-day? ev))+106
(assert-equal (parse-ical-date "20240315") (ical-event-dtstart ev))+107
(assert-equal (parse-ical-date "20240316") (ical-event-dtend ev))))+108
+109
(test "handles folded lines"+110
(let* ((events (ical-parse folded-ical))+111
(ev (car events)))+112
(assert-equal "[email protected]" (ical-event-uid ev))+113
(assert-true (> (string-length (ical-event-summary ev)) 50))))+114
+115
(test "parses multiple events"+116
(let ((events (ical-parse multi-event-ical)))+117
(assert-equal 2 (length events))+118
(assert-equal "Event One" (ical-event-summary (car events)))+119
(assert-equal "Event Two" (ical-event-summary (cadr events))))))+120
+121
+122
;; ============================================================+123
;; iCalendar Generation+124
;; ============================================================+125
+126
(test-group "ical-generate"+127
+128
(test "generates valid iCalendar text"+129
(let* ((ev (ical-event uid: "gen-test-1"+130
summary: "Test Event"+131
dtstart: (parse-ical-datetime "20240315T090000Z")+132
dtend: (parse-ical-datetime "20240315T100000Z")))+133
(text (ical-generate ev)))+134
(assert-true (string? text))+135
(assert-true (> (string-length text) 0))+136
;; Check key content lines are present+137
(assert-true (string-contains? text "BEGIN:VCALENDAR"))+138
(assert-true (string-contains? text "VERSION:2.0"))+139
(assert-true (string-contains? text "BEGIN:VEVENT"))+140
(assert-true (string-contains? text "UID:gen-test-1"))+141
(assert-true (string-contains? text "SUMMARY:Test Event"))+142
(assert-true (string-contains? text "DTSTART:20240315T090000Z"))+143
(assert-true (string-contains? text "DTEND:20240315T100000Z"))+144
(assert-true (string-contains? text "END:VEVENT"))+145
(assert-true (string-contains? text "END:VCALENDAR"))))+146
+147
(test "generates all-day event with VALUE=DATE"+148
(let* ((ev (ical-event uid: "allday-gen-1"+149
summary: "Holiday"+150
dtstart: (parse-ical-date "20240315")+151
dtend: (parse-ical-date "20240316")+152
all-day?: #t))+153
(text (ical-generate ev)))+154
(assert-true (string-contains? text "DTSTART;VALUE=DATE:20240315"))+155
(assert-true (string-contains? text "DTEND;VALUE=DATE:20240316"))))+156
+157
(test "includes optional fields when set"+158
(let* ((ev (ical-event uid: "opt-1"+159
summary: "Full Event"+160
dtstart: (parse-ical-datetime "20240315T090000Z")+161
description: "A detailed description"+162
location: "Room 42"+163
status: "CONFIRMED"+164
organizer: "[email protected]"+165
attendees: '("[email protected]")))+166
(text (ical-generate ev)))+167
(assert-true (string-contains? text "DESCRIPTION:A detailed description"))+168
(assert-true (string-contains? text "LOCATION:Room 42"))+169
(assert-true (string-contains? text "STATUS:CONFIRMED"))+170
(assert-true (string-contains? text "ORGANIZER:mailto:[email protected]"))+171
(assert-true (string-contains? text "ATTENDEE:mailto:[email protected]"))))+172
+173
(test "round-trip: parse then generate preserves key fields"+174
(let* ((events (ical-parse simple-ical))+175
(ev (car events))+176
(text (ical-generate ev))+177
(events2 (ical-parse text))+178
(ev2 (car events2)))+179
(assert-equal (ical-event-uid ev) (ical-event-uid ev2))+180
(assert-equal (ical-event-summary ev) (ical-event-summary ev2))+181
(assert-equal (ical-event-dtstart ev) (ical-event-dtstart ev2))+182
(assert-equal (ical-event-dtend ev) (ical-event-dtend ev2)))))+183
+184
+185
;; ============================================================+186
;; UID Generation+187
;; ============================================================+188
+189
(test-group "generate-event-uid"+190
+191
(test "produces non-empty string"+192
(let ((uid (generate-event-uid)))+193
(assert-true (string? uid))+194
(assert-true (> (string-length uid) 0))))+195
+196
(test "produces unique values"+197
(let ((uid1 (generate-event-uid))+198
(uid2 (generate-event-uid)))+199
(assert-false (equal? uid1 uid2)))))+200
+201
+202
;; ============================================================+203
;; Recurrence Expansion+204
;; ============================================================+205
+206
(test-group "ical-expand-recurrence"+207
+208
(test "non-recurring event returns itself"+209
(let ((ev (ical-event uid: "norec"+210
dtstart: 1710493200 dtend: 1710496800)))+211
(let ((expanded (ical-expand-recurrence ev)))+212
(assert-equal 1 (length expanded)))))+213
+214
(test "daily recurrence with COUNT"+215
(let ((ev (ical-event uid: "daily-1"+216
dtstart: 1710493200+217
dtend: 1710496800+218
rrule: "FREQ=DAILY;COUNT=5")))+219
(let ((expanded (ical-expand-recurrence ev)))+220
(assert-equal 5 (length expanded))+221
;; Each event should be 1 day apart+222
(assert-equal (+ 1710493200 86400)+223
(ical-event-dtstart (cadr expanded))))))+224
+225
(test "weekly recurrence with BYDAY"+226
(let ((ev (ical-event uid: "weekly-1"+227
dtstart: 1710144000 ;; 2024-03-11 Monday 08:00 UTC+228
dtend: 1710147600+229
rrule: "FREQ=WEEKLY;BYDAY=MO,WE,FR;COUNT=6")))+230
(let ((expanded (ical-expand-recurrence ev)))+231
(assert-equal 6 (length expanded)))))+232
+233
(test "monthly recurrence with COUNT"+234
(let ((ev (ical-event uid: "monthly-1"+235
dtstart: 1710493200+236
dtend: 1710496800+237
rrule: "FREQ=MONTHLY;COUNT=3")))+238
(let ((expanded (ical-expand-recurrence ev)))+239
(assert-equal 3 (length expanded)))))+240
+241
(test "daily recurrence respects date range"+242
(let* ((start 1710493200)+243
(ev (ical-event uid: "range-1"+244
dtstart: start+245
dtend: (+ start 3600)+246
rrule: "FREQ=DAILY;COUNT=30")))+247
(let ((expanded (ical-expand-recurrence ev+248
start: start+249
end: (+ start (* 7 86400)))))+250
;; Should only include events within the 7-day range+251
(assert-true (<= (length expanded) 7))+252
(assert-true (> (length expanded) 0))))))+253
+254
+255
;; ============================================================+256
;; Multistatus Response Parsing+257
;; ============================================================+258
+259
(test-group "parse-multistatus"+260
+261
(test "parses single response"+262
(let* ((xml "<d:multistatus xmlns:d=\"DAV:\"><d:response><d:href>/cal/1.ics</d:href><d:propstat><d:prop><d:displayname>Test Calendar</d:displayname></d:prop><d:status>HTTP/1.1 200 OK</d:status></d:propstat></d:response></d:multistatus>")+263
(sxml (xml->sxml xml))+264
(entries (parse-multistatus sxml)))+265
(assert-equal 1 (length entries))+266
(assert-equal "/cal/1.ics" (dict-ref (car entries) href:))))+267
+268
(test "parses multiple responses"+269
(let* ((xml "<d:multistatus xmlns:d=\"DAV:\"><d:response><d:href>/cal/1.ics</d:href><d:propstat><d:prop><d:displayname>One</d:displayname></d:prop><d:status>HTTP/1.1 200 OK</d:status></d:propstat></d:response><d:response><d:href>/cal/2.ics</d:href><d:propstat><d:prop><d:displayname>Two</d:displayname></d:prop><d:status>HTTP/1.1 200 OK</d:status></d:propstat></d:response></d:multistatus>")+270
(sxml (xml->sxml xml))+271
(entries (parse-multistatus sxml)))+272
(assert-equal 2 (length entries))+273
(assert-equal "/cal/1.ics" (dict-ref (car entries) href:))+274
(assert-equal "/cal/2.ics" (dict-ref (cadr entries) href:))))+275
+276
(test "extracts displayname property"+277
(let* ((xml "<d:multistatus xmlns:d=\"DAV:\"><d:response><d:href>/cal/</d:href><d:propstat><d:prop><d:displayname>Work</d:displayname></d:prop><d:status>HTTP/1.1 200 OK</d:status></d:propstat></d:response></d:multistatus>")+278
(sxml (xml->sxml xml))+279
(entries (parse-multistatus sxml))+280
(entry (car entries)))+281
(assert-equal "Work"+282
(dict-ref entry (string->keyword "d:displayname") #f))))+283
+284
(test "skips 404 propstat"+285
(let* ((xml "<d:multistatus xmlns:d=\"DAV:\"><d:response><d:href>/cal/</d:href><d:propstat><d:prop><d:displayname>Work</d:displayname></d:prop><d:status>HTTP/1.1 200 OK</d:status></d:propstat><d:propstat><d:prop><d:missing-prop/></d:prop><d:status>HTTP/1.1 404 Not Found</d:status></d:propstat></d:response></d:multistatus>")+286
(sxml (xml->sxml xml))+287
(entries (parse-multistatus sxml))+288
(entry (car entries)))+289
;; displayname from 200 propstat should be present+290
(assert-equal "Work"+291
(dict-ref entry (string->keyword "d:displayname") #f))+292
;; missing-prop from 404 propstat should not be present+293
(assert-false+294
(dict-ref entry (string->keyword "d:missing-prop") #f)))))+295
+296
+297
;; ============================================================+298
;; URL Resolution+299
;; ============================================================+300
+301
(test-group "resolve-url"+302
+303
(test "absolute URL passes through"+304
(assert-equal "https://example.com/path"+305
(resolve-url "https://cal.example.com" "https://example.com/path")))+306
+307
(test "relative path resolves against base"+308
(assert-equal "https://cal.example.com/dav/calendars/"+309
(resolve-url "https://cal.example.com" "/dav/calendars/")))+310
+311
(test "base URL with port"+312
(assert-equal "https://cal.example.com:8443/dav/"+313
(resolve-url "https://cal.example.com:8443" "/dav/"))))+314
+315
+316
(run-tests)