cgit.sxemacs.org Git - gnus/blob - lisp/gnus-icalendar.el

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