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 ;; TODO: make the template customizable
 365 (defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
 366   "Return string with new `org-mode' entry describing EVENT."
 367   (with-temp-buffer
 368     (org-mode)
 369     (with-slots (organizer summary description location
 370                            recur uid) event
 371       (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
 372                       "Not replied yet"))
 373              (props `(("ICAL_EVENT" . "t")
 374                       ("ID" . ,uid)
 375                       ("DT" . ,(gnus-icalendar-event:org-timestamp event))
 376                       ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
 377                       ("LOCATION" . ,(gnus-icalendar-event:location event))
 378                       ("RRULE" . ,(gnus-icalendar-event:recur event))
 379                       ("REPLY" . ,reply))))
 380
 381         (insert (format "* %s (%s)\n\n" summary location))
 382         (mapc (lambda (prop)
 383                 (org-entry-put (point) (car prop) (cdr prop)))
 384               props))
 385
 386       (when description
 387         (save-restriction
 388           (narrow-to-region (point) (point))
 389           (insert description)
 390           (indent-region (point-min) (point-max) 2)
 391           (fill-region (point-min) (point-max))))
 392
 393       (buffer-string))))
 394
 395 (defun gnus-icalendar--deactivate-org-timestamp (ts)
 396   (replace-regexp-in-string "[<>]"
 397                             (lambda (m) (cond ((string= m "<") "[")
 398                                               ((string= m ">") "]")))
 399                             ts))
 400
 401 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
 402   "Return the name of the file containing EVENT org entry.
 403 Return nil when not found.
 404
 405 All org agenda files are searched for the EVENT entry.  When
 406 the optional ORG-FILE argument is specified, only that one file
 407 is searched."
 408   (let ((uid (gnus-icalendar-event:uid event))
 409         (files (or org-file (org-agenda-files t 'ifmode))))
 410     (gmm-labels
 411         ((find-event-in (file)
 412            (org-check-agenda-file file)
 413            (with-current-buffer (find-file-noselect file)
 414              (let ((event-pos (org-find-entry-with-id uid)))
 415                (when (and event-pos
 416                           (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos)))
 417                                    "t"))
 418                  (throw 'found file))))))
 419
 420       (gnus-icalendar-find-if #'find-event-in files))))
 421
 422
 423 (defun gnus-icalendar--show-org-event (event &optional org-file)
 424   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 425     (when file
 426       (switch-to-buffer (find-file file))
 427       (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
 428       (org-show-entry))))
 429
 430
 431 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
 432   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 433     (when file
 434       (with-current-buffer (find-file-noselect file)
 435         (with-slots (uid summary description organizer location recur) event
 436           (let ((event-pos (org-find-entry-with-id uid)))
 437             (when event-pos
 438               (goto-char event-pos)
 439
 440               ;; update the headline, keep todo, priority and tags, if any
 441               (save-excursion
 442                 (let* ((priority (org-entry-get (point) "PRIORITY"))
 443                        (headline (delq nil (list
 444                                             (org-entry-get (point) "TODO")
 445                                             (when priority (format "[#%s]" priority))
 446                                             (format "%s (%s)" summary location)
 447                                             (org-entry-get (point) "TAGS")))))
 448
 449                   (re-search-forward "^\\*+ " (line-end-position))
 450                   (delete-region (point) (line-end-position))
 451                   (insert (mapconcat #'identity headline " "))))
 452
 453               ;; update props and description
 454               (let ((entry-end (org-entry-end-position))
 455                     (entry-outline-level (org-outline-level)))
 456
 457                 ;; delete body of the entry, leave org drawers intact
 458                 (save-restriction
 459                   (org-narrow-to-element)
 460                   (goto-char entry-end)
 461                   (re-search-backward "^[\t ]*:END:")
 462                   (forward-line)
 463                   (delete-region (point) entry-end))
 464
 465                 ;; put new event description in the entry body
 466                 (when description
 467                   (save-restriction
 468                     (narrow-to-region (point) (point))
 469                     (insert "\n" (replace-regexp-in-string "[\n]+$" "\n" description) "\n")
 470                     (indent-region (point-min) (point-max) (1+ entry-outline-level))
 471                     (fill-region (point-min) (point-max))))
 472
 473                 ;; update entry properties
 474                 (org-entry-put event-pos "DT" (gnus-icalendar-event:org-timestamp event))
 475                 (org-entry-put event-pos "ORGANIZER" organizer)
 476                 (org-entry-put event-pos "LOCATION" location)
 477                 (org-entry-put event-pos "RRULE" recur)
 478                 (when reply-status (org-entry-put event-pos "REPLY"
 479                                                   (capitalize (symbol-name reply-status))))
 480                 (save-buffer)))))))))
 481
 482
 483 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
 484   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 485     (when file
 486       (with-current-buffer (find-file-noselect file)
 487         (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 488           (when event-pos
 489             (let ((ts (org-entry-get event-pos "DT")))
 490               (when ts
 491                 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
 492                 (save-buffer)))))))))
 493
 494
 495 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
 496   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 497     (when file
 498       (save-excursion
 499         (with-current-buffer (find-file-noselect file)
 500           (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 501             (org-entry-get event-pos "REPLY")))))))
 502
 503
 504 (defun gnus-icalendar-insinuate-org-templates ()
 505   (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
 506                       org-capture-templates)
 507     (setq org-capture-templates
 508           (append `((,gnus-icalendar-org-template-key
 509                      ,gnus-icalendar-org-template-name
 510                      entry
 511                      (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
 512                      "%i"
 513                      :immediate-finish t))
 514                   org-capture-templates))
 515
 516     ;; hide the template from interactive template selection list
 517     ;; (org-capture)
 518     ;; NOTE: doesn't work when capturing from string
 519     ;; (when (boundp 'org-capture-templates-contexts)
 520     ;;   (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
 521     ;;         org-capture-templates-contexts))
 522     ))
 523
 524 (defun gnus-icalendar:org-event-save (event reply-status)
 525   (with-temp-buffer
 526     (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
 527                         gnus-icalendar-org-template-key)))
 528
 529 (defun gnus-icalendar-show-org-agenda (event)
 530   (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
 531                                     (gnus-icalendar-event:start-time event)))
 532          (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
 533                                   (cadr time-delta))
 534                                86400))))
 535
 536     (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
 537
 538 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
 539   (if (gnus-icalendar-find-org-event-file event)
 540       (gnus-icalendar--update-org-event event reply-status)
 541     (gnus-icalendar:org-event-save event reply-status)))
 542
 543 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel))
 544   (when (gnus-icalendar-find-org-event-file event)
 545     (gnus-icalendar--cancel-org-event event)))
 546
 547 (defun gnus-icalendar-org-setup ()
 548   (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
 549       (progn
 550         (gnus-icalendar-insinuate-org-templates)
 551         (setq gnus-icalendar-org-enabled-p t))
 552     (message "Cannot enable Calendar->Org: missing capture file, headline")))
 553
 554 ;;;
 555 ;;; gnus-icalendar
 556 ;;;
 557
 558 (defgroup gnus-icalendar nil
 559   "Settings for inline display of iCalendar invitations."
 560   :group 'gnus-article
 561   :prefix "gnus-icalendar-")
 562
 563 (defcustom gnus-icalendar-reply-bufname "*CAL*"
 564   "Buffer used for building iCalendar invitation reply."
 565   :type '(string)
 566   :group 'gnus-icalendar)
 567
 568 (make-variable-buffer-local
 569  (defvar gnus-icalendar-reply-status nil))
 570
 571 (make-variable-buffer-local
 572  (defvar gnus-icalendar-event nil))
 573
 574 (make-variable-buffer-local
 575  (defvar gnus-icalendar-handle nil))
 576
 577 (defvar gnus-icalendar-identities
 578   (apply #'append
 579          (mapcar (lambda (x) (if (listp x) x (list x)))
 580                  (list user-full-name (regexp-quote user-mail-address)
 581                        ; NOTE: this one can be a list
 582                        gnus-ignored-from-addresses))))
 583
 584 ;; TODO: make the template customizable
 585 (defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
 586   "Format an overview of EVENT details."
 587   (gmm-labels ((format-header (x)
 588             (format "%-12s%s"
 589                     (propertize (concat (car x) ":") 'face 'bold)
 590                     (cadr x))))
 591
 592     (with-slots (organizer summary description location recur uid method rsvp) event
 593       (let ((headers `(("Summary" ,summary)
 594                       ("Location" ,location)
 595                       ("Time" ,(gnus-icalendar-event:org-timestamp event))
 596                       ("Organizer" ,organizer)
 597                       ("Method" ,method))))
 598
 599        (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
 600          (setq headers (append headers
 601                                `(("Status" ,(or reply-status "Not replied yet"))))))
 602
 603        (concat
 604         (mapconcat #'format-header headers "\n")
 605         "\n\n"
 606         description)))))
 607
 608 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
 609   "Execute BODY in buffer containing the decoded contents of HANDLE."
 610   (let ((charset (make-symbol "charset")))
 611     `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
 612        (with-temp-buffer
 613          (mm-insert-part ,handle)
 614          (when (string= ,charset "utf-8")
 615            (mm-decode-coding-region (point-min) (point-max) 'utf-8))
 616
 617          ,@body))))
 618
 619
 620 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
 621   (gnus-icalendar-with-decoded-handle handle
 622                        (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
 623
 624 (defun gnus-icalendar-insert-button (text callback data)
 625   ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
 626   ;; of button.
 627   (let ((start (point)))
 628     (gnus-add-text-properties
 629      start
 630      (progn
 631        (insert "[ " text " ]")
 632        (point))
 633      `(gnus-callback
 634        ,callback
 635        keymap ,gnus-mime-button-map
 636        face ,gnus-article-button-face
 637        gnus-data ,data))
 638     (widget-convert-button 'link start (point)
 639                            :action 'gnus-widget-press-button
 640                            :button-keymap gnus-widget-button-keymap)))
 641
 642 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
 643   (let ((message-signature nil))
 644     (with-current-buffer gnus-summary-buffer
 645       (gnus-summary-reply)
 646       (message-goto-body)
 647       (mml-insert-multipart "alternative")
 648       (mml-insert-empty-tag 'part 'type "text/plain")
 649       (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
 650       (message-goto-subject)
 651       (delete-region (line-beginning-position) (line-end-position))
 652       (insert "Subject: " subject)
 653       (message-send-and-exit))))
 654
 655 (defun gnus-icalendar-reply (data)
 656   (let* ((handle (car data))
 657          (status (cadr data))
 658          (event (caddr data))
 659          (reply (gnus-icalendar-with-decoded-handle handle
 660                   (gnus-icalendar-event-reply-from-buffer
 661                    (current-buffer) status gnus-icalendar-identities))))
 662
 663     (when reply
 664       (gmm-labels ((fold-icalendar-buffer ()
 665                (goto-char (point-min))
 666                (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
 667                  (replace-match "\\1\n \\2")
 668                  (goto-char (line-beginning-position)))))
 669         (let ((subject (concat (capitalize (symbol-name status))
 670                                ": " (gnus-icalendar-event:summary event))))
 671
 672           (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
 673             (delete-region (point-min) (point-max))
 674             (insert reply)
 675             (fold-icalendar-buffer)
 676             (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
 677
 678           ;; Back in article buffer
 679           (setq-local gnus-icalendar-reply-status status)
 680           (when gnus-icalendar-org-enabled-p
 681             (gnus-icalendar--update-org-event event status)
 682             ;; refresh article buffer to update the reply status
 683             (with-current-buffer gnus-summary-buffer
 684               (gnus-summary-show-article))))))))
 685
 686 (defun gnus-icalendar-sync-event-to-org (event)
 687   (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
 688
 689 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
 690   (when (gnus-icalendar-event:rsvp event)
 691     `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
 692       ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
 693       ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
 694
 695 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
 696   "No buttons for REPLY events."
 697   nil)
 698
 699 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
 700   (or (when gnus-icalendar-org-enabled-p
 701         (gnus-icalendar--get-org-event-reply-status event))
 702       "Not replied yet"))
 703
 704 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
 705   "No reply status for REPLY events."
 706   nil)
 707
 708
 709 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
 710   (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
 711          (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
 712
 713     (delq nil (list
 714                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 715                (when (gnus-icalendar-event-request-p event)
 716                  `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
 717                (when org-entry-exists-p
 718                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 719
 720 (defun gnus-icalendar-mm-inline (handle)
 721   (let ((event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
 722
 723     (setq gnus-icalendar-reply-status nil)
 724
 725     (when event
 726       (gmm-labels ((insert-button-group (buttons)
 727                 (when buttons
 728                   (mapc (lambda (x)
 729                           (apply 'gnus-icalendar-insert-button x)
 730                           (insert "    "))
 731                         buttons)
 732                   (insert "\n\n"))))
 733
 734         (insert-button-group
 735          (gnus-icalendar-event:inline-reply-buttons event handle))
 736
 737         (when gnus-icalendar-org-enabled-p
 738           (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
 739
 740         (setq gnus-icalendar-event event
 741               gnus-icalendar-handle handle)
 742
 743         (insert (gnus-icalendar-event->gnus-calendar
 744                  event
 745                  (gnus-icalendar-event:inline-reply-status event)))))))
 746
 747 (defun gnus-icalendar-save-part (handle)
 748   (let (event)
 749     (when (and (equal (car (mm-handle-type handle)) "text/calendar")
 750                (setq event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
 751
 752       (gnus-icalendar-event:sync-to-org event))))
 753
 754
 755 (defun gnus-icalendar-save-event ()
 756   "Save the Calendar event in the text/calendar part under point."
 757   (interactive)
 758   (gnus-article-check-buffer)
 759   (let ((data (get-text-property (point) 'gnus-data)))
 760     (when data
 761       (gnus-icalendar-save-part data))))
 762
 763 (defun gnus-icalendar-reply-accept ()
 764   "Accept invitation in the current article."
 765   (interactive)
 766   (with-current-buffer gnus-article-buffer
 767     (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
 768     (setq-local gnus-icalendar-reply-status 'accepted)))
 769
 770 (defun gnus-icalendar-reply-tentative ()
 771   "Send tentative response to invitation in the current article."
 772   (interactive)
 773   (with-current-buffer gnus-article-buffer
 774     (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
 775     (setq-local gnus-icalendar-reply-status 'tentative)))
 776
 777 (defun gnus-icalendar-reply-decline ()
 778   "Decline invitation in the current article."
 779   (interactive)
 780   (with-current-buffer gnus-article-buffer
 781     (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
 782     (setq-local gnus-icalendar-reply-status 'declined)))
 783
 784 (defun gnus-icalendar-event-export ()
 785   "Export calendar event to `org-mode', or update existing agenda entry."
 786   (interactive)
 787   (with-current-buffer gnus-article-buffer
 788     (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
 789   ;; refresh article buffer in case the reply had been sent before initial org
 790   ;; export
 791   (with-current-buffer gnus-summary-buffer
 792     (gnus-summary-show-article)))
 793
 794 (defun gnus-icalendar-event-show ()
 795   "Display `org-mode' agenda entry related to the calendar event."
 796   (interactive)
 797   (gnus-icalendar--show-org-event
 798    (with-current-buffer gnus-article-buffer
 799      gnus-icalendar-event)))
 800
 801 (defun gnus-icalendar-event-check-agenda ()
 802   "Display `org-mode' agenda for days between event start and end dates."
 803   (interactive)
 804   (gnus-icalendar-show-org-agenda
 805    (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
 806
 807 (defvar gnus-mime-action-alist)         ; gnus-art
 808
 809 (defun gnus-icalendar-setup ()
 810   (add-to-list 'mm-inlined-types "text/calendar")
 811   (add-to-list 'mm-automatic-display "text/calendar")
 812   (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
 813
 814   (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
 815     "a" gnus-icalendar-reply-accept
 816     "t" gnus-icalendar-reply-tentative
 817     "d" gnus-icalendar-reply-decline
 818     "c" gnus-icalendar-event-check-agenda
 819     "e" gnus-icalendar-event-export
 820     "s" gnus-icalendar-event-show)
 821
 822   (require 'gnus-art)
 823   (add-to-list 'gnus-mime-action-alist
 824                (cons "save calendar event" 'gnus-icalendar-save-event)
 825                t))
 826
 827 (provide 'gnus-icalendar)
 828
 829 ;;; gnus-icalendar.el ends here