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