;;; gnus-icalendar.el --- reply to iCalendar meeting requests -*- lexical-binding:t -*- ;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Jan Tatarik ;; 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 . ;;; 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")) (if (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule) (match-string 1 rrule) default-interval))) (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)) (weekday-map '(("SU" . 0) ("MO" . 1) ("TU" . 2) ("WE" . 3) ("TH" . 4) ("FR" . 5) ("SA" . 6)))) (when (and rrule (string-match "BYDAY=\\([^;]+\\)" rrule)) (let ((bydays (split-string (match-string 1 rrule) ","))) (seq-map (lambda (x) (cdr (assoc x weekday-map))) (seq-filter (lambda (x) (string-match "^[A-Z]\\{2\\}$" x)) bydays)))))) (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 (str-or-fun) (if (functionp str-or-fun) (funcall str-or-fun att-email) (string-match str-or-fun 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) ;; RFC5546: default ROLE is REQ-PARTICIPANT (and prop (or (plist-get (cadr prop) 'ROLE) "REQ-PARTICIPANT"))) (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)) ;; RFC5546: default ROLE is REQ-PARTICIPANT (role (and attendee (or (plist-get (cadr attendee) 'ROLE) "REQ-PARTICIPANT"))) (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 "\\;" (string-replace "\\," "," (string-replace "\\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 (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 (if (eq keyword :uid) ;; The UID has to be a string. (or (plist-get args keyword) "") (plist-get args keyword)))))))) (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")) ;; 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. (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) (lwarn 'gnus-icalendar :warning "Could not find an event attendee matching given identity") (push (format "ATTENDEE;RSVP=TRUE;PARTSTAT=%s;CN=%s:MAILTO:%s" attendee-status user-full-name user-mail-address) reply-event-lines)) (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))))) (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 (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)))) ) (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) (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 ; 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 (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 (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) (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)))) (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 (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 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 () "Accept invitation in the current article." (interactive nil gnus-article-mode gnus-summary-mode) (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 nil gnus-article-mode gnus-summary-mode) (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 nil gnus-article-mode gnus-summary-mode) (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 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