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

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