;;; gnus-icalendar.el --- reply to iCalendar meeting requests
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
;; Keywords: mail, icalendar, org
(require 'icalendar)
(require 'eieio)
+(require 'gmm-utils)
(require 'mm-decode)
(require 'gnus-sum)
+(require 'gnus-art)
(eval-when-compile (require 'cl))
:accessor gnus-icalendar-event:location
:initform ""
:type (or null string))
- (start :initarg :start
- :accessor gnus-icalendar-event:start
+ (start-time :initarg :start-time
+ :accessor gnus-icalendar-event:start-time
:initform ""
- :type (or null string))
- (end :initarg :end
- :accessor gnus-icalendar-event:end
+ :type (or null t))
+ (end-time :initarg :end-time
+ :accessor gnus-icalendar-event:end-time
:initform ""
- :type (or null string))
+ :type (or null t))
(recur :initarg :recur
:accessor gnus-icalendar-event:recur
:initform ""
(rsvp :initarg :rsvp
:accessor gnus-icalendar-event:rsvp
:initform nil
- :type (or null boolean)))
+ :type (or null boolean))
+ (participation-type :initarg :participation-type
+ :accessor gnus-icalendar-event:participation-type
+ :initform 'non-participant
+ :type (or null t))
+ (req-participants :initarg :req-participants
+ :accessor gnus-icalendar-event:req-participants
+ :initform nil
+ :type (or null t))
+ (opt-participants :initarg :opt-participants
+ :accessor gnus-icalendar-event:opt-participants
+ :initform nil
+ :type (or null t)))
"generic iCalendar Event class")
(defclass gnus-icalendar-event-request (gnus-icalendar-event)
(or (match-string 1 rrule)
default-interval)))
-(defmethod gnus-icalendar-event:start-time ((event gnus-icalendar-event))
- "Return time value of the EVENT start date."
- (date-to-time (gnus-icalendar-event:start event)))
-
-(defmethod gnus-icalendar-event:end-time ((event gnus-icalendar-event))
- "Return time value of the EVENT end date."
- (date-to-time (gnus-icalendar-event:end event)))
+(defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
+ (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
-
-(defun gnus-icalendar-event--decode-datefield (ical field zone-map &optional date-style)
- (let* ((calendar-date-style (or date-style 'european))
- (date (icalendar--get-event-property ical field))
- (date-zone (icalendar--find-time-zone
- (icalendar--get-event-property-attributes
- ical field)
- zone-map))
- (date-decoded (icalendar--decode-isodatetime date nil date-zone)))
-
- (concat (icalendar--datetime-to-iso-date date-decoded "-")
- " "
- (icalendar--datetime-to-colontime date-decoded))))
+(defun gnus-icalendar-event--decode-datefield (event field zone-map)
+ (let* ((dtdate (icalendar--get-event-property event field))
+ (dtdate-zone (icalendar--find-time-zone
+ (icalendar--get-event-property-attributes
+ event field) zone-map))
+ (dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone)))
+ (apply 'encode-time dtdate-dec)))
(defun gnus-icalendar-event--find-attendee (ical name-or-email)
(let* ((event (car (icalendar--all-events ical)))
(event-props (caddr event)))
- (labels ((attendee-name (att) (plist-get (cadr att) 'CN))
+ (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
(attendee-email (att)
(replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
(attendee-prop-matches-p (prop)
(gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
+(defun gnus-icalendar-event--get-attendee-names (ical)
+ (let* ((event (car (icalendar--all-events ical)))
+ (attendee-props (gnus-remove-if-not
+ (lambda (p) (eq (car p) 'ATTENDEE))
+ (caddr event))))
+
+ (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
+ (attendee-name (prop)
+ (or (plist-get (cadr prop) 'CN)
+ (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
+ (attendees-by-type (type)
+ (gnus-remove-if-not
+ (lambda (p) (string= (attendee-role p) type))
+ attendee-props))
+ (attendee-names-by-type (type)
+ (mapcar #'attendee-name (attendees-by-type type))))
+
+ (list
+ (attendee-names-by-type "REQ-PARTICIPANT")
+ (attendee-names-by-type "OPT-PARTICIPANT")))))
(defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
(let* ((event (car (icalendar--all-events ical)))
- (zone-map (icalendar--convert-all-timezones ical))
(organizer (replace-regexp-in-string
"^.*MAILTO:" ""
(or (icalendar--get-event-property event 'ORGANIZER) "")))
(method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
(attendee (when attendee-name-or-email
(gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
+ (attendee-names (gnus-icalendar-event--get-attendee-names ical))
+ (role (plist-get (cadr attendee) 'ROLE))
+ (participation-type (pcase role
+ ("REQ-PARTICIPANT" 'required)
+ ("OPT-PARTICIPANT" 'optional)
+ (_ 'non-participant)))
+ (zone-map (icalendar--convert-all-timezones ical))
(args (list :method method
:organizer organizer
- :start (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map)
- :end (gnus-icalendar-event--decode-datefield event 'DTEND zone-map)
- :rsvp (string= (plist-get (cadr attendee) 'RSVP)
- "TRUE")))
+ :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map)
+ :end-time (gnus-icalendar-event--decode-datefield event 'DTEND zone-map)
+ :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE")
+ :participation-type participation-type
+ :req-participants (car attendee-names)
+ :opt-participants (cadr attendee-names)))
(event-class (cond
((string= method "REQUEST") 'gnus-icalendar-event-request)
((string= method "CANCEL") 'gnus-icalendar-event-cancel)
((string= method "REPLY") 'gnus-icalendar-event-reply)
(t 'gnus-icalendar-event))))
- (labels ((map-property (prop)
+ (gmm-labels ((map-property (prop)
(let ((value (icalendar--get-event-property event prop)))
(when value
;; ugly, but cannot get
(let ((summary-status (capitalize (symbol-name status)))
(attendee-status (upcase (symbol-name status)))
reply-event-lines)
- (labels ((update-summary (line)
+ (gmm-labels ((update-summary (line)
(if (string-match "^[^:]+:" line)
(replace-match (format "\\&%s: " summary-status) t nil line)
line))
((string= key "ATTENDEE") (update-attendee-status line))
((string= key "SUMMARY") (update-summary line))
((string= key "DTSTAMP") (update-dtstamp))
- ((find key '("ORGANIZER" "DTSTART" "DTEND"
- "LOCATION" "DURATION" "SEQUENCE"
- "RECURRENCE-ID" "UID")) line)
+ ((member key '("ORGANIZER" "DTSTART" "DTEND"
+ "LOCATION" "DURATION" "SEQUENCE"
+ "RECURRENCE-ID" "UID")) line)
(t nil))))
(when new-line
(push new-line reply-event-lines))))))
The reply will have STATUS (`accepted', `tentative' or `declined').
The reply will be composed for attendees matching any entry
on the IDENTITIES list."
- (flet ((extract-block (blockname)
+ (gmm-labels ((extract-block (blockname)
(save-excursion
(let ((block-start-re (format "^BEGIN:%s" blockname))
(block-end-re (format "^END:%s" blockname))
(defgroup gnus-icalendar-org nil
"Settings for Calendar Event gnus/org integration."
+ :version "24.4"
:group 'gnus-icalendar
:prefix "gnus-icalendar-org-")
(defcustom gnus-icalendar-org-capture-file nil
"Target Org file for storing captured calendar events."
- :type 'file
+ :type '(choice (const nil) file)
:group 'gnus-icalendar-org)
(defcustom gnus-icalendar-org-capture-headline nil
"Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
(let* ((start (gnus-icalendar-event:start-time event))
(end (gnus-icalendar-event:end-time event))
- (start-date (format-time-string "%Y-%m-%d %a" start t))
- (start-time (format-time-string "%H:%M" start t))
- (end-date (format-time-string "%Y-%m-%d %a" end t))
- (end-time (format-time-string "%H:%M" end t))
+ (start-date (format-time-string "%Y-%m-%d %a" start))
+ (start-time (format-time-string "%H:%M" start))
+ (start-at-midnight (string= start-time "00:00"))
+ (end-date (format-time-string "%Y-%m-%d %a" end))
+ (end-time (format-time-string "%H:%M" end))
+ (end-at-midnight (string= end-time "00:00"))
+ (start-end-date-diff (/ (float-time (time-subtract
+ (date-to-time end-date)
+ (date-to-time start-date)))
+ 86400))
(org-repeat (gnus-icalendar-event:org-repeat event))
- (repeat (if org-repeat (concat " " org-repeat) "")))
-
- (if (equal start-date end-date)
- (format "<%s %s-%s%s>" start-date start-time end-time repeat)
- (format "<%s %s>--<%s %s>" start-date start-time end-date end-time))))
+ (repeat (if org-repeat (concat " " org-repeat) ""))
+ (time-1-day '(0 86400)))
+
+ ;; NOTE: special care is needed with appointments ending at midnight
+ ;; (typically all-day events): the end time has to be changed to 23:59 to
+ ;; prevent org agenda showing the event on one additional day
+ (cond
+ ;; start/end midnight
+ ;; A 0:0 - A+1 0:0 -> A
+ ;; A 0:0 - A+n 0:0 -> A - A+n-1
+ ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
+ (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
+ (format "<%s>--<%s>" start-date end-ts))
+ (format "<%s%s>" start-date repeat)))
+ ;; end midnight
+ ;; A .:. - A+1 0:0 -> A .:.-23:59
+ ;; A .:. - A+n 0:0 -> A .:. - A_n-1
+ (end-at-midnight (if (= start-end-date-diff 1)
+ (format "<%s %s-23:59%s>" start-date start-time repeat)
+ (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
+ (format "<%s %s>--<%s>" start-date start-time end-ts))))
+ ;; start midnight
+ ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
+ ;; A 0:0 - A+n .:. -> A - A+n .:.
+ ((and start-at-midnight
+ (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
+ ;; default
+ ;; A .:. - A .:. -> A .:.-.:.
+ ;; A .:. - B .:.
+ ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
+ (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
+
+(defun gnus-icalendar--format-summary-line (summary &optional location)
+ (if location
+ (format "%s (%s)" summary location)
+ (format "%s" summary)))
+
+
+(defun gnus-icalendar--format-participant-list (participants)
+ (mapconcat #'identity participants ", "))
;; TODO: make the template customizable
(defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
"Not replied yet"))
(props `(("ICAL_EVENT" . "t")
("ID" . ,uid)
- ("DT" . ,(gnus-icalendar-event:org-timestamp event))
("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
("LOCATION" . ,(gnus-icalendar-event:location event))
+ ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
+ ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
+ ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
("RRULE" . ,(gnus-icalendar-event:recur event))
("REPLY" . ,reply))))
- (insert (format "* %s (%s)\n\n" summary location))
+ (insert (format "* %s\n\n"
+ (gnus-icalendar--format-summary-line summary location)))
(mapc (lambda (prop)
(org-entry-put (point) (car prop) (cdr prop)))
props))
(when description
(save-restriction
(narrow-to-region (point) (point))
- (insert description)
+ (insert (gnus-icalendar-event:org-timestamp event)
+ "\n\n"
+ description)
(indent-region (point-min) (point-max) 2)
(fill-region (point-min) (point-max))))
is searched."
(let ((uid (gnus-icalendar-event:uid event))
(files (or org-file (org-agenda-files t 'ifmode))))
- (flet
+ (gmm-labels
((find-event-in (file)
(org-check-agenda-file file)
(with-current-buffer (find-file-noselect file)
(let ((file (gnus-icalendar-find-org-event-file event org-file)))
(when file
(with-current-buffer (find-file-noselect file)
- (with-slots (uid summary description organizer location recur) event
+ (with-slots (uid summary description organizer location recur
+ participation-type req-participants opt-participants) event
(let ((event-pos (org-find-entry-with-id uid)))
(when event-pos
(goto-char event-pos)
(headline (delq nil (list
(org-entry-get (point) "TODO")
(when priority (format "[#%s]" priority))
- (format "%s (%s)" summary location)
+ (gnus-icalendar--format-summary-line summary location)
(org-entry-get (point) "TAGS")))))
(re-search-forward "^\\*+ " (line-end-position))
(when description
(save-restriction
(narrow-to-region (point) (point))
- (insert "\n" (replace-regexp-in-string "[\n]+$" "\n" description) "\n")
+ (insert "\n"
+ (gnus-icalendar-event:org-timestamp event)
+ "\n\n"
+ (replace-regexp-in-string "[\n]+$" "\n" description)
+ "\n")
(indent-region (point-min) (point-max) (1+ entry-outline-level))
(fill-region (point-min) (point-max))))
;; update entry properties
- (org-entry-put event-pos "DT" (gnus-icalendar-event:org-timestamp event))
- (org-entry-put event-pos "ORGANIZER" organizer)
- (org-entry-put event-pos "LOCATION" location)
- (org-entry-put event-pos "RRULE" recur)
- (when reply-status (org-entry-put event-pos "REPLY"
- (capitalize (symbol-name reply-status))))
+ (gmm-labels
+ ((update-org-entry (position property value)
+ (if (or (null value)
+ (string= value ""))
+ (org-entry-delete position property)
+ (org-entry-put position property value))))
+
+ (update-org-entry event-pos "ORGANIZER" organizer)
+ (update-org-entry event-pos "LOCATION" location)
+ (update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type))
+ (update-org-entry event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants))
+ (update-org-entry event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants))
+ (update-org-entry event-pos "RRULE" recur)
+ (update-org-entry event-pos "REPLY"
+ (if reply-status (capitalize (symbol-name reply-status))
+ "Not replied yet")))
(save-buffer)))))))))
(gnus-icalendar--update-org-event event reply-status)
(gnus-icalendar:org-event-save event reply-status)))
-(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel))
+(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
(when (gnus-icalendar-find-org-event-file event)
(gnus-icalendar--cancel-org-event event)))
(defgroup gnus-icalendar nil
"Settings for inline display of iCalendar invitations."
+ :version "24.4"
:group 'gnus-article
:prefix "gnus-icalendar-")
:type '(string)
:group 'gnus-icalendar)
+(defcustom gnus-icalendar-additional-identities nil
+ "We need to know your identity to make replies to calendar requests work.
+
+Gnus will only offer you the Accept/Tentative/Decline buttons for
+calendar events if any of your identities matches at least one
+RSVP participant.
+
+Your identity is guessed automatically from the variables
+`user-full-name', `user-mail-address',
+`gnus-ignored-from-addresses' and `message-alternative-emails'.
+
+If you need even more aliases you can define them here. It really
+only makes sense to define names or email addresses."
+
+ :type '(repeat string)
+ :group 'gnus-icalendar)
+
(make-variable-buffer-local
(defvar gnus-icalendar-reply-status nil))
(make-variable-buffer-local
(defvar gnus-icalendar-handle nil))
-(defvar gnus-icalendar-identities
+(defun gnus-icalendar-identities ()
+ "Return list of regexp-quoted names and email addresses belonging to the user.
+
+These will be used to retrieve the RSVP information from ical events."
(apply #'append
(mapcar (lambda (x) (if (listp x) x (list x)))
(list user-full-name (regexp-quote user-mail-address)
- ; NOTE: this one can be a list
- gnus-ignored-from-addresses))))
+ ; NOTE: these can be lists
+ gnus-ignored-from-addresses ; already regexp-quoted
+ message-alternative-emails ;
+ (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
;; TODO: make the template customizable
(defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
"Format an overview of EVENT details."
- (flet ((format-header (x)
+ (gmm-labels ((format-header (x)
(format "%-12s%s"
(propertize (concat (car x) ":") 'face 'bold)
(cadr x))))
- (with-slots (organizer summary description location recur uid method rsvp) event
+ (with-slots (organizer summary description location recur uid
+ method rsvp participation-type) event
(let ((headers `(("Summary" ,summary)
- ("Location" ,location)
+ ("Location" ,(or location ""))
("Time" ,(gnus-icalendar-event:org-timestamp event))
("Organizer" ,organizer)
+ ("Attendance" ,(if (eq participation-type 'non-participant)
+ "You are not listed as an attendee"
+ (capitalize (symbol-name participation-type))))
("Method" ,method))))
(when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
(event (caddr data))
(reply (gnus-icalendar-with-decoded-handle handle
(gnus-icalendar-event-reply-from-buffer
- (current-buffer) status gnus-icalendar-identities))))
+ (current-buffer) status (gnus-icalendar-identities)))))
(when reply
- (flet ((fold-icalendar-buffer ()
+ (gmm-labels ((fold-icalendar-buffer ()
(goto-char (point-min))
(while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
(replace-match "\\1\n \\2")
(when org-entry-exists-p
`("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
+
+(defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
+ (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
+
+ (delq nil (list
+ `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
+ (when org-entry-exists-p
+ `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
+ (when org-entry-exists-p
+ `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
+
+
(defun gnus-icalendar-mm-inline (handle)
- (let ((event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
+ (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
(setq gnus-icalendar-reply-status nil)
(when event
- (flet ((insert-button-group (buttons)
+ (gmm-labels ((insert-button-group (buttons)
(when buttons
(mapc (lambda (x)
(apply 'gnus-icalendar-insert-button x)
(defun gnus-icalendar-save-part (handle)
(let (event)
(when (and (equal (car (mm-handle-type handle)) "text/calendar")
- (setq event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
+ (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
(gnus-icalendar-event:sync-to-org event))))
(gnus-icalendar-show-org-agenda
(with-current-buffer gnus-article-buffer gnus-icalendar-event)))
+(defvar gnus-mime-action-alist) ; gnus-art
+
(defun gnus-icalendar-setup ()
(add-to-list 'mm-inlined-types "text/calendar")
(add-to-list 'mm-automatic-display "text/calendar")
projects / gnus / blobdiff