HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Doc fixes
[bpt/emacs.git] / lisp / gnus / gnus-icalendar.el
CommitLineData
89cccc2f
G		 1;;; gnus-icalendar.el --- reply to iCalendar meeting requests
2
ba318903 3;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
89cccc2f
G		 4
5;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
6;; Keywords: mail, icalendar, org
7
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.
12
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.
17
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/>.
20
21;;; Commentary:
22
23;; To install:
24;; (require 'gnus-icalendar)
25;; (gnus-icalendar-setup)
26
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)
32
33
34;;; Code:
35
36(require 'icalendar)
37(require 'eieio)
9ab16aab 38(require 'gmm-utils)
89cccc2f
G		 39(require 'mm-decode)
40(require 'gnus-sum)
41
42(eval-when-compile (require 'cl))
43
44(defun gnus-icalendar-find-if (pred seq)
45 (catch 'found
46 (while seq
47 (when (funcall pred (car seq))
48 (throw 'found (car seq)))
49 (pop seq))))
50
51;;;
52;;; ical-event
53;;;
54
55(defclass gnus-icalendar-event ()
56 ((organizer :initarg :organizer
57 :accessor gnus-icalendar-event:organizer
58 :initform ""
59 :type (or null string))
60 (summary :initarg :summary
61 :accessor gnus-icalendar-event:summary
62 :initform ""
63 :type (or null string))
64 (description :initarg :description
65 :accessor gnus-icalendar-event:description
66 :initform ""
67 :type (or null string))
68 (location :initarg :location
69 :accessor gnus-icalendar-event:location
70 :initform ""
71 :type (or null string))
62dfefa0
JT		 72 (start-time :initarg :start-time
73 :accessor gnus-icalendar-event:start-time
89cccc2f 74 :initform ""
62dfefa0
JT		 75 :type (or null t))
76 (end-time :initarg :end-time
77 :accessor gnus-icalendar-event:end-time
89cccc2f 78 :initform ""
62dfefa0 79 :type (or null t))
89cccc2f
G		 80 (recur :initarg :recur
81 :accessor gnus-icalendar-event:recur
82 :initform ""
83 :type (or null string))
84 (uid :initarg :uid
85 :accessor gnus-icalendar-event:uid
86 :type string)
87 (method :initarg :method
88 :accessor gnus-icalendar-event:method
89 :initform "PUBLISH"
90 :type (or null string))
91 (rsvp :initarg :rsvp
92 :accessor gnus-icalendar-event:rsvp
93 :initform nil
8ef7141b 94 :type (or null boolean))
42e51060
JT		 95 (participation-type :initarg :participation-type
96 :accessor gnus-icalendar-event:participation-type
97 :initform 'non-participant
98 :type (or null t))
8ef7141b
JT		 99 (req-participants :initarg :req-participants
100 :accessor gnus-icalendar-event:req-participants
101 :initform nil
102 :type (or null t))
103 (opt-participants :initarg :opt-participants
104 :accessor gnus-icalendar-event:opt-participants
105 :initform nil
106 :type (or null t)))
89cccc2f
G		 107 "generic iCalendar Event class")
108
109(defclass gnus-icalendar-event-request (gnus-icalendar-event)
110 nil
111 "iCalendar class for REQUEST events")
112
113(defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
114 nil
115 "iCalendar class for CANCEL events")
116
117(defclass gnus-icalendar-event-reply (gnus-icalendar-event)
118 nil
119 "iCalendar class for REPLY events")
120
121(defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
122 "Return t if EVENT is recurring."
123 (not (null (gnus-icalendar-event:recur event))))
124
125(defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
126 "Return recurring frequency of EVENT."
127 (let ((rrule (gnus-icalendar-event:recur event)))
128 (string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
129 (match-string 1 rrule)))
130
131(defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
132 "Return recurring interval of EVENT."
133 (let ((rrule (gnus-icalendar-event:recur event))
134 (default-interval 1))
135
136 (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
137 (or (match-string 1 rrule)
138 default-interval)))
139
62dfefa0
JT		 140(defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
141 (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
89cccc2f 142
62dfefa0
JT		 143(defun gnus-icalendar-event--decode-datefield (ical field)
144 (let* ((date (icalendar--get-event-property ical field))
145 (date-props (icalendar--get-event-property-attributes ical field))
146 (tz (plist-get date-props 'TZID)))
89cccc2f 147
62dfefa0 148 (date-to-time (timezone-make-date-arpa-standard date nil tz))))
89cccc2f
G		 149
150(defun gnus-icalendar-event--find-attendee (ical name-or-email)
151 (let* ((event (car (icalendar--all-events ical)))
152 (event-props (caddr event)))
9ab16aab 153 (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
89cccc2f
G		 154 (attendee-email (att)
155 (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
156 (attendee-prop-matches-p (prop)
157 (and (eq (car prop) 'ATTENDEE)
158 (or (member (attendee-name prop) name-or-email)
159 (let ((att-email (attendee-email prop)))
160 (gnus-icalendar-find-if (lambda (email)
161 (string-match email att-email))
162 name-or-email))))))
163
164 (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
165
8ef7141b
JT		 166(defun gnus-icalendar-event--get-attendee-names (ical)
167 (let* ((event (car (icalendar--all-events ical)))
168 (attendee-props (gnus-remove-if-not
169 (lambda (p) (eq (car p) 'ATTENDEE))
170 (caddr event))))
171
172 (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
173 (attendee-name (prop) (plist-get (cadr prop) 'CN))
174 (attendees-by-type (type)
175 (gnus-remove-if-not
176 (lambda (p) (string= (attendee-role p) type))
177 attendee-props))
178 (attendee-names-by-type (type)
179 (mapcar #'attendee-name (attendees-by-type type))))
180
181 (list
182 (attendee-names-by-type "REQ-PARTICIPANT")
183 (attendee-names-by-type "OPT-PARTICIPANT")))))
89cccc2f
G		 184
185(defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
186 (let* ((event (car (icalendar--all-events ical)))
89cccc2f
G		 187 (organizer (replace-regexp-in-string
188 "^.*MAILTO:" ""
189 (or (icalendar--get-event-property event 'ORGANIZER) "")))
190 (prop-map '((summary . SUMMARY)
191 (description . DESCRIPTION)
192 (location . LOCATION)
193 (recur . RRULE)
194 (uid . UID)))
195 (method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
196 (attendee (when attendee-name-or-email
197 (gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
8ef7141b 198 (attendee-names (gnus-icalendar-event--get-attendee-names ical))
42e51060
JT		 199 (role (plist-get (cadr attendee) 'ROLE))
200 (participation-type (pcase role
201 ("REQ-PARTICIPANT" 'required)
202 ("OPT-PARTICIPANT" 'optional)
203 (_ 'non-participant)))
89cccc2f
G		 204 (args (list :method method
205 :organizer organizer
62dfefa0
JT		 206 :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART)
207 :end-time (gnus-icalendar-event--decode-datefield event 'DTEND)
42e51060
JT		 208 :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE")
209 :participation-type participation-type
210 :req-participants (car attendee-names)
8ef7141b 211 :opt-participants (cadr attendee-names)))
ec956438
JT		 212 (event-class (cond
213 ((string= method "REQUEST") 'gnus-icalendar-event-request)
214 ((string= method "CANCEL") 'gnus-icalendar-event-cancel)
215 ((string= method "REPLY") 'gnus-icalendar-event-reply)
216 (t 'gnus-icalendar-event))))
89cccc2f 217
9ab16aab 218 (gmm-labels ((map-property (prop)
89cccc2f
G		 219 (let ((value (icalendar--get-event-property event prop)))
220 (when value
221 ;; ugly, but cannot get
222 ;;replace-regexp-in-string work with "\\" as
223 ;;REP, plus we should also handle "\\;"
224 (replace-regexp-in-string
225 "\\\\," ","
226 (replace-regexp-in-string
227 "\\\\n" "\n" (substring-no-properties value))))))
228 (accumulate-args (mapping)
229 (destructuring-bind (slot . ical-property) mapping
230 (setq args (append (list
231 (intern (concat ":" (symbol-name slot)))
232 (map-property ical-property))
233 args)))))
234
235 (mapc #'accumulate-args prop-map)
236 (apply 'make-instance event-class args))))
237
238(defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
239 "Parse RFC5545 iCalendar in buffer BUF and return an event object.
240
241Return a gnus-icalendar-event object representing the first event
242contained in the invitation. Return nil for calendars without an event entry.
243
244ATTENDEE-NAME-OR-EMAIL is a list of strings that will be matched
245against the event's attendee names and emails. Invitation rsvp
246status will be retrieved from the first matching attendee record."
247 (let ((ical (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
248 (goto-char (point-min))
249 (icalendar--read-element nil nil))))
250
251 (when ical
252 (gnus-icalendar-event-from-ical ical attendee-name-or-email))))
253
254;;;
255;;; gnus-icalendar-event-reply
256;;;
257
258(defun gnus-icalendar-event--build-reply-event-body (ical-request status identities)
259 (let ((summary-status (capitalize (symbol-name status)))
260 (attendee-status (upcase (symbol-name status)))
261 reply-event-lines)
9ab16aab 262 (gmm-labels ((update-summary (line)
89cccc2f
G		 263 (if (string-match "^[^:]+:" line)
264 (replace-match (format "\\&%s: " summary-status) t nil line)
265 line))
266 (update-dtstamp ()
267 (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
268 (attendee-matches-identity (line)
269 (gnus-icalendar-find-if (lambda (name) (string-match-p name line))
270 identities))
271 (update-attendee-status (line)
272 (when (and (attendee-matches-identity line)
273 (string-match "\\(PARTSTAT=\\)[^;]+" line))
274 (replace-match (format "\\1%s" attendee-status) t nil line)))
275 (process-event-line (line)
276 (when (string-match "^\\([^;:]+\\)" line)
277 (let* ((key (match-string 0 line))
278 ;; NOTE: not all of the below fields are mandatory,
279 ;; but they are often present in other clients'
280 ;; replies. Can be helpful for debugging, too.
ec956438
JT		 281 (new-line
282 (cond
283 ((string= key "ATTENDEE") (update-attendee-status line))
284 ((string= key "SUMMARY") (update-summary line))
285 ((string= key "DTSTAMP") (update-dtstamp))
a99f655b
GM		 286 ((member key '("ORGANIZER" "DTSTART" "DTEND"
287 "LOCATION" "DURATION" "SEQUENCE"
288 "RECURRENCE-ID" "UID")) line)
ec956438 289 (t nil))))
89cccc2f
G		 290 (when new-line
291 (push new-line reply-event-lines))))))
292
293 (mapc #'process-event-line (split-string ical-request "\n"))
294
295 (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
296 reply-event-lines)
297 (error "Could not find an event attendee matching given identity"))
298
299 (mapconcat #'identity `("BEGIN:VEVENT"
300 ,@(nreverse reply-event-lines)
301 "END:VEVENT")
302 "\n"))))
303
304(defun gnus-icalendar-event-reply-from-buffer (buf status identities)
305 "Build a calendar event reply for request contained in BUF.
306The reply will have STATUS (`accepted', `tentative' or `declined').
307The reply will be composed for attendees matching any entry
308on the IDENTITIES list."
9ab16aab 309 (gmm-labels ((extract-block (blockname)
89cccc2f
G		 310 (save-excursion
311 (let ((block-start-re (format "^BEGIN:%s" blockname))
312 (block-end-re (format "^END:%s" blockname))
313 start)
314 (when (re-search-forward block-start-re nil t)
315 (setq start (line-beginning-position))
316 (re-search-forward block-end-re)
317 (buffer-substring-no-properties start (line-end-position)))))))
318
319 (let (zone event)
320 (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
321 (goto-char (point-min))
322 (setq zone (extract-block "VTIMEZONE")
323 event (extract-block "VEVENT")))
324
325 (when event
326 (let ((contents (list "BEGIN:VCALENDAR"
327 "METHOD:REPLY"
328 "PRODID:Gnus"
329 "VERSION:2.0"
330 zone
331 (gnus-icalendar-event--build-reply-event-body event status identities)
332 "END:VCALENDAR")))
333
334 (mapconcat #'identity (delq nil contents) "\n"))))))
335
336;;;
337;;; gnus-icalendar-org
338;;;
339;;; TODO: this is an optional feature, and it's only available with org-mode
340;;; 7+, so will need to properly handle emacsen with no/outdated org-mode
341
342(require 'org)
343(require 'org-capture)
344
345(defgroup gnus-icalendar-org nil
346 "Settings for Calendar Event gnus/org integration."
bb098075 347 :version "24.4"
89cccc2f
G		 348 :group 'gnus-icalendar
349 :prefix "gnus-icalendar-org-")
350
351(defcustom gnus-icalendar-org-capture-file nil
352 "Target Org file for storing captured calendar events."
ae3f0661 353 :type '(choice (const nil) file)
89cccc2f
G		 354 :group 'gnus-icalendar-org)
355
356(defcustom gnus-icalendar-org-capture-headline nil
357 "Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
358 :type '(repeat string)
359 :group 'gnus-icalendar-org)
360
361(defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
362 "Org-mode template name."
363 :type '(string)
364 :group 'gnus-icalendar-org)
365
366(defcustom gnus-icalendar-org-template-key "#"
367 "Org-mode template hotkey."
368 :type '(string)
369 :group 'gnus-icalendar-org)
370
371(defvar gnus-icalendar-org-enabled-p nil)
372
373
374(defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event))
375 "Return `org-mode' timestamp repeater string for recurring EVENT.
376Return nil for non-recurring EVENT."
377 (when (gnus-icalendar-event:recurring-p event)
378 (let* ((freq-map '(("HOURLY" . "h")
379 ("DAILY" . "d")
380 ("WEEKLY" . "w")
381 ("MONTHLY" . "m")
382 ("YEARLY" . "y")))
383 (org-freq (cdr (assoc (gnus-icalendar-event:recurring-freq event) freq-map))))
384
385 (when org-freq
386 (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
387
388(defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
389 "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
390 (let* ((start (gnus-icalendar-event:start-time event))
391 (end (gnus-icalendar-event:end-time event))
62dfefa0
JT		 392 (start-date (format-time-string "%Y-%m-%d %a" start))
393 (start-time (format-time-string "%H:%M" start))
680f4ae6 394 (start-at-midnight (string= start-time "00:00"))
62dfefa0
JT		 395 (end-date (format-time-string "%Y-%m-%d %a" end))
396 (end-time (format-time-string "%H:%M" end))
680f4ae6
JT		 397 (end-at-midnight (string= end-time "00:00"))
398 (start-end-date-diff (/ (float-time (time-subtract
399 (date-to-time end-date)
400 (date-to-time start-date)))
401 86400))
89cccc2f 402 (org-repeat (gnus-icalendar-event:org-repeat event))
680f4ae6
JT		 403 (repeat (if org-repeat (concat " " org-repeat) ""))
404 (time-1-day '(0 86400)))
405
406 ;; NOTE: special care is needed with appointments ending at midnight
407 ;; (typically all-day events): the end time has to be changed to 23:59 to
408 ;; prevent org agenda showing the event on one additional day
409 (cond
410 ;; start/end midnight
411 ;; A 0:0 - A+1 0:0 -> A
412 ;; A 0:0 - A+n 0:0 -> A - A+n-1
413 ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
414 (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
415 (format "<%s>--<%s>" start-date end-ts))
416 (format "<%s%s>" start-date repeat)))
417 ;; end midnight
418 ;; A .:. - A+1 0:0 -> A .:.-23:59
419 ;; A .:. - A+n 0:0 -> A .:. - A_n-1
420 (end-at-midnight (if (= start-end-date-diff 1)
421 (format "<%s %s-23:59%s>" start-date start-time repeat)
422 (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
423 (format "<%s %s>--<%s>" start-date start-time end-ts))))
424 ;; start midnight
425 ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
426 ;; A 0:0 - A+n .:. -> A - A+n .:.
427 ((and start-at-midnight
428 (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
429 ;; default
430 ;; A .:. - A .:. -> A .:.-.:.
431 ;; A .:. - B .:.
432 ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
433 (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
89cccc2f 434
0f755e30
JT		 435(defun gnus-icalendar--format-summary-line (summary &optional location)
436 (if location
437 (format "%s (%s)" summary location)
438 (format "%s" summary)))
439
8ef7141b
JT		 440
441(defun gnus-icalendar--format-participant-list (participants)
442 (mapconcat #'identity participants ", "))
443
89cccc2f
G		 444;; TODO: make the template customizable
445(defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
446 "Return string with new `org-mode' entry describing EVENT."
447 (with-temp-buffer
448 (org-mode)
449 (with-slots (organizer summary description location
450 recur uid) event
451 (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
452 "Not replied yet"))
453 (props `(("ICAL_EVENT" . "t")
454 ("ID" . ,uid)
455 ("DT" . ,(gnus-icalendar-event:org-timestamp event))
456 ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
457 ("LOCATION" . ,(gnus-icalendar-event:location event))
42e51060 458 ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
8ef7141b
JT		 459 ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
460 ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
89cccc2f
G		 461 ("RRULE" . ,(gnus-icalendar-event:recur event))
462 ("REPLY" . ,reply))))
463
0f755e30
JT		 464 (insert (format "* %s\n\n"
465 (gnus-icalendar--format-summary-line summary location)))
89cccc2f
G		 466 (mapc (lambda (prop)
467 (org-entry-put (point) (car prop) (cdr prop)))
468 props))
469
470 (when description
471 (save-restriction
472 (narrow-to-region (point) (point))
473 (insert description)
474 (indent-region (point-min) (point-max) 2)
475 (fill-region (point-min) (point-max))))
476
477 (buffer-string))))
478
479(defun gnus-icalendar--deactivate-org-timestamp (ts)
480 (replace-regexp-in-string "[<>]"
ec956438
JT		 481 (lambda (m) (cond ((string= m "<") "[")
482 ((string= m ">") "]")))
89cccc2f
G		 483 ts))
484
485(defun gnus-icalendar-find-org-event-file (event &optional org-file)
486 "Return the name of the file containing EVENT org entry.
487Return nil when not found.
488
489All org agenda files are searched for the EVENT entry. When
490the optional ORG-FILE argument is specified, only that one file
491is searched."
492 (let ((uid (gnus-icalendar-event:uid event))
493 (files (or org-file (org-agenda-files t 'ifmode))))
9ab16aab 494 (gmm-labels
89cccc2f
G		 495 ((find-event-in (file)
496 (org-check-agenda-file file)
497 (with-current-buffer (find-file-noselect file)
498 (let ((event-pos (org-find-entry-with-id uid)))
499 (when (and event-pos
500 (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos)))
501 "t"))
502 (throw 'found file))))))
503
504 (gnus-icalendar-find-if #'find-event-in files))))
505
506
507(defun gnus-icalendar--show-org-event (event &optional org-file)
508 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
509 (when file
510 (switch-to-buffer (find-file file))
511 (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
512 (org-show-entry))))
513
514
515(defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
516 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
517 (when file
518 (with-current-buffer (find-file-noselect file)
8ef7141b 519 (with-slots (uid summary description organizer location recur
42e51060 520 participation-type req-participants opt-participants) event
89cccc2f
G		 521 (let ((event-pos (org-find-entry-with-id uid)))
522 (when event-pos
523 (goto-char event-pos)
524
525 ;; update the headline, keep todo, priority and tags, if any
526 (save-excursion
527 (let* ((priority (org-entry-get (point) "PRIORITY"))
528 (headline (delq nil (list
529 (org-entry-get (point) "TODO")
530 (when priority (format "[#%s]" priority))
0f755e30 531 (gnus-icalendar--format-summary-line summary location)
89cccc2f
G		 532 (org-entry-get (point) "TAGS")))))
533
534 (re-search-forward "^\\*+ " (line-end-position))
535 (delete-region (point) (line-end-position))
536 (insert (mapconcat #'identity headline " "))))
537
538 ;; update props and description
539 (let ((entry-end (org-entry-end-position))
540 (entry-outline-level (org-outline-level)))
541
542 ;; delete body of the entry, leave org drawers intact
543 (save-restriction
544 (org-narrow-to-element)
545 (goto-char entry-end)
546 (re-search-backward "^[\t ]*:END:")
547 (forward-line)
548 (delete-region (point) entry-end))
549
550 ;; put new event description in the entry body
551 (when description
552 (save-restriction
553 (narrow-to-region (point) (point))
554 (insert "\n" (replace-regexp-in-string "[\n]+$" "\n" description) "\n")
555 (indent-region (point-min) (point-max) (1+ entry-outline-level))
556 (fill-region (point-min) (point-max))))
557
558 ;; update entry properties
559 (org-entry-put event-pos "DT" (gnus-icalendar-event:org-timestamp event))
560 (org-entry-put event-pos "ORGANIZER" organizer)
561 (org-entry-put event-pos "LOCATION" location)
42e51060 562 (org-entry-put event-pos "PARTICIPATION_TYPE" (symbol-name participation-type))
8ef7141b
JT		 563 (org-entry-put event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants))
564 (org-entry-put event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants))
89cccc2f
G		 565 (org-entry-put event-pos "RRULE" recur)
566 (when reply-status (org-entry-put event-pos "REPLY"
567 (capitalize (symbol-name reply-status))))
568 (save-buffer)))))))))
569
570
571(defun gnus-icalendar--cancel-org-event (event &optional org-file)
572 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
573 (when file
574 (with-current-buffer (find-file-noselect file)
575 (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
576 (when event-pos
577 (let ((ts (org-entry-get event-pos "DT")))
578 (when ts
579 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
580 (save-buffer)))))))))
581
582
583(defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
584 (let ((file (gnus-icalendar-find-org-event-file event org-file)))
585 (when file
586 (save-excursion
587 (with-current-buffer (find-file-noselect file)
588 (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
589 (org-entry-get event-pos "REPLY")))))))
590
591
592(defun gnus-icalendar-insinuate-org-templates ()
593 (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
594 org-capture-templates)
595 (setq org-capture-templates
596 (append `((,gnus-icalendar-org-template-key
597 ,gnus-icalendar-org-template-name
598 entry
599 (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
600 "%i"
601 :immediate-finish t))
602 org-capture-templates))
603
604 ;; hide the template from interactive template selection list
605 ;; (org-capture)
606 ;; NOTE: doesn't work when capturing from string
607 ;; (when (boundp 'org-capture-templates-contexts)
608 ;; (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
609 ;; org-capture-templates-contexts))
610 ))
611
612(defun gnus-icalendar:org-event-save (event reply-status)
613 (with-temp-buffer
614 (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
615 gnus-icalendar-org-template-key)))
616
617(defun gnus-icalendar-show-org-agenda (event)
618 (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
619 (gnus-icalendar-event:start-time event)))
620 (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
621 (cadr time-delta))
622 86400))))
623
624 (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
625
626(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
627 (if (gnus-icalendar-find-org-event-file event)
628 (gnus-icalendar--update-org-event event reply-status)
629 (gnus-icalendar:org-event-save event reply-status)))
630
0f755e30 631(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
89cccc2f
G		 632 (when (gnus-icalendar-find-org-event-file event)
633 (gnus-icalendar--cancel-org-event event)))
634
635(defun gnus-icalendar-org-setup ()
636 (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
637 (progn
638 (gnus-icalendar-insinuate-org-templates)
639 (setq gnus-icalendar-org-enabled-p t))
640 (message "Cannot enable Calendar->Org: missing capture file, headline")))
641
642;;;
643;;; gnus-icalendar
644;;;
645
646(defgroup gnus-icalendar nil
647 "Settings for inline display of iCalendar invitations."
bb098075 648 :version "24.4"
89cccc2f
G		 649 :group 'gnus-article
650 :prefix "gnus-icalendar-")
651
652(defcustom gnus-icalendar-reply-bufname "*CAL*"
653 "Buffer used for building iCalendar invitation reply."
654 :type '(string)
655 :group 'gnus-icalendar)
656
680f4ae6
JT		 657(defcustom gnus-icalendar-additional-identities nil
658 "We need to know your identity to make replies to calendar requests work.
659
660Gnus will only offer you the Accept/Tentative/Decline buttons for
661calendar events if any of your identities matches at least one
662RSVP participant.
663
664Your identity is guessed automatically from the variables `user-full-name',
665`user-mail-address', and `gnus-ignored-from-addresses'.
666
667If you need even more aliases you can define them here. It really
668only makes sense to define names or email addresses."
669
670 :type '(repeat string)
671 :group 'gnus-icalendar)
672
89cccc2f
G		 673(make-variable-buffer-local
674 (defvar gnus-icalendar-reply-status nil))
675
676(make-variable-buffer-local
677 (defvar gnus-icalendar-event nil))
678
679(make-variable-buffer-local
680 (defvar gnus-icalendar-handle nil))
681
88312cfc
JT		 682(defun gnus-icalendar-identities ()
683 "Return list of regexp-quoted names and email addresses belonging to the user.
684
685These will be used to retrieve the RSVP information from ical events."
89cccc2f
G		 686 (apply #'append
687 (mapcar (lambda (x) (if (listp x) x (list x)))
688 (list user-full-name (regexp-quote user-mail-address)
680f4ae6
JT		 689 ; NOTE: these can be lists
690 gnus-ignored-from-addresses ; already regexp-quoted
691 (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
89cccc2f
G		 692
693;; TODO: make the template customizable
694(defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
695 "Format an overview of EVENT details."
9ab16aab 696 (gmm-labels ((format-header (x)
89cccc2f
G		 697 (format "%-12s%s"
698 (propertize (concat (car x) ":") 'face 'bold)
699 (cadr x))))
700
8ef7141b 701 (with-slots (organizer summary description location recur uid
42e51060 702 method rsvp participation-type) event
89cccc2f 703 (let ((headers `(("Summary" ,summary)
0f755e30 704 ("Location" ,(or location ""))
89cccc2f
G		 705 ("Time" ,(gnus-icalendar-event:org-timestamp event))
706 ("Organizer" ,organizer)
42e51060
JT		 707 ("Attendance" ,(if (eq participation-type 'non-participant)
708 "You are not listed as an attendee"
709 (capitalize (symbol-name participation-type))))
89cccc2f
G		 710 ("Method" ,method))))
711
712 (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
713 (setq headers (append headers
714 `(("Status" ,(or reply-status "Not replied yet"))))))
715
716 (concat
717 (mapconcat #'format-header headers "\n")
718 "\n\n"
719 description)))))
720
721(defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
722 "Execute BODY in buffer containing the decoded contents of HANDLE."
723 (let ((charset (make-symbol "charset")))
724 `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
725 (with-temp-buffer
726 (mm-insert-part ,handle)
727 (when (string= ,charset "utf-8")
728 (mm-decode-coding-region (point-min) (point-max) 'utf-8))
729
730 ,@body))))
731
732
733(defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
734 (gnus-icalendar-with-decoded-handle handle
735 (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
736
737(defun gnus-icalendar-insert-button (text callback data)
738 ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
739 ;; of button.
740 (let ((start (point)))
741 (gnus-add-text-properties
742 start
743 (progn
744 (insert "[ " text " ]")
745 (point))
746 `(gnus-callback
747 ,callback
748 keymap ,gnus-mime-button-map
749 face ,gnus-article-button-face
750 gnus-data ,data))
751 (widget-convert-button 'link start (point)
752 :action 'gnus-widget-press-button
753 :button-keymap gnus-widget-button-keymap)))
754
755(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
756 (let ((message-signature nil))
757 (with-current-buffer gnus-summary-buffer
758 (gnus-summary-reply)
759 (message-goto-body)
760 (mml-insert-multipart "alternative")
761 (mml-insert-empty-tag 'part 'type "text/plain")
762 (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
763 (message-goto-subject)
764 (delete-region (line-beginning-position) (line-end-position))
765 (insert "Subject: " subject)
766 (message-send-and-exit))))
767
768(defun gnus-icalendar-reply (data)
769 (let* ((handle (car data))
770 (status (cadr data))
771 (event (caddr data))
772 (reply (gnus-icalendar-with-decoded-handle handle
773 (gnus-icalendar-event-reply-from-buffer
88312cfc 774 (current-buffer) status (gnus-icalendar-identities)))))
89cccc2f
G		 775
776 (when reply
9ab16aab 777 (gmm-labels ((fold-icalendar-buffer ()
89cccc2f
G		 778 (goto-char (point-min))
779 (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
780 (replace-match "\\1\n \\2")
781 (goto-char (line-beginning-position)))))
782 (let ((subject (concat (capitalize (symbol-name status))
783 ": " (gnus-icalendar-event:summary event))))
784
785 (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
786 (delete-region (point-min) (point-max))
787 (insert reply)
788 (fold-icalendar-buffer)
789 (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
790
791 ;; Back in article buffer
792 (setq-local gnus-icalendar-reply-status status)
793 (when gnus-icalendar-org-enabled-p
794 (gnus-icalendar--update-org-event event status)
795 ;; refresh article buffer to update the reply status
796 (with-current-buffer gnus-summary-buffer
797 (gnus-summary-show-article))))))))
798
799(defun gnus-icalendar-sync-event-to-org (event)
800 (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
801
802(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
803 (when (gnus-icalendar-event:rsvp event)
804 `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
805 ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
806 ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
807
808(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
809 "No buttons for REPLY events."
810 nil)
811
812(defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
813 (or (when gnus-icalendar-org-enabled-p
814 (gnus-icalendar--get-org-event-reply-status event))
815 "Not replied yet"))
816
817(defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
818 "No reply status for REPLY events."
819 nil)
820
821
822(defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
823 (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
824 (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
825
826 (delq nil (list
827 `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
828 (when (gnus-icalendar-event-request-p event)
829 `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
830 (when org-entry-exists-p
831 `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
832
0f755e30
JT		 833
834(defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
835 (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
836
837 (delq nil (list
838 `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
839 (when org-entry-exists-p
840 `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
841 (when org-entry-exists-p
842 `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
843
844
89cccc2f 845(defun gnus-icalendar-mm-inline (handle)
88312cfc 846 (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
89cccc2f
G		 847
848 (setq gnus-icalendar-reply-status nil)
849
850 (when event
9ab16aab 851 (gmm-labels ((insert-button-group (buttons)
89cccc2f
G		 852 (when buttons
853 (mapc (lambda (x)
854 (apply 'gnus-icalendar-insert-button x)
855 (insert " "))
856 buttons)
857 (insert "\n\n"))))
858
859 (insert-button-group
860 (gnus-icalendar-event:inline-reply-buttons event handle))
861
862 (when gnus-icalendar-org-enabled-p
863 (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
864
865 (setq gnus-icalendar-event event
866 gnus-icalendar-handle handle)
867
868 (insert (gnus-icalendar-event->gnus-calendar
869 event
870 (gnus-icalendar-event:inline-reply-status event)))))))
871
872(defun gnus-icalendar-save-part (handle)
873 (let (event)
874 (when (and (equal (car (mm-handle-type handle)) "text/calendar")
88312cfc 875 (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
89cccc2f
G		 876
877 (gnus-icalendar-event:sync-to-org event))))
878
879
880(defun gnus-icalendar-save-event ()
881 "Save the Calendar event in the text/calendar part under point."
882 (interactive)
883 (gnus-article-check-buffer)
884 (let ((data (get-text-property (point) 'gnus-data)))
885 (when data
886 (gnus-icalendar-save-part data))))
887
888(defun gnus-icalendar-reply-accept ()
889 "Accept invitation in the current article."
890 (interactive)
891 (with-current-buffer gnus-article-buffer
892 (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
893 (setq-local gnus-icalendar-reply-status 'accepted)))
894
895(defun gnus-icalendar-reply-tentative ()
896 "Send tentative response to invitation in the current article."
897 (interactive)
898 (with-current-buffer gnus-article-buffer
899 (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
900 (setq-local gnus-icalendar-reply-status 'tentative)))
901
902(defun gnus-icalendar-reply-decline ()
903 "Decline invitation in the current article."
904 (interactive)
905 (with-current-buffer gnus-article-buffer
906 (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
907 (setq-local gnus-icalendar-reply-status 'declined)))
908
909(defun gnus-icalendar-event-export ()
910 "Export calendar event to `org-mode', or update existing agenda entry."
911 (interactive)
912 (with-current-buffer gnus-article-buffer
913 (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
914 ;; refresh article buffer in case the reply had been sent before initial org
915 ;; export
916 (with-current-buffer gnus-summary-buffer
917 (gnus-summary-show-article)))
918
919(defun gnus-icalendar-event-show ()
920 "Display `org-mode' agenda entry related to the calendar event."
921 (interactive)
922 (gnus-icalendar--show-org-event
923 (with-current-buffer gnus-article-buffer
924 gnus-icalendar-event)))
925
926(defun gnus-icalendar-event-check-agenda ()
927 "Display `org-mode' agenda for days between event start and end dates."
928 (interactive)
929 (gnus-icalendar-show-org-agenda
930 (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
931
a99f655b
GM		 932(defvar gnus-mime-action-alist) ; gnus-art
933
89cccc2f
G		 934(defun gnus-icalendar-setup ()
935 (add-to-list 'mm-inlined-types "text/calendar")
936 (add-to-list 'mm-automatic-display "text/calendar")
937 (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
938
939 (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
940 "a" gnus-icalendar-reply-accept
941 "t" gnus-icalendar-reply-tentative
942 "d" gnus-icalendar-reply-decline
943 "c" gnus-icalendar-event-check-agenda
944 "e" gnus-icalendar-event-export
945 "s" gnus-icalendar-event-show)
946
947 (require 'gnus-art)
948 (add-to-list 'gnus-mime-action-alist
949 (cons "save calendar event" 'gnus-icalendar-save-event)
950 t))
951
952(provide 'gnus-icalendar)
953
954;;; gnus-icalendar.el ends here
Unnamed repository; edit this file 'description' to name the repository.