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

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