code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-icalendar.el

   1 ;;; gnus-icalendar.el --- reply to iCalendar meeting requests
   2
   3 ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
   6 ;; Keywords: mail, icalendar, org
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; To install:
  24 ;; (require 'gnus-icalendar)
  25 ;; (gnus-icalendar-setup)
  26
  27 ;; to enable optional iCalendar->Org sync functionality
  28 ;; NOTE: both the capture file and the headline(s) inside must already exist
  29 ;; (setq gnus-icalendar-org-capture-file "~/org/notes.org")
  30 ;; (setq gnus-icalendar-org-capture-headline '("Calendar"))
  31 ;; (gnus-icalendar-org-setup)
  32
  33
  34 ;;; Code:
  35
  36 (require 'icalendar)
  37 (require 'eieio)
  38 (require 'gmm-utils)
  39 (require 'mm-decode)
  40 (require 'gnus-sum)
  41 (require 'gnus-art)
  42
  43 (eval-when-compile (require 'cl))
  44
  45 (defun gnus-icalendar-find-if (pred seq)
  46   (catch 'found
  47     (while seq
  48       (when (funcall pred (car seq))
  49         (throw 'found (car seq)))
  50       (pop seq))))
  51
  52 ;;;
  53 ;;; ical-event
  54 ;;;
  55
  56 (defclass gnus-icalendar-event ()
  57   ((organizer :initarg :organizer
  58               :accessor gnus-icalendar-event:organizer
  59               :initform ""
  60               :type (or null string))
  61    (summary :initarg :summary
  62             :accessor gnus-icalendar-event:summary
  63             :initform ""
  64             :type (or null string))
  65    (description :initarg :description
  66                 :accessor gnus-icalendar-event:description
  67                 :initform ""
  68                 :type (or null string))
  69    (location :initarg :location
  70              :accessor gnus-icalendar-event:location
  71              :initform ""
  72              :type (or null string))
  73    (start-time :initarg :start-time
  74           :accessor gnus-icalendar-event:start-time
  75           :initform ""
  76           :type (or null t))
  77    (end-time :initarg :end-time
  78         :accessor gnus-icalendar-event:end-time
  79         :initform ""
  80         :type (or null t))
  81    (recur :initarg :recur
  82           :accessor gnus-icalendar-event:recur
  83           :initform ""
  84           :type (or null string))
  85    (uid :initarg :uid
  86         :accessor gnus-icalendar-event:uid
  87         :type string)
  88    (method :initarg :method
  89            :accessor gnus-icalendar-event:method
  90            :initform "PUBLISH"
  91            :type (or null string))
  92    (rsvp :initarg :rsvp
  93          :accessor gnus-icalendar-event:rsvp
  94          :initform nil
  95          :type (or null boolean))
  96    (participation-type :initarg :participation-type
  97          :accessor gnus-icalendar-event:participation-type
  98          :initform 'non-participant
  99          :type (or null t))
 100    (req-participants :initarg :req-participants
 101          :accessor gnus-icalendar-event:req-participants
 102          :initform nil
 103          :type (or null t))
 104    (opt-participants :initarg :opt-participants
 105          :accessor gnus-icalendar-event:opt-participants
 106          :initform nil
 107          :type (or null t)))
 108   "generic iCalendar Event class")
 109
 110 (defclass gnus-icalendar-event-request (gnus-icalendar-event)
 111   nil
 112   "iCalendar class for REQUEST events")
 113
 114 (defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
 115   nil
 116   "iCalendar class for CANCEL events")
 117
 118 (defclass gnus-icalendar-event-reply (gnus-icalendar-event)
 119   nil
 120   "iCalendar class for REPLY events")
 121
 122 (cl-defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
 123   "Return t if EVENT is recurring."
 124   (not (null (gnus-icalendar-event:recur event))))
 125
 126 (cl-defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
 127   "Return recurring frequency of EVENT."
 128   (let ((rrule (gnus-icalendar-event:recur event)))
 129     (string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
 130     (match-string 1 rrule)))
 131
 132 (cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
 133   "Return recurring interval of EVENT."
 134   (let ((rrule (gnus-icalendar-event:recur event))
 135         (default-interval 1))
 136
 137     (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
 138     (or (match-string 1 rrule)
 139         default-interval)))
 140
 141 (cl-defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
 142   (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
 143
 144 (defun gnus-icalendar-event--decode-datefield (event field zone-map)
 145   (let* ((dtdate (icalendar--get-event-property event field))
 146          (dtdate-zone (icalendar--find-time-zone
 147                        (icalendar--get-event-property-attributes
 148                         event field) zone-map))
 149          (dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone)))
 150     (apply 'encode-time dtdate-dec)))
 151
 152 (defun gnus-icalendar-event--find-attendee (ical name-or-email)
 153   (let* ((event (car (icalendar--all-events ical)))
 154          (event-props (caddr event)))
 155     (cl-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
 156                 (attendee-email
 157                  (att)
 158                  (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
 159                 (attendee-prop-matches-p
 160                  (prop)
 161                  (and (eq (car prop) 'ATTENDEE)
 162                       (or (member (attendee-name prop) name-or-email)
 163                           (let ((att-email (attendee-email prop)))
 164                             (gnus-icalendar-find-if
 165                              (lambda (email)
 166                                (string-match email att-email))
 167                              name-or-email))))))
 168       (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
 169
 170 (defun gnus-icalendar-event--get-attendee-names (ical)
 171   (let* ((event (car (icalendar--all-events ical)))
 172          (attendee-props (gnus-remove-if-not
 173                           (lambda (p) (eq (car p) 'ATTENDEE))
 174                           (caddr event))))
 175
 176     (cl-labels
 177         ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
 178          (attendee-name
 179           (prop)
 180           (or (plist-get (cadr prop) 'CN)
 181               (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
 182          (attendees-by-type (type)
 183                             (gnus-remove-if-not
 184                              (lambda (p) (string= (attendee-role p) type))
 185                              attendee-props))
 186          (attendee-names-by-type
 187           (type)
 188           (mapcar #'attendee-name (attendees-by-type type))))
 189       (list
 190        (attendee-names-by-type "REQ-PARTICIPANT")
 191        (attendee-names-by-type "OPT-PARTICIPANT")))))
 192
 193 (defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
 194   (let* ((event (car (icalendar--all-events ical)))
 195          (organizer (replace-regexp-in-string
 196                      "^.*MAILTO:" ""
 197                      (or (icalendar--get-event-property event 'ORGANIZER) "")))
 198          (prop-map '((summary . SUMMARY)
 199                      (description . DESCRIPTION)
 200                      (location . LOCATION)
 201                      (recur . RRULE)
 202                      (uid . UID)))
 203          (method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
 204          (attendee (when attendee-name-or-email
 205                      (gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
 206          (attendee-names (gnus-icalendar-event--get-attendee-names ical))
 207          (role (plist-get (cadr attendee) 'ROLE))
 208          (participation-type (pcase role
 209                               ("REQ-PARTICIPANT" 'required)
 210                               ("OPT-PARTICIPANT" 'optional)
 211                               (_                 'non-participant)))
 212          (zone-map (icalendar--convert-all-timezones ical))
 213          (args (list :method method
 214                      :organizer organizer
 215                      :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map)
 216                      :end-time (gnus-icalendar-event--decode-datefield event 'DTEND zone-map)
 217                      :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE")
 218                      :participation-type participation-type
 219                      :req-participants (car attendee-names)
 220                      :opt-participants (cadr attendee-names)))
 221          (event-class (cond
 222                        ((string= method "REQUEST") 'gnus-icalendar-event-request)
 223                        ((string= method "CANCEL") 'gnus-icalendar-event-cancel)
 224                        ((string= method "REPLY") 'gnus-icalendar-event-reply)
 225                        (t 'gnus-icalendar-event))))
 226
 227     (cl-labels
 228         ((map-property
 229           (prop)
 230           (let ((value (icalendar--get-event-property event prop)))
 231             (when value
 232               ;; ugly, but cannot get
 233               ;;replace-regexp-in-string work with "\\" as
 234               ;;REP, plus we should also handle "\\;"
 235               (replace-regexp-in-string
 236                "\\\\," ","
 237                (replace-regexp-in-string
 238                 "\\\\n" "\n" (substring-no-properties value))))))
 239          (accumulate-args
 240           (mapping)
 241           (destructuring-bind (slot . ical-property) mapping
 242             (setq args (append (list
 243                                 (intern (concat ":" (symbol-name slot)))
 244                                 (map-property ical-property))
 245                                args)))))
 246       (mapc #'accumulate-args prop-map)
 247       (apply 'make-instance event-class args))))
 248
 249 (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
 250   "Parse RFC5545 iCalendar in buffer BUF and return an event object.
 251
 252 Return a gnus-icalendar-event object representing the first event
 253 contained in the invitation. Return nil for calendars without an event entry.
 254
 255 ATTENDEE-NAME-OR-EMAIL is a list of strings that will be matched
 256 against the event's attendee names and emails. Invitation rsvp
 257 status will be retrieved from the first matching attendee record."
 258   (let ((ical (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
 259                 (goto-char (point-min))
 260                 (icalendar--read-element nil nil))))
 261
 262     (when ical
 263       (gnus-icalendar-event-from-ical ical attendee-name-or-email))))
 264
 265 ;;;
 266 ;;; gnus-icalendar-event-reply
 267 ;;;
 268
 269 (defun gnus-icalendar-event--build-reply-event-body (ical-request status identities)
 270   (let ((summary-status (capitalize (symbol-name status)))
 271         (attendee-status (upcase (symbol-name status)))
 272         reply-event-lines)
 273     (cl-labels
 274         ((update-summary
 275           (line)
 276           (if (string-match "^[^:]+:" line)
 277               (replace-match (format "\\&%s: " summary-status) t nil line)
 278             line))
 279          (update-dtstamp ()
 280                          (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
 281          (attendee-matches-identity
 282           (line)
 283           (gnus-icalendar-find-if (lambda (name) (string-match-p name line))
 284                                   identities))
 285          (update-attendee-status
 286           (line)
 287           (when (and (attendee-matches-identity line)
 288                      (string-match "\\(PARTSTAT=\\)[^;]+" line))
 289             (replace-match (format "\\1%s" attendee-status) t nil line)))
 290          (process-event-line
 291           (line)
 292           (when (string-match "^\\([^;:]+\\)" line)
 293             (let* ((key (match-string 0 line))
 294                    ;; NOTE: not all of the below fields are mandatory,
 295                    ;; but they are often present in other clients'
 296                    ;; replies. Can be helpful for debugging, too.
 297                    (new-line
 298                     (cond
 299                      ((string= key "ATTENDEE") (update-attendee-status line))
 300                      ((string= key "SUMMARY") (update-summary line))
 301                      ((string= key "DTSTAMP") (update-dtstamp))
 302                      ((member key '("ORGANIZER" "DTSTART" "DTEND"
 303                                     "LOCATION" "DURATION" "SEQUENCE"
 304                                     "RECURRENCE-ID" "UID")) line)
 305                      (t nil))))
 306               (when new-line
 307                 (push new-line reply-event-lines))))))
 308
 309       (mapc #'process-event-line (split-string ical-request "\n"))
 310
 311       (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
 312                                       reply-event-lines)
 313         (error "Could not find an event attendee matching given identity"))
 314
 315       (mapconcat #'identity `("BEGIN:VEVENT"
 316                               ,@(nreverse reply-event-lines)
 317                               "END:VEVENT")
 318                  "\n"))))
 319
 320 (defun gnus-icalendar-event-reply-from-buffer (buf status identities)
 321   "Build a calendar event reply for request contained in BUF.
 322 The reply will have STATUS (`accepted', `tentative' or  `declined').
 323 The reply will be composed for attendees matching any entry
 324 on the IDENTITIES list."
 325   (cl-labels
 326       ((extract-block
 327         (blockname)
 328         (save-excursion
 329           (let ((block-start-re (format "^BEGIN:%s" blockname))
 330                 (block-end-re (format "^END:%s" blockname))
 331                 start)
 332             (when (re-search-forward block-start-re nil t)
 333               (setq start (line-beginning-position))
 334               (re-search-forward block-end-re)
 335               (buffer-substring-no-properties start (line-end-position)))))))
 336     (let (zone event)
 337       (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
 338         (goto-char (point-min))
 339         (setq zone (extract-block "VTIMEZONE")
 340               event (extract-block "VEVENT")))
 341
 342       (when event
 343         (let ((contents (list "BEGIN:VCALENDAR"
 344                               "METHOD:REPLY"
 345                               "PRODID:Gnus"
 346                               "VERSION:2.0"
 347                               zone
 348                               (gnus-icalendar-event--build-reply-event-body event status identities)
 349                               "END:VCALENDAR")))
 350
 351           (mapconcat #'identity (delq nil contents) "\n"))))))
 352
 353 ;;;
 354 ;;; gnus-icalendar-org
 355 ;;;
 356 ;;; TODO: this is an optional feature, and it's only available with org-mode
 357 ;;; 7+, so will need to properly handle emacsen with no/outdated org-mode
 358
 359 (require 'org)
 360 (require 'org-capture)
 361
 362 (defgroup gnus-icalendar-org nil
 363   "Settings for Calendar Event gnus/org integration."
 364   :version "24.4"
 365   :group 'gnus-icalendar
 366   :prefix "gnus-icalendar-org-")
 367
 368 (defcustom gnus-icalendar-org-capture-file nil
 369   "Target Org file for storing captured calendar events."
 370   :type '(choice (const nil) file)
 371   :group 'gnus-icalendar-org)
 372
 373 (defcustom gnus-icalendar-org-capture-headline nil
 374   "Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
 375   :type '(repeat string)
 376   :group 'gnus-icalendar-org)
 377
 378 (defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
 379   "Org-mode template name."
 380   :type '(string)
 381   :group 'gnus-icalendar-org)
 382
 383 (defcustom gnus-icalendar-org-template-key "#"
 384   "Org-mode template hotkey."
 385   :type '(string)
 386   :group 'gnus-icalendar-org)
 387
 388 (defvar gnus-icalendar-org-enabled-p nil)
 389
 390
 391 (cl-defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event))
 392   "Return `org-mode' timestamp repeater string for recurring EVENT.
 393 Return nil for non-recurring EVENT."
 394   (when (gnus-icalendar-event:recurring-p event)
 395     (let* ((freq-map '(("HOURLY" . "h")
 396                        ("DAILY" . "d")
 397                        ("WEEKLY" . "w")
 398                        ("MONTHLY" . "m")
 399                        ("YEARLY" . "y")))
 400            (org-freq (cdr (assoc (gnus-icalendar-event:recurring-freq event) freq-map))))
 401
 402       (when org-freq
 403         (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
 404
 405 (cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
 406   "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
 407   (let* ((start (gnus-icalendar-event:start-time event))
 408          (end (gnus-icalendar-event:end-time event))
 409          (start-date (format-time-string "%Y-%m-%d" start))
 410          (start-time (format-time-string "%H:%M" start))
 411          (start-at-midnight (string= start-time "00:00"))
 412          (end-date (format-time-string "%Y-%m-%d" end))
 413          (end-time (format-time-string "%H:%M" end))
 414          (end-at-midnight (string= end-time "00:00"))
 415          (start-end-date-diff (/ (float-time (time-subtract
 416                                         (date-to-time end-date)
 417                                         (date-to-time start-date)))
 418                                  86400))
 419          (org-repeat (gnus-icalendar-event:org-repeat event))
 420          (repeat (if org-repeat (concat " " org-repeat) ""))
 421          (time-1-day '(0 86400)))
 422
 423     ;; NOTE: special care is needed with appointments ending at midnight
 424     ;; (typically all-day events): the end time has to be changed to 23:59 to
 425     ;; prevent org agenda showing the event on one additional day
 426     (cond
 427      ;; start/end midnight
 428      ;; A 0:0 - A+1 0:0 -> A
 429      ;; A 0:0 - A+n 0:0 -> A - A+n-1
 430      ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
 431                                                   (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day))))
 432                                                     (format "<%s>--<%s>" start-date end-ts))
 433                                                 (format "<%s%s>" start-date repeat)))
 434      ;; end midnight
 435      ;; A .:. - A+1 0:0 -> A .:.-23:59
 436      ;; A .:. - A+n 0:0 -> A .:. - A_n-1
 437      (end-at-midnight (if (= start-end-date-diff 1)
 438                           (format "<%s %s-23:59%s>" start-date start-time repeat)
 439                         (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day))))
 440                           (format "<%s %s>--<%s>" start-date start-time end-ts))))
 441      ;; start midnight
 442      ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
 443      ;; A 0:0 - A+n .:. -> A - A+n .:.
 444      ((and start-at-midnight
 445            (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
 446      ;; default
 447      ;; A .:. - A .:. -> A .:.-.:.
 448      ;; A .:. - B .:.
 449      ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
 450      (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
 451
 452 (defun gnus-icalendar--format-summary-line (summary &optional location)
 453   (if location
 454       (format "%s (%s)" summary location)
 455     (format "%s" summary)))
 456
 457
 458 (defun gnus-icalendar--format-participant-list (participants)
 459   (mapconcat #'identity participants ", "))
 460
 461 ;; TODO: make the template customizable
 462 (cl-defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
 463   "Return string with new `org-mode' entry describing EVENT."
 464   (with-temp-buffer
 465     (org-mode)
 466     (with-slots (organizer summary description location
 467                            recur uid) event
 468       (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
 469                       "Not replied yet"))
 470              (props `(("ICAL_EVENT" . "t")
 471                       ("ID" . ,uid)
 472                       ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
 473                       ("LOCATION" . ,(gnus-icalendar-event:location event))
 474                       ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
 475                       ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
 476                       ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
 477                       ("RRULE" . ,(gnus-icalendar-event:recur event))
 478                       ("REPLY" . ,reply))))
 479
 480         (insert (format "* %s\n\n"
 481                         (gnus-icalendar--format-summary-line summary location)))
 482         (mapc (lambda (prop)
 483                 (org-entry-put (point) (car prop) (cdr prop)))
 484               props))
 485
 486       (when description
 487         (save-restriction
 488           (narrow-to-region (point) (point))
 489           (insert (gnus-icalendar-event:org-timestamp event)
 490                   "\n\n"
 491                   description)
 492           (indent-region (point-min) (point-max) 2)
 493           (fill-region (point-min) (point-max))))
 494
 495       (buffer-string))))
 496
 497 (defun gnus-icalendar--deactivate-org-timestamp (ts)
 498   (replace-regexp-in-string "[<>]"
 499                             (lambda (m) (cond ((string= m "<") "[")
 500                                               ((string= m ">") "]")))
 501                             ts))
 502
 503 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
 504   "Return the name of the file containing EVENT org entry.
 505 Return nil when not found.
 506
 507 All org agenda files are searched for the EVENT entry.  When
 508 the optional ORG-FILE argument is specified, only that one file
 509 is searched."
 510   (let ((uid (gnus-icalendar-event:uid event))
 511         (files (or org-file (org-agenda-files t 'ifmode))))
 512     (cl-labels
 513         ((find-event-in
 514           (file)
 515           (org-check-agenda-file file)
 516           (with-current-buffer (find-file-noselect file)
 517             (let ((event-pos (org-find-entry-with-id uid)))
 518               (when (and event-pos
 519                          (string= (cdr (assoc "ICAL_EVENT"
 520                                               (org-entry-properties event-pos)))
 521                                   "t"))
 522                 (throw 'found file))))))
 523       (gnus-icalendar-find-if #'find-event-in files))))
 524
 525
 526 (defun gnus-icalendar--show-org-event (event &optional org-file)
 527   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 528     (when file
 529       (switch-to-buffer (find-file file))
 530       (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
 531       (org-show-entry))))
 532
 533
 534 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
 535   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 536     (when file
 537       (with-current-buffer (find-file-noselect file)
 538         (with-slots (uid summary description organizer location recur
 539                          participation-type req-participants opt-participants) event
 540           (let ((event-pos (org-find-entry-with-id uid)))
 541             (when event-pos
 542               (goto-char event-pos)
 543
 544               ;; update the headline, keep todo, priority and tags, if any
 545               (save-excursion
 546                 (let* ((priority (org-entry-get (point) "PRIORITY"))
 547                        (headline (delq nil (list
 548                                             (org-entry-get (point) "TODO")
 549                                             (when priority (format "[#%s]" priority))
 550                                             (gnus-icalendar--format-summary-line summary location)
 551                                             (org-entry-get (point) "TAGS")))))
 552
 553                   (re-search-forward "^\\*+ " (line-end-position))
 554                   (delete-region (point) (line-end-position))
 555                   (insert (mapconcat #'identity headline " "))))
 556
 557               ;; update props and description
 558               (let ((entry-end (org-entry-end-position))
 559                     (entry-outline-level (org-outline-level)))
 560
 561                 ;; delete body of the entry, leave org drawers intact
 562                 (save-restriction
 563                   (org-narrow-to-element)
 564                   (goto-char entry-end)
 565                   (re-search-backward "^[\t ]*:END:")
 566                   (forward-line)
 567                   (delete-region (point) entry-end))
 568
 569                 ;; put new event description in the entry body
 570                 (when description
 571                   (save-restriction
 572                     (narrow-to-region (point) (point))
 573                     (insert "\n"
 574                             (gnus-icalendar-event:org-timestamp event)
 575                             "\n\n"
 576                             (replace-regexp-in-string "[\n]+$" "\n" description)
 577                             "\n")
 578                     (indent-region (point-min) (point-max) (1+ entry-outline-level))
 579                     (fill-region (point-min) (point-max))))
 580
 581                 ;; update entry properties
 582                 (cl-labels
 583                     ((update-org-entry
 584                       (position property value)
 585                       (if (or (null value)
 586                               (string= value ""))
 587                           (org-entry-delete position property)
 588                         (org-entry-put position property value))))
 589
 590                   (update-org-entry event-pos "ORGANIZER" organizer)
 591                   (update-org-entry event-pos "LOCATION" location)
 592                   (update-org-entry event-pos "PARTICIPATION_TYPE"
 593                                     (symbol-name participation-type))
 594                   (update-org-entry event-pos "REQ_PARTICIPANTS"
 595                                     (gnus-icalendar--format-participant-list
 596                                      req-participants))
 597                   (update-org-entry event-pos "OPT_PARTICIPANTS"
 598                                     (gnus-icalendar--format-participant-list
 599                                      opt-participants))
 600                   (update-org-entry event-pos "RRULE" recur)
 601                   (update-org-entry
 602                    event-pos "REPLY"
 603                    (if reply-status (capitalize (symbol-name reply-status))
 604                      "Not replied yet")))
 605                 (save-buffer)))))))))
 606
 607
 608 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
 609   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 610     (when file
 611       (with-current-buffer (find-file-noselect file)
 612         (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 613           (when event-pos
 614             (let ((ts (org-entry-get event-pos "DT")))
 615               (when ts
 616                 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
 617                 (save-buffer)))))))))
 618
 619
 620 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
 621   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 622     (when file
 623       (save-excursion
 624         (with-current-buffer (find-file-noselect file)
 625           (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 626             (org-entry-get event-pos "REPLY")))))))
 627
 628
 629 (defun gnus-icalendar-insinuate-org-templates ()
 630   (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
 631                       org-capture-templates)
 632     (setq org-capture-templates
 633           (append `((,gnus-icalendar-org-template-key
 634                      ,gnus-icalendar-org-template-name
 635                      entry
 636                      (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
 637                      "%i"
 638                      :immediate-finish t))
 639                   org-capture-templates))
 640
 641     ;; hide the template from interactive template selection list
 642     ;; (org-capture)
 643     ;; NOTE: doesn't work when capturing from string
 644     ;; (when (boundp 'org-capture-templates-contexts)
 645     ;;   (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
 646     ;;         org-capture-templates-contexts))
 647     ))
 648
 649 (defun gnus-icalendar:org-event-save (event reply-status)
 650   (with-temp-buffer
 651     (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
 652                         gnus-icalendar-org-template-key)))
 653
 654 (defun gnus-icalendar-show-org-agenda (event)
 655   (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
 656                                     (gnus-icalendar-event:start-time event)))
 657          (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
 658                                   (cadr time-delta))
 659                                86400))))
 660
 661     (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
 662
 663 (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
 664   (if (gnus-icalendar-find-org-event-file event)
 665       (gnus-icalendar--update-org-event event reply-status)
 666     (gnus-icalendar:org-event-save event reply-status)))
 667
 668 (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
 669   (when (gnus-icalendar-find-org-event-file event)
 670     (gnus-icalendar--cancel-org-event event)))
 671
 672 (defun gnus-icalendar-org-setup ()
 673   (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
 674       (progn
 675         (gnus-icalendar-insinuate-org-templates)
 676         (setq gnus-icalendar-org-enabled-p t))
 677     (message "Cannot enable Calendar->Org: missing capture file, headline")))
 678
 679 ;;;
 680 ;;; gnus-icalendar
 681 ;;;
 682
 683 (defgroup gnus-icalendar nil
 684   "Settings for inline display of iCalendar invitations."
 685   :version "24.4"
 686   :group 'gnus-article
 687   :prefix "gnus-icalendar-")
 688
 689 (defcustom gnus-icalendar-reply-bufname "*CAL*"
 690   "Buffer used for building iCalendar invitation reply."
 691   :type '(string)
 692   :group 'gnus-icalendar)
 693
 694 (defcustom gnus-icalendar-additional-identities nil
 695   "We need to know your identity to make replies to calendar requests work.
 696
 697 Gnus will only offer you the Accept/Tentative/Decline buttons for
 698 calendar events if any of your identities matches at least one
 699 RSVP participant.
 700
 701 Your identity is guessed automatically from the variables
 702 `user-full-name', `user-mail-address',
 703 `gnus-ignored-from-addresses' and `message-alternative-emails'.
 704
 705 If you need even more aliases you can define them here.  It really
 706 only makes sense to define names or email addresses."
 707
 708   :type '(repeat string)
 709   :group 'gnus-icalendar)
 710
 711 (make-variable-buffer-local
 712  (defvar gnus-icalendar-reply-status nil))
 713
 714 (make-variable-buffer-local
 715  (defvar gnus-icalendar-event nil))
 716
 717 (make-variable-buffer-local
 718  (defvar gnus-icalendar-handle nil))
 719
 720 (defun gnus-icalendar-identities ()
 721   "Return list of regexp-quoted names and email addresses belonging to the user.
 722
 723 These will be used to retrieve the RSVP information from ical events."
 724   (apply #'append
 725          (mapcar
 726           (lambda (x) (if (listp x) x (list x)))
 727           (list user-full-name (regexp-quote user-mail-address)
 728                 ;; NOTE: these can be lists
 729                 gnus-ignored-from-addresses ; already regexp-quoted
 730                 (unless (functionp message-alternative-emails) ; String or function.
 731                   message-alternative-emails)
 732                 (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
 733
 734 ;; TODO: make the template customizable
 735 (cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
 736   "Format an overview of EVENT details."
 737   (cl-labels
 738       ((format-header (x)
 739                       (format "%-12s%s"
 740                               (propertize (concat (car x) ":") 'face 'bold)
 741                               (cadr x))))
 742
 743     (with-slots (organizer summary description location recur uid
 744                            method rsvp participation-type) event
 745       (let ((headers `(("Summary" ,summary)
 746                        ("Location" ,(or location ""))
 747                        ("Time" ,(gnus-icalendar-event:org-timestamp event))
 748                        ("Organizer" ,organizer)
 749                        ("Attendance" ,(if (eq participation-type 'non-participant)
 750                                           "You are not listed as an attendee"
 751                                         (capitalize (symbol-name participation-type))))
 752                        ("Method" ,method))))
 753
 754         (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
 755           (setq headers (append headers
 756                                 `(("Status" ,(or reply-status "Not replied yet"))))))
 757
 758         (concat
 759          (mapconcat #'format-header headers "\n")
 760          "\n\n"
 761          description)))))
 762
 763 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
 764   "Execute BODY in buffer containing the decoded contents of HANDLE."
 765   (let ((charset (make-symbol "charset")))
 766     `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
 767        (with-temp-buffer
 768          (mm-insert-part ,handle)
 769          (when (string= ,charset "utf-8")
 770            (decode-coding-region (point-min) (point-max) 'utf-8))
 771          ,@body))))
 772
 773
 774 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
 775   (gnus-icalendar-with-decoded-handle handle
 776                        (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
 777
 778 (defun gnus-icalendar-insert-button (text callback data)
 779   ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
 780   ;; of button.
 781   (let ((start (point)))
 782     (add-text-properties
 783      start
 784      (progn
 785        (insert "[ " text " ]")
 786        (point))
 787      `(gnus-callback
 788        ,callback
 789        keymap ,gnus-mime-button-map
 790        face ,gnus-article-button-face
 791        gnus-data ,data))
 792     (widget-convert-button 'link start (point)
 793                            :action 'gnus-widget-press-button)))
 794
 795 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
 796   (let ((message-signature nil))
 797     (with-current-buffer gnus-summary-buffer
 798       (gnus-summary-reply)
 799       (message-goto-body)
 800       (mml-insert-multipart "alternative")
 801       (mml-insert-empty-tag 'part 'type "text/plain")
 802       (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
 803       (message-goto-subject)
 804       (delete-region (line-beginning-position) (line-end-position))
 805       (insert "Subject: " subject)
 806       (message-send-and-exit))))
 807
 808 (defun gnus-icalendar-reply (data)
 809   (let* ((handle (car data))
 810          (status (cadr data))
 811          (event (caddr data))
 812          (reply (gnus-icalendar-with-decoded-handle handle
 813                   (gnus-icalendar-event-reply-from-buffer
 814                    (current-buffer) status (gnus-icalendar-identities)))))
 815
 816     (when reply
 817       (cl-labels
 818           ((fold-icalendar-buffer
 819             ()
 820             (goto-char (point-min))
 821             (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
 822               (replace-match "\\1\n \\2")
 823               (goto-char (line-beginning-position)))))
 824         (let ((subject (concat (capitalize (symbol-name status))
 825                                ": " (gnus-icalendar-event:summary event))))
 826
 827           (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
 828             (delete-region (point-min) (point-max))
 829             (insert reply)
 830             (fold-icalendar-buffer)
 831             (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
 832
 833           ;; Back in article buffer
 834           (setq-local gnus-icalendar-reply-status status)
 835           (when gnus-icalendar-org-enabled-p
 836             (gnus-icalendar--update-org-event event status)
 837             ;; refresh article buffer to update the reply status
 838             (with-current-buffer gnus-summary-buffer
 839               (gnus-summary-show-article))))))))
 840
 841 (defun gnus-icalendar-sync-event-to-org (event)
 842   (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
 843
 844 (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
 845   (when (gnus-icalendar-event:rsvp event)
 846     `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
 847       ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
 848       ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
 849
 850 (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
 851   "No buttons for REPLY events."
 852   nil)
 853
 854 (cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
 855   (or (when gnus-icalendar-org-enabled-p
 856         (gnus-icalendar--get-org-event-reply-status event))
 857       "Not replied yet"))
 858
 859 (cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
 860   "No reply status for REPLY events."
 861   nil)
 862
 863
 864 (cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
 865   (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
 866          (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
 867
 868     (delq nil (list
 869                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 870                (when (gnus-icalendar-event-request-p event)
 871                  `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
 872                (when org-entry-exists-p
 873                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 874
 875
 876 (cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
 877   (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
 878
 879     (delq nil (list
 880                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 881                (when org-entry-exists-p
 882                  `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
 883                (when org-entry-exists-p
 884                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 885
 886
 887 (defun gnus-icalendar-mm-inline (handle)
 888   (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 889
 890     (setq gnus-icalendar-reply-status nil)
 891
 892     (when event
 893       (cl-labels
 894           ((insert-button-group
 895             (buttons)
 896             (when buttons
 897               (mapc (lambda (x)
 898                       (apply 'gnus-icalendar-insert-button x)
 899                       (insert "    "))
 900                     buttons)
 901               (insert "\n\n"))))
 902
 903         (insert-button-group
 904          (gnus-icalendar-event:inline-reply-buttons event handle))
 905
 906         (when gnus-icalendar-org-enabled-p
 907           (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
 908
 909         (setq gnus-icalendar-event event
 910               gnus-icalendar-handle handle)
 911
 912         (insert (gnus-icalendar-event->gnus-calendar
 913                  event
 914                  (gnus-icalendar-event:inline-reply-status event)))))))
 915
 916 (defun gnus-icalendar-save-part (handle)
 917   (let (event)
 918     (when (and (equal (car (mm-handle-type handle)) "text/calendar")
 919                (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 920
 921       (gnus-icalendar-event:sync-to-org event))))
 922
 923
 924 (defun gnus-icalendar-save-event ()
 925   "Save the Calendar event in the text/calendar part under point."
 926   (interactive)
 927   (gnus-article-check-buffer)
 928   (let ((data (get-text-property (point) 'gnus-data)))
 929     (when data
 930       (gnus-icalendar-save-part data))))
 931
 932 (defun gnus-icalendar-reply-accept ()
 933   "Accept invitation in the current article."
 934   (interactive)
 935   (with-current-buffer gnus-article-buffer
 936     (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
 937     (setq-local gnus-icalendar-reply-status 'accepted)))
 938
 939 (defun gnus-icalendar-reply-tentative ()
 940   "Send tentative response to invitation in the current article."
 941   (interactive)
 942   (with-current-buffer gnus-article-buffer
 943     (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
 944     (setq-local gnus-icalendar-reply-status 'tentative)))
 945
 946 (defun gnus-icalendar-reply-decline ()
 947   "Decline invitation in the current article."
 948   (interactive)
 949   (with-current-buffer gnus-article-buffer
 950     (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
 951     (setq-local gnus-icalendar-reply-status 'declined)))
 952
 953 (defun gnus-icalendar-event-export ()
 954   "Export calendar event to `org-mode', or update existing agenda entry."
 955   (interactive)
 956   (with-current-buffer gnus-article-buffer
 957     (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
 958   ;; refresh article buffer in case the reply had been sent before initial org
 959   ;; export
 960   (with-current-buffer gnus-summary-buffer
 961     (gnus-summary-show-article)))
 962
 963 (defun gnus-icalendar-event-show ()
 964   "Display `org-mode' agenda entry related to the calendar event."
 965   (interactive)
 966   (gnus-icalendar--show-org-event
 967    (with-current-buffer gnus-article-buffer
 968      gnus-icalendar-event)))
 969
 970 (defun gnus-icalendar-event-check-agenda ()
 971   "Display `org-mode' agenda for days between event start and end dates."
 972   (interactive)
 973   (gnus-icalendar-show-org-agenda
 974    (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
 975
 976 (defvar gnus-mime-action-alist)         ; gnus-art
 977
 978 (defun gnus-icalendar-setup ()
 979   (add-to-list 'mm-inlined-types "text/calendar")
 980   (add-to-list 'mm-automatic-display "text/calendar")
 981   (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
 982
 983   (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
 984     "a" gnus-icalendar-reply-accept
 985     "t" gnus-icalendar-reply-tentative
 986     "d" gnus-icalendar-reply-decline
 987     "c" gnus-icalendar-event-check-agenda
 988     "e" gnus-icalendar-event-export
 989     "s" gnus-icalendar-event-show)
 990
 991   (require 'gnus-art)
 992   (add-to-list 'gnus-mime-action-alist
 993                (cons "save calendar event" 'gnus-icalendar-save-event)
 994                t))
 995
 996 (provide 'gnus-icalendar)
 997
 998 ;;; gnus-icalendar.el ends here