andros/emacs-gpu
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
v0.3.0
emacs-gpu/lisp/gnus/gnus-icalendar.el
T
Richard LawrenceandEli Zaretskii 70b79b3ed8 Rename `icalendar-recur' type and related functions 
More context in Bug#80786 and:
https://lists.gnu.org/archive/html/emacs-orgmode/2026-03/msg00286.html

`icalendar-recur' as a type name for RRULE values was confusing and made
the accessors for this type difficult to discover, because `icalendar-recur-'
is also used as a prefix in icalendar-recur.el.  This change renames the
`icalendar-recur' type to `icalendar-rrule-value' and renames the
accessor functions for these values appropriately.

* lisp/calendar/icalendar-parser.el:  Rename symbols as follows:
(icalendar-recur): `icalendar-rrule-value'
(icalendar-read-recur-rule-part): `icalendar-read-rrule-part'
(icalendar-print-recur-rule-part): `icalendar-print-rrule-part'
(icalendar-recur-rule-part): `icalendar-rrule-part'
(icalendar-read-recur): `icalendar-read-rrule-value'
(icalendar-print-recur): `icalendar-print-rrule-value'
(icalendar--recur-value-types): `icalendar--rrule-value-types'
(icalendar-recur-value-p): `icalendar-rrule-value-p'
(icalendar-recur-freq): `icalendar-rrule-freq'
(icalendar-recur-interval-size): `icalendar-rrule-interval-size'
(icalendar-recur-until): `icalendar-rrule-until'
(icalendar-recur-count): `icalendar-rrule-count'
(icalendar-recur-weekstart): `icalendar-rrule-weekstart'
(icalendar-recur-by*): `icalendar-rrule-by*'.
(icalendar-rrule):
(icalendar-index-insert):
(icalendar-index-get): Update references.
* lisp/calendar/icalendar-recur.el (icalendar-recur-find-interval):
(icalendar-recur-nth-interval):
(icalendar-recur-next-interval):
(icalendar-recur-previous-interval):
(icalendar-recur-refine-from-clauses):
(icalendar-recur-recurrences-in-interval):
(icalendar-recur-recurrences-in-window):
(icalendar-recur-recurrences-to-count):
(icalendar-recur-tz-observance-on): Update references.
* lisp/calendar/diary-icalendar.el: Update references.
* lisp/calendar/icalendar-shortdoc.el (icalendar): Update shortdoc examples.
* lisp/gnus/gnus-icalendar.el: Update references.
* test/lisp/calendar/diary-icalendar-tests.el:
* test/lisp/calendar/icalendar-parser-tests.el:
* test/lisp/calendar/icalendar-recur-tests.el: Update references in tests.
2026-05-23 13:25:19 +03:00

1051 lines
42 KiB
EmacsLisp
Raw Permalink Blame History

;;; gnus-icalendar.el --- reply to iCalendar meeting requests -*- lexical-binding:t -*-
;; Copyright (C) 2013-2026 Free Software Foundation, Inc.
;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
;; Keywords: mail, icalendar, org
;; This file is part of GNU Emacs.
;; GNU Emacs 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.
;; GNU Emacs 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 GNU Emacs. 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 'icalendar-parser)
(eval-when-compile (require 'icalendar-macs))
(require 'icalendar-ast)
(require 'icalendar-utils)
(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 nil
:type (or null list))
(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."
(ical:rrule-freq (gnus-icalendar-event:recur event)))
(cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
"Return recurring interval of EVENT."
(ical:rrule-interval-size (gnus-icalendar-event:recur event)))
(cl-defmethod gnus-icalendar-event:recurring-days ((event gnus-icalendar-event))
"Return, when available, the week day numbers on which the EVENT recurs."
(let ((rrule (gnus-icalendar-event:recur event)))
(when rrule
(mapcar (lambda (el) (if (consp el) (car el) el))
(ical:rrule-by* 'BYDAY rrule)))))
(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--find-attendee (attendees ids)
"Return the first `icalendar-attendee' in ATTENDEES matching IDS.
IDS should be a list of strings. The first attendee is returned whose
name (as `icalendar-cnparam') or email address (without \"mailto:\")
is a member of IDS."
(catch 'found
(dolist (attendee attendees)
(ical:with-property attendee ((ical:cnparam :value name))
(let ((email (ical:strip-mailto value)))
(when (or (member name ids)
(member email ids))
(throw 'found attendee)))))))
(defun gnus-icalendar-event--attendees-by-type (attendees)
"Return lists of required and optional participants in ATTENDEES.
ATTENDEES must be a list of `icalendar-attendee' nodes. The returned
list has the form (REQUIRED OPTIONAL), where each is a list of
`icalendar-attendee' nodes."
(let (required optional)
(dolist (attendee attendees)
(ical:with-property attendee ((ical:roleparam :value role))
(when (or (null role) ; "REQ-PARTICIPANT" is the default
(equal role "REQ-PARTICIPANT"))
(push attendee required))
(when (equal role "OPT-PARTICIPANT")
(push attendee optional))))
(list (nreverse required)
(nreverse optional))))
(defun gnus-icalendar-event-from-ical (vcalendar &optional ids)
"Initialize an event instance with the first `icalendar-vevent' in VCALENDAR.
IDS should be a list of strings representing names and email addresses
by which to identify an `icalendar-attendee' in the event as the
recipient."
(ical:with-component vcalendar
((ical:vevent vevent)
(ical:method :value method))
(ical:with-component vevent
((ical:organizer :value organizer)
(ical:attendee :all attendees)
(ical:summary :value summary)
(ical:description :value description)
(ical:dtstart :value dtstart)
(ical:dtend :value dtend)
(ical:location :value location)
(ical:rrule :value rrule)
(ical:uid :value uid))
(let* ((attendee (when ids (gnus-icalendar-event--find-attendee attendees ids)))
(rsvp-p (ical:with-param-of attendee 'ical:rsvpparam))
;; RFC5546: default ROLE is REQ-PARTICIPANT
(role (when attendee
(or (ical:with-param-of attendee 'ical:roleparam)
"REQ-PARTICIPANT")))
(participation-type (pcase role
("REQ-PARTICIPANT" 'required)
("OPT-PARTICIPANT" 'optional)
(_ 'non-participant)))
(req/opt (gnus-icalendar-event--attendees-by-type attendees))
(args
(list :method method
:organizer (when organizer (ical:strip-mailto organizer))
:summary summary
:description description
:location location
:recur rrule
:start-time (encode-time dtstart)
:end-time (encode-time dtend)
:rsvp rsvp-p
:participation-type participation-type
:req-participants (car req/opt)
:opt-participants (cadr req/opt)
:uid (or uid ""))) ; UID must be a string
(event-class (pcase method
("REQUEST" 'gnus-icalendar-event-request)
("CANCEL" 'gnus-icalendar-event-cancel)
("REPLY" 'gnus-icalendar-event-reply)
(_ 'gnus-icalendar-event))))
;; Initialize and return the instance:
(apply
#'make-instance
event-class
(cl-loop for slot in (eieio-class-slots event-class)
for keyword = (intern
(format ":%s" (eieio-slot-descriptor-name slot)))
when (plist-member args keyword)
append (list keyword (plist-get args keyword))))))))
(defun gnus-icalendar-event-from-buffer (buf &optional ids)
"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.
IDS is a list of strings that identify the recipient
`icalendar-attendee' by name or email address. Invitation rsvp status
will be retrieved from the first matching attendee record."
(let ((vcalendar (ical:parse buf)))
(when vcalendar
(gnus-icalendar-event-from-ical vcalendar ids))))
;;;
;;; gnus-icalendar-event-reply
;;;
(defun gnus-icalendar-event--build-reply (vcalendar status ids &optional comment)
"Return an `icalendar-vcalendar' based on VCALENDAR with updated STATUS.
STATUS should one of \\='accepted, \\='declined, or \\='tentative. The
recipient whose participation status is updated to STATUS is identified
in EVENT by finding an `icalendar-attendee' whose name or email address
matches one of the strings in IDS. If no such attendee is found, a new
`icalendar-attendee' is added from the values of `user-mail-address' and
`user-full-name'. COMMENT, if provided, will be added as an
`icalendar-comment' to the returned event."
(let ((summary-status (capitalize (symbol-name status)))
(attendee-status (upcase (symbol-name status)))
recipient)
(ical:with-component vcalendar
((ical:vtimezone :all tz-nodes)
(ical:vevent :first vevent))
(ical:with-component vevent
((ical:summary :value summary)
(ical:attendee :all attendees)
(ical:uid :value uid)
(ical:comment :value old-comment)
;; The nodes below are copied unchanged to the reply. Not all
;; of them are mandatory, but they are often present in other
;; clients' replies. Can be helpful for debugging, too.
(ical:organizer :first organizer-node)
(ical:dtstart :first dtstart-node)
(ical:dtend :first dtend-node)
(ical:duration :first duration-node)
(ical:location :first location-node)
(ical:sequence :first sequence-node)
(ical:recurrence-id :first recid-node))
(setq recipient (gnus-icalendar-event--find-attendee attendees ids))
(if recipient
(ical:with-property recipient
((ical:partstatparam :first partstat-node))
(ical:ast-node-set-value partstat-node attendee-status))
;; RFC5546 refers to uninvited attendees as "party crashers".
;; This situation is common if the invitation is sent to a group
;; of people via a mailing list.
(lwarn 'gnus-icalendar :warning
"Could not find a matching event attendee; creating new.")
(setq recipient
(ical:make-property ical:attendee
(concat "mailto:" user-mail-address)
(ical:partstatparam attendee-status)
(ical:cnparam user-full-name)))
(push recipient attendees))
;; Build the reply:
(ical:make-vcalendar
(ical:method "REPLY")
(@ tz-nodes)
(ical:vevent
(ical:uid uid)
recid-node
sequence-node
organizer-node
dtstart-node
dtend-node
duration-node
location-node
(ical:summary
(if (string-match "^[^:]+:" summary)
(replace-match (format "\\&%s: " summary-status) t nil summary)
summary))
(ical:comment (or comment old-comment))
(@ attendees)))))))
(defun gnus-icalendar-event-reply-from-buffer (buf status ids
&optional comment)
"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 in the
IDS list. Optional argument COMMENT will be placed in the
comment field of the reply."
(let (vcalendar reply)
(with-current-buffer (ical:unfolded-buffer-from-buffer (get-buffer buf))
(setq vcalendar (ical:parse))
(unless vcalendar
(error "Could not parse invitation; see buffer %s"
(buffer-name (ical:error-buffer))))
(setq reply
(gnus-icalendar-event--build-reply vcalendar status ids comment))
(ical:print-calendar-node reply))))
;;;
;;; 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
(alist-get (gnus-icalendar-event:recurring-freq event) freq-map))
(interval-size (gnus-icalendar-event:recurring-interval event)))
(when org-freq
(format "+%d%s" interval-size org-freq)))))
(defun gnus-icalendar--find-day (start-date end-date day)
(let ((time-1-day 86400))
(if (= (decoded-time-weekday (decode-time start-date))
day)
(list start-date end-date)
(gnus-icalendar--find-day (time-add start-date time-1-day)
(time-add end-date time-1-day)
day))))
(defun gnus-icalendar-event--org-timestamp (start end org-repeat)
(let* ((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))))
(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
(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))))
)
(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
"Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
;; if org-repeat +1d or +1w and byday: generate one timestamp per
;; byday, starting at start-date. Change +1d to +7d.
(let ((start (gnus-icalendar-event:start-time event))
(end (gnus-icalendar-event:end-time event))
(org-repeat (gnus-icalendar-event:org-repeat event))
(recurring-days (gnus-icalendar-event:recurring-days event)))
(if (and (or (string= org-repeat "+1d")
(string= org-repeat "+1w"))
recurring-days)
(let ((repeat "+1w")
(dates (seq-sort-by
#'car
#'time-less-p
(seq-map (lambda (x)
(gnus-icalendar--find-day start end x))
recurring-days))))
(mapconcat (lambda (x)
(gnus-icalendar-event--org-timestamp (car x) (cadr x)
repeat))
dates "\n"))
(gnus-icalendar-event--org-timestamp start end org-repeat))))
(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)
"Format PARTICIPANTS as a comma-separated list.
Each `icalendar-attendee' in PARTICIPANTS will be represented like
A. Person <a.person@example.domain>
or simply: <a.person@example.domain>, if no `icalendar-cnparam' is present."
(mapconcat
(lambda (attendee)
(ical:with-property attendee ((ical:cnparam :value cn))
(if cn
(format "%s <%s>" cn value)
(format "<%s>" value))))
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-fold-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
(save-restriction
(narrow-to-region (point) (point))
(insert "\n"
(gnus-icalendar-event:org-timestamp event)
"\n\n"
(replace-regexp-in-string "[\n]+$" "\n"
(or description "No 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 ; String or function.
message-alternative-emails ; String or function.
(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 (cl-typep event 'gnus-icalendar-event-reply)) 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 (downcase
(or (cdr (assoc 'charset (mm-handle-type ,handle)))
"utf-8"))))
(with-temp-buffer
(mm-insert-part ,handle)
(decode-coding-region (point-min) (point-max) (intern ,charset))
,@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
category t
button t
gnus-data ,data))))
(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject organizer)
(let ((message-signature nil))
(with-current-buffer gnus-summary-buffer
(gnus-summary-reply)
;; Reply to the organizer, not to whoever sent the invitation. person
;; Some calendar systems use specific email address as organizer to
;; receive these responses.
(message-replace-header "To" organizer)
(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 &optional comment)
(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) comment)))
(organizer (gnus-icalendar-event:organizer event)))
(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 (gnus-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 organizer))
;; 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)
(let ((accept-btn "Accept")
(tentative-btn "Tentative")
(decline-btn "Decline"))
(unless (gnus-icalendar-event:rsvp event)
(setq accept-btn "Uninvited Accept"
tentative-btn "Uninvited Tentative"
decline-btn "Uninvited Decline"))
`((,accept-btn gnus-icalendar-reply (,handle accepted ,event))
(,tentative-btn gnus-icalendar-reply (,handle tentative ,event))
(,decline-btn 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 (cl-typep event 'gnus-icalendar-event-request)
`(,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 nil gnus-article-mode gnus-summary-mode)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
(gnus-icalendar-save-part data))))
(defun gnus-icalendar-reply-accept (&optional comment-p)
"Accept invitation in the current article.
Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]')
means prompt for a comment to include in the reply."
(interactive "P" gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event)
(when comment-p (read-string "Comment: ")))
(setq-local gnus-icalendar-reply-status 'accepted)))
(defun gnus-icalendar-reply-tentative (&optional comment-p)
"Send tentative response to invitation in the current article.
Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]')
means prompt for a comment to include in the reply."
(interactive "P" gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event)
(when comment-p (read-string "Comment: ")))
(setq-local gnus-icalendar-reply-status 'tentative)))
(defun gnus-icalendar-reply-decline (&optional comment-p)
"Decline invitation in the current article.
Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]')
means prompt for a comment to include in the reply."
(interactive "P" gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event)
(when comment-p (read-string "Comment: ")))
(setq-local gnus-icalendar-reply-status 'declined)))
(defun gnus-icalendar-event-export ()
"Export calendar event to `org-mode', or update existing agenda entry."
(interactive nil gnus-article-mode gnus-summary-mode)
(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 nil gnus-article-mode gnus-summary-mode)
(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 nil gnus-article-mode gnus-summary-mode)
(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))
(define-key gnus-summary-mode-map "i"
(define-keymap :prefix 'gnus-summary-calendar-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
;; Local Variables:
;; read-symbol-shorthands: (("ical:" . "icalendar-"))
;; End:
Reference in New Issue View Git Blame Copy Permalink