mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-02 08:22:22 +00:00
461101d67c
* lisp/gnus/gnus-icalendar.el (gnus-icalendar-insert-button): * lisp/gnus/gnus-art.el (gnus-insert-mime-button) (gnus-mime-display-alternative, gnus-insert-prev-page-button) (gnus-insert-next-page-button) (gnus-insert-mime-security-button): Make button-1 work on all the Gnus buttons (bug#38144).
992 lines
38 KiB
EmacsLisp
992 lines
38 KiB
EmacsLisp
;;; gnus-icalendar.el --- reply to iCalendar meeting requests -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
|
|
|
|
;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
|
|
;; Keywords: mail, icalendar, org
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; To install:
|
|
;; (require 'gnus-icalendar)
|
|
;; (gnus-icalendar-setup)
|
|
|
|
;; to enable optional iCalendar->Org sync functionality
|
|
;; NOTE: both the capture file and the headline(s) inside must already exist
|
|
;; (setq gnus-icalendar-org-capture-file "~/org/notes.org")
|
|
;; (setq gnus-icalendar-org-capture-headline '("Calendar"))
|
|
;; (gnus-icalendar-org-setup)
|
|
|
|
|
|
;;; Code:
|
|
|
|
(require 'icalendar)
|
|
(require 'eieio)
|
|
(require 'gmm-utils)
|
|
(require 'mm-decode)
|
|
(require 'gnus-sum)
|
|
(require 'gnus-art)
|
|
|
|
(eval-when-compile (require 'cl-lib))
|
|
|
|
(defun gnus-icalendar-find-if (pred seq)
|
|
(catch 'found
|
|
(while seq
|
|
(when (funcall pred (car seq))
|
|
(throw 'found (car seq)))
|
|
(pop seq))))
|
|
|
|
;;;
|
|
;;; ical-event
|
|
;;;
|
|
|
|
(defclass gnus-icalendar-event ()
|
|
((organizer :initarg :organizer
|
|
:accessor gnus-icalendar-event:organizer
|
|
:initform ""
|
|
:type (or null string))
|
|
(summary :initarg :summary
|
|
:accessor gnus-icalendar-event:summary
|
|
:initform ""
|
|
:type (or null string))
|
|
(description :initarg :description
|
|
:accessor gnus-icalendar-event:description
|
|
:initform ""
|
|
:type (or null string))
|
|
(location :initarg :location
|
|
:accessor gnus-icalendar-event:location
|
|
:initform ""
|
|
:type (or null string))
|
|
(start-time :initarg :start-time
|
|
:accessor gnus-icalendar-event:start-time
|
|
:initform ""
|
|
:type (or null t))
|
|
(end-time :initarg :end-time
|
|
:accessor gnus-icalendar-event:end-time
|
|
:initform ""
|
|
:type (or null t))
|
|
(recur :initarg :recur
|
|
:accessor gnus-icalendar-event:recur
|
|
:initform ""
|
|
:type (or null string))
|
|
(uid :initarg :uid
|
|
:accessor gnus-icalendar-event:uid
|
|
:type string)
|
|
(method :initarg :method
|
|
:accessor gnus-icalendar-event:method
|
|
:initform "PUBLISH"
|
|
:type (or null string))
|
|
(rsvp :initarg :rsvp
|
|
:accessor gnus-icalendar-event:rsvp
|
|
:initform nil
|
|
: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)
|
|
nil
|
|
"iCalendar class for REQUEST events")
|
|
|
|
(defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
|
|
nil
|
|
"iCalendar class for CANCEL events")
|
|
|
|
(defclass gnus-icalendar-event-reply (gnus-icalendar-event)
|
|
nil
|
|
"iCalendar class for REPLY events")
|
|
|
|
(cl-defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
|
|
"Return t if EVENT is recurring."
|
|
(not (null (gnus-icalendar-event:recur event))))
|
|
|
|
(cl-defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
|
|
"Return recurring frequency of EVENT."
|
|
(let ((rrule (gnus-icalendar-event:recur event)))
|
|
(string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
|
|
(match-string 1 rrule)))
|
|
|
|
(cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
|
|
"Return recurring interval of EVENT."
|
|
(let ((rrule (gnus-icalendar-event:recur event))
|
|
(default-interval 1))
|
|
|
|
(string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
|
|
(or (match-string 1 rrule)
|
|
default-interval)))
|
|
|
|
(cl-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 (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)))
|
|
(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)))
|
|
(cl-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
|
|
(attendee-email
|
|
(att)
|
|
(replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
|
|
(attendee-prop-matches-p
|
|
(prop)
|
|
(and (eq (car prop) 'ATTENDEE)
|
|
(or (member (attendee-name prop) name-or-email)
|
|
(let ((att-email (attendee-email prop)))
|
|
(gnus-icalendar-find-if
|
|
(lambda (email)
|
|
(string-match email att-email))
|
|
name-or-email))))))
|
|
(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 (seq-filter
|
|
(lambda (p) (eq (car p) 'ATTENDEE))
|
|
(caddr event))))
|
|
|
|
(cl-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)
|
|
(seq-filter
|
|
(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)))
|
|
(organizer (replace-regexp-in-string
|
|
"^.*MAILTO:" ""
|
|
(or (icalendar--get-event-property event 'ORGANIZER) "")))
|
|
(prop-map '((summary . SUMMARY)
|
|
(description . DESCRIPTION)
|
|
(location . LOCATION)
|
|
(recur . RRULE)
|
|
(uid . UID)))
|
|
(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-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))))
|
|
|
|
(cl-labels
|
|
((map-property
|
|
(prop)
|
|
(let ((value (icalendar--get-event-property event prop)))
|
|
(when value
|
|
;; ugly, but cannot get
|
|
;;replace-regexp-in-string work with "\\" as
|
|
;;REP, plus we should also handle "\\;"
|
|
(replace-regexp-in-string
|
|
"\\\\," ","
|
|
(replace-regexp-in-string
|
|
"\\\\n" "\n" (substring-no-properties value))))))
|
|
(accumulate-args
|
|
(mapping)
|
|
(cl-destructuring-bind (slot . ical-property) mapping
|
|
(setq args (append (list
|
|
(intern (concat ":" (symbol-name slot)))
|
|
(map-property ical-property))
|
|
args)))))
|
|
(mapc #'accumulate-args prop-map)
|
|
(apply #'make-instance event-class args))))
|
|
|
|
(defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
|
|
"Parse RFC5545 iCalendar in buffer BUF and return an event object.
|
|
|
|
Return a gnus-icalendar-event object representing the first event
|
|
contained in the invitation. Return nil for calendars without an
|
|
event entry.
|
|
|
|
ATTENDEE-NAME-OR-EMAIL is a list of strings that will be matched
|
|
against the event's attendee names and emails. Invitation rsvp
|
|
status will be retrieved from the first matching attendee record."
|
|
(let ((ical (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
|
|
(goto-char (point-min))
|
|
(icalendar--read-element nil nil))))
|
|
|
|
(when ical
|
|
(gnus-icalendar-event-from-ical ical attendee-name-or-email))))
|
|
|
|
;;;
|
|
;;; gnus-icalendar-event-reply
|
|
;;;
|
|
|
|
(defun gnus-icalendar-event--build-reply-event-body (ical-request status identities)
|
|
(let ((summary-status (capitalize (symbol-name status)))
|
|
(attendee-status (upcase (symbol-name status)))
|
|
reply-event-lines)
|
|
(cl-labels
|
|
((update-summary
|
|
(line)
|
|
(if (string-match "^[^:]+:" line)
|
|
(replace-match (format "\\&%s: " summary-status) t nil line)
|
|
line))
|
|
(update-dtstamp ()
|
|
(format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
|
|
(attendee-matches-identity
|
|
(line)
|
|
(gnus-icalendar-find-if (lambda (name) (string-match-p name line))
|
|
identities))
|
|
(update-attendee-status
|
|
(line)
|
|
(when (and (attendee-matches-identity line)
|
|
(string-match "\\(PARTSTAT=\\)[^;]+" line))
|
|
(replace-match (format "\\1%s" attendee-status) t nil line)))
|
|
(process-event-line
|
|
(line)
|
|
(when (string-match "^\\([^;:]+\\)" line)
|
|
(let* ((key (match-string 0 line))
|
|
;; 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
|
|
(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)
|
|
(t nil))))
|
|
(when new-line
|
|
(push new-line reply-event-lines))))))
|
|
|
|
(mapc #'process-event-line (split-string ical-request "\n"))
|
|
|
|
(unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
|
|
reply-event-lines)
|
|
(error "Could not find an event attendee matching given identity"))
|
|
|
|
(mapconcat #'identity `("BEGIN:VEVENT"
|
|
,@(nreverse reply-event-lines)
|
|
"END:VEVENT")
|
|
"\n"))))
|
|
|
|
(defun gnus-icalendar-event-reply-from-buffer (buf status identities)
|
|
"Build a calendar event reply for request contained in BUF.
|
|
The reply will have STATUS (`accepted', `tentative' or `declined').
|
|
The reply will be composed for attendees matching any entry
|
|
on the IDENTITIES list."
|
|
(cl-labels
|
|
((extract-block
|
|
(blockname)
|
|
(save-excursion
|
|
(let ((block-start-re (format "^BEGIN:%s" blockname))
|
|
(block-end-re (format "^END:%s" blockname))
|
|
start)
|
|
(when (re-search-forward block-start-re nil t)
|
|
(setq start (line-beginning-position))
|
|
(re-search-forward block-end-re)
|
|
(buffer-substring-no-properties start (line-end-position)))))))
|
|
(let (zone event)
|
|
(with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
|
|
(goto-char (point-min))
|
|
(setq zone (extract-block "VTIMEZONE")
|
|
event (extract-block "VEVENT")))
|
|
|
|
(when event
|
|
(let ((contents (list "BEGIN:VCALENDAR"
|
|
"METHOD:REPLY"
|
|
"PRODID:Gnus"
|
|
"VERSION:2.0"
|
|
zone
|
|
(gnus-icalendar-event--build-reply-event-body event status identities)
|
|
"END:VCALENDAR")))
|
|
|
|
(mapconcat #'identity (delq nil contents) "\n"))))))
|
|
|
|
;;;
|
|
;;; gnus-icalendar-org
|
|
;;
|
|
;; TODO: this is an optional feature, and it's only available with org-mode
|
|
;; 7+, so will need to properly handle emacsen with no/outdated org-mode
|
|
|
|
(require 'org)
|
|
(require 'org-capture)
|
|
|
|
(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 '(choice (const nil) file))
|
|
|
|
(defcustom gnus-icalendar-org-capture-headline nil
|
|
"Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
|
|
:type '(repeat string))
|
|
|
|
(defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
|
|
"Org-mode template name."
|
|
:type '(string))
|
|
|
|
(defcustom gnus-icalendar-org-template-key "#"
|
|
"Org-mode template hotkey."
|
|
:type '(string))
|
|
|
|
(defvar gnus-icalendar-org-enabled-p nil)
|
|
|
|
|
|
(cl-defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event))
|
|
"Return `org-mode' timestamp repeater string for recurring EVENT.
|
|
Return nil for non-recurring EVENT."
|
|
(when (gnus-icalendar-event:recurring-p event)
|
|
(let* ((freq-map '(("HOURLY" . "h")
|
|
("DAILY" . "d")
|
|
("WEEKLY" . "w")
|
|
("MONTHLY" . "m")
|
|
("YEARLY" . "y")))
|
|
(org-freq (cdr (assoc (gnus-icalendar-event:recurring-freq event) freq-map))))
|
|
|
|
(when org-freq
|
|
(format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
|
|
|
|
(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-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" 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" end))
|
|
(end-time (format-time-string "%H:%M" end))
|
|
(end-at-midnight (string= end-time "00:00"))
|
|
(start-end-date-diff
|
|
(time-to-number-of-days (time-subtract
|
|
(org-time-string-to-time end-date)
|
|
(org-time-string-to-time start-date))))
|
|
(org-repeat (gnus-icalendar-event:org-repeat event))
|
|
(repeat (if org-repeat (concat " " org-repeat) ""))
|
|
(time-1-day 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" (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" (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
|
|
(cl-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
|
|
(cl-defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
|
|
"Return string with new `org-mode' entry describing EVENT."
|
|
(with-temp-buffer
|
|
(org-mode)
|
|
(with-slots (organizer summary description location
|
|
recur uid) event
|
|
(let* ((reply (if reply-status (capitalize (symbol-name reply-status))
|
|
"Not replied yet"))
|
|
(props `(("ICAL_EVENT" . "t")
|
|
("ID" . ,uid)
|
|
("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\n\n"
|
|
(gnus-icalendar--format-summary-line summary location)))
|
|
(mapc (lambda (prop)
|
|
(org-entry-put (point) (car prop) (cdr prop)))
|
|
props))
|
|
|
|
(save-restriction
|
|
(narrow-to-region (point) (point))
|
|
(insert (gnus-icalendar-event:org-timestamp event)
|
|
"\n\n"
|
|
(or description "No description"))
|
|
(indent-region (point-min) (point-max) 2)
|
|
(fill-region (point-min) (point-max)))
|
|
|
|
(buffer-string))))
|
|
|
|
(defun gnus-icalendar--deactivate-org-timestamp (ts)
|
|
(replace-regexp-in-string "[<>]"
|
|
(lambda (m) (cond ((string= m "<") "[")
|
|
((string= m ">") "]")))
|
|
ts))
|
|
|
|
(defun gnus-icalendar-find-org-event-file (event &optional org-file)
|
|
"Return the name of the file containing EVENT org entry.
|
|
Return nil when not found.
|
|
|
|
All org agenda files are searched for the EVENT entry. When
|
|
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))))
|
|
(cl-labels
|
|
((find-event-in
|
|
(file)
|
|
(org-check-agenda-file file)
|
|
(with-current-buffer (find-file-noselect file)
|
|
(let ((event-pos (org-find-entry-with-id uid)))
|
|
(when (and event-pos
|
|
(string= (cdr (assoc "ICAL_EVENT"
|
|
(org-entry-properties event-pos)))
|
|
"t"))
|
|
(throw 'found file))))))
|
|
(gnus-icalendar-find-if #'find-event-in files))))
|
|
|
|
|
|
(defun gnus-icalendar--show-org-event (event &optional org-file)
|
|
(let ((file (gnus-icalendar-find-org-event-file event org-file)))
|
|
(when file
|
|
(switch-to-buffer (find-file file))
|
|
(goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
|
|
(org-show-entry))))
|
|
|
|
|
|
(defun gnus-icalendar--update-org-event (event reply-status &optional org-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
|
|
participation-type req-participants opt-participants) event
|
|
(let ((event-pos (org-find-entry-with-id uid)))
|
|
(when event-pos
|
|
(goto-char event-pos)
|
|
|
|
;; update the headline, keep todo, priority and tags, if any
|
|
(save-excursion
|
|
(let* ((priority (org-entry-get (point) "PRIORITY"))
|
|
(headline (delq nil (list
|
|
(org-entry-get (point) "TODO")
|
|
(when priority (format "[#%s]" priority))
|
|
(gnus-icalendar--format-summary-line summary location)
|
|
(org-entry-get (point) "TAGS")))))
|
|
|
|
(re-search-forward "^\\*+ " (line-end-position))
|
|
(delete-region (point) (line-end-position))
|
|
(insert (mapconcat #'identity headline " "))))
|
|
|
|
;; update props and description
|
|
(let ((entry-end (org-entry-end-position))
|
|
(entry-outline-level (org-outline-level)))
|
|
|
|
;; delete body of the entry, leave org drawers intact
|
|
(save-restriction
|
|
(org-narrow-to-element)
|
|
(goto-char entry-end)
|
|
(re-search-backward "^[\t ]*:END:")
|
|
(forward-line)
|
|
(delete-region (point) entry-end))
|
|
|
|
;; put new event description in the entry body
|
|
(when description
|
|
(save-restriction
|
|
(narrow-to-region (point) (point))
|
|
(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
|
|
(cl-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)))))))))
|
|
|
|
|
|
(defun gnus-icalendar--cancel-org-event (event &optional org-file)
|
|
(let ((file (gnus-icalendar-find-org-event-file event org-file)))
|
|
(when file
|
|
(with-current-buffer (find-file-noselect file)
|
|
(let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
|
|
(when event-pos
|
|
(let ((ts (org-entry-get event-pos "DT")))
|
|
(when ts
|
|
(org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
|
|
(save-buffer)))))))))
|
|
|
|
|
|
(defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
|
|
(let ((file (gnus-icalendar-find-org-event-file event org-file)))
|
|
(when file
|
|
(save-excursion
|
|
(with-current-buffer (find-file-noselect file)
|
|
(let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
|
|
(org-entry-get event-pos "REPLY")))))))
|
|
|
|
|
|
(defun gnus-icalendar-insinuate-org-templates ()
|
|
(unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
|
|
org-capture-templates)
|
|
(setq org-capture-templates
|
|
(append `((,gnus-icalendar-org-template-key
|
|
,gnus-icalendar-org-template-name
|
|
entry
|
|
(file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
|
|
"%i"
|
|
:immediate-finish t))
|
|
org-capture-templates))
|
|
|
|
;; hide the template from interactive template selection list
|
|
;; (org-capture)
|
|
;; NOTE: doesn't work when capturing from string
|
|
;; (when (boundp 'org-capture-templates-contexts)
|
|
;; (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
|
|
;; org-capture-templates-contexts))
|
|
))
|
|
|
|
(defun gnus-icalendar:org-event-save (event reply-status)
|
|
(with-temp-buffer
|
|
(org-capture-string (gnus-icalendar-event->org-entry event reply-status)
|
|
gnus-icalendar-org-template-key)))
|
|
|
|
(defun gnus-icalendar-show-org-agenda (event)
|
|
(let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
|
|
(gnus-icalendar-event:start-time event)))
|
|
(duration-days (1+ (floor (time-convert time-delta 'integer) 86400))))
|
|
(org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
|
|
|
|
(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
|
|
(if (gnus-icalendar-find-org-event-file event)
|
|
(gnus-icalendar--update-org-event event reply-status)
|
|
(gnus-icalendar:org-event-save event reply-status)))
|
|
|
|
(cl-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)))
|
|
|
|
(defun gnus-icalendar-org-setup ()
|
|
(if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
|
|
(progn
|
|
(gnus-icalendar-insinuate-org-templates)
|
|
(setq gnus-icalendar-org-enabled-p t))
|
|
(message "Cannot enable Calendar->Org: missing capture file, headline")))
|
|
|
|
;;;
|
|
;;; gnus-icalendar
|
|
;;;
|
|
|
|
(defgroup gnus-icalendar nil
|
|
"Settings for inline display of iCalendar invitations."
|
|
:version "24.4"
|
|
:group 'gnus-article
|
|
:prefix "gnus-icalendar-")
|
|
|
|
(defcustom gnus-icalendar-reply-bufname "*CAL*"
|
|
"Buffer used for building iCalendar invitation reply."
|
|
:type '(string))
|
|
|
|
(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))
|
|
|
|
(defvar-local gnus-icalendar-reply-status nil)
|
|
|
|
(defvar-local gnus-icalendar-event nil)
|
|
|
|
(defvar-local gnus-icalendar-handle nil)
|
|
|
|
(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: these can be lists
|
|
gnus-ignored-from-addresses ; already regexp-quoted
|
|
(unless (functionp message-alternative-emails) ; String or function.
|
|
message-alternative-emails)
|
|
(mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
|
|
|
|
;; TODO: make the template customizable
|
|
(cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
|
|
"Format an overview of EVENT details."
|
|
(cl-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 participation-type)
|
|
event
|
|
(let ((headers `(("Summary" ,summary)
|
|
("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)
|
|
(setq headers (append headers
|
|
`(("Status" ,(or reply-status "Not replied yet"))))))
|
|
|
|
(concat
|
|
(mapconcat #'format-header headers "\n")
|
|
"\n\n"
|
|
description)))))
|
|
|
|
(defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
|
|
"Execute BODY in buffer containing the decoded contents of HANDLE."
|
|
(let ((charset (make-symbol "charset")))
|
|
`(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
|
|
(with-temp-buffer
|
|
(mm-insert-part ,handle)
|
|
(when (string= (downcase ,charset) "utf-8")
|
|
(decode-coding-region (point-min) (point-max) 'utf-8))
|
|
,@body))))
|
|
|
|
|
|
(defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
|
|
(gnus-icalendar-with-decoded-handle handle
|
|
(gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
|
|
|
|
(defun gnus-icalendar-insert-button (text callback data)
|
|
;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
|
|
;; of button.
|
|
(let ((start (point)))
|
|
(add-text-properties
|
|
start
|
|
(progn
|
|
(insert "[ " text " ]")
|
|
(point))
|
|
`(gnus-callback
|
|
,callback
|
|
keymap ,gnus-mime-button-map
|
|
face ,gnus-article-button-face
|
|
follow-link t
|
|
button t
|
|
gnus-data ,data))))
|
|
|
|
(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
|
|
(let ((message-signature nil))
|
|
(with-current-buffer gnus-summary-buffer
|
|
(gnus-summary-reply)
|
|
(message-goto-body)
|
|
(mml-insert-multipart "alternative")
|
|
(mml-insert-empty-tag 'part 'type "text/plain")
|
|
(mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
|
|
(message-goto-subject)
|
|
(delete-region (line-beginning-position) (line-end-position))
|
|
(insert "Subject: " subject)
|
|
(message-send-and-exit))))
|
|
|
|
(defun gnus-icalendar-reply (data)
|
|
(let* ((handle (car data))
|
|
(status (cadr data))
|
|
(event (caddr data))
|
|
(reply (gnus-icalendar-with-decoded-handle handle
|
|
(gnus-icalendar-event-reply-from-buffer
|
|
(current-buffer) status (gnus-icalendar-identities)))))
|
|
|
|
(when reply
|
|
(cl-labels
|
|
((fold-icalendar-buffer
|
|
()
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
|
|
(replace-match "\\1\n \\2")
|
|
(goto-char (line-beginning-position)))))
|
|
(let ((subject (concat (capitalize (symbol-name status))
|
|
": " (gnus-icalendar-event:summary event))))
|
|
|
|
(with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
|
|
(delete-region (point-min) (point-max))
|
|
(insert reply)
|
|
(fold-icalendar-buffer)
|
|
(gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
|
|
|
|
;; Back in article buffer
|
|
(setq-local gnus-icalendar-reply-status status)
|
|
(when gnus-icalendar-org-enabled-p
|
|
(gnus-icalendar--update-org-event event status)
|
|
;; refresh article buffer to update the reply status
|
|
(with-current-buffer gnus-summary-buffer
|
|
(gnus-summary-show-article))))))))
|
|
|
|
(defun gnus-icalendar-sync-event-to-org (event)
|
|
(gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
|
|
|
|
(cl-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)))))
|
|
|
|
(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle)
|
|
"No buttons for REPLY events."
|
|
nil)
|
|
|
|
(cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
|
|
(or (when gnus-icalendar-org-enabled-p
|
|
(gnus-icalendar--get-org-event-reply-status event))
|
|
"Not replied yet"))
|
|
|
|
(cl-defmethod gnus-icalendar-event:inline-reply-status ((_event gnus-icalendar-event-reply))
|
|
"No reply status for REPLY events."
|
|
nil)
|
|
|
|
|
|
(cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
|
|
(let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
|
|
(export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
|
|
|
|
(delq nil (list
|
|
`("Show Agenda" gnus-icalendar-show-org-agenda ,event)
|
|
(when (gnus-icalendar-event-request-p event)
|
|
`(,export-button-text gnus-icalendar-sync-event-to-org ,event))
|
|
(when org-entry-exists-p
|
|
`("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
|
|
|
|
|
|
(cl-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))))))
|
|
|
|
;;;###autoload
|
|
(defun gnus-icalendar-mm-inline (handle)
|
|
(let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
|
|
|
|
(setq gnus-icalendar-reply-status nil)
|
|
|
|
(when event
|
|
(cl-labels
|
|
((insert-button-group
|
|
(buttons)
|
|
(when buttons
|
|
(mapc (lambda (x)
|
|
(apply #'gnus-icalendar-insert-button x)
|
|
(insert " "))
|
|
buttons)
|
|
(insert "\n\n"))))
|
|
|
|
(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)))
|
|
|
|
(setq gnus-icalendar-event event
|
|
gnus-icalendar-handle handle)
|
|
|
|
(insert (gnus-icalendar-event->gnus-calendar
|
|
event
|
|
(gnus-icalendar-event:inline-reply-status event)))))))
|
|
|
|
(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))))
|
|
|
|
(gnus-icalendar-event:sync-to-org event))))
|
|
|
|
|
|
(defun gnus-icalendar-save-event ()
|
|
"Save the Calendar event in the text/calendar part under point."
|
|
(interactive)
|
|
(gnus-article-check-buffer)
|
|
(let ((data (get-text-property (point) 'gnus-data)))
|
|
(when data
|
|
(gnus-icalendar-save-part data))))
|
|
|
|
(defun gnus-icalendar-reply-accept ()
|
|
"Accept invitation in the current article."
|
|
(interactive)
|
|
(with-current-buffer gnus-article-buffer
|
|
(gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
|
|
(setq-local gnus-icalendar-reply-status 'accepted)))
|
|
|
|
(defun gnus-icalendar-reply-tentative ()
|
|
"Send tentative response to invitation in the current article."
|
|
(interactive)
|
|
(with-current-buffer gnus-article-buffer
|
|
(gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
|
|
(setq-local gnus-icalendar-reply-status 'tentative)))
|
|
|
|
(defun gnus-icalendar-reply-decline ()
|
|
"Decline invitation in the current article."
|
|
(interactive)
|
|
(with-current-buffer gnus-article-buffer
|
|
(gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
|
|
(setq-local gnus-icalendar-reply-status 'declined)))
|
|
|
|
(defun gnus-icalendar-event-export ()
|
|
"Export calendar event to `org-mode', or update existing agenda entry."
|
|
(interactive)
|
|
(with-current-buffer gnus-article-buffer
|
|
(gnus-icalendar-sync-event-to-org gnus-icalendar-event))
|
|
;; refresh article buffer in case the reply had been sent before initial org
|
|
;; export
|
|
(with-current-buffer gnus-summary-buffer
|
|
(gnus-summary-show-article)))
|
|
|
|
(defun gnus-icalendar-event-show ()
|
|
"Display `org-mode' agenda entry related to the calendar event."
|
|
(interactive)
|
|
(gnus-icalendar--show-org-event
|
|
(with-current-buffer gnus-article-buffer
|
|
gnus-icalendar-event)))
|
|
|
|
(defun gnus-icalendar-event-check-agenda ()
|
|
"Display `org-mode' agenda for days between event start and end dates."
|
|
(interactive)
|
|
(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 ()
|
|
;; FIXME: Get rid of this!
|
|
;; The three add-to-list are now redundant (good), but I think the rest
|
|
;; is still not automatically setup.
|
|
(add-to-list 'mm-inlined-types "text/calendar")
|
|
(add-to-list 'mm-automatic-display "text/calendar")
|
|
(add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
|
|
|
|
(gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
|
|
"a" gnus-icalendar-reply-accept
|
|
"t" gnus-icalendar-reply-tentative
|
|
"d" gnus-icalendar-reply-decline
|
|
"c" gnus-icalendar-event-check-agenda
|
|
"e" gnus-icalendar-event-export
|
|
"s" gnus-icalendar-event-show)
|
|
|
|
(require 'gnus-art)
|
|
(add-to-list 'gnus-mime-action-alist
|
|
(cons "save calendar event" #'gnus-icalendar-save-event)
|
|
t))
|
|
|
|
(provide 'gnus-icalendar)
|
|
|
|
;;; gnus-icalendar.el ends here
|