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