code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-icalendar.el

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