1 ;;; gnus-icalendar.el --- reply to iCalendar meeting requests
3 ;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
5 ;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
6 ;; Keywords: mail, icalendar, org
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;; (require 'gnus-icalendar)
25 ;; (gnus-icalendar-setup)
27 ;; to enable optional iCalendar->Org sync functionality
28 ;; NOTE: both the capture file and the headline(s) inside must already exist
29 ;; (setq gnus-icalendar-org-capture-file "~/org/notes.org")
30 ;; (setq gnus-icalendar-org-capture-headline '("Calendar"))
31 ;; (gnus-icalendar-org-setup)
43 (eval-when-compile (require 'cl))
45 (defun gnus-icalendar-find-if (pred seq)
48 (when (funcall pred (car seq))
49 (throw 'found (car seq)))
56 (defclass gnus-icalendar-event ()
57 ((organizer :initarg :organizer
58 :accessor gnus-icalendar-event:organizer
60 :type (or null string))
61 (summary :initarg :summary
62 :accessor gnus-icalendar-event:summary
64 :type (or null string))
65 (description :initarg :description
66 :accessor gnus-icalendar-event:description
68 :type (or null string))
69 (location :initarg :location
70 :accessor gnus-icalendar-event:location
72 :type (or null string))
73 (start-time :initarg :start-time
74 :accessor gnus-icalendar-event:start-time
77 (end-time :initarg :end-time
78 :accessor gnus-icalendar-event:end-time
81 (recur :initarg :recur
82 :accessor gnus-icalendar-event:recur
84 :type (or null string))
86 :accessor gnus-icalendar-event:uid
88 (method :initarg :method
89 :accessor gnus-icalendar-event:method
91 :type (or null string))
93 :accessor gnus-icalendar-event:rsvp
95 :type (or null boolean))
96 (participation-type :initarg :participation-type
97 :accessor gnus-icalendar-event:participation-type
98 :initform 'non-participant
100 (req-participants :initarg :req-participants
101 :accessor gnus-icalendar-event:req-participants
104 (opt-participants :initarg :opt-participants
105 :accessor gnus-icalendar-event:opt-participants
108 "generic iCalendar Event class")
110 (defclass gnus-icalendar-event-request (gnus-icalendar-event)
112 "iCalendar class for REQUEST events")
114 (defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
116 "iCalendar class for CANCEL events")
118 (defclass gnus-icalendar-event-reply (gnus-icalendar-event)
120 "iCalendar class for REPLY events")
122 (defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
123 "Return t if EVENT is recurring."
124 (not (null (gnus-icalendar-event:recur event))))
126 (defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
127 "Return recurring frequency of EVENT."
128 (let ((rrule (gnus-icalendar-event:recur event)))
129 (string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
130 (match-string 1 rrule)))
132 (defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
133 "Return recurring interval of EVENT."
134 (let ((rrule (gnus-icalendar-event:recur event))
135 (default-interval 1))
137 (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
138 (or (match-string 1 rrule)
141 (defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
142 (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
144 (defun gnus-icalendar-event--decode-datefield (ical field)
145 (let* ((date (icalendar--get-event-property ical field))
146 (date-props (icalendar--get-event-property-attributes ical field))
147 (tz (plist-get date-props 'TZID)))
149 (date-to-time (timezone-make-date-arpa-standard date nil tz))))
151 (defun gnus-icalendar-event--find-attendee (ical name-or-email)
152 (let* ((event (car (icalendar--all-events ical)))
153 (event-props (caddr event)))
154 (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
155 (attendee-email (att)
156 (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
157 (attendee-prop-matches-p (prop)
158 (and (eq (car prop) 'ATTENDEE)
159 (or (member (attendee-name prop) name-or-email)
160 (let ((att-email (attendee-email prop)))
161 (gnus-icalendar-find-if (lambda (email)
162 (string-match email att-email))
165 (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
167 (defun gnus-icalendar-event--get-attendee-names (ical)
168 (let* ((event (car (icalendar--all-events ical)))
169 (attendee-props (gnus-remove-if-not
170 (lambda (p) (eq (car p) 'ATTENDEE))
173 (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
174 (attendee-name (prop)
175 (or (plist-get (cadr prop) 'CN)
176 (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
177 (attendees-by-type (type)
179 (lambda (p) (string= (attendee-role p) type))
181 (attendee-names-by-type (type)
182 (mapcar #'attendee-name (attendees-by-type type))))
185 (attendee-names-by-type "REQ-PARTICIPANT")
186 (attendee-names-by-type "OPT-PARTICIPANT")))))
188 (defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
189 (let* ((event (car (icalendar--all-events ical)))
190 (organizer (replace-regexp-in-string
192 (or (icalendar--get-event-property event 'ORGANIZER) "")))
193 (prop-map '((summary . SUMMARY)
194 (description . DESCRIPTION)
195 (location . LOCATION)
198 (method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
199 (attendee (when attendee-name-or-email
200 (gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
201 (attendee-names (gnus-icalendar-event--get-attendee-names ical))
202 (role (plist-get (cadr attendee) 'ROLE))
203 (participation-type (pcase role
204 ("REQ-PARTICIPANT" 'required)
205 ("OPT-PARTICIPANT" 'optional)
206 (_ 'non-participant)))
207 (args (list :method method
209 :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART)
210 :end-time (gnus-icalendar-event--decode-datefield event 'DTEND)
211 :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE")
212 :participation-type participation-type
213 :req-participants (car attendee-names)
214 :opt-participants (cadr attendee-names)))
216 ((string= method "REQUEST") 'gnus-icalendar-event-request)
217 ((string= method "CANCEL") 'gnus-icalendar-event-cancel)
218 ((string= method "REPLY") 'gnus-icalendar-event-reply)
219 (t 'gnus-icalendar-event))))
221 (gmm-labels ((map-property (prop)
222 (let ((value (icalendar--get-event-property event prop)))
224 ;; ugly, but cannot get
225 ;;replace-regexp-in-string work with "\\" as
226 ;;REP, plus we should also handle "\\;"
227 (replace-regexp-in-string
229 (replace-regexp-in-string
230 "\\\\n" "\n" (substring-no-properties value))))))
231 (accumulate-args (mapping)
232 (destructuring-bind (slot . ical-property) mapping
233 (setq args (append (list
234 (intern (concat ":" (symbol-name slot)))
235 (map-property ical-property))
238 (mapc #'accumulate-args prop-map)
239 (apply 'make-instance event-class args))))
241 (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
242 "Parse RFC5545 iCalendar in buffer BUF and return an event object.
244 Return a gnus-icalendar-event object representing the first event
245 contained in the invitation. Return nil for calendars without an event entry.
247 ATTENDEE-NAME-OR-EMAIL is a list of strings that will be matched
248 against the event's attendee names and emails. Invitation rsvp
249 status will be retrieved from the first matching attendee record."
250 (let ((ical (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
251 (goto-char (point-min))
252 (icalendar--read-element nil nil))))
255 (gnus-icalendar-event-from-ical ical attendee-name-or-email))))
258 ;;; gnus-icalendar-event-reply
261 (defun gnus-icalendar-event--build-reply-event-body (ical-request status identities)
262 (let ((summary-status (capitalize (symbol-name status)))
263 (attendee-status (upcase (symbol-name status)))
265 (gmm-labels ((update-summary (line)
266 (if (string-match "^[^:]+:" line)
267 (replace-match (format "\\&%s: " summary-status) t nil line)
270 (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
271 (attendee-matches-identity (line)
272 (gnus-icalendar-find-if (lambda (name) (string-match-p name line))
274 (update-attendee-status (line)
275 (when (and (attendee-matches-identity line)
276 (string-match "\\(PARTSTAT=\\)[^;]+" line))
277 (replace-match (format "\\1%s" attendee-status) t nil line)))
278 (process-event-line (line)
279 (when (string-match "^\\([^;:]+\\)" line)
280 (let* ((key (match-string 0 line))
281 ;; NOTE: not all of the below fields are mandatory,
282 ;; but they are often present in other clients'
283 ;; replies. Can be helpful for debugging, too.
286 ((string= key "ATTENDEE") (update-attendee-status line))
287 ((string= key "SUMMARY") (update-summary line))
288 ((string= key "DTSTAMP") (update-dtstamp))
289 ((member key '("ORGANIZER" "DTSTART" "DTEND"
290 "LOCATION" "DURATION" "SEQUENCE"
291 "RECURRENCE-ID" "UID")) line)
294 (push new-line reply-event-lines))))))
296 (mapc #'process-event-line (split-string ical-request "\n"))
298 (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
300 (error "Could not find an event attendee matching given identity"))
302 (mapconcat #'identity `("BEGIN:VEVENT"
303 ,@(nreverse reply-event-lines)
307 (defun gnus-icalendar-event-reply-from-buffer (buf status identities)
308 "Build a calendar event reply for request contained in BUF.
309 The reply will have STATUS (`accepted', `tentative' or `declined').
310 The reply will be composed for attendees matching any entry
311 on the IDENTITIES list."
312 (gmm-labels ((extract-block (blockname)
314 (let ((block-start-re (format "^BEGIN:%s" blockname))
315 (block-end-re (format "^END:%s" blockname))
317 (when (re-search-forward block-start-re nil t)
318 (setq start (line-beginning-position))
319 (re-search-forward block-end-re)
320 (buffer-substring-no-properties start (line-end-position)))))))
323 (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
324 (goto-char (point-min))
325 (setq zone (extract-block "VTIMEZONE")
326 event (extract-block "VEVENT")))
329 (let ((contents (list "BEGIN:VCALENDAR"
334 (gnus-icalendar-event--build-reply-event-body event status identities)
337 (mapconcat #'identity (delq nil contents) "\n"))))))
340 ;;; gnus-icalendar-org
342 ;;; TODO: this is an optional feature, and it's only available with org-mode
343 ;;; 7+, so will need to properly handle emacsen with no/outdated org-mode
346 (require 'org-capture)
348 (defgroup gnus-icalendar-org nil
349 "Settings for Calendar Event gnus/org integration."
351 :group 'gnus-icalendar
352 :prefix "gnus-icalendar-org-")
354 (defcustom gnus-icalendar-org-capture-file nil
355 "Target Org file for storing captured calendar events."
356 :type '(choice (const nil) file)
357 :group 'gnus-icalendar-org)
359 (defcustom gnus-icalendar-org-capture-headline nil
360 "Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
361 :type '(repeat string)
362 :group 'gnus-icalendar-org)
364 (defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
365 "Org-mode template name."
367 :group 'gnus-icalendar-org)
369 (defcustom gnus-icalendar-org-template-key "#"
370 "Org-mode template hotkey."
372 :group 'gnus-icalendar-org)
374 (defvar gnus-icalendar-org-enabled-p nil)
377 (defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event))
378 "Return `org-mode' timestamp repeater string for recurring EVENT.
379 Return nil for non-recurring EVENT."
380 (when (gnus-icalendar-event:recurring-p event)
381 (let* ((freq-map '(("HOURLY" . "h")
386 (org-freq (cdr (assoc (gnus-icalendar-event:recurring-freq event) freq-map))))
389 (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
391 (defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
392 "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
393 (let* ((start (gnus-icalendar-event:start-time event))
394 (end (gnus-icalendar-event:end-time event))
395 (start-date (format-time-string "%Y-%m-%d %a" start))
396 (start-time (format-time-string "%H:%M" start))
397 (start-at-midnight (string= start-time "00:00"))
398 (end-date (format-time-string "%Y-%m-%d %a" end))
399 (end-time (format-time-string "%H:%M" end))
400 (end-at-midnight (string= end-time "00:00"))
401 (start-end-date-diff (/ (float-time (time-subtract
402 (date-to-time end-date)
403 (date-to-time start-date)))
405 (org-repeat (gnus-icalendar-event:org-repeat event))
406 (repeat (if org-repeat (concat " " org-repeat) ""))
407 (time-1-day '(0 86400)))
409 ;; NOTE: special care is needed with appointments ending at midnight
410 ;; (typically all-day events): the end time has to be changed to 23:59 to
411 ;; prevent org agenda showing the event on one additional day
413 ;; start/end midnight
414 ;; A 0:0 - A+1 0:0 -> A
415 ;; A 0:0 - A+n 0:0 -> A - A+n-1
416 ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
417 (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
418 (format "<%s>--<%s>" start-date end-ts))
419 (format "<%s%s>" start-date repeat)))
421 ;; A .:. - A+1 0:0 -> A .:.-23:59
422 ;; A .:. - A+n 0:0 -> A .:. - A_n-1
423 (end-at-midnight (if (= start-end-date-diff 1)
424 (format "<%s %s-23:59%s>" start-date start-time repeat)
425 (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
426 (format "<%s %s>--<%s>" start-date start-time end-ts))))
428 ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
429 ;; A 0:0 - A+n .:. -> A - A+n .:.
430 ((and start-at-midnight
431 (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
433 ;; A .:. - A .:. -> A .:.-.:.
435 ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
436 (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
438 (defun gnus-icalendar--format-summary-line (summary &optional location)
440 (format "%s (%s)" summary location)
441 (format "%s" summary)))
444 (defun gnus-icalendar--format-participant-list (participants)
445 (mapconcat #'identity participants ", "))
447 ;; TODO: make the template customizable
448 (defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
449 "Return string with new `org-mode' entry describing EVENT."
452 (with-slots (organizer summary description location
454 (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
456 (props `(("ICAL_EVENT" . "t")
458 ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
459 ("LOCATION" . ,(gnus-icalendar-event:location event))
460 ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
461 ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
462 ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
463 ("RRULE" . ,(gnus-icalendar-event:recur event))
464 ("REPLY" . ,reply))))
466 (insert (format "* %s\n\n"
467 (gnus-icalendar--format-summary-line summary location)))
469 (org-entry-put (point) (car prop) (cdr prop)))
474 (narrow-to-region (point) (point))
475 (insert (gnus-icalendar-event:org-timestamp event)
478 (indent-region (point-min) (point-max) 2)
479 (fill-region (point-min) (point-max))))
483 (defun gnus-icalendar--deactivate-org-timestamp (ts)
484 (replace-regexp-in-string "[<>]"
485 (lambda (m) (cond ((string= m "<") "[")
486 ((string= m ">") "]")))
489 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
490 "Return the name of the file containing EVENT org entry.
491 Return nil when not found.
493 All org agenda files are searched for the EVENT entry. When
494 the optional ORG-FILE argument is specified, only that one file
496 (let ((uid (gnus-icalendar-event:uid event))
497 (files (or org-file (org-agenda-files t 'ifmode))))
499 ((find-event-in (file)
500 (org-check-agenda-file file)
501 (with-current-buffer (find-file-noselect file)
502 (let ((event-pos (org-find-entry-with-id uid)))
504 (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos)))
506 (throw 'found file))))))
508 (gnus-icalendar-find-if #'find-event-in files))))
511 (defun gnus-icalendar--show-org-event (event &optional org-file)
512 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
514 (switch-to-buffer (find-file file))
515 (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
519 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
520 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
522 (with-current-buffer (find-file-noselect file)
523 (with-slots (uid summary description organizer location recur
524 participation-type req-participants opt-participants) event
525 (let ((event-pos (org-find-entry-with-id uid)))
527 (goto-char event-pos)
529 ;; update the headline, keep todo, priority and tags, if any
531 (let* ((priority (org-entry-get (point) "PRIORITY"))
532 (headline (delq nil (list
533 (org-entry-get (point) "TODO")
534 (when priority (format "[#%s]" priority))
535 (gnus-icalendar--format-summary-line summary location)
536 (org-entry-get (point) "TAGS")))))
538 (re-search-forward "^\\*+ " (line-end-position))
539 (delete-region (point) (line-end-position))
540 (insert (mapconcat #'identity headline " "))))
542 ;; update props and description
543 (let ((entry-end (org-entry-end-position))
544 (entry-outline-level (org-outline-level)))
546 ;; delete body of the entry, leave org drawers intact
548 (org-narrow-to-element)
549 (goto-char entry-end)
550 (re-search-backward "^[\t ]*:END:")
552 (delete-region (point) entry-end))
554 ;; put new event description in the entry body
557 (narrow-to-region (point) (point))
559 (gnus-icalendar-event:org-timestamp event)
561 (replace-regexp-in-string "[\n]+$" "\n" description)
563 (indent-region (point-min) (point-max) (1+ entry-outline-level))
564 (fill-region (point-min) (point-max))))
566 ;; update entry properties
568 ((update-org-entry (position property value)
571 (org-entry-delete position property)
572 (org-entry-put position property value))))
574 (update-org-entry event-pos "ORGANIZER" organizer)
575 (update-org-entry event-pos "LOCATION" location)
576 (update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type))
577 (update-org-entry event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants))
578 (update-org-entry event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants))
579 (update-org-entry event-pos "RRULE" recur)
580 (update-org-entry event-pos "REPLY"
581 (if reply-status (capitalize (symbol-name reply-status))
583 (save-buffer)))))))))
586 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
587 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
589 (with-current-buffer (find-file-noselect file)
590 (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
592 (let ((ts (org-entry-get event-pos "DT")))
594 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
595 (save-buffer)))))))))
598 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
599 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
602 (with-current-buffer (find-file-noselect file)
603 (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
604 (org-entry-get event-pos "REPLY")))))))
607 (defun gnus-icalendar-insinuate-org-templates ()
608 (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
609 org-capture-templates)
610 (setq org-capture-templates
611 (append `((,gnus-icalendar-org-template-key
612 ,gnus-icalendar-org-template-name
614 (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
616 :immediate-finish t))
617 org-capture-templates))
619 ;; hide the template from interactive template selection list
621 ;; NOTE: doesn't work when capturing from string
622 ;; (when (boundp 'org-capture-templates-contexts)
623 ;; (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
624 ;; org-capture-templates-contexts))
627 (defun gnus-icalendar:org-event-save (event reply-status)
629 (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
630 gnus-icalendar-org-template-key)))
632 (defun gnus-icalendar-show-org-agenda (event)
633 (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
634 (gnus-icalendar-event:start-time event)))
635 (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
639 (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
641 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
642 (if (gnus-icalendar-find-org-event-file event)
643 (gnus-icalendar--update-org-event event reply-status)
644 (gnus-icalendar:org-event-save event reply-status)))
646 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
647 (when (gnus-icalendar-find-org-event-file event)
648 (gnus-icalendar--cancel-org-event event)))
650 (defun gnus-icalendar-org-setup ()
651 (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
653 (gnus-icalendar-insinuate-org-templates)
654 (setq gnus-icalendar-org-enabled-p t))
655 (message "Cannot enable Calendar->Org: missing capture file, headline")))
661 (defgroup gnus-icalendar nil
662 "Settings for inline display of iCalendar invitations."
665 :prefix "gnus-icalendar-")
667 (defcustom gnus-icalendar-reply-bufname "*CAL*"
668 "Buffer used for building iCalendar invitation reply."
670 :group 'gnus-icalendar)
672 (defcustom gnus-icalendar-additional-identities nil
673 "We need to know your identity to make replies to calendar requests work.
675 Gnus will only offer you the Accept/Tentative/Decline buttons for
676 calendar events if any of your identities matches at least one
679 Your identity is guessed automatically from the variables
680 `user-full-name', `user-mail-address',
681 `gnus-ignored-from-addresses' and `message-alternative-emails'.
683 If you need even more aliases you can define them here. It really
684 only makes sense to define names or email addresses."
686 :type '(repeat string)
687 :group 'gnus-icalendar)
689 (make-variable-buffer-local
690 (defvar gnus-icalendar-reply-status nil))
692 (make-variable-buffer-local
693 (defvar gnus-icalendar-event nil))
695 (make-variable-buffer-local
696 (defvar gnus-icalendar-handle nil))
698 (defun gnus-icalendar-identities ()
699 "Return list of regexp-quoted names and email addresses belonging to the user.
701 These will be used to retrieve the RSVP information from ical events."
703 (mapcar (lambda (x) (if (listp x) x (list x)))
704 (list user-full-name (regexp-quote user-mail-address)
705 ; NOTE: these can be lists
706 gnus-ignored-from-addresses ; already regexp-quoted
707 message-alternative-emails ;
708 (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
710 ;; TODO: make the template customizable
711 (defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
712 "Format an overview of EVENT details."
713 (gmm-labels ((format-header (x)
715 (propertize (concat (car x) ":") 'face 'bold)
718 (with-slots (organizer summary description location recur uid
719 method rsvp participation-type) event
720 (let ((headers `(("Summary" ,summary)
721 ("Location" ,(or location ""))
722 ("Time" ,(gnus-icalendar-event:org-timestamp event))
723 ("Organizer" ,organizer)
724 ("Attendance" ,(if (eq participation-type 'non-participant)
725 "You are not listed as an attendee"
726 (capitalize (symbol-name participation-type))))
727 ("Method" ,method))))
729 (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
730 (setq headers (append headers
731 `(("Status" ,(or reply-status "Not replied yet"))))))
734 (mapconcat #'format-header headers "\n")
738 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
739 "Execute BODY in buffer containing the decoded contents of HANDLE."
740 (let ((charset (make-symbol "charset")))
741 `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
743 (mm-insert-part ,handle)
744 (when (string= ,charset "utf-8")
745 (mm-decode-coding-region (point-min) (point-max) 'utf-8))
750 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
751 (gnus-icalendar-with-decoded-handle handle
752 (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
754 (defun gnus-icalendar-insert-button (text callback data)
755 ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
757 (let ((start (point)))
758 (gnus-add-text-properties
761 (insert "[ " text " ]")
765 keymap ,gnus-mime-button-map
766 face ,gnus-article-button-face
768 (widget-convert-button 'link start (point)
769 :action 'gnus-widget-press-button
770 :button-keymap gnus-widget-button-keymap)))
772 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
773 (let ((message-signature nil))
774 (with-current-buffer gnus-summary-buffer
777 (mml-insert-multipart "alternative")
778 (mml-insert-empty-tag 'part 'type "text/plain")
779 (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
780 (message-goto-subject)
781 (delete-region (line-beginning-position) (line-end-position))
782 (insert "Subject: " subject)
783 (message-send-and-exit))))
785 (defun gnus-icalendar-reply (data)
786 (let* ((handle (car data))
789 (reply (gnus-icalendar-with-decoded-handle handle
790 (gnus-icalendar-event-reply-from-buffer
791 (current-buffer) status (gnus-icalendar-identities)))))
794 (gmm-labels ((fold-icalendar-buffer ()
795 (goto-char (point-min))
796 (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
797 (replace-match "\\1\n \\2")
798 (goto-char (line-beginning-position)))))
799 (let ((subject (concat (capitalize (symbol-name status))
800 ": " (gnus-icalendar-event:summary event))))
802 (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
803 (delete-region (point-min) (point-max))
805 (fold-icalendar-buffer)
806 (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
808 ;; Back in article buffer
809 (setq-local gnus-icalendar-reply-status status)
810 (when gnus-icalendar-org-enabled-p
811 (gnus-icalendar--update-org-event event status)
812 ;; refresh article buffer to update the reply status
813 (with-current-buffer gnus-summary-buffer
814 (gnus-summary-show-article))))))))
816 (defun gnus-icalendar-sync-event-to-org (event)
817 (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
819 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
820 (when (gnus-icalendar-event:rsvp event)
821 `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
822 ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
823 ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
825 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
826 "No buttons for REPLY events."
829 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
830 (or (when gnus-icalendar-org-enabled-p
831 (gnus-icalendar--get-org-event-reply-status event))
834 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
835 "No reply status for REPLY events."
839 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
840 (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
841 (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
844 `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
845 (when (gnus-icalendar-event-request-p event)
846 `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
847 (when org-entry-exists-p
848 `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
851 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
852 (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
855 `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
856 (when org-entry-exists-p
857 `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
858 (when org-entry-exists-p
859 `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
862 (defun gnus-icalendar-mm-inline (handle)
863 (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
865 (setq gnus-icalendar-reply-status nil)
868 (gmm-labels ((insert-button-group (buttons)
871 (apply 'gnus-icalendar-insert-button x)
877 (gnus-icalendar-event:inline-reply-buttons event handle))
879 (when gnus-icalendar-org-enabled-p
880 (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
882 (setq gnus-icalendar-event event
883 gnus-icalendar-handle handle)
885 (insert (gnus-icalendar-event->gnus-calendar
887 (gnus-icalendar-event:inline-reply-status event)))))))
889 (defun gnus-icalendar-save-part (handle)
891 (when (and (equal (car (mm-handle-type handle)) "text/calendar")
892 (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
894 (gnus-icalendar-event:sync-to-org event))))
897 (defun gnus-icalendar-save-event ()
898 "Save the Calendar event in the text/calendar part under point."
900 (gnus-article-check-buffer)
901 (let ((data (get-text-property (point) 'gnus-data)))
903 (gnus-icalendar-save-part data))))
905 (defun gnus-icalendar-reply-accept ()
906 "Accept invitation in the current article."
908 (with-current-buffer gnus-article-buffer
909 (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
910 (setq-local gnus-icalendar-reply-status 'accepted)))
912 (defun gnus-icalendar-reply-tentative ()
913 "Send tentative response to invitation in the current article."
915 (with-current-buffer gnus-article-buffer
916 (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
917 (setq-local gnus-icalendar-reply-status 'tentative)))
919 (defun gnus-icalendar-reply-decline ()
920 "Decline invitation in the current article."
922 (with-current-buffer gnus-article-buffer
923 (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
924 (setq-local gnus-icalendar-reply-status 'declined)))
926 (defun gnus-icalendar-event-export ()
927 "Export calendar event to `org-mode', or update existing agenda entry."
929 (with-current-buffer gnus-article-buffer
930 (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
931 ;; refresh article buffer in case the reply had been sent before initial org
933 (with-current-buffer gnus-summary-buffer
934 (gnus-summary-show-article)))
936 (defun gnus-icalendar-event-show ()
937 "Display `org-mode' agenda entry related to the calendar event."
939 (gnus-icalendar--show-org-event
940 (with-current-buffer gnus-article-buffer
941 gnus-icalendar-event)))
943 (defun gnus-icalendar-event-check-agenda ()
944 "Display `org-mode' agenda for days between event start and end dates."
946 (gnus-icalendar-show-org-agenda
947 (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
949 (defvar gnus-mime-action-alist) ; gnus-art
951 (defun gnus-icalendar-setup ()
952 (add-to-list 'mm-inlined-types "text/calendar")
953 (add-to-list 'mm-automatic-display "text/calendar")
954 (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
956 (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
957 "a" gnus-icalendar-reply-accept
958 "t" gnus-icalendar-reply-tentative
959 "d" gnus-icalendar-reply-decline
960 "c" gnus-icalendar-event-check-agenda
961 "e" gnus-icalendar-event-export
962 "s" gnus-icalendar-event-show)
965 (add-to-list 'gnus-mime-action-alist
966 (cons "save calendar event" 'gnus-icalendar-save-event)
969 (provide 'gnus-icalendar)
971 ;;; gnus-icalendar.el ends here