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
 416           (/ (float-time (time-subtract
 417                           (org-time-string-to-time end-date)
 418                           (org-time-string-to-time start-date)))
 419              86400))
 420          (org-repeat (gnus-icalendar-event:org-repeat event))
 421          (repeat (if org-repeat (concat " " org-repeat) ""))
 422          (time-1-day '(0 86400)))
 423
 424     ;; NOTE: special care is needed with appointments ending at midnight
 425     ;; (typically all-day events): the end time has to be changed to 23:59 to
 426     ;; prevent org agenda showing the event on one additional day
 427     (cond
 428      ;; start/end midnight
 429      ;; A 0:0 - A+1 0:0 -> A
 430      ;; A 0:0 - A+n 0:0 -> A - A+n-1
 431      ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
 432                                                   (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day))))
 433                                                     (format "<%s>--<%s>" start-date end-ts))
 434                                                 (format "<%s%s>" start-date repeat)))
 435      ;; end midnight
 436      ;; A .:. - A+1 0:0 -> A .:.-23:59
 437      ;; A .:. - A+n 0:0 -> A .:. - A_n-1
 438      (end-at-midnight (if (= start-end-date-diff 1)
 439                           (format "<%s %s-23:59%s>" start-date start-time repeat)
 440                         (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day))))
 441                           (format "<%s %s>--<%s>" start-date start-time end-ts))))
 442      ;; start midnight
 443      ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
 444      ;; A 0:0 - A+n .:. -> A - A+n .:.
 445      ((and start-at-midnight
 446            (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
 447      ;; default
 448      ;; A .:. - A .:. -> A .:.-.:.
 449      ;; A .:. - B .:.
 450      ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
 451      (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
 452
 453 (defun gnus-icalendar--format-summary-line (summary &optional location)
 454   (if location
 455       (format "%s (%s)" summary location)
 456     (format "%s" summary)))
 457
 458
 459 (defun gnus-icalendar--format-participant-list (participants)
 460   (mapconcat #'identity participants ", "))
 461
 462 ;; TODO: make the template customizable
 463 (cl-defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
 464   "Return string with new `org-mode' entry describing EVENT."
 465   (with-temp-buffer
 466     (org-mode)
 467     (with-slots (organizer summary description location
 468                            recur uid) event
 469       (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
 470                       "Not replied yet"))
 471              (props `(("ICAL_EVENT" . "t")
 472                       ("ID" . ,uid)
 473                       ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
 474                       ("LOCATION" . ,(gnus-icalendar-event:location event))
 475                       ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
 476                       ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
 477                       ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
 478                       ("RRULE" . ,(gnus-icalendar-event:recur event))
 479                       ("REPLY" . ,reply))))
 480
 481         (insert (format "* %s\n\n"
 482                         (gnus-icalendar--format-summary-line summary location)))
 483         (mapc (lambda (prop)
 484                 (org-entry-put (point) (car prop) (cdr prop)))
 485               props))
 486
 487       (when description
 488         (save-restriction
 489           (narrow-to-region (point) (point))
 490           (insert (gnus-icalendar-event:org-timestamp event)
 491                   "\n\n"
 492                   description)
 493           (indent-region (point-min) (point-max) 2)
 494           (fill-region (point-min) (point-max))))
 495
 496       (buffer-string))))
 497
 498 (defun gnus-icalendar--deactivate-org-timestamp (ts)
 499   (replace-regexp-in-string "[<>]"
 500                             (lambda (m) (cond ((string= m "<") "[")
 501                                               ((string= m ">") "]")))
 502                             ts))
 503
 504 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
 505   "Return the name of the file containing EVENT org entry.
 506 Return nil when not found.
 507
 508 All org agenda files are searched for the EVENT entry.  When
 509 the optional ORG-FILE argument is specified, only that one file
 510 is searched."
 511   (let ((uid (gnus-icalendar-event:uid event))
 512         (files (or org-file (org-agenda-files t 'ifmode))))
 513     (cl-labels
 514         ((find-event-in
 515           (file)
 516           (org-check-agenda-file file)
 517           (with-current-buffer (find-file-noselect file)
 518             (let ((event-pos (org-find-entry-with-id uid)))
 519               (when (and event-pos
 520                          (string= (cdr (assoc "ICAL_EVENT"
 521                                               (org-entry-properties event-pos)))
 522                                   "t"))
 523                 (throw 'found file))))))
 524       (gnus-icalendar-find-if #'find-event-in files))))
 525
 526
 527 (defun gnus-icalendar--show-org-event (event &optional org-file)
 528   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 529     (when file
 530       (switch-to-buffer (find-file file))
 531       (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
 532       (org-show-entry))))
 533
 534
 535 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
 536   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 537     (when file
 538       (with-current-buffer (find-file-noselect file)
 539         (with-slots (uid summary description organizer location recur
 540                          participation-type req-participants opt-participants) event
 541           (let ((event-pos (org-find-entry-with-id uid)))
 542             (when event-pos
 543               (goto-char event-pos)
 544
 545               ;; update the headline, keep todo, priority and tags, if any
 546               (save-excursion
 547                 (let* ((priority (org-entry-get (point) "PRIORITY"))
 548                        (headline (delq nil (list
 549                                             (org-entry-get (point) "TODO")
 550                                             (when priority (format "[#%s]" priority))
 551                                             (gnus-icalendar--format-summary-line summary location)
 552                                             (org-entry-get (point) "TAGS")))))
 553
 554                   (re-search-forward "^\\*+ " (line-end-position))
 555                   (delete-region (point) (line-end-position))
 556                   (insert (mapconcat #'identity headline " "))))
 557
 558               ;; update props and description
 559               (let ((entry-end (org-entry-end-position))
 560                     (entry-outline-level (org-outline-level)))
 561
 562                 ;; delete body of the entry, leave org drawers intact
 563                 (save-restriction
 564                   (org-narrow-to-element)
 565                   (goto-char entry-end)
 566                   (re-search-backward "^[\t ]*:END:")
 567                   (forward-line)
 568                   (delete-region (point) entry-end))
 569
 570                 ;; put new event description in the entry body
 571                 (when description
 572                   (save-restriction
 573                     (narrow-to-region (point) (point))
 574                     (insert "\n"
 575                             (gnus-icalendar-event:org-timestamp event)
 576                             "\n\n"
 577                             (replace-regexp-in-string "[\n]+$" "\n" description)
 578                             "\n")
 579                     (indent-region (point-min) (point-max) (1+ entry-outline-level))
 580                     (fill-region (point-min) (point-max))))
 581
 582                 ;; update entry properties
 583                 (cl-labels
 584                     ((update-org-entry
 585                       (position property value)
 586                       (if (or (null value)
 587                               (string= value ""))
 588                           (org-entry-delete position property)
 589                         (org-entry-put position property value))))
 590
 591                   (update-org-entry event-pos "ORGANIZER" organizer)
 592                   (update-org-entry event-pos "LOCATION" location)
 593                   (update-org-entry event-pos "PARTICIPATION_TYPE"
 594                                     (symbol-name participation-type))
 595                   (update-org-entry event-pos "REQ_PARTICIPANTS"
 596                                     (gnus-icalendar--format-participant-list
 597                                      req-participants))
 598                   (update-org-entry event-pos "OPT_PARTICIPANTS"
 599                                     (gnus-icalendar--format-participant-list
 600                                      opt-participants))
 601                   (update-org-entry event-pos "RRULE" recur)
 602                   (update-org-entry
 603                    event-pos "REPLY"
 604                    (if reply-status (capitalize (symbol-name reply-status))
 605                      "Not replied yet")))
 606                 (save-buffer)))))))))
 607
 608
 609 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
 610   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 611     (when file
 612       (with-current-buffer (find-file-noselect file)
 613         (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 614           (when event-pos
 615             (let ((ts (org-entry-get event-pos "DT")))
 616               (when ts
 617                 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
 618                 (save-buffer)))))))))
 619
 620
 621 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
 622   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 623     (when file
 624       (save-excursion
 625         (with-current-buffer (find-file-noselect file)
 626           (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 627             (org-entry-get event-pos "REPLY")))))))
 628
 629
 630 (defun gnus-icalendar-insinuate-org-templates ()
 631   (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
 632                       org-capture-templates)
 633     (setq org-capture-templates
 634           (append `((,gnus-icalendar-org-template-key
 635                      ,gnus-icalendar-org-template-name
 636                      entry
 637                      (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
 638                      "%i"
 639                      :immediate-finish t))
 640                   org-capture-templates))
 641
 642     ;; hide the template from interactive template selection list
 643     ;; (org-capture)
 644     ;; NOTE: doesn't work when capturing from string
 645     ;; (when (boundp 'org-capture-templates-contexts)
 646     ;;   (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
 647     ;;         org-capture-templates-contexts))
 648     ))
 649
 650 (defun gnus-icalendar:org-event-save (event reply-status)
 651   (with-temp-buffer
 652     (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
 653                         gnus-icalendar-org-template-key)))
 654
 655 (defun gnus-icalendar-show-org-agenda (event)
 656   (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
 657                                     (gnus-icalendar-event:start-time event)))
 658          (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
 659                                   (cadr time-delta))
 660                                86400))))
 661
 662     (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
 663
 664 (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
 665   (if (gnus-icalendar-find-org-event-file event)
 666       (gnus-icalendar--update-org-event event reply-status)
 667     (gnus-icalendar:org-event-save event reply-status)))
 668
 669 (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
 670   (when (gnus-icalendar-find-org-event-file event)
 671     (gnus-icalendar--cancel-org-event event)))
 672
 673 (defun gnus-icalendar-org-setup ()
 674   (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
 675       (progn
 676         (gnus-icalendar-insinuate-org-templates)
 677         (setq gnus-icalendar-org-enabled-p t))
 678     (message "Cannot enable Calendar->Org: missing capture file, headline")))
 679
 680 ;;;
 681 ;;; gnus-icalendar
 682 ;;;
 683
 684 (defgroup gnus-icalendar nil
 685   "Settings for inline display of iCalendar invitations."
 686   :version "24.4"
 687   :group 'gnus-article
 688   :prefix "gnus-icalendar-")
 689
 690 (defcustom gnus-icalendar-reply-bufname "*CAL*"
 691   "Buffer used for building iCalendar invitation reply."
 692   :type '(string)
 693   :group 'gnus-icalendar)
 694
 695 (defcustom gnus-icalendar-additional-identities nil
 696   "We need to know your identity to make replies to calendar requests work.
 697
 698 Gnus will only offer you the Accept/Tentative/Decline buttons for
 699 calendar events if any of your identities matches at least one
 700 RSVP participant.
 701
 702 Your identity is guessed automatically from the variables
 703 `user-full-name', `user-mail-address',
 704 `gnus-ignored-from-addresses' and `message-alternative-emails'.
 705
 706 If you need even more aliases you can define them here.  It really
 707 only makes sense to define names or email addresses."
 708
 709   :type '(repeat string)
 710   :group 'gnus-icalendar)
 711
 712 (make-variable-buffer-local
 713  (defvar gnus-icalendar-reply-status nil))
 714
 715 (make-variable-buffer-local
 716  (defvar gnus-icalendar-event nil))
 717
 718 (make-variable-buffer-local
 719  (defvar gnus-icalendar-handle nil))
 720
 721 (defun gnus-icalendar-identities ()
 722   "Return list of regexp-quoted names and email addresses belonging to the user.
 723
 724 These will be used to retrieve the RSVP information from ical events."
 725   (apply #'append
 726          (mapcar
 727           (lambda (x) (if (listp x) x (list x)))
 728           (list user-full-name (regexp-quote user-mail-address)
 729                 ;; NOTE: these can be lists
 730                 gnus-ignored-from-addresses ; already regexp-quoted
 731                 (unless (functionp message-alternative-emails) ; String or function.
 732                   message-alternative-emails)
 733                 (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
 734
 735 ;; TODO: make the template customizable
 736 (cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
 737   "Format an overview of EVENT details."
 738   (cl-labels
 739       ((format-header (x)
 740                       (format "%-12s%s"
 741                               (propertize (concat (car x) ":") 'face 'bold)
 742                               (cadr x))))
 743
 744     (with-slots (organizer summary description location recur uid
 745                            method rsvp participation-type) event
 746       (let ((headers `(("Summary" ,summary)
 747                        ("Location" ,(or location ""))
 748                        ("Time" ,(gnus-icalendar-event:org-timestamp event))
 749                        ("Organizer" ,organizer)
 750                        ("Attendance" ,(if (eq participation-type 'non-participant)
 751                                           "You are not listed as an attendee"
 752                                         (capitalize (symbol-name participation-type))))
 753                        ("Method" ,method))))
 754
 755         (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
 756           (setq headers (append headers
 757                                 `(("Status" ,(or reply-status "Not replied yet"))))))
 758
 759         (concat
 760          (mapconcat #'format-header headers "\n")
 761          "\n\n"
 762          description)))))
 763
 764 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
 765   "Execute BODY in buffer containing the decoded contents of HANDLE."
 766   (let ((charset (make-symbol "charset")))
 767     `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
 768        (with-temp-buffer
 769          (mm-insert-part ,handle)
 770          (when (string= ,charset "utf-8")
 771            (decode-coding-region (point-min) (point-max) 'utf-8))
 772          ,@body))))
 773
 774
 775 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
 776   (gnus-icalendar-with-decoded-handle handle
 777                        (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
 778
 779 (defun gnus-icalendar-insert-button (text callback data)
 780   ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
 781   ;; of button.
 782   (let ((start (point)))
 783     (add-text-properties
 784      start
 785      (progn
 786        (insert "[ " text " ]")
 787        (point))
 788      `(gnus-callback
 789        ,callback
 790        keymap ,gnus-mime-button-map
 791        face ,gnus-article-button-face
 792        gnus-data ,data))
 793     (widget-convert-button 'link start (point)
 794                            :action 'gnus-widget-press-button)))
 795
 796 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
 797   (let ((message-signature nil))
 798     (with-current-buffer gnus-summary-buffer
 799       (gnus-summary-reply)
 800       (message-goto-body)
 801       (mml-insert-multipart "alternative")
 802       (mml-insert-empty-tag 'part 'type "text/plain")
 803       (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
 804       (message-goto-subject)
 805       (delete-region (line-beginning-position) (line-end-position))
 806       (insert "Subject: " subject)
 807       (message-send-and-exit))))
 808
 809 (defun gnus-icalendar-reply (data)
 810   (let* ((handle (car data))
 811          (status (cadr data))
 812          (event (caddr data))
 813          (reply (gnus-icalendar-with-decoded-handle handle
 814                   (gnus-icalendar-event-reply-from-buffer
 815                    (current-buffer) status (gnus-icalendar-identities)))))
 816
 817     (when reply
 818       (cl-labels
 819           ((fold-icalendar-buffer
 820             ()
 821             (goto-char (point-min))
 822             (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
 823               (replace-match "\\1\n \\2")
 824               (goto-char (line-beginning-position)))))
 825         (let ((subject (concat (capitalize (symbol-name status))
 826                                ": " (gnus-icalendar-event:summary event))))
 827
 828           (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
 829             (delete-region (point-min) (point-max))
 830             (insert reply)
 831             (fold-icalendar-buffer)
 832             (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
 833
 834           ;; Back in article buffer
 835           (setq-local gnus-icalendar-reply-status status)
 836           (when gnus-icalendar-org-enabled-p
 837             (gnus-icalendar--update-org-event event status)
 838             ;; refresh article buffer to update the reply status
 839             (with-current-buffer gnus-summary-buffer
 840               (gnus-summary-show-article))))))))
 841
 842 (defun gnus-icalendar-sync-event-to-org (event)
 843   (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
 844
 845 (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
 846   (when (gnus-icalendar-event:rsvp event)
 847     `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
 848       ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
 849       ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
 850
 851 (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
 852   "No buttons for REPLY events."
 853   nil)
 854
 855 (cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
 856   (or (when gnus-icalendar-org-enabled-p
 857         (gnus-icalendar--get-org-event-reply-status event))
 858       "Not replied yet"))
 859
 860 (cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
 861   "No reply status for REPLY events."
 862   nil)
 863
 864
 865 (cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
 866   (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
 867          (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
 868
 869     (delq nil (list
 870                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 871                (when (gnus-icalendar-event-request-p event)
 872                  `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
 873                (when org-entry-exists-p
 874                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 875
 876
 877 (cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
 878   (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
 879
 880     (delq nil (list
 881                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 882                (when org-entry-exists-p
 883                  `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
 884                (when org-entry-exists-p
 885                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 886
 887
 888 (defun gnus-icalendar-mm-inline (handle)
 889   (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 890
 891     (setq gnus-icalendar-reply-status nil)
 892
 893     (when event
 894       (cl-labels
 895           ((insert-button-group
 896             (buttons)
 897             (when buttons
 898               (mapc (lambda (x)
 899                       (apply 'gnus-icalendar-insert-button x)
 900                       (insert "    "))
 901                     buttons)
 902               (insert "\n\n"))))
 903
 904         (insert-button-group
 905          (gnus-icalendar-event:inline-reply-buttons event handle))
 906
 907         (when gnus-icalendar-org-enabled-p
 908           (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
 909
 910         (setq gnus-icalendar-event event
 911               gnus-icalendar-handle handle)
 912
 913         (insert (gnus-icalendar-event->gnus-calendar
 914                  event
 915                  (gnus-icalendar-event:inline-reply-status event)))))))
 916
 917 (defun gnus-icalendar-save-part (handle)
 918   (let (event)
 919     (when (and (equal (car (mm-handle-type handle)) "text/calendar")
 920                (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 921
 922       (gnus-icalendar-event:sync-to-org event))))
 923
 924
 925 (defun gnus-icalendar-save-event ()
 926   "Save the Calendar event in the text/calendar part under point."
 927   (interactive)
 928   (gnus-article-check-buffer)
 929   (let ((data (get-text-property (point) 'gnus-data)))
 930     (when data
 931       (gnus-icalendar-save-part data))))
 932
 933 (defun gnus-icalendar-reply-accept ()
 934   "Accept invitation in the current article."
 935   (interactive)
 936   (with-current-buffer gnus-article-buffer
 937     (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
 938     (setq-local gnus-icalendar-reply-status 'accepted)))
 939
 940 (defun gnus-icalendar-reply-tentative ()
 941   "Send tentative response to invitation in the current article."
 942   (interactive)
 943   (with-current-buffer gnus-article-buffer
 944     (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
 945     (setq-local gnus-icalendar-reply-status 'tentative)))
 946
 947 (defun gnus-icalendar-reply-decline ()
 948   "Decline invitation in the current article."
 949   (interactive)
 950   (with-current-buffer gnus-article-buffer
 951     (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
 952     (setq-local gnus-icalendar-reply-status 'declined)))
 953
 954 (defun gnus-icalendar-event-export ()
 955   "Export calendar event to `org-mode', or update existing agenda entry."
 956   (interactive)
 957   (with-current-buffer gnus-article-buffer
 958     (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
 959   ;; refresh article buffer in case the reply had been sent before initial org
 960   ;; export
 961   (with-current-buffer gnus-summary-buffer
 962     (gnus-summary-show-article)))
 963
 964 (defun gnus-icalendar-event-show ()
 965   "Display `org-mode' agenda entry related to the calendar event."
 966   (interactive)
 967   (gnus-icalendar--show-org-event
 968    (with-current-buffer gnus-article-buffer
 969      gnus-icalendar-event)))
 970
 971 (defun gnus-icalendar-event-check-agenda ()
 972   "Display `org-mode' agenda for days between event start and end dates."
 973   (interactive)
 974   (gnus-icalendar-show-org-agenda
 975    (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
 976
 977 (defvar gnus-mime-action-alist)         ; gnus-art
 978
 979 (defun gnus-icalendar-setup ()
 980   (add-to-list 'mm-inlined-types "text/calendar")
 981   (add-to-list 'mm-automatic-display "text/calendar")
 982   (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
 983
 984   (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
 985     "a" gnus-icalendar-reply-accept
 986     "t" gnus-icalendar-reply-tentative
 987     "d" gnus-icalendar-reply-decline
 988     "c" gnus-icalendar-event-check-agenda
 989     "e" gnus-icalendar-event-export
 990     "s" gnus-icalendar-event-show)
 991
 992   (require 'gnus-art)
 993   (add-to-list 'gnus-mime-action-alist
 994                (cons "save calendar event" 'gnus-icalendar-save-event)
 995                t))
 996
 997 (provide 'gnus-icalendar)
 998
 999 ;;; gnus-icalendar.el ends here