src/bureau/calendar.sgl

1;;; (bureau calendar) - Calendar MCP tool handlers.

2;;;

3;;; Provides calendar-related MCP tools: list calendars, query events,

4;;; event details, create/update/delete events, and find free slots.

6(define-library (bureau calendar)

7 (import (sigil core)

8 (sigil string)

9 (sigil json)

10 (sigil list)

11 (sigil math)

12 (sigil time)

13 (sigil caldav)

14 (bureau connection)

15 (bureau config)

16 (bureau format)

17 (bureau util))

18 (export register-calendar-tools!

19 ;; Exported for testing

20 find-free-slots

21 merge-intervals)

22 (begin

24 ;; ============================================================

25 ;; Tool Schemas

26 ;; ============================================================

28 (define calendars-schema

29 '((type . "object")

30 (properties . ())))

32 (define events-schema

33 '((type . "object")

34 (properties . ((start . ((type . "string")

                                 (description . "Start of date range (ISO 8601, e.g. '2026-03-12' or '2026-03-12T09:00:00Z')")))

36 (end . ((type . "string")

37 (description . "End of date range (ISO 8601)")))

38 (calendar . ((type . "string")

39 (description . "Calendar name to query (default: all calendars)")))

40 (expand-recurring . ((type . "boolean")

                                            (description . "Expand recurring events into individual occurrences (default: true)")))))

42 (required . ("start" "end"))))

44 (define event-details-schema

45 '((type . "object")

46 (properties . ((url . ((type . "string")

47 (description . "Event URL (from events query results)")))))

48 (required . ("url"))))

50 (define event-create-schema

51 '((type . "object")

52 (properties . ((summary . ((type . "string")

53 (description . "Event title")))

54 (start . ((type . "string")

55 (description . "Start date/time (ISO 8601)")))

56 (end . ((type . "string")

57 (description . "End date/time (ISO 8601)")))

58 (calendar . ((type . "string")

59 (description . "Calendar name (default: first calendar)")))

60 (description . ((type . "string")

61 (description . "Event description")))

62 (location . ((type . "string")

63 (description . "Event location")))

64 (all-day . ((type . "boolean")

65 (description . "Create as all-day event (default: false)")))

66 (recurrence . ((type . "string")

67 (description . "Recurrence rule (e.g. 'FREQ=WEEKLY;BYDAY=MO,WE,FR')")))

68 (attendees . ((type . "string")

69 (description . "Comma-separated email addresses of participants to invite")))))

70 (required . ("summary" "start" "end"))))

72 (define event-update-schema

73 '((type . "object")

74 (properties . ((url . ((type . "string")

75 (description . "Event URL to update")))

76 (summary . ((type . "string")

77 (description . "New event title")))

78 (start . ((type . "string")

79 (description . "New start date/time (ISO 8601)")))

80 (end . ((type . "string")

81 (description . "New end date/time (ISO 8601)")))

82 (description . ((type . "string")

83 (description . "New event description")))

84 (location . ((type . "string")

85 (description . "New event location")))))

86 (required . ("url"))))

88 (define event-add-attendees-schema

89 '((type . "object")

90 (properties . ((url . ((type . "string")

91 (description . "Event URL to update")))

92 (attendees . ((type . "string")

93 (description . "Comma-separated email addresses of participants to invite")))))

94 (required . ("url" "attendees"))))

96 (define event-delete-schema

97 '((type . "object")

98 (properties . ((url . ((type . "string")

99 (description . "Event URL to delete")))))

100 (required . ("url"))))

101

102 (define free-slots-schema

103 '((type . "object")

104 (properties . ((start . ((type . "string")

105 (description . "Start of date range (ISO 8601)")))

106 (end . ((type . "string")

107 (description . "End of date range (ISO 8601)")))

108 (calendar . ((type . "string")

109 (description . "Calendar name (default: all calendars)")))

110 (min-duration . ((type . "integer")

111 (description . "Minimum slot duration in minutes (default: 30)")))

112 (working-hours-only . ((type . "boolean")

113

                                              (description . "Only show slots during working hours 09:00-17:00 (default: true)")))))

114 (required . ("start" "end"))))

115

116

117 ;; ============================================================

118 ;; Helpers

119 ;; ============================================================

120

121 ;; Get calendars to query — either a specific one or all

122 (define (resolve-calendars client calendar-name)

123 (if calendar-name

124 (let ((cal (caldav-calendar-by-name client calendar-name)))

125 (if cal

126 (list cal)

127 (error (string-append "Calendar not found: " calendar-name

128 ". Use bureau/calendars to see available calendars."))))

129 (caldav-calendars client)))

130

131 ;; Query events across one or more calendars

132 (define (query-events client calendars start end expand?)

133 (let loop ((cals calendars) (result '()))

134 (if (null? cals)

135 ;; Sort all events by start time

136 (list-sort (lambda (a b)

137 (< (ical-event-dtstart a) (ical-event-dtstart b)))

138 result)

139 (let* ((cal (car cals))

140 (href (dict-ref cal href:))

141 (cal-name (dict-ref cal name: #f))

142 (events (guard (e (else '()))

143 (caldav-events client

144 calendar-href: href

145 start: start

146 end: end

147 expand-recurrence?: expand?))))

148 ;; Stamp each event with calendar name

149 (for-each (lambda (ev)

150 (set-ical-event-calendar-name! ev cal-name))

151 events)

152 (loop (cdr cals) (append result events))))))

153

154

155 ;; ============================================================

156 ;; Tool Handlers

157 ;; ============================================================

158

159 (define (tool-calendars args)

160 (let* ((client (ensure-caldav-client))

161 (calendars (caldav-calendars client)))

162 (if (null? calendars)

163 "No calendars found."

164 (string-join (map format-calendar calendars) "\n"))))

165

166 (define (tool-events args)

167 (let* ((client (ensure-caldav-client))

168 (start (parse-iso8601 (require-arg args start: "start")))

169 (end (parse-iso8601 (require-arg args end: "end")))

170 (calendar-name (dict-ref args calendar: #f))

171 (expand? (dict-ref args expand-recurring: #t))

172 (calendars (resolve-calendars client calendar-name))

173 (events (query-events client calendars start end expand?)))

174 (if (null? events)

175 "No events found in the specified date range."

176 (string-append

177 (number->string (length events)) " event(s) found:\n\n"

178 (string-join (map format-event-summary events) "\n")))))

179

180 (define (tool-event-details args)

181 (let* ((client (ensure-caldav-client))

182 (url (require-arg args url: "url"))

183 (event (caldav-event-get client url)))

184 (if event

185 (format-event-full event)

186 (string-append "Event not found: " url))))

187

188 ;; Parse a comma-separated attendee string into a list of attendee dicts

189 (define (parse-attendee-list str)

190 (map (lambda (email)

191 (ical-attendee (string-trim email)))

192 (string-split str ",")))

193

194 (define (tool-event-create args)

195 (let* ((client (ensure-caldav-client))

196 (summary (require-arg args summary: "summary"))

197 (start (parse-iso8601 (require-arg args start: "start")))

198 (end (parse-iso8601 (require-arg args end: "end")))

199 (calendar-name (dict-ref args calendar: #f))

200 (description (dict-ref args description: #f))

201 (location (dict-ref args location: #f))

202 (all-day? (dict-ref args all-day: #f))

203 (recurrence (dict-ref args recurrence: #f))

204 (attendees-str (dict-ref args attendees: #f))

205 (attendees (if attendees-str (parse-attendee-list attendees-str) '()))

206 ;; Auto-set organizer when attendees are present

207 (organizer (if (pair? attendees) (bureau-username) #f))

208 (tz (bureau-timezone))

209 ;; Resolve calendar

210 (calendars (caldav-calendars client))

211 (calendar (if calendar-name

212 (or (caldav-calendar-by-name client calendar-name)

213 (error (string-append "Calendar not found: " calendar-name)))

214 (if (pair? calendars)

215 (car calendars)

216 (error "No calendars found"))))

217 (href (dict-ref calendar href:))

218 ;; Create

219 (event (caldav-event-create! client

220 calendar-href: href

221 summary: summary

222 dtstart: start

223 dtend: end

224 description: (or description "")

225 location: (or location "")

226 all-day?: all-day?

227 rrule: recurrence

228 organizer: organizer

229 attendees: attendees

230 timezone: tz)))

231 (string-append "Event created:\n\n" (format-event-full event))))

232

233 (define (tool-event-update args)

234 (let* ((client (ensure-caldav-client))

235 (url (require-arg args url: "url"))

236 (event (caldav-event-get client url))

237 (_ (unless event (error (string-append "Event not found: " url))))

238 ;; Apply updates

239 (summary (dict-ref args summary: #f))

240 (start (dict-ref args start: #f))

241 (end (dict-ref args end: #f))

242 (description (dict-ref args description: #f))

243 (location (dict-ref args location: #f)))

244 (when summary (set-ical-event-summary! event summary))

245 (when start (set-ical-event-dtstart! event (parse-iso8601 start)))

246 (when end (set-ical-event-dtend! event (parse-iso8601 end)))

247 (when description (set-ical-event-description! event description))

248 (when location (set-ical-event-location! event location))

249 (caldav-event-update! client event)

250 (string-append "Event updated:\n\n" (format-event-full event))))

251

252 (define (tool-event-add-attendees args)

253 (let* ((client (ensure-caldav-client))

254 (url (require-arg args url: "url"))

255 (attendees-str (require-arg args attendees: "attendees"))

256 (new-attendees (parse-attendee-list attendees-str))

257 (event (caldav-event-get client url))

258 (_ (unless event (error (string-append "Event not found: " url))))

259 ;; Add organizer if not already set

260 (_ (unless (ical-event-organizer event)

261 (set-ical-event-organizer! event (bureau-username))))

262 ;; Merge new attendees with existing ones

263 (existing (ical-event-attendees event))

264 (existing-emails (map ical-attendee-email existing))

265 (to-add (filter (lambda (att)

266 (not (member (ical-attendee-email att) existing-emails)))

267 new-attendees))

268 (_ (set-ical-event-attendees! event (append existing to-add))))

269 (caldav-event-update! client event)

270 (string-append

271 "Added " (number->string (length to-add)) " attendee(s):\n\n"

272 (format-event-full event))))

273

274 (define (tool-event-delete args)

275 (let* ((client (ensure-caldav-client))

276 (url (require-arg args url: "url")))

277 (caldav-event-delete! client url)

278 (string-append "Event deleted: " url)))

279

280 (define (tool-free-slots args)

281 (let* ((client (ensure-caldav-client))

282 (start (parse-iso8601 (require-arg args start: "start")))

283 (end (parse-iso8601 (require-arg args end: "end")))

284 (calendar-name (dict-ref args calendar: #f))

285 (min-duration (* (dict-ref args min-duration: 30) 60)) ;; convert to seconds

286 (working-hours? (dict-ref args working-hours-only: #t))

287 ;; Get all events in range

288 (calendars (resolve-calendars client calendar-name))

289 (events (query-events client calendars start end #t))

290 ;; Build busy intervals

291 (busy (map (lambda (ev)

292 (cons (ical-event-dtstart ev)

293 (or (ical-event-dtend ev)

294 (+ (ical-event-dtstart ev) 3600))))

295 events))

296 ;; Find free slots

297 (slots (find-free-slots busy start end min-duration working-hours?)))

298 (if (null? slots)

299 "No free time slots found in the specified range."

300 (string-append

301 (number->string (length slots)) " free slot(s) found:\n\n"

302 (string-join (map (lambda (slot)

303 (format-free-slot (car slot) (cdr slot)))

304 slots)

305 "\n")))))

306

307

308 ;; ============================================================

309 ;; Free Slots Algorithm

310 ;; ============================================================

311

312 ;; Merge overlapping intervals. Input: list of (start . end) pairs, sorted by start.

313 (define (merge-intervals intervals)

314 (if (null? intervals)

315 '()

316 (let loop ((rest (cdr intervals))

317 (current (car intervals))

318 (result '()))

319 (if (null? rest)

320 (reverse (cons current result))

321 (let ((next (car rest)))

322 (if (<= (car next) (cdr current))

323 ;; Overlapping — extend current

324 (loop (cdr rest)

325 (cons (car current) (max (cdr current) (cdr next)))

326 result)

327 ;; Gap — emit current, start new

328 (loop (cdr rest)

329 next

330 (cons current result))))))))

331

332 ;; Find free slots between busy intervals

333 (define (find-free-slots busy range-start range-end min-duration working-hours?)

334 (let* ((sorted (list-sort (lambda (a b) (< (car a) (car b))) busy))

335 (merged (merge-intervals sorted))

336 ;; Find gaps

337 (raw-slots (find-gaps merged range-start range-end)))

338 ;; Filter by working hours and minimum duration

339 (let ((slots (if working-hours?

340 (apply append (map split-to-working-hours raw-slots))

341 raw-slots)))

342 (filter (lambda (slot)

343 (>= (- (cdr slot) (car slot)) min-duration))

344 slots))))

345

346 ;; Find gaps between merged busy intervals

347 (define (find-gaps merged range-start range-end)

348 (if (null? merged)

349 (list (cons range-start range-end))

350 (let ((slots '()))

351 ;; Gap before first event

352 (when (< range-start (car (car merged)))

353 (set! slots (list (cons range-start (car (car merged))))))

354 ;; Gaps between events

355 (let loop ((rest merged))

356 (when (and (pair? rest) (pair? (cdr rest)))

357 (let ((gap-start (cdr (car rest)))

358 (gap-end (car (cadr rest))))

359 (when (< gap-start gap-end)

360 (set! slots (cons (cons gap-start gap-end) slots))))

361 (loop (cdr rest))))

362 ;; Gap after last event

363 (let ((last-end (cdr (last merged))))

364 (when (< last-end range-end)

365 (set! slots (cons (cons last-end range-end) slots))))

366 (reverse slots))))

367

368 ;; Get the last element of a list

369 (define (last lst)

370 (if (null? (cdr lst)) (car lst) (last (cdr lst))))

371

372 ;; Split a free slot into working-hours segments (09:00-17:00 each day)

373 (define (split-to-working-hours slot)

374 (let ((slot-start (car slot))

375 (slot-end (cdr slot)))

376 (let loop ((day-start (day-at-hour slot-start 9))

377 (result '()))

378 (if (>= day-start slot-end)

379 (reverse result)

380 (let* ((day-end (+ day-start (* 8 3600))) ;; 17:00

381 (effective-start (max slot-start day-start))

382 (effective-end (min slot-end day-end)))

383 (if (< effective-start effective-end)

384 (loop (+ day-start 86400) ;; next day

385 (cons (cons effective-start effective-end) result))

386 (loop (+ day-start 86400) result)))))))

387

388 ;; Get the timestamp for a specific hour on the same day as `ts`

389 (define (day-at-hour ts hour)

390 (let* ((components (time->list ts))

391 ;; time->list returns (second minute hour day month year weekday yearday dst?)

392 (day (list-ref components 3))

393 (month (list-ref components 4))

394 (year (list-ref components 5)))

395 (list->time (list 0 0 hour day month year))))

396

397

398 ;; ============================================================

399 ;; Registration

400 ;; ============================================================

401

402 ;;; Register all calendar tools with the MCP server.

403 (define (register-calendar-tools! server register-tool!)

404 (: any? procedure? -> void?)

405

406 (register-tool! server

407 "bureau/calendars"

408 "List all calendars."

409 calendars-schema

410 tool-calendars)

411

412 (register-tool! server

413 "bureau/events"

414 "Query calendar events in a date range. Returns event summaries with URLs for follow-up."

415 events-schema

416 tool-events)

417

418 (register-tool! server

419 "bureau/event-details"

420 "Get full details of a calendar event by its URL."

421 event-details-schema

422 tool-event-details)

423

424 (register-tool! server

425 "bureau/event-create"

426 "Create a new calendar event."

427 event-create-schema

428 tool-event-create)

429

430 (register-tool! server

431 "bureau/event-update"

432 "Update an existing calendar event. Only the specified fields are changed."

433 event-update-schema

434 tool-event-update)

435

436 (register-tool! server

437 "bureau/event-add-attendees"

438 "Invite participants to an existing calendar event. The server sends invitation emails automatically."

439 event-add-attendees-schema

440 tool-event-add-attendees)

441

442 (register-tool! server

443 "bureau/event-delete"

444 "Delete a calendar event."

445 event-delete-schema

446 tool-event-delete)

447

448 (register-tool! server

449 "bureau/free-slots"

450 "Find free time slots in a date range by analyzing calendar events. Useful for scheduling meetings."

451 free-slots-schema

452 tool-free-slots))))