X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-icalendar.el;h=dc423d85d191d0151996bb04f21b32cb4d173f41;hp=460599519c8dd261d6a8b5753d2cbb5d9886d73c;hb=94f288135f95ca48fb50f5aa43bc09f9669c5c23;hpb=c8dab3f51ce17261e26834b807131794a5bb8229 diff --git a/lisp/gnus-icalendar.el b/lisp/gnus-icalendar.el index 460599519..dc423d85d 100644 --- a/lisp/gnus-icalendar.el +++ b/lisp/gnus-icalendar.el @@ -1,6 +1,6 @@ ;;; 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 ;; Keywords: mail, icalendar, org @@ -35,8 +35,10 @@ (require 'icalendar) (require 'eieio) +(require 'gmm-utils) (require 'mm-decode) (require 'gnus-sum) +(require 'gnus-art) (eval-when-compile (require 'cl)) @@ -68,14 +70,14 @@ :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 "" @@ -90,7 +92,19 @@ (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) @@ -124,32 +138,21 @@ (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) @@ -162,10 +165,29 @@ (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) ""))) @@ -177,19 +199,28 @@ (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"))) - (event-class (pcase method - ("REQUEST" 'gnus-icalendar-event-request) - ("CANCEL" 'gnus-icalendar-event-cancel) - ("REPLY" 'gnus-icalendar-event-reply) - (_ 'gnus-icalendar-event)))) - - (labels ((map-property (prop) + :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)))) + + (gmm-labels ((map-property (prop) (let ((value (icalendar--get-event-property event prop))) (when value ;; ugly, but cannot get @@ -233,7 +264,7 @@ status will be retrieved from the first matching attendee record." (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)) @@ -252,14 +283,15 @@ status will be retrieved from the first matching attendee record." ;; NOTE: not all of the below fields are mandatory, ;; but they are often present in other clients' ;; replies. Can be helpful for debugging, too. - (new-line (pcase key - ("ATTENDEE" (update-attendee-status line)) - ("SUMMARY" (update-summary line)) - ("DTSTAMP" (update-dtstamp)) - ((or "ORGANIZER" "DTSTART" "DTEND" + (new-line + (cond + ((string= key "ATTENDEE") (update-attendee-status line)) + ((string= key "SUMMARY") (update-summary line)) + ((string= key "DTSTAMP") (update-dtstamp)) + ((member key '("ORGANIZER" "DTSTART" "DTEND" "LOCATION" "DURATION" "SEQUENCE" - "RECURRENCE-ID" "UID") line) - (_ nil)))) + "RECURRENCE-ID" "UID")) line) + (t nil)))) (when new-line (push new-line reply-event-lines)))))) @@ -279,7 +311,7 @@ status will be retrieved from the first matching attendee record." 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)) @@ -317,12 +349,13 @@ on the IDENTITIES list." (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 @@ -361,16 +394,57 @@ Return nil for non-recurring EVENT." "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) @@ -383,13 +457,16 @@ Return nil for non-recurring EVENT." "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)) @@ -397,7 +474,9 @@ Return nil for non-recurring EVENT." (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)))) @@ -405,7 +484,8 @@ Return nil for non-recurring EVENT." (defun gnus-icalendar--deactivate-org-timestamp (ts) (replace-regexp-in-string "[<>]" - (lambda (m) (pcase m ("<" "[") (">" "]"))) + (lambda (m) (cond ((string= m "<") "[") + ((string= m ">") "]"))) ts)) (defun gnus-icalendar-find-org-event-file (event &optional org-file) @@ -417,7 +497,7 @@ the optional ORG-FILE argument is specified, only that one file 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) @@ -442,7 +522,8 @@ is searched." (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) @@ -453,7 +534,7 @@ is searched." (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)) @@ -476,17 +557,31 @@ is searched." (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))))))))) @@ -550,7 +645,7 @@ is searched." (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))) @@ -567,6 +662,7 @@ is searched." (defgroup gnus-icalendar nil "Settings for inline display of iCalendar invitations." + :version "24.4" :group 'gnus-article :prefix "gnus-icalendar-") @@ -575,6 +671,23 @@ is searched." :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)) @@ -584,26 +697,35 @@ is searched." (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) @@ -668,10 +790,10 @@ is searched." (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") @@ -696,13 +818,13 @@ is searched." (defun gnus-icalendar-sync-event-to-org (event) (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status)) -(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event)) +(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle) (when (gnus-icalendar-event:rsvp event) `(("Accept" gnus-icalendar-reply (,handle accepted ,event)) ("Tentative" gnus-icalendar-reply (,handle tentative ,event)) ("Decline" gnus-icalendar-reply (,handle declined ,event))))) -(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply)) +(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle) "No buttons for REPLY events." nil) @@ -727,13 +849,25 @@ is searched." (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) @@ -741,7 +875,8 @@ is searched." buttons) (insert "\n\n")))) - (insert-button-group (gnus-icalendar-event:inline-reply-buttons event)) + (insert-button-group + (gnus-icalendar-event:inline-reply-buttons event handle)) (when gnus-icalendar-org-enabled-p (insert-button-group (gnus-icalendar-event:inline-org-buttons event))) @@ -756,7 +891,7 @@ is searched." (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)))) @@ -813,6 +948,8 @@ is searched." (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") @@ -831,6 +968,6 @@ is searched." (cons "save calendar event" 'gnus-icalendar-save-event) t)) - (provide 'gnus-icalendar) + ;;; gnus-icalendar.el ends here