├── .gitignore ├── gcal-id.el ├── README.org ├── gcal-recur.el ├── gcal.el └── gcal-org.el /.gitignore: -------------------------------------------------------------------------------- 1 | gcal-my-test.el 2 | *.elc 3 | -------------------------------------------------------------------------------- /gcal-id.el: -------------------------------------------------------------------------------- 1 | ;;; gcal-id.el --- Google Calendar ID -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016 AKIYAMA Kouhei 4 | 5 | ;; Author: AKIYAMA Kouhei 6 | ;; URL: https://github.com/misohena/gcal 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 . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'cl-lib) 28 | 29 | (defvar gcal-base32hex-table "0123456789ABCDEFGHIJKLMNOPQRSTUV") 30 | 31 | (defun gcal-base32hex-p (string) 32 | (and 33 | (stringp string) 34 | (not 35 | (cl-find-if-not (lambda (c) (cl-position c gcal-base32hex-table)) (upcase string))))) 36 | 37 | (defun gcal-base32hex-decode (string) 38 | "RFC2938" 39 | (let* ((nums (mapcar 40 | (lambda (c) (cl-position c gcal-base32hex-table)) 41 | (upcase string))) 42 | (nums-len (length nums)) 43 | (i 0) 44 | (last-byte 0) 45 | (result nil)) 46 | (while (< i nums-len) 47 | (let* ((num (elt nums i)) 48 | (dstbit (% (* i 5) 8))) 49 | 50 | (setq last-byte (logior last-byte (ash num (- 3 dstbit)))) 51 | 52 | (when (>= dstbit 3) 53 | (push last-byte result) 54 | (setq last-byte (logand (ash num (- (+ 8 3) dstbit)) 255)))) 55 | 56 | (setq i (1+ i))) 57 | 58 | (if (> (% nums-len 8) 0) 59 | (push last-byte result)) 60 | 61 | (concat (nreverse result)))) 62 | 63 | (defun gcal-base32hex-encode (string) 64 | "RFC2938" 65 | (let* ((string-len (length string)) 66 | (i 0) 67 | (last-byte 0) 68 | (result nil)) 69 | (while (< i string-len) 70 | (let* ((char (elt string i)) 71 | (dstbit (% (* i 8) 5)) 72 | (left (logior (ash char (- -3 dstbit)) last-byte)) 73 | (center (logand (ash char (- 2 dstbit)) 31)) 74 | (right (logand (ash char (- 7 dstbit)) 31))) 75 | (push left result) 76 | (if (< dstbit 2) 77 | (setq last-byte center) 78 | (setq last-byte right) 79 | (push center result))) 80 | (setq i (1+ i))) 81 | 82 | (if (> (% string-len 5) 0) 83 | (push last-byte result)) 84 | 85 | (concat 86 | (mapcar 87 | (lambda (n) (elt gcal-base32hex-table n)) 88 | (nreverse result))))) 89 | 90 | (defun gcal-hexstr-to-bytes (str) 91 | (concat 92 | (cl-loop for (a b) on (mapcar (lambda (c) (string-to-number (string c) 16)) str) 93 | by #'cddr 94 | collect (+ (ash a 4) b)))) 95 | 96 | (defun gcal-hexstr-from-bytes (bytes) 97 | (mapconcat (lambda (c) (format "%02x" c)) bytes "")) 98 | 99 | (defun gcal-uuid-to-bytes (uuid) 100 | ;;;@todo swap endian? 101 | (mapconcat 102 | (lambda (str) (gcal-hexstr-to-bytes str)) 103 | (split-string uuid "-") 104 | "")) 105 | 106 | (defun gcal-uuid-from-bytes (bytes) 107 | ;;;@todo swap endian? 108 | (let ((str (gcal-hexstr-from-bytes bytes))) 109 | (concat 110 | (substring str 0 8) "-" 111 | (substring str 8 12) "-" 112 | (substring str 12 16) "-" 113 | (substring str 16 20) "-" 114 | (substring str 20 32)))) 115 | 116 | (defun gcal-uuid-from-base32hex (base32hex) 117 | (gcal-uuid-from-bytes (gcal-base32hex-decode base32hex))) 118 | 119 | (defun gcal-uuid-to-base32hex (uuid) 120 | (gcal-base32hex-encode (gcal-uuid-to-bytes uuid))) 121 | 122 | 123 | (defun gcal-uuid-p (uuid) 124 | (and 125 | (stringp uuid) 126 | (let ((compos (split-string uuid "-"))) 127 | (and (= (length compos) 5) 128 | (= (length (nth 0 compos)) 8) 129 | (= (length (nth 1 compos)) 4) 130 | (= (length (nth 2 compos)) 4) 131 | (= (length (nth 3 compos)) 4) 132 | (= (length (nth 4 compos)) 12) 133 | (null (cl-find-if-not (lambda (c) 134 | (or (and (>= c ?0) (<= c ?9)) 135 | (and (>= c ?a) (<= c ?f)) 136 | (and (>= c ?A) (<= c ?F)) 137 | (= c ?-))) 138 | uuid)))))) 139 | 140 | (provide 'gcal-id) 141 | ;;; gcal-id.el ends here 142 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | # -*- lexical-binding: t; -*- 2 | * Google Calendar Utilities for Emacs 3 | ** Settings on Google server 4 | 5 | 1. Access Google Cloud Console ( https://console.cloud.google.com/cloud-resource-manager ). 6 | 2. Create a Project. 7 | 3. Enable Google Calendar API. 8 | 4. Create a OAuth Client ID (Choose *"Desktop"* type and Download client ID and client secret). 9 | 5. Change publishing status to *"In production"* in OAuth Consent Screen. 10 | 11 | ** gcal.el 12 | 13 | Settings: 14 | 15 | #+BEGIN_SRC elisp 16 | ;; Get from Google Developer Console 17 | (setq gcal-client-id "xxxxxxxxx.apps.googleusercontent.com") 18 | (setq gcal-client-secret "xxxx-XxxxXxxXXXxx") ;;API-KEY 19 | #+END_SRC 20 | 21 | Usege: 22 | 23 | #+BEGIN_SRC elisp 24 | (require 'gcal) 25 | 26 | ;; list my calendars 27 | (gcal-calendar-list-list) ;; Calendar List 28 | 29 | ;; list events 30 | (gcal-events-list 31 | "example@group.calendar.google.com" ;; Calendar ID 32 | `((timeMin . ,(gcal-datetime 2016 5 1)) 33 | (timeMax . ,(gcal-datetime 2016 6 1)))) 34 | 35 | ;; insert event 36 | (gcal-events-insert 37 | "example@group.calendar.google.com" 38 | `((start . ,(gcal-gtime 2016 5 27)) 39 | (end . ,(gcal-gtime 2016 5 28)) 40 | (summary . "My Special Holiday"))) 41 | 42 | ;; delete event 43 | (gcal-events-delete "example@group.calendar.google.com" "{event id}") 44 | #+END_SRC 45 | 46 | ** gcal-org.el 47 | 48 | Usage: 49 | 50 | #+BEGIN_SRC elisp 51 | (require 'gcal-org) 52 | 53 | ;; Org to Google Calendar 54 | 55 | (gcal-org-push-file 56 | "example@group.calendar.google.com" ;; Calendar ID 57 | "~/my-schedule.org" ;; Org file 58 | "~/my-schedule.gcal-cache") ;; Cache file (If omitted, use the global cache file ~/.emacs.d/.gcal-org-pushed-events) 59 | 60 | ;; Google Calendar to Org 61 | 62 | (gcal-org-pull-to-file 63 | "example@group.calendar.google.com" 64 | "~/my-schedule.org" 65 | "Inbox" 66 | "~/my-schedule.gcal-cache") 67 | #+END_SRC 68 | 69 | Parse org & Upload 70 | 71 | #+BEGIN_SRC elisp 72 | ;; Org to oevent(org-mode event) 73 | (gcal-org-parse-buffer) ;; Parse current buffer. Return a list of gcal-org-event object(including properties :id, :ord, :summary, :location, :ts-start, :ts-end, :ts-prefx, ...). 74 | 75 | (gcal-org-parse-file "~/my-schedule.org") ;; Parse specified org file. 76 | 77 | ;; Upload oevents to Google Calendar 78 | (gcal-org-push-oevents 79 | "example@group.calendar.google.com" 80 | (gcal-org-parse-file "~/my-schedule.org") 81 | nil) 82 | 83 | ;; Upload oevents to Google Calendar (delta) 84 | (gcal-org-push-oevents 85 | "example@group.calendar.google.com" 86 | (gcal-org-parse-file "~/my-schedule.org") 87 | (gcal-org-parse-file "~/my-schedule.org.old")) 88 | 89 | ;; Delete events from Google Calendar 90 | (gcal-org-push-oevents 91 | "example@group.calendar.google.com" 92 | nil 93 | (gcal-org-parse-file "~/my-schedule.org")) 94 | 95 | #+END_SRC 96 | 97 | Download 98 | 99 | #+BEGIN_SRC elisp 100 | ;; Download oevents from Goole Calendar 101 | (gcal-org-pull-oevents 102 | "example@group.calendar.google.com" 103 | `((timeMin . ,(gcal-time-format (current-time) nil)))) ;;after current time 104 | #+END_SRC 105 | 106 | ** Asynchronous execution 107 | 108 | #+begin_src elisp 109 | (gcal-http-async ;; or -sync 110 | (gcal-async-let ((calendars (gcal-calendar-list-list))) 111 | (message "number of items: %s" (length (alist-get 'items calendars))))) 112 | #+end_src 113 | 114 | #+begin_src elisp 115 | (gcal-http-async 116 | (gcal-async-let* ((calendars (gcal-calendar-list-list)) ;; If you call an async function, it must be the last in the expression. 117 | (calendar-id (alist-get 'id (elt (alist-get 'items calendars) 118 | 5))) ;; It is also possible to not include async functions. 119 | (events (gcal-events-list calendar-id 120 | `((timeMin . ,(gcal-datetime 2024 2 1)) 121 | (timeMax . ,(gcal-datetime 2024 3 1)))))) 122 | (message "events=%s" events))) 123 | #+end_src 124 | 125 | #+begin_src elisp 126 | (gcal-http-async 127 | (let ((event-list .....) 128 | (calendar-id ".......") 129 | response-list) 130 | (gcal-async-wait-all 131 | ;; Inside this, multiple asynchronous functions are executed. 132 | (dolist (event-data event-list) 133 | (gcal-async-let ((response (gcal-events-insert calendar-id event-data))) 134 | (push response response-list))) 135 | ;; Called when everything is complete. 136 | (if (seq-some #'gcal-failed-p response-list) 137 | (message "Looks like something went wrong.") 138 | (message "It seems to have finished without any problems."))))) 139 | #+end_src 140 | 141 | ** Documents 142 | - [[http://misohena.jp/blog/2016-05-26-access-google-calendar-api-from-emacs.html][About gcal.el]] 143 | - [[http://misohena.jp/blog/2016-05-29-sync-events-between-google-calendar-and-org-mode.html][About gcal-org.el]] 144 | -------------------------------------------------------------------------------- /gcal-recur.el: -------------------------------------------------------------------------------- 1 | ;;; gcal-recur.el --- Expand recurrence rule -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2021 AKIYAMA Kouhei 4 | 5 | ;; Author: AKIYAMA Kouhei 6 | ;; Keywords: 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 . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'calendar) 28 | 29 | 30 | (defun gcal-recur-between (recurrence 31 | ;; encoded-time 32 | enct-dtstart 33 | enct-time-min time-min-inclusive 34 | enct-time-max time-max-inclusive 35 | min-count 36 | &optional time-zone) 37 | ;;@todo Support RDATE and EXDATE? Google Calendar's recurrence property does not support RDATE and EXDATE. 38 | (seq-uniq 39 | (sort 40 | (seq-mapcat 41 | (lambda (line) 42 | (let* ((name-param-value (gcal-recur-parse-content-line line)) 43 | (name (car name-param-value)) 44 | (value (caddr name-param-value))) 45 | (when (string= name "RRULE") 46 | (gcal-recur-rrule-between 47 | (gcal-recur-parse-value-properties value) 48 | enct-dtstart 49 | enct-time-min time-min-inclusive 50 | enct-time-max time-max-inclusive 51 | min-count 52 | time-zone)))) 53 | recurrence) 54 | #'time-less-p) 55 | #'time-equal-p)) 56 | 57 | ;; (mapcar 58 | ;; (lambda (t) (format-time-string "%F(%a) %T" t)) 59 | ;; (gcal-recur-between 60 | ;; ["RRULE:FREQ=DAILY;INTERVAL=10" "RRULE:FREQ=MONTHLY;INTERVAL=2;BYDAY=1MO;BYHOUR=12"] 61 | ;; (encode-time '(0 0 0 1 2 2021 nil nil nil)) 62 | ;; (encode-time '(0 0 0 1 2 2021 nil nil nil)) t 63 | ;; (encode-time '(0 0 0 1 2 2100 nil nil nil)) nil 64 | ;; 1)) 65 | 66 | 67 | ;; 68 | ;; RRULE 69 | ;; 70 | 71 | ;; (mapcar #'decode-time 72 | ;; (gcal-recur-rrule-between 73 | ;; ;; "FREQ=YEARLY;INTERVAL=2;BYMONTH=1,2,3,4,5,6;BYWEEKNO=4,5;BYYEARDAY=1,28,31;BYMONTHDAY=28,29,30;BYDAY=TH" 74 | ;; ;; "FREQ=MONTHLY;INTERVAL=2;BYMONTH=1,2,3,4,5,6;BYMONTHDAY=28,29,30;BYDAY=TH" 75 | ;; ;;"FREQ=WEEKLY;INTERVAL=2;COUNT=3" 76 | ;; ;;"FREQ=DAILY;INTERVAL=2" 77 | ;; ;;"FREQ=WEEKLY;WKST=SU;UNTIL=20210321" 78 | ;; ;;"" 79 | ;; "FREQ=YEARLY;BYMONTHDAY=-1,-2,-3;BYDAY=MO" 80 | ;; (encode-time '(59 59 23 14 2 2021 nil nil nil)) 81 | ;; (encode-time '(0 0 0 10 2 2021 nil nil nil)) nil 82 | ;; (encode-time '(0 0 0 1 1 2100 nil nil nil)) nil 83 | ;; 10)) 84 | 85 | (defun gcal-recur-rrule-between (rules 86 | enct-dtstart 87 | enct-time-min time-min-inclusive 88 | enct-time-max time-max-inclusive 89 | min-count 90 | &optional time-zone) 91 | (when (stringp rules) 92 | (setq rules (gcal-recur-parse-value-properties rules))) 93 | 94 | (let* ((freq (gcal-recur-rrule-freq rules)) 95 | (interval (gcal-recur-rrule-interval rules)) 96 | (wkst (gcal-recur-rrule-wkst rules)) 97 | (bysetpos (gcal-recur-rrule-bysetpos rules)) 98 | (count (gcal-recur-rrule-count rules)) 99 | (until (gcal-recur-rrule-until rules time-zone))) 100 | 101 | ;; apply until to time-max 102 | (when (and until 103 | (time-less-p until enct-time-max)) ;;or (and (time-equal-p until time-max) time-max-inclusive) 104 | (setq enct-time-max until) 105 | (setq time-max-inclusive t)) 106 | 107 | ;; 108 | (if (or 109 | ;; time-min > time-max 110 | (time-less-p enct-time-max enct-time-min) 111 | (and (time-equal-p enct-time-min enct-time-max) 112 | (not time-min-inclusive) 113 | (not time-max-inclusive)) 114 | ;; time-max < dtstart 115 | (time-less-p enct-time-max enct-dtstart) 116 | (and (time-equal-p enct-time-max enct-dtstart) 117 | (not time-max-inclusive)) 118 | ;; count < 1 119 | (and count 120 | (< count 1))) 121 | nil 122 | 123 | (let* (;; decoded time 124 | (dect-dtstart (decode-time enct-dtstart time-zone)) 125 | (dect-time-min (decode-time enct-time-min time-zone)) 126 | (dect-time-max (decode-time enct-time-max time-zone)) 127 | ;; date number of based on FREQ 128 | (dtstart-num (gcal-recur-dect-to-freq-number dect-dtstart freq wkst)) 129 | (time-min-num (gcal-recur-dect-to-freq-number dect-time-min freq wkst)) 130 | (time-max-num (gcal-recur-dect-to-freq-number dect-time-max freq wkst)) 131 | 132 | (period 133 | (if (and (null count) 134 | (< dtstart-num time-min-num)) 135 | ;; Calculate from the middle period 136 | (let ((num-in-interval (mod (- time-min-num dtstart-num) interval))) 137 | (+ time-min-num 138 | (if (> num-in-interval 0) (- interval num-in-interval) 0))) 139 | ;; Calculate from the first period if count= is specified or time-min <= dtstart 140 | dtstart-num)) 141 | result-datetimes) 142 | 143 | ;; Push the first event(dtstart) if time-min <= dtstart 144 | (when (or (time-less-p enct-time-min enct-dtstart) 145 | (and (time-equal-p enct-time-min enct-dtstart) 146 | time-min-inclusive)) 147 | (setq result-datetimes (list enct-dtstart)) 148 | (setq enct-time-min enct-dtstart) 149 | (setq time-min-inclusive nil)) 150 | ;; Count the first event 151 | ;; Must count even if time-min > dtstart 152 | (when count 153 | (setq count (1- count))) 154 | 155 | ;; events between time-min to time-max 156 | (while (and 157 | (<= period time-max-num) 158 | (or (null count) (> count 0)) 159 | (< (length result-datetimes) min-count)) 160 | 161 | (let ((datetimes-on-period 162 | (thread-first 163 | (gcal-recur-dates-on-period freq rules period dect-dtstart) 164 | (gcal-recur-ymd-list-sort-and-unique ) 165 | (gcal-recur-limit-bysetpos bysetpos) 166 | (gcal-recur-complete-hms rules dect-dtstart time-zone) 167 | (gcal-recur-sorted-encoded-time-list-after enct-dtstart nil) ;; nil means exclusive. dtstart already pushed 168 | (gcal-recur-limit-by-count count)))) 169 | 170 | (when count 171 | (setq count (- count (length datetimes-on-period)))) 172 | 173 | (setq result-datetimes 174 | (nconc 175 | result-datetimes 176 | (gcal-recur-sorted-encoded-time-list-between 177 | datetimes-on-period 178 | enct-time-min time-min-inclusive 179 | enct-time-max time-max-inclusive))) 180 | (setq period (+ period interval)))) 181 | 182 | result-datetimes)))) 183 | 184 | (defun gcal-recur-dect-to-freq-number (dect freq wkst) 185 | (cond 186 | ((eq freq 'yearly) (decoded-time-year dect)) ;;year number = year 187 | ((eq freq 'monthly) (+ (* 12 (decoded-time-year dect)) (1- (decoded-time-month dect)))) ;;month number = 12*year+month-1 188 | ((eq freq 'weekly) (gcal-absdn-to-abs-week-number (gcal-absdn-from-decoded-time dect) wkst)) ;;week number = (absdn-wkst)/7 189 | ((eq freq 'daily) (gcal-absdn-from-decoded-time dect)) ;;day number = absdn 190 | (t 1))) 191 | 192 | (defun gcal-recur-dates-on-period (freq rules period dect-dtstart) 193 | (cond 194 | ((eq freq 'yearly) (gcal-recur-dates-on-period-year rules period dect-dtstart)) 195 | ((eq freq 'monthly) (gcal-recur-dates-on-period-month rules period dect-dtstart)) 196 | ((eq freq 'weekly) (gcal-recur-dates-on-period-week rules period dect-dtstart)) 197 | ((eq freq 'daily) (gcal-recur-dates-on-period-day rules period dect-dtstart)))) 198 | 199 | (defun gcal-recur-dates-on-period-year (rules year dect-dtstart) 200 | (let ((bymonth (gcal-recur-rrule-bymonth rules)) 201 | (byweekno (gcal-recur-rrule-byweekno rules)) 202 | (byyearday (gcal-recur-rrule-byyearday rules)) 203 | (bymonthday (gcal-recur-rrule-bymonthday rules)) 204 | (byday (gcal-recur-rrule-byday rules)) 205 | (wkst (gcal-recur-rrule-wkst rules)) 206 | (candidates (list (list year nil nil)))) 207 | 208 | (if bymonth 209 | (setq candidates 210 | (gcal-recur-expand-bymonth year bymonth))) 211 | 212 | (if byweekno 213 | (setq candidates 214 | (gcal-recur-ymd-list-filter-matched 215 | candidates 216 | (gcal-recur-expand-byweekno year wkst byweekno)))) 217 | 218 | (if byyearday 219 | (setq candidates 220 | (gcal-recur-ymd-list-filter-matched 221 | candidates 222 | (gcal-recur-expand-byyearday year byyearday)))) 223 | 224 | (if bymonthday 225 | (setq candidates 226 | (gcal-recur-ymd-list-make-combination 227 | candidates 228 | (gcal-recur-expand-bymonthday year bymonthday)))) 229 | 230 | (if byday 231 | (setq candidates 232 | (gcal-recur-ymd-list-make-combination 233 | candidates 234 | ;; within the year/months specified by bymonth 235 | (gcal-recur-expand-byday year bymonth byday)))) 236 | 237 | (setq candidates 238 | (gcal-recur-ymd-list-complete 239 | candidates 240 | year 241 | (decoded-time-month dect-dtstart) ;;same month as dtstart 242 | (decoded-time-day dect-dtstart))) ;;same day as dtstart 243 | 244 | candidates)) 245 | 246 | (defun gcal-recur-dates-on-period-month (rules month-num dect-dtstart) 247 | (let* ((year (/ month-num 12)) 248 | (month (1+ (% month-num 12))) 249 | (bymonth (gcal-recur-rrule-bymonth rules)) 250 | ;;(byweekno (gcal-recur-rrule-byweekno rules)) 251 | ;;(byyearday (gcal-recur-rrule-byyearday rules)) 252 | (bymonthday (gcal-recur-rrule-bymonthday rules)) 253 | (byday (gcal-recur-rrule-byday rules)) 254 | ;;(wkst (gcal-recur-rrule-wkst rules)) 255 | (candidates (list (list year month nil)))) 256 | 257 | (if bymonth 258 | (setq candidates 259 | (gcal-recur-ymd-list-filter-matched 260 | candidates 261 | (gcal-recur-expand-bymonth year bymonth)))) ;;Limit 262 | 263 | (if bymonthday 264 | (setq candidates 265 | (gcal-recur-ymd-list-make-combination 266 | candidates 267 | (gcal-recur-expand-bymonthday year bymonthday)))) 268 | 269 | (if byday 270 | (setq candidates 271 | (gcal-recur-ymd-list-make-combination 272 | candidates 273 | ;; within the month 274 | (gcal-recur-expand-byday year month byday)))) 275 | 276 | (setq candidates 277 | (gcal-recur-ymd-list-complete 278 | candidates 279 | year 280 | month 281 | (decoded-time-day dect-dtstart))) ;;same day as dtstart 282 | 283 | candidates)) 284 | 285 | (defun gcal-recur-dates-on-period-week (rules abs-week-num dect-dtstart) 286 | (let* ((bymonth (gcal-recur-rrule-bymonth rules)) 287 | ;;(byweekno (gcal-recur-rrule-byweekno rules)) 288 | ;;(byyearday (gcal-recur-rrule-byyearday rules)) 289 | ;;(bymonthday (gcal-recur-rrule-bymonthday rules)) 290 | (byday (gcal-recur-rrule-byday rules)) 291 | (wkst (gcal-recur-rrule-wkst rules)) 292 | (dtstart-dow (gcal-absdn-day-of-week (gcal-absdn-from-decoded-time dect-dtstart))) 293 | (candidates (list (list nil nil nil)))) 294 | 295 | (if bymonth 296 | (setq candidates 297 | (gcal-recur-expand-bymonth nil bymonth))) 298 | 299 | (setq candidates 300 | (gcal-recur-ymd-list-make-combination 301 | candidates 302 | ;; within the week 303 | (mapcar 304 | #'gcal-absdn-to-ymd 305 | (gcal-recur-expand-byday-absdn 306 | (gcal-absdn-from-abs-week-number abs-week-num wkst) 307 | (+ (gcal-absdn-from-abs-week-number abs-week-num wkst) 7) 308 | (or byday (list (cons nil dtstart-dow))))))) 309 | 310 | candidates)) 311 | 312 | (defun gcal-recur-dates-on-period-day (rules absdn _dect-dtstart) 313 | (let* ((ymd (gcal-absdn-to-ymd absdn)) 314 | (year (car ymd)) 315 | (month (cadr ymd)) 316 | (day (caddr ymd)) 317 | (bymonth (gcal-recur-rrule-bymonth rules)) 318 | ;;(byweekno (gcal-recur-rrule-byweekno rules)) 319 | ;;(byyearday (gcal-recur-rrule-byyearday rules)) 320 | (bymonthday (gcal-recur-rrule-bymonthday rules)) 321 | (byday (gcal-recur-rrule-byday rules)) 322 | ;;(wkst (gcal-recur-rrule-wkst rules)) 323 | (candidates (list (list year month day)))) 324 | 325 | (if bymonth 326 | (setq candidates 327 | (gcal-recur-ymd-list-filter-matched 328 | candidates 329 | (gcal-recur-expand-bymonth year bymonth)))) ;;Limit 330 | 331 | (if bymonthday 332 | (setq candidates 333 | (gcal-recur-ymd-list-make-combination 334 | candidates 335 | (gcal-recur-expand-bymonthday year bymonthday)))) 336 | 337 | (if byday 338 | (setq candidates 339 | (gcal-recur-ymd-list-make-combination 340 | candidates 341 | ;; within the day 342 | (mapcar 343 | #'gcal-absdn-to-ymd 344 | (gcal-recur-expand-byday-absdn absdn (1+ absdn) byday))))) 345 | 346 | (setq candidates 347 | (gcal-recur-ymd-list-complete 348 | candidates 349 | year 350 | month 351 | day)) 352 | 353 | candidates)) 354 | 355 | (defun gcal-recur-complete-hms (ymd-list rules dect-dtstart time-zone) 356 | (let* ((byhour (gcal-recur-rrule-byhour rules)) 357 | (byminute (gcal-recur-rrule-byminute rules)) 358 | (bysecond (gcal-recur-rrule-bysecond rules)) 359 | ;; Google Calendar does not support hourly, minutely, secondly frequencies. 360 | ;; Multiple values of byhour, byminute, bysecond properties are also not supported. 361 | (hour (if (= (length byhour) 1) (car byhour) (decoded-time-hour dect-dtstart))) 362 | (minute (if (= (length byminute) 1) (car byminute) (decoded-time-minute dect-dtstart))) 363 | (second (if (= (length bysecond) 1) (car bysecond) (decoded-time-second dect-dtstart)))) 364 | (gcal-recur-ymd-list-to-encoded-time ymd-list hour minute second time-zone))) 365 | 366 | 367 | 368 | ;; 369 | ;; Expand BYxxxxx rules 370 | ;; 371 | 372 | (defun gcal-recur-expand-bymonth (year bymonth) 373 | (mapcar (lambda (month) (list year month nil)) bymonth)) 374 | 375 | (defun gcal-recur-expand-byweekno (year wkst byweekno) 376 | (let ((absdn-weekno1 (gcal-absdn-first-week-of-year year wkst)) 377 | (absdn-weekno1-next-year (gcal-absdn-first-week-of-year (1+ year) wkst))) 378 | 379 | (mapcan 380 | (lambda (weekno) 381 | (let ((absdn-week 382 | (cond 383 | ((>= weekno 1) 384 | (+ absdn-weekno1 (* (1- weekno) 7))) 385 | ((<= weekno -1) 386 | (+ absdn-weekno1-next-year (* weekno 7))) 387 | (t 388 | (error "Invalid weekno %s" weekno)))) 389 | dates-in-week) 390 | (dotimes (i 7) 391 | (let ((ymd (gcal-absdn-to-ymd (+ absdn-week i)))) 392 | (if (= (car ymd) year) 393 | (push ymd dates-in-week)))) 394 | (nreverse dates-in-week))) 395 | byweekno))) 396 | ;;TEST: (gcal-recur-expand-byweekno 2021 0 '(1 -1)) => ((2021 1 3) (2021 1 4) (2021 1 5) (2021 1 6) (2021 1 7) (2021 1 8) (2021 1 9) (2021 12 26) (2021 12 27) (2021 12 28) (2021 12 29) (2021 12 30) (2021 12 31)) 397 | 398 | (defun gcal-recur-expand-byyearday (year byyearday) 399 | (mapcar 400 | (lambda (d) 401 | (let ((tm (decoded-time-add 402 | (if (< d 0) 403 | (make-decoded-time :year (1+ year) :month 1 :day 1) 404 | (make-decoded-time :year year :month 1 :day 0)) 405 | (make-decoded-time :day d)))) 406 | (list 407 | (decoded-time-year tm) 408 | (decoded-time-month tm) 409 | (decoded-time-day tm)))) 410 | byyearday)) 411 | ;;TEST: (gcal-recur-expand-byyearday 2021 '(1 2 -1 -2)) => ((2021 1 1) (2021 1 2) (2021 12 31) (2021 12 30)) 412 | 413 | (defun gcal-recur-expand-bymonthday (year bymonthday) 414 | ;; Keep negative day because month may not be fixed. 415 | ;; FREQ=YEARLY;BYMONTHDAY=-1,-2,-3;BYDAY=MO 416 | ;; see: gcal-recur-complete-negative-day 417 | (mapcar (lambda (d) (list year nil d)) bymonthday)) 418 | ;;TEST: (gcal-recur-expand-bymonthday 2021 '(1 2 3 -1 -2 -3)) 419 | 420 | (defun gcal-recur-expand-byday (year month-or-bymonth byday) 421 | ;; (From https://tools.ietf.org/html/rfc5545#section-3.3.10) 422 | ;; Each BYDAY value can also be preceded by a positive (+n) or 423 | ;; negative (-n) integer. If present, this indicates the nth 424 | ;; occurrence of a specific day within the MONTHLY or YEARLY "RRULE". 425 | 426 | ;; For example, within a MONTHLY rule, +1MO (or simply 1MO) 427 | ;; represents the first Monday within the month, whereas -1MO 428 | ;; represents the last Monday of the month. The numeric value in a 429 | ;; BYDAY rule part with the FREQ rule part set to YEARLY corresponds 430 | ;; to an offset within the month when the BYMONTH rule part is 431 | ;; present, and corresponds to an offset within the year when the 432 | ;; BYWEEKNO or BYMONTH rule parts are present. If an integer 433 | ;; ^^^^^^^ ? 434 | ;; modifier is not present, it means all days of this type within the 435 | ;; specified frequency. For example, within a MONTHLY rule, MO 436 | ;; represents all Mondays within the month. The BYDAY rule part MUST 437 | ;; NOT be specified with a numeric value when the FREQ rule part is 438 | ;; not set to MONTHLY or YEARLY. Furthermore, the BYDAY rule part 439 | ;; MUST NOT be specified with a numeric value with the FREQ rule part 440 | ;; set to YEARLY when the BYWEEKNO rule part is specified. 441 | 442 | (mapcar 443 | #'gcal-absdn-to-ymd 444 | (cond 445 | ;; FREQ=MONTHLY 446 | ((integerp month-or-bymonth) 447 | (gcal-recur-expand-byday-absdn 448 | (gcal-absdn year month-or-bymonth 1) 449 | (gcal-absdn year (1+ month-or-bymonth) 1) 450 | byday)) 451 | ;; FREQ=YEARLY;BYMONTH= 452 | ((consp month-or-bymonth) 453 | (mapcan 454 | (lambda (m) 455 | (gcal-recur-expand-byday-absdn 456 | (gcal-absdn year m 1) 457 | (gcal-absdn year (1+ m) 1) 458 | byday)) 459 | month-or-bymonth)) 460 | ;; FREQ=YEARLY 461 | (t 462 | (gcal-recur-expand-byday-absdn 463 | (gcal-absdn year 1 1) 464 | (gcal-absdn (1+ year) 1 1) 465 | byday))))) 466 | ;;TEST: (gcal-recur-expand-byday 2021 2 '((nil . 1) (nil . 2))) => ((2021 2 1) (2021 2 2) (2021 2 8) (2021 2 9) (2021 2 15) (2021 2 16) (2021 2 22) (2021 2 23)) 467 | ;;TEST: (gcal-recur-expand-byday 2021 '(1 2) '((1 . 1) (-1 . 2))) => ((2021 1 4) (2021 1 26) (2021 2 1) (2021 2 23)) 468 | ;;TEST: (gcal-recur-expand-byday 2021 nil '((1 . 1) (-1 . 2))) => ((2021 1 4) (2021 12 28)) 469 | 470 | (defun gcal-recur-expand-byday-absdn (absdn-lower absdn-upper byday) 471 | (seq-uniq 472 | (sort 473 | (mapcan 474 | (lambda (num-day) 475 | (let* ((num (car num-day)) 476 | (day (cdr num-day)) 477 | (first-day (+ absdn-lower (mod (- day absdn-lower) 7))) 478 | (last-day (- (1- absdn-upper) (mod (- (1- absdn-upper) day) 7))) 479 | result-days) 480 | 481 | (cond 482 | ;; All days within the period(between absdn-lower and absdn-upper) 483 | ((null num) 484 | (let ((d first-day)) 485 | (while (< d absdn-upper) 486 | (push d result-days) 487 | (setq d (+ d 7))))) 488 | ;; First day 489 | ((>= num 1) 490 | (let ((d (+ first-day (* (1- num) 7)))) 491 | (if (< d absdn-upper) 492 | (push d result-days)))) 493 | ;; Last day 494 | ((<= num -1) 495 | (let ((d (+ last-day (* (1+ num) 7)))) 496 | (if (>= d absdn-lower) 497 | (push d result-days)))) 498 | ;; 0 is invalid 499 | (t (error "Invalid byday"))) 500 | 501 | (nreverse result-days))) 502 | byday) 503 | #'<))) 504 | ;;TEST: (mapcar #'gcal-absdn-to-ymd (gcal-recur-expand-byday-absdn (gcal-absdn 2021 2 1) (gcal-absdn 2021 2 28) '((nil . 1) (1 . 2) (-1 . 3) (2 . 4) (-2 . 5)))) => ((2021 2 1) (2021 2 2) (2021 2 8) (2021 2 11) (2021 2 15) (2021 2 19) (2021 2 22) (2021 2 24)) 505 | 506 | 507 | 508 | ;; 509 | ;; Limit 510 | ;; 511 | 512 | (defun gcal-recur-limit-bysetpos (sorted-ymd-list bysetpos) 513 | (if (null bysetpos) 514 | sorted-ymd-list 515 | (let* ((len (length sorted-ymd-list)) 516 | (indices 517 | (seq-uniq 518 | (sort (seq-filter 519 | (lambda (pos) (and (>= pos 0) (< pos len))) 520 | (mapcar 521 | (lambda (pos) (cond 522 | ((<= pos -1) (+ len pos)) 523 | ((>= pos 1) (1- pos)) 524 | (t (error "Invalid bysetpos")))) 525 | bysetpos)) 526 | #'<))) 527 | (index 0) 528 | result) 529 | (while (and sorted-ymd-list indices) 530 | (when (= (car indices) index) 531 | (push (car sorted-ymd-list) result) 532 | (setq indices (cdr indices))) 533 | (setq sorted-ymd-list (cdr sorted-ymd-list)) 534 | (setq index (1+ index))) 535 | (nreverse result)))) 536 | ;;TEST: (gcal-recur-limit-bysetpos '((2021 2 17) (2021 2 18) (2021 2 19)) '(1 -1 -2 -3 -4)) 537 | 538 | (defun gcal-recur-limit-by-count (list count) 539 | ;; (seq-take list count) is non-destructive 540 | (cond 541 | ((null count) list) 542 | ((<= count 0) nil) 543 | ((<= (length list) count) list) 544 | (t 545 | (setcdr (nthcdr (1- count) list) nil) ;;destructive 546 | list))) 547 | 548 | 549 | 550 | ;; 551 | ;; Year/Month/Day 552 | ;; 553 | 554 | (defun gcal-recur-ymd-match-p (l r) 555 | (while (and l r (or (null (car l)) (null (car r)) (= (car l) (car r)))) 556 | (setq l (cdr l)) 557 | (setq r (cdr r))) 558 | (and (null l) (null r))) 559 | ;;TEST: (gcal-recur-ymd-match-p '(2021 8 nil) '(2021 8 14)) 560 | 561 | (defun gcal-recur-ymd-list-filter-matched (pattern-list target-list) 562 | (if pattern-list 563 | (seq-filter 564 | (lambda (target) 565 | (seq-contains-p pattern-list target #'gcal-recur-ymd-match-p)) 566 | target-list))) 567 | ;;TEST: (gcal-recur-ymd-list-filter-matched '((2021 2 nil) (2021 4 nil)) '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => ((2021 2 10) (2021 4 10)) 568 | ;;TEST: (gcal-recur-ymd-list-filter-matched nil '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => nil 569 | ;;TEST: (gcal-recur-ymd-list-filter-matched '((nil nil nil)) '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => ((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10)) 570 | ;;TEST: (gcal-recur-ymd-list-filter-matched '((2021 3 nil) (2021 5 nil)) '((nil nil 13) (nil nil 18) (nil nil 21))) => ((nil nil 13) (nil nil 18) (nil nil 21)) 571 | ;;TEST: (gcal-recur-ymd-list-filter-matched '((2021 3 12) (2021 3 13) (2021 3 14)) '((nil nil 13) (nil nil 14))) => ((nil nil 13) (nil nil 14)) 572 | ;;TEST: (gcal-recur-ymd-list-filter-matched nil '((nil nil 13) (nil nil 14))) => nil 573 | ;;TEST: (gcal-recur-ymd-list-filter-matched '((nil nil nil)) '((nil nil 13) (nil nil 14))) => ((nil nil 13) (nil nil 14)) 574 | 575 | (defun gcal-recur-ymd-fulldate-p (ymd) 576 | (and (car ymd) (cadr ymd) (caddr ymd))) 577 | 578 | (defun gcal-recur-ymd-list-fulldate-p (ymd-list) 579 | (not (seq-some (lambda (ymd) (not (gcal-recur-ymd-complete-p ymd))) ymd-list))) 580 | ;;TEST: (gcal-recur-ymd-list-fulldate-p '((2021 2 16) (2021 2 17) (2021 2 18))) => t 581 | ;;TEST: (gcal-recur-ymd-list-fulldate-p '((2021 2 nil) (2021 2 nil) (2021 2 nil))) => nil 582 | 583 | (defun gcal-recur-ymd-complete (ymd year month day) 584 | "Fill in the undetermined part of the YMD to YEAR/MONTH/DAY." 585 | (gcal-recur-ymd-filter-invalid-date 586 | (if (gcal-recur-ymd-fulldate-p ymd) 587 | ymd 588 | (let ((year (or (car ymd) year)) 589 | (month (or (cadr ymd) month)) 590 | (day (or (caddr ymd) day))) 591 | (list 592 | year 593 | month 594 | (gcal-recur-complete-negative-day year month day)))))) 595 | ;;TEST: (gcal-recur-ymd-complete '(nil nil nil) 2021 2 14) => (2021 2 14) 596 | ;;TEST: (gcal-recur-ymd-complete '(2022 10 nil) 2021 2 14) => (2022 10 14) 597 | ;;TEST: (gcal-recur-ymd-complete '(2022 10 20) 2021 2 14) => (2022 10 20) 598 | ;;TEST: (gcal-recur-ymd-complete '(2021 nil -28) 2021 2 14) => (2021 2 1) 599 | ;;TEST: (gcal-recur-ymd-complete '(2021 nil -28) 2021 2 14) => (2021 2 1) 600 | ;;TEST: (gcal-recur-ymd-complete '(2021 nil -31) 2021 2 14) => nil 601 | 602 | (defun gcal-recur-ymd-list-complete (ymd-list year month day) 603 | (mapcar 604 | (lambda (ymd) 605 | (gcal-recur-ymd-complete ymd year month day)) 606 | ymd-list)) 607 | 608 | (defun gcal-recur-complete-negative-day (year month day) 609 | (if (and year month day) 610 | (let ((days-in-month (date-days-in-month year month))) 611 | (if (<= day -1) 612 | (+ days-in-month day 1) 613 | day)) 614 | day)) 615 | ;;TEST: (gcal-recur-complete-negative-day 2021 2 -1) => 28 616 | 617 | (defun gcal-recur-ymd-filter-invalid-date (ymd) 618 | (if (or (not (gcal-recur-ymd-fulldate-p ymd)) 619 | ;; 1 <= day <= (date-days-in-month year month) 620 | (<= 1 (caddr ymd) (date-days-in-month (car ymd) (cadr ymd)))) 621 | ymd 622 | nil)) 623 | 624 | (defun gcal-recur-ymd-mix (l-ymd r-ymd) 625 | (catch 'gcal-recur--break 626 | (let* ((year (gcal-recur-ymd-mix-num (car l-ymd) (car r-ymd))) 627 | (month (gcal-recur-ymd-mix-num (cadr l-ymd) (cadr r-ymd))) 628 | (day (gcal-recur-ymd-mix-num 629 | (gcal-recur-complete-negative-day year month (caddr l-ymd)) 630 | (gcal-recur-complete-negative-day year month (caddr r-ymd))))) 631 | (gcal-recur-ymd-filter-invalid-date 632 | (list year month day))))) 633 | ;;TEST: (gcal-recur-ymd-mix '(2021 7 nil) '(nil nil 10)) => (2021 7 10) 634 | ;;TEST: (gcal-recur-ymd-mix '(2021 2 nil) '(nil nil 29)) => nil 635 | ;;TEST: (gcal-recur-ymd-mix '(2021 7 nil) '(nil 8 10)) => nil 636 | ;;TEST: (gcal-recur-ymd-mix '(2021 2 nil) '(nil 2 -28)) => (2021 2 1) 637 | ;;TEST: (gcal-recur-ymd-mix '(2021 2 1) '(nil 2 -28)) => (2021 2 1) 638 | ;;TEST: (gcal-recur-ymd-mix '(2021 nil -28) '(nil 2 nil)) => (2021 2 1) 639 | 640 | (defun gcal-recur-ymd-mix-num (l r) 641 | (cond 642 | ((null l) r) 643 | ((null r) l) 644 | ((= l r) l) 645 | (t (throw 'gcal-recur--break nil)))) 646 | 647 | (defun gcal-recur-ymd-list-make-combination (l-list r-list) 648 | (let (result) 649 | (dolist (l l-list) 650 | (dolist (r r-list) 651 | (if-let ((ymd (gcal-recur-ymd-mix l r))) 652 | (push ymd result)))) 653 | (nreverse result))) 654 | ;;TEST: (gcal-recur-ymd-list-make-combination '((2021 2 nil) (2021 4 nil)) '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => ((2021 2 10) (2021 4 10)) 655 | ;;TEST: (gcal-recur-ymd-list-make-combination nil '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => nil 656 | ;;TEST: (gcal-recur-ymd-list-make-combination '((nil nil nil)) '((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10))) => ((2021 2 10) (2021 3 10) (2021 4 10) (2021 5 10)) 657 | ;;TEST: (gcal-recur-ymd-list-make-combination '((2021 3 nil) (2021 5 nil)) '((nil nil 13) (nil nil 18) (nil nil 21))) => ((2021 3 13) (2021 3 18) (2021 3 21) (2021 5 13) (2021 5 18) (2021 5 21)) 658 | ;;TEST: (gcal-recur-ymd-list-make-combination '((2021 3 12) (2021 3 13) (2021 3 14)) '((nil nil 13) (nil nil 14))) => ((2021 3 13) (2021 3 14)) 659 | ;;TEST: (gcal-recur-ymd-list-make-combination nil '((nil nil 13) (nil nil 14))) => nil 660 | ;;TEST: (gcal-recur-ymd-list-make-combination '((nil nil nil)) '((nil nil 13) (nil nil 14))) => ((nil nil 13) (nil nil 14)) 661 | 662 | (defun gcal-recur-ymd-less-p (l r) 663 | (or 664 | (< (car l) (car r)) 665 | (and 666 | (= (car l) (car r)) 667 | (or 668 | (< (cadr l) (cadr r)) 669 | (and 670 | (= (cadr l) (cadr r)) 671 | (< (caddr l) (caddr r))))))) 672 | 673 | (defun gcal-recur-ymd-list-sort-and-unique (ymd-list) 674 | ;;@todo Remove same value with adjacent only 675 | (seq-uniq 676 | (sort ymd-list #'gcal-recur-ymd-less-p))) 677 | 678 | (defun gcal-recur-split-list (lst predicate) 679 | (cond 680 | ((null lst) 681 | (cons nil nil)) 682 | ((funcall predicate (car lst)) 683 | (cons nil lst)) 684 | (t 685 | (let ((p lst)) 686 | (while (and (cdr p) (not (funcall predicate (cadr p)))) 687 | (setq p (cdr p))) 688 | (prog1 (cons lst (cdr p)) 689 | (setcdr p nil)))))) 690 | 691 | (defun gcal-recur-sorted-ymd-list-after (ymd-list-sorted ymd-lower lower-inclusive) 692 | (cdr 693 | (gcal-recur-split-list 694 | ymd-list-sorted 695 | (lambda (ymd) 696 | (if lower-inclusive 697 | (not (gcal-recur-ymd-less-p ymd ymd-lower)) 698 | (gcal-recur-ymd-less-p ymd-lower ymd)))))) 699 | 700 | (defun gcal-recur-sorted-encoded-time-list-after (enct-list-sorted enct-lower lower-inclusive) 701 | (cdr 702 | (gcal-recur-split-list 703 | enct-list-sorted 704 | (lambda (enct) 705 | (if lower-inclusive 706 | (not (time-less-p enct enct-lower)) 707 | (time-less-p enct-lower enct)))))) 708 | 709 | (defun gcal-recur-sorted-encoded-time-list-between (enct-list-sorted 710 | enct-lower lower-inclusive 711 | enct-upper upper-inclusive) 712 | (car 713 | (gcal-recur-split-list 714 | (cdr 715 | (gcal-recur-split-list 716 | enct-list-sorted 717 | (lambda (enct) 718 | (if lower-inclusive 719 | (not (time-less-p enct enct-lower)) 720 | (time-less-p enct-lower enct))))) 721 | (lambda (enct) 722 | (if upper-inclusive 723 | (time-less-p enct-upper enct) 724 | (not (time-less-p enct enct-upper))))))) 725 | 726 | (defun gcal-recur-ymd-to-encoded-time (ymd h m s time-zone) 727 | (encode-time (list s m h (caddr ymd) (cadr ymd) (car ymd) nil nil time-zone))) 728 | ;;TEST: (decode-time (gcal-recur-ymd-to-encoded-time '(2012 3 4) 5 6 7 nil)) => (7 6 5 4 3 2012 0 nil 32400) 729 | 730 | (defun gcal-recur-ymd-list-to-encoded-time (ymd-list h m s time-zone) 731 | (mapcar 732 | (lambda (ymd) 733 | (gcal-recur-ymd-to-encoded-time ymd h m s time-zone)) 734 | ymd-list)) 735 | 736 | 737 | 738 | ;; 739 | ;; Absolute Day Number 740 | ;; 741 | 742 | (defun gcal-absdn (year month day) 743 | ;;(time-to-days (encode-time (list 0 0 0 day month year nil nil nil))) 744 | (calendar-absolute-from-gregorian (list month day year))) 745 | 746 | (defun gcal-absdn-day-of-week (absdn) 747 | (mod absdn 7)) 748 | 749 | (defun gcal-absdn-from-decoded-time (dect) 750 | (gcal-absdn 751 | (decoded-time-year dect) 752 | (decoded-time-month dect) 753 | (decoded-time-day dect))) 754 | 755 | (defun gcal-absdn-to-decoded-time (absdn) 756 | ;; Is converting function in time-date.el? 757 | (let ((date (calendar-gregorian-from-absolute absdn))) 758 | (make-decoded-time :year (caddr date) 759 | :month (car date) 760 | :day (cadr date)))) 761 | 762 | (defun gcal-absdn-to-ymd (absdn) 763 | ;; Is converting function in time-date.el? 764 | (let ((date (calendar-gregorian-from-absolute absdn))) 765 | (list (caddr date) 766 | (car date) 767 | (cadr date)))) 768 | 769 | (defun gcal-absdn-first-week-of-year (year wkst) 770 | ;; A week is defined as a seven day period, starting on the day of 771 | ;; the week defined to be the week start (see WKST). Week number 772 | ;; one of the calendar year is the first week that contains at least 773 | ;; four (4) days in that calendar year. 774 | ;; (from https://tools.ietf.org/html/rfc5545#section-3.3.10) 775 | (let* ((absdn-jan1 (gcal-absdn year 1 1)) 776 | (weekdn-jan1 (gcal-absdn-day-of-week (- absdn-jan1 wkst)))) 777 | (+ 778 | (- absdn-jan1 weekdn-jan1) 779 | (if (>= weekdn-jan1 4) 7 0)))) 780 | 781 | (defun gcal-absdn-to-abs-week-number (absdn wkst) 782 | (/ (- absdn wkst) 7)) 783 | 784 | (defun gcal-absdn-from-abs-week-number (abs-week-number wkst) 785 | (+ (* abs-week-number 7) wkst)) 786 | 787 | 788 | 789 | ;; 790 | ;; Parse String 791 | ;; 792 | 793 | (defun gcal-recur-parse-content-line (line) 794 | ;; https://tools.ietf.org/html/rfc5545#section-3.1 795 | (when (stringp line) 796 | (let* ((nameparam-value (gcal-string-divide line ?:)) 797 | (nameparam (car nameparam-value)) 798 | (value (cdr nameparam-value)) 799 | (name-param (gcal-string-divide nameparam ?\;)) 800 | (name (car name-param)) 801 | (param (cdr name-param))) 802 | (list 803 | name 804 | (gcal-recur-parse-value-properties param) 805 | value)))) 806 | ;;TEST: (gcal-recur-parse-content-line "RDATE;VALUE=DATE:19970304,19970504") => ("RDATE" (("VALUE" . "DATE")) "19970304,19970504") 807 | 808 | (defun gcal-recur-parse-value-properties (value) 809 | ;; https://tools.ietf.org/html/rfc5545#section-3.1.1 810 | (when (stringp value) 811 | (mapcar (lambda (v) (gcal-string-divide v ?=)) (split-string value ";")))) 812 | ;;TEST: (gcal-recur-parse-value-properties "FREQ=YEARLY;INTERVAL=2") => (("FREQ" . "YEARLY") ("INTERVAL" . "2")) 813 | 814 | (defun gcal-recur-parse-number-list (str) 815 | (when (stringp str) 816 | (mapcar #'string-to-number (split-string str " *, *")))) 817 | ;; TEST (gcal-recur-parse-number-list "1,2,3") => (1 2 3) 818 | 819 | (defun gcal-recur-parse-bywday-list (str) 820 | (when (stringp str) 821 | (save-match-data 822 | (mapcar 823 | (lambda (weekdaynum) 824 | (when (string-match "\\([-+]?[0-9]+\\)?\\([A-Z][A-Z]\\)" weekdaynum) 825 | (cons 826 | (if-let ((num (match-string 1 weekdaynum))) 827 | (string-to-number num)) 828 | (gcal-recur-parse-weekday (match-string 2 weekdaynum))))) 829 | (split-string str " *, *"))))) 830 | ;; TEST: (gcal-recur-parse-bywday-list "MO,1TU,-2WED") => ((nil . 1) (1 . 2) (-2 . 3)) 831 | 832 | (defun gcal-recur-parse-weekday (str) 833 | (seq-position '("SU" "MO" "TU" "WE" "TH" "FR" "SA") str)) 834 | 835 | (defun gcal-recur-rrule-freq (rules) 836 | (cdr 837 | (assoc 838 | (cdr (assoc "FREQ" rules)) 839 | '(("YEARLY" . yearly) 840 | ("MONTHLY" . monthly) 841 | ("WEEKLY" . weekly) 842 | ("DAILY" . daily) 843 | ("HOURLY" . hourly) 844 | ("MINUTELY" . minutely) 845 | ("SECONDLY" . secondly))))) 846 | (defun gcal-recur-rrule-interval (rules) 847 | (max 1 (string-to-number (or (cdr (assoc "INTERVAL" rules)) "1")))) 848 | (defun gcal-recur-rrule-bymonth (rules) 849 | (gcal-recur-parse-number-list (cdr (assoc "BYMONTH" rules)))) 850 | (defun gcal-recur-rrule-byweekno (rules) 851 | (gcal-recur-parse-number-list (cdr (assoc "BYWEEKNO" rules)))) 852 | (defun gcal-recur-rrule-byyearday (rules) 853 | (gcal-recur-parse-number-list (cdr (assoc "BYYEARDAY" rules)))) 854 | (defun gcal-recur-rrule-bymonthday (rules) 855 | (gcal-recur-parse-number-list (cdr (assoc "BYMONTHDAY" rules)))) 856 | (defun gcal-recur-rrule-byday (rules) 857 | (gcal-recur-parse-bywday-list (cdr (assoc "BYDAY" rules)))) 858 | (defun gcal-recur-rrule-byhour (rules) 859 | (gcal-recur-parse-number-list (cdr (assoc "BYHOUR" rules)))) 860 | (defun gcal-recur-rrule-byminute (rules) 861 | (gcal-recur-parse-number-list (cdr (assoc "BYMINUTE" rules)))) 862 | (defun gcal-recur-rrule-bysecond (rules) 863 | (gcal-recur-parse-number-list (cdr (assoc "BYSECOND" rules)))) 864 | (defun gcal-recur-rrule-bysetpos (rules) 865 | (gcal-recur-parse-number-list (cdr (assoc "BYSETPOS" rules)))) 866 | (defun gcal-recur-rrule-wkst (rules) 867 | (gcal-recur-parse-weekday (or (cdr (assoc "WKST" rules)) "MO"))) ;;default=MO(1) 868 | (defun gcal-recur-rrule-count (rules) 869 | (when-let ((str (cdr (assoc "COUNT" rules)))) 870 | (string-to-number str))) 871 | (defun gcal-recur-rrule-until (rules time-zone) 872 | (when-let ((str (cdr (assoc "UNTIL" rules)))) 873 | (save-match-data 874 | (if (string-match "\\`\\([0-9][0-9][0-9][0-9]\\)-?\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)\\'" str) 875 | ;;date only 876 | (encode-time 877 | (list 878 | 59 59 23 ;;last second of the date in local time 879 | (string-to-number (match-string 3 str)) 880 | (string-to-number (match-string 2 str)) 881 | (string-to-number (match-string 1 str)) 882 | nil nil time-zone)) 883 | ;; date-time 884 | (parse-iso8601-time-string str))))) 885 | 886 | 887 | 888 | ;; 889 | ;; String 890 | ;; 891 | 892 | (defun gcal-string-divide (string divider) 893 | (if-let ((pos (seq-position string divider))) 894 | (cons (substring string 0 pos) 895 | (substring string (1+ pos))) 896 | (cons string nil))) 897 | ;;TEST: (gcal-string-divide "abc" ?:) => ("abc") 898 | ;;TEST: (gcal-string-divide "abc:" ?:) => ("abc" . "") 899 | ;;TEST: (gcal-string-divide "abc:def" ?:) => ("abc" . "def") 900 | ;;TEST: (gcal-string-divide "abc:def:ghi" ?:) => ("abc" . "def:ghi") 901 | 902 | 903 | 904 | ;; 905 | ;; Sexp Diary Entry 906 | ;; 907 | 908 | ;; %%(gcal-recur-diary "2021-02-22" ["RRULE:FREQ=DAILY;BYDAY=MO,TU,WED"]) Test Entry 909 | (defun gcal-recur-diary (dtstart recurrence &optional mark) 910 | (with-no-warnings (defvar date) (defvar entry)) 911 | (let* (;; calendar date 912 | (m (calendar-extract-month date)) 913 | (d (calendar-extract-day date)) 914 | (y (calendar-extract-year date)) 915 | ;; dtstart 916 | (dtstart-parsed (parse-time-string dtstart)) 917 | (dtstart-date-only (or (null (decoded-time-second dtstart-parsed)) 918 | (null (decoded-time-minute dtstart-parsed)) 919 | (null (decoded-time-hour dtstart-parsed)))) 920 | (dtstart-datetime (if dtstart-date-only 921 | (nconc (list 0 0 0) (cdddr dtstart-parsed)) 922 | dtstart-parsed)) 923 | ;; occurrences 924 | (event-times 925 | (gcal-recur-between 926 | recurrence 927 | (encode-time dtstart-datetime) 928 | (encode-time (list 0 0 0 d m y nil nil nil)) t 929 | (encode-time (list 0 0 0 (1+ d) m y nil nil nil)) nil 930 | 1))) 931 | (message "entry=%s" entry) 932 | (if event-times 933 | (cons mark 934 | (if dtstart-date-only 935 | entry 936 | (concat (format-time-string "%R " (car event-times)) entry)))))) 937 | 938 | 939 | 940 | (provide 'gcal-recur) 941 | ;;; gcal-recur.el ends here 942 | -------------------------------------------------------------------------------- /gcal.el: -------------------------------------------------------------------------------- 1 | ;;; gcal.el --- Google Calendar Interface -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016 AKIYAMA Kouhei 4 | 5 | ;; Author: AKIYAMA Kouhei 6 | ;; Version: 0.9.0 7 | ;; Keywords: convenience 8 | ;; Package-Requires: ((emacs "26.3")) 9 | ;; URL: https://github.com/misohena/gcal 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; 27 | ;; (require 'gcal) 28 | ;; (setq gcal-client-id "xxxxxxxxx.apps.googleusercontent.com") 29 | ;; (setq gcal-client-secret "xxxx-XxxxXxxXXXxx") ;;API-KEY 30 | ;; 31 | ;; ;; list my calendars 32 | ;; (gcal-calendar-list-list) ;; Calendar List 33 | ;; 34 | ;; ;; list events 35 | ;; (gcal-events-list 36 | ;; "example@gmail.com" ;;<- calendar-id 37 | ;; `((timeMin . ,(gcal-datetime 2016 5 1)) 38 | ;; (timeMax . ,(gcal-datetime 2016 6 1)))) 39 | ;; 40 | ;; ;; insert event 41 | ;; (gcal-events-insert 42 | ;; "example@gmail.com" 43 | ;; `((start . ,(gcal-gtime 2016 5 27)) 44 | ;; (end . ,(gcal-gtime 2016 5 28)) 45 | ;; (summary . "My Special Holiday"))) 46 | ;; 47 | ;; ;; delete event 48 | ;; (gcal-events-delete "example@gmail.com" "xxx{event id}xxx") 49 | ;; 50 | 51 | ;;; Code: 52 | 53 | (require 'url) 54 | (require 'url-util) 55 | (require 'json) 56 | (require 'parse-time) 57 | (require 'eieio) 58 | 59 | 60 | 61 | ;;;; Utilities 62 | 63 | (defvar gcal-log-enabled nil) 64 | 65 | (defun gcal-log (format-string &rest args) 66 | (when gcal-log-enabled 67 | (apply 'message format-string args)) 68 | nil) 69 | 70 | ;;;; Asynchronous Execution Infrastructure 71 | 72 | (defvar gcal-async-callback nil) 73 | 74 | (defun gcal-async-callback-capture () 75 | (pcase gcal-async-callback 76 | ;; nil 77 | ('nil 78 | nil) 79 | ;; (sticky ) 80 | (`(sticky ,fun-ref ,fun-callback) 81 | (when fun-ref 82 | (funcall fun-ref)) 83 | fun-callback) 84 | ;; 85 | ((and (pred functionp) fun-callback) 86 | (setq gcal-async-callback nil) 87 | fun-callback) 88 | ;; Unknown 89 | (_ 90 | nil))) 91 | 92 | (defun gcal-async-callback-call (callback result) 93 | (if callback 94 | (funcall callback result) 95 | result)) 96 | 97 | 98 | ;;;;; gcal-async-let* 99 | 100 | ;; Example1: 101 | ;; (gcal-http-async ;; or -sync 102 | ;; (gcal-async-let 103 | ;; ((title 104 | ;; (gcal-async-let* 105 | ;; (;; Get first web page (can be async) 106 | ;; (response1 107 | ;; (gcal-http "GET" "https://example.com/")) 108 | ;; ;; Get first link destination in the page (can be async) 109 | ;; (response2 110 | ;; (let ((body (gcal-http-response-body response1))) 111 | ;; (when (string-match "href=\"\\([^\"]+\\)\"" body) 112 | ;; (gcal-http "GET" (match-string 1 body)))))) 113 | ;; ;; Get title (not async) 114 | ;; (let ((body (gcal-http-response-body response2))) 115 | ;; (when (string-match "\\([^<]+\\)" body) 116 | ;; (match-string 1 body)))))) 117 | ;; (message "title=%s" title))) 118 | ;; 119 | ;; The good thing about this way of writing is that the code is 120 | ;; exactly the same both synchronously and asynchronously. Also, for 121 | ;; synchronous execution, replacing gcal-async-let with let will work. 122 | 123 | ;; Example2: 124 | ;; (gcal-http-async 125 | ;; (gcal-async-let ((callst (gcal-calendar-list-list))) 126 | ;; (pp callst (current-buffer)))) 127 | 128 | 129 | (defmacro gcal-async-let*--0 (_varlist &rest body) 130 | ;; There is no async expression. 131 | `(progn 132 | ,@body)) 133 | 134 | (defmacro gcal-async-let*--1-inner (varlist body current-buffer callback) 135 | (if (null varlist) 136 | ;; Body 137 | ;; () body 138 | `(with-current-buffer 139 | (if (buffer-live-p ,current-buffer) 140 | ,current-buffer (current-buffer)) 141 | (gcal-async-callback-call 142 | ,callback 143 | (progn 144 | ;; @todo Should I also consider asynchronous processing within the body? 145 | ;; That way, `gcal-calendar-list-list' can be written as follows. 146 | ;; (defun gcal-calendar-list-list () 147 | ;; (gcal-async-let* ((params (gcal-access-token-params))) 148 | ;; (gcal-retrieve-json-get (gcal-calendar-list-url) params))) 149 | ,@body))) 150 | ;; 1 or more variables 151 | ;; ((var expr)...) body 152 | (let ((var (nth 0 (car varlist))) 153 | (expr (nth 1 (car varlist)))) 154 | `(let* ((gcal-async-callback 155 | (lambda (,var) 156 | (gcal-async-let*--1-inner ,(cdr varlist) ,body 157 | ,current-buffer ,callback))) 158 | (result 159 | ;; @todo Should I restore the current buffer here as well? 160 | ;;(with-current-buffer (if (buffer-live-p ,current-buffer) ,current-buffer (current-buffer)) ,expr ) 161 | ,expr)) 162 | (if gcal-async-callback 163 | (funcall (gcal-async-callback-capture) result) 164 | result))))) 165 | 166 | (defmacro gcal-async-let*--1 (varlist &rest body) 167 | (let ((current-buffer (gensym "current-buffer-")) 168 | (callback (gensym "callback-"))) 169 | `(let ((,current-buffer (current-buffer)) 170 | (,callback (gcal-async-callback-capture))) 171 | (gcal-async-let*--1-inner ,varlist ,body ,current-buffer ,callback)))) 172 | 173 | (defmacro gcal-async-let* (varlist &rest body) 174 | "(gcal-async-let* ((var1 async-expr1) (var2 async-expr2) ...) body) 175 | 176 | First async-expr1 is evaluated and once its value is determined 177 | it is set to var1. After that, async-exprN and varN are evaluated 178 | in the same way, and finally body is evaluated. 179 | 180 | Only one asynchronous function can be called within async-expr, 181 | and it must be called at the end of the expression. If async-expr 182 | does not contain an async function, its last evaluated value is 183 | set to var. 184 | 185 | Returns the return value of the function that was first executed 186 | asynchronously. If there is no asynchronous function, returns 187 | the value of BODY. 188 | 189 | If `gcal-async-callback' is set, it will be called after body is 190 | evaluated. 191 | 192 | Same as `let*' if no asynchronous processing is performed." 193 | (declare (indent 1)) 194 | (unless lexical-binding 195 | (error "gcal.el requires lexical binding.")) 196 | (if (null varlist) 197 | `(gcal-async-let*--0 nil ,@body) 198 | `(gcal-async-let*--1 ,varlist ,@body))) 199 | 200 | 201 | ;;;;; gcal-async-let (Parallel Execution) 202 | 203 | (defmacro gcal-async-let--2 (varlist &rest body) 204 | (let ((current-buffer (gensym "current-buffer-")) 205 | (callback (gensym "callback-")) 206 | (result-vars (mapcar (lambda (_) (gensym "result-")) varlist)) 207 | (fun-expr-vars (mapcar (lambda (_) (gensym "fun-expr-")) varlist)) 208 | (fun-initialized (gensym "fun-initialized-")) 209 | (num-uninitialized (gensym "num-uninitialized"))) 210 | `(let* (;; (fun-expr1 (lambda () )) 211 | ;; (fun-expr2 (lambda () )) 212 | ;; (fun-exprN (lambda () )) 213 | ,@(cl-loop for (_var expr) in varlist 214 | for fun-expr in fun-expr-vars 215 | collect `(,fun-expr (lambda () ,expr))) 216 | ;; var1 217 | ;; var2 218 | ;; varN 219 | ,@(cl-loop for (var _expr) in varlist 220 | collect var) 221 | (,current-buffer (current-buffer)) 222 | (,callback (gcal-async-callback-capture)) 223 | (,num-uninitialized ,(length varlist)) 224 | (,fun-initialized (lambda () 225 | (when (= (cl-decf ,num-uninitialized) 0) 226 | (with-current-buffer 227 | (if (buffer-live-p ,current-buffer) 228 | ,current-buffer (current-buffer)) 229 | (gcal-async-callback-call 230 | ,callback 231 | (progn 232 | ,@body))))))) 233 | ,@(cl-loop for (var _expr) in varlist 234 | for fun-expr in fun-expr-vars 235 | for result in result-vars 236 | collect 237 | `(let* ((gcal-async-callback (lambda (res) 238 | (setq ,var res) 239 | (funcall ,fun-initialized))) 240 | (,result (funcall ,fun-expr))) 241 | (if gcal-async-callback 242 | (funcall (gcal-async-callback-capture) ,result) 243 | ,result)))))) 244 | 245 | (defmacro gcal-async-let (varlist &rest body) 246 | "(gcal-async-let ((var1 async-expr1) (var2 async-expr2) ...) body) 247 | 248 | All async-exprs are evaluated first. Once the value of async-expr 249 | is determined, it will be set to the corresponding var. Once all 250 | vars are set, the body is evaluated. 251 | 252 | Only one asynchronous function can be called within async-expr, 253 | and it must be called at the end of the expression. If async-expr 254 | does not contain an async function, its last evaluated value is 255 | set to var. 256 | 257 | If `gcal-async-callback' is set, it will be called after body is 258 | evaluated. 259 | 260 | Returns the return value of the last function executed 261 | asynchronously. If there is no asynchronous function, returns 262 | the value of BODY. 263 | 264 | Same as `let' if no asynchronous processing is performed." 265 | (declare (indent 1)) 266 | (unless lexical-binding 267 | (error "gcal.el requires lexical binding.")) 268 | (pcase (length varlist) 269 | (0 `(gcal-async-let*--0 nil ,@body)) 270 | (1 `(gcal-async-let*--1 ,varlist ,@body)) 271 | (_ `(gcal-async-let--2 ,varlist ,@body)))) 272 | 273 | ;;;;; gcal-async-wait-all 274 | 275 | ;; Example: 276 | ;; (gcal-async-wait-all 277 | ;; (progn 278 | ;; (gcal-events-insert "xxxxxxxxxxxxx@gmail.com" 279 | ;; `((start (date "2024-02-11") ) 280 | ;; (end (date "2024-02-12")) 281 | ;; (summary . "Test Event1"))) 282 | ;; (gcal-events-insert "xxxxxxxxxxxxx@gmail.com" 283 | ;; `((start (date "2024-02-11") ) 284 | ;; (end (date "2024-02-12")) 285 | ;; (summary . "Test Event2"))) 286 | ;; (gcal-events-insert "xxxxxxxxxxxxx@gmail.com" 287 | ;; `((start (date "2024-02-11") ) 288 | ;; (end (date "2024-02-12")) 289 | ;; (summary . "Test Event3")))) 290 | ;; (message "Finish")) 291 | 292 | (defun gcal-async-wait-all--impl (fun-async-expr fun-body) 293 | (let* ((callback (gcal-async-callback-capture)) 294 | (current-buffer (current-buffer)) 295 | (count 0) 296 | (waiting nil) 297 | (fun-body-caller (lambda () 298 | (with-current-buffer 299 | (if (buffer-live-p current-buffer) 300 | current-buffer (current-buffer)) 301 | (gcal-async-callback-call 302 | callback 303 | (funcall fun-body))))) 304 | (gcal-async-callback (list 'sticky 305 | (lambda () 306 | (cl-incf count)) 307 | (lambda (_return-value) 308 | (cl-decf count) 309 | (when (and waiting (= count 0)) 310 | (funcall fun-body-caller))))) 311 | (result-async-expr (funcall fun-async-expr))) 312 | (if (= count 0) 313 | (funcall fun-body-caller) 314 | (setq waiting t) 315 | result-async-expr))) 316 | 317 | (defmacro gcal-async-wait-all (multiple-async-expr &rest body) 318 | "(gcal-async-wait-all multiple-async-expr body)" 319 | (declare (indent 1)) 320 | `(gcal-async-wait-all--impl 321 | (lambda () ,multiple-async-expr) 322 | (lambda () ,@body))) 323 | 324 | 325 | 326 | ;;;; Alternative to `url-queue-retrieve' 327 | 328 | ;; I want to use `url-queue-retrieve', but it doesn't support 329 | ;; url-request-* variables! (as of Emacs 29.2) 330 | 331 | (cl-defstruct (gcal-url-retrieve-request 332 | (:constructor gcal-url-retrieve-request)) 333 | url callback cbargs silent inhibit-cookies method headers data 334 | buffer start-time) 335 | (defvar gcal-url-retrieve--waiting nil) 336 | (defvar gcal-url-retrieve--running nil) 337 | (defvar gcal-url-retrieve--timer nil) 338 | (defconst gcal-url-retrieve-parallel-processes 6) 339 | (defconst gcal-url-retrieve-timeout 5) 340 | 341 | (defun gcal-url-retrieve (url callback cbargs silent inhibit-cookies) 342 | (let ((request 343 | (gcal-url-retrieve-request 344 | :url url :callback callback :cbargs cbargs :silent silent 345 | :inhibit-cookies inhibit-cookies 346 | :method url-request-method :headers url-request-extra-headers 347 | :data url-request-data))) 348 | (gcal-url-retrieve--push request) 349 | (gcal-url-retrieve--next) 350 | request)) 351 | 352 | (defun gcal-url-retrieve--push (request) 353 | (setq gcal-url-retrieve--waiting 354 | (nconc gcal-url-retrieve--waiting (list request)))) 355 | 356 | (defun gcal-url-retrieve--pop () 357 | (pop gcal-url-retrieve--waiting)) 358 | 359 | (defun gcal-url-retrieve--next () 360 | ;;@todo Should I slightly delay startup with a timer? 361 | (while (and gcal-url-retrieve--waiting 362 | (< (length gcal-url-retrieve--running) 363 | gcal-url-retrieve-parallel-processes)) 364 | (gcal-url-retrieve--run (gcal-url-retrieve--pop))) 365 | (gcal-url-retrieve--update-timer)) 366 | 367 | (defun gcal-url-retrieve--run (request) 368 | (with-slots (url silent inhibit-cookies method headers data buffer start-time) 369 | request 370 | (gcal-log "gcal-url-retrieve--run url=%s" url) 371 | (condition-case err 372 | (let ((url-request-method method) 373 | (url-request-extra-headers headers) 374 | (url-request-data data)) 375 | (setf buffer (url-retrieve url #'gcal-url-retrieve--callback 376 | (list request) silent inhibit-cookies) 377 | start-time (float-time)) 378 | (push request gcal-url-retrieve--running)) 379 | (error 380 | ;; Pass the error to the callback 381 | (gcal-url-retrieve--call 382 | request 383 | `(:error (error gcal-url-retrieve-error ,(format "Error: %s" err)))) 384 | (gcal-url-retrieve--next))))) 385 | 386 | (defun gcal-url-retrieve--callback (status request) 387 | (gcal-url-retrieve--remove-from-running-list request) 388 | (unwind-protect 389 | (gcal-url-retrieve--call request status) 390 | (gcal-url-retrieve--next))) 391 | 392 | (defun gcal-url-retrieve--remove-from-running-list (request) 393 | (setq gcal-url-retrieve--running 394 | (delq request gcal-url-retrieve--running))) 395 | 396 | (defun gcal-url-retrieve--call (request status) 397 | (with-slots (buffer cbargs) request 398 | (when-let ((callback (oref request callback))) 399 | (oset request callback nil) ;; Prevent double calls 400 | 401 | (with-current-buffer 402 | (if (buffer-live-p buffer) 403 | buffer 404 | ;; Killing the buffer is the responsibility of the callback. 405 | (generate-new-buffer " *gcal-url-retrieve-temp*" t)) 406 | (apply callback status cbargs))))) 407 | 408 | (defun gcal-url-retrieve--kill-all-timeout-requests () 409 | (when-let ((timeout-requests (seq-filter #'gcal-url-retrieve--timeout-p 410 | gcal-url-retrieve--running))) 411 | (unwind-protect 412 | (dolist (request timeout-requests) 413 | (gcal-url-retrieve--kill request) 414 | (gcal-url-retrieve--remove-from-running-list request) 415 | (gcal-url-retrieve--call request 416 | '(:error 417 | (error gcal-url-retrieve-timeout "Timeout")))) 418 | (gcal-url-retrieve--next)))) 419 | 420 | (defun gcal-url-retrieve--timeout-p (request) 421 | (>= (- (float-time) (oref request start-time)) gcal-url-retrieve-timeout)) 422 | 423 | (defun gcal-url-retrieve--kill (request) 424 | (with-slots (buffer) request 425 | (when (bufferp buffer) 426 | (cl-loop for process = (get-buffer-process buffer) 427 | while process 428 | do 429 | (set-process-sentinel process #'ignore) 430 | (ignore-errors (delete-process process)))))) 431 | 432 | (defun gcal-url-retrieve--update-timer () 433 | (if gcal-url-retrieve--running 434 | (gcal-url-retrieve--schedule-timer) 435 | (gcal-url-retrieve--cancel-timer))) 436 | 437 | (defun gcal-url-retrieve--schedule-timer () 438 | (unless gcal-url-retrieve--timer 439 | (setq gcal-url-retrieve--timer 440 | (run-with-idle-timer 441 | 1 1 #'gcal-url-retrieve--kill-all-timeout-requests)))) 442 | 443 | (defun gcal-url-retrieve--cancel-timer () 444 | (when gcal-url-retrieve--timer 445 | (cancel-timer gcal-url-retrieve--timer) 446 | (setq gcal-url-retrieve--timer nil))) 447 | 448 | 449 | 450 | ;;;; Process HTTP Request 451 | 452 | (defvar gcal-http-sync nil 453 | "`t' or `sync' means `gcal-http' must be synchronous. 454 | `async' means `gcal-http' must be asynchronous. 455 | `nil' means to use the default (specified in `gcal-http-impl').") 456 | 457 | (defmacro gcal-http-sync (&rest body) 458 | "`gcal-http' in BODY will be executed synchronously." 459 | `(let ((gcal-http-sync t)) 460 | ,@body)) 461 | 462 | (defmacro gcal-http-async (&rest body) 463 | "`gcal-http' in BODY will be executed asynchronously." 464 | `(let ((gcal-http-sync 'async)) 465 | ,@body)) 466 | 467 | (defvar gcal-http-impl 'gcal-http-impl-url-retrieve-synchronously 468 | "A function that handles a HTTP request. 469 | 470 | Typically, this function actually sends the HTTP request and 471 | returns the result, but it can also send it asynchronously and 472 | return only the information to wait for the result, or it can 473 | return the request itself without sending it.") 474 | 475 | (defun gcal-http-impl () 476 | (pcase gcal-http-sync 477 | ('nil gcal-http-impl) 478 | ('async 'gcal-http-impl-url-retrieve) 479 | (_ 'gcal-http-impl-url-retrieve-synchronously))) 480 | 481 | (defun gcal-http (method url &optional params headers data response-filters) 482 | "Process a HTTP Request." 483 | (funcall 484 | (gcal-http-impl) 485 | method url params headers data response-filters)) 486 | 487 | (defun gcal-http-impl-url-retrieve-synchronously 488 | (method url params headers data &optional response-filters) 489 | (let* ((url-request-method (or method "GET")) 490 | (url-request-extra-headers headers) 491 | (url-request-data data) 492 | (buffer (url-retrieve-synchronously 493 | (gcal-http-make-query-url url params))) 494 | (response (unwind-protect 495 | (gcal-parse-http-response buffer) 496 | (kill-buffer buffer))) 497 | (response (gcal-http-apply-response-filters response 498 | response-filters))) 499 | response)) 500 | 501 | (defun gcal-http-impl-url-retrieve 502 | (method url params headers data &optional response-filters) 503 | (let* ((url-request-method (or method "GET")) 504 | (url-request-extra-headers headers) 505 | (url-request-data data) 506 | (callback (gcal-async-callback-capture)) 507 | ;; I want to use `url-queue-retrieve', but it doesn't 508 | ;; support url-request-* variables! 509 | ;; (retrieve-fun 'url-queue-retrieve) 510 | ;; (retrieve-fun 'url-retrieve) 511 | (retrieve-fun 'gcal-url-retrieve) 512 | (value 513 | (funcall 514 | retrieve-fun 515 | (gcal-http-make-query-url url params) ;; URL 516 | (gcal-http-impl-url-retrieve--make-callback-fun 517 | response-filters callback 518 | retrieve-fun url params headers data) ;; CALLBACK 519 | nil ;; CBARGS 520 | nil ;; SILENT 521 | t ;; INHIBIT-COOKIES 522 | ))) 523 | (list 'gcal-http-waiting retrieve-fun value))) 524 | 525 | (defun gcal-http-impl-url-retrieve--make-callback-fun 526 | (response-filters 527 | callback 528 | retrieve-fun url params headers data) 529 | (lambda (status) 530 | (let ((buffer (current-buffer))) 531 | (unwind-protect 532 | (let* ((response 533 | (if-let ((err (plist-get status :error))) 534 | ;; Error! 535 | (progn 536 | (message 537 | "%s error %s url=%s params=%s headers=%s data=[[[%s]]] buffer=[[[%s]]]" 538 | retrieve-fun (prin1-to-string err) 539 | url params headers data 540 | (buffer-string)) 541 | (pcase err 542 | ;; (error http 404) 543 | (`(error http ,_code) 544 | (gcal-parse-http-response buffer)) 545 | (_ 546 | ;;@todo 500? 547 | (gcal-http-response-data 548 | 500 nil 549 | (concat 550 | "{ \"error\": { \"code\": 500, \"message\": " 551 | "\"An unexpected error occurred on url-retrieve: " 552 | (format "%s" err) 553 | "\" } }"))))) 554 | ;; Normal 555 | (gcal-parse-http-response buffer))) 556 | (response 557 | (gcal-http-apply-response-filters 558 | response response-filters))) 559 | (gcal-async-callback-call callback response)) 560 | (when (buffer-live-p buffer) 561 | (kill-buffer buffer)))))) 562 | 563 | 564 | ;; For response 565 | 566 | (defun gcal-http-response-status (response) (nth 0 response)) 567 | (defun gcal-http-response-headers (response) (nth 2 response)) 568 | (defun gcal-http-response-body (response) (nth 3 response)) 569 | 570 | (defun gcal-http-response-data (status headers body) 571 | (list status 572 | nil ;; reason-phrase (should not be used) 573 | headers 574 | body)) 575 | 576 | (defun gcal-parse-http-response (buffer) 577 | "Parse HTTP response in buffer." 578 | (with-current-buffer buffer 579 | (goto-char (point-min)) 580 | ;; status-line (ex: HTTP/1.1 200 OK) 581 | (when (looking-at "^HTTP/[^ ]+ \\([0-9]+\\) ?\\(.*\\)$") 582 | (forward-line) 583 | (gcal-http-response-data 584 | ;; status-code (integer) 585 | (string-to-number (match-string 1)) 586 | ;; header-field* (alist) 587 | (gcal-parse-http-headers) ;; goto beginning of message-body 588 | ;; message-body (string) 589 | (buffer-substring (point) (point-max)))))) 590 | 591 | (defun gcal-parse-http-headers () 592 | "Parse HTTP header fields in the current buffer." 593 | (let (headers) 594 | (while (not (looking-at "\\(?:\r\n\\|\n\\)")) 595 | (when (looking-at "^\\([^:\r\n]+\\): \\([^\r\n]*\\)\\(?:\r\n\\|\n\\)") 596 | (push (cons (match-string 1) (match-string 2)) headers)) 597 | (forward-line)) 598 | (goto-char (match-end 0)) ;;move to after \r\n (at beginning of content) 599 | (nreverse headers))) 600 | 601 | (defun gcal-http-response-to-json (response) 602 | "Convert HTTP response(return value of gcal-http, 603 | gcal-parse-http-response) to parsed JSON object(by 604 | json-read-from-string)." 605 | (let* ((status (gcal-http-response-status response)) 606 | (body (gcal-http-response-body response))) 607 | ;;@todo check status more 608 | (cond 609 | ((equal status 204) nil) ;;empty result 610 | ((and (stringp body) (not (string-empty-p body))) 611 | (json-read-from-string (decode-coding-string body 'utf-8)))))) 612 | 613 | (defun gcal-http-apply-response-filters (response response-filters) 614 | (dolist (fun response-filters) 615 | (setq response (funcall fun response))) 616 | response) 617 | 618 | ;; For request 619 | 620 | (defun gcal-http-make-query (params) 621 | "Build query string. (ex: a=1&b=2&c=3)" 622 | (mapconcat 623 | (lambda (kv) 624 | (let* ((key (car kv)) 625 | (v (cdr kv)) 626 | (values (if (listp v) v (list v)))) 627 | (mapconcat 628 | (lambda (value) 629 | (concat 630 | (url-hexify-string (format "%s" key)) 631 | "=" 632 | (url-hexify-string (format "%s" value)))) 633 | values 634 | "&"))) 635 | params 636 | "&")) 637 | 638 | (defun gcal-http-make-query-url (url params) 639 | "Build url with query string. (ex:http://example.com/?a=1&b=2&c=3)" 640 | (let ((query (gcal-http-make-query params))) 641 | (if (string-empty-p query) url (concat url "?" query)))) 642 | 643 | (defconst gcal-http-headers-post-form 644 | '(("Content-Type" . "application/x-www-form-urlencoded"))) 645 | 646 | (defconst gcal-http-headers-post-json 647 | '(("Content-Type" . "application/json"))) 648 | 649 | (defun gcal-http-make-json-string (json-obj) 650 | (encode-coding-string (json-encode json-obj) 'utf-8)) 651 | 652 | (defun gcal-http-post-form (url params) 653 | "Send POST request(with x-www-form-url-encoded parms) to url." 654 | (gcal-http "POST" url nil 655 | gcal-http-headers-post-form 656 | (gcal-http-make-query params))) 657 | 658 | (defun gcal-http-post-json (url params json-obj &optional method) 659 | "Send POST request(with json) to url." 660 | (gcal-http (or method "POST") url params 661 | gcal-http-headers-post-json 662 | (gcal-http-make-json-string json-obj))) 663 | 664 | (defun gcal-retrieve-json (method url params &optional headers data) 665 | "Send HTTP request and return parsed JSON object." 666 | (gcal-http method url params headers data '(gcal-http-response-to-json))) 667 | 668 | (defun gcal-retrieve-json-get (url params) 669 | "Send HTTP GET request and return parsed JSON object." 670 | (gcal-http "GET" url params nil nil '(gcal-http-response-to-json))) 671 | 672 | (defun gcal-retrieve-json-post-form (url params) 673 | "Send HTTP POST request(x-www-form-url-encoded) and return 674 | parsed JSON object." 675 | (gcal-http "POST" url nil 676 | gcal-http-headers-post-form 677 | (gcal-http-make-query params) 678 | '(gcal-http-response-to-json))) 679 | 680 | (defun gcal-retrieve-json-post-json (url params json-obj &optional method) 681 | "Send HTTP POST request(with encoded JSON string) and return 682 | parsed JSON object." 683 | (gcal-http (or method "POST") url params 684 | gcal-http-headers-post-json 685 | (gcal-http-make-json-string json-obj) 686 | '(gcal-http-response-to-json))) 687 | 688 | 689 | 690 | ;;;; OAuth 691 | 692 | ;; (This part can be used other than Google Calendar) 693 | ;; 694 | ;; Example: 695 | ;; (defvar example-token nil) 696 | ;; (setq example-token 697 | ;; (gcal-oauth-token-get 698 | ;; example-token 699 | ;; "~/.gcal-token" 700 | ;; "https://accounts.google.com/o/oauth2/v2/auth" 701 | ;; "https://oauth2.googleapis.com/token" 702 | ;; "xxx.apps.googleusercontent.com" 703 | ;; "secret_xxx" 704 | ;; "https://www.googleapis.com/auth/calendar")) 705 | ;; 706 | ;; (gcal-oauth-token-access example-token) ;;Access Token 707 | ;; (gcal-oauth-token-expires example-token) ;;Expiration Time 708 | ;; (gcal-oauth-token-refresh example-token) ;;Refresh Token 709 | ;; (gcal-oauth-token-expired-p example-token) 710 | 711 | ;; Example: 712 | ;; (setq token 713 | ;; (gcal-oauth-auth 714 | ;; "https://accounts.google.com/o/oauth2/v2/auth" 715 | ;; "https://oauth2.googleapis.com/token" 716 | ;; "xxx.apps.googleusercontent.com" 717 | ;; "secret_xxx" 718 | ;; "https://www.googleapis.com/auth/calendar")) 719 | 720 | ;; Example: 721 | ;; (gcal-oauth-refresh 722 | ;; token "xxxx" "xxxx" "https://oauth2.googleapis.com/token") 723 | 724 | (cl-defstruct (gcal-oauth-token 725 | (:constructor gcal-oauth-token-make)) 726 | access expires refresh url-unused) 727 | 728 | (defun gcal-oauth-token-get (token 729 | token-file 730 | auth-url token-url client-id client-secret scope 731 | &optional force-update) 732 | "Get an OAuth token. 733 | If necessary, load from TOKEN-FILE, authenticate, and refresh. 734 | 735 | FORCE-UPDATE specifies the TOKEN forced update method. 736 | Can be one of the following: 737 | - nil : Do not force updates. 738 | - reauth : Discard TOKEN and re-authenticate. 739 | - refresh : Refresh access token in TOKEN." 740 | 741 | (when (or (null client-id) (string-empty-p client-id)) 742 | (error "client-id is not specified")) 743 | (when (or (null client-secret) (string-empty-p client-secret)) 744 | (error "client-secret is not specified")) 745 | 746 | ;; Load from token-file 747 | (if (eq force-update 'reauth) 748 | (setq token nil) 749 | (unless token 750 | (setq token (gcal-oauth-load-token token-file)))) 751 | 752 | (gcal-async-let* 753 | ((token 754 | (if (and token 755 | (or (eq force-update 'refresh) 756 | (gcal-oauth-token-expired-p token))) 757 | ;; Refresh token 758 | (gcal-oauth-refresh token client-id client-secret token-url 759 | ;; Save when refreshed 760 | token-file) 761 | token)) 762 | (token 763 | (if token 764 | token 765 | ;; New token 766 | (gcal-oauth-auth auth-url token-url client-id client-secret scope 767 | ;; Save when created 768 | token-file)))) 769 | ;; failed 770 | (unless token 771 | (error "Failed to get access token")) 772 | ;; return token 773 | token)) 774 | 775 | (defun gcal-oauth-auth (auth-url token-url client-id client-secret scope 776 | &optional token-file) 777 | "Get a new OAuth token. 778 | Returns a `gcal-oauth-token' object or nil on failure. 779 | Returns nil on failure." 780 | (gcal-async-let ((response (gcal-oauth-auth--retrieve 781 | auth-url token-url 782 | client-id client-secret scope))) 783 | (when response 784 | (let ((token (gcal-oauth-token-make 785 | :access (alist-get 'access_token response) 786 | :expires (gcal-oauth-response-expires-at response) 787 | :refresh (alist-get 'refresh_token response)))) 788 | (when token-file 789 | (gcal-oauth-save-token token-file token)) 790 | token)))) 791 | 792 | (defun gcal-oauth-refresh (token client-id client-secret token-url 793 | &optional token-file) 794 | "Refresh `gcal-oauth-token' object TOKEN. 795 | Returns TOKEN with updated access token and expiration date. 796 | Returns nil if refresh fails." 797 | (gcal-async-let ((response (gcal-oauth-refresh--retrieve 798 | (gcal-oauth-token-refresh token) 799 | token-url 800 | client-id 801 | client-secret))) 802 | (when response 803 | (setf (gcal-oauth-token-access token) 804 | (alist-get 'access_token response)) 805 | (setf (gcal-oauth-token-expires token) 806 | (gcal-oauth-response-expires-at response)) 807 | (when token-file 808 | (gcal-oauth-save-token token-file token)) 809 | token))) 810 | 811 | ;; Expiration Time 812 | 813 | (defun gcal-oauth-response-expires-at (response) 814 | "Obtain the token expiration time from RESPONSE. 815 | 816 | Assume that RESPONSE was obtained at (current-time)." 817 | (let* ((expires-in (alist-get 'expires_in response)) 818 | (expires-at 819 | (if expires-in 820 | (time-add (current-time) (seconds-to-time expires-in)) 821 | nil))) 822 | expires-at)) 823 | 824 | (defun gcal-oauth-token-expired-p (token) 825 | "Return non-nil if the access token held by TOKEN has expired." 826 | (and 827 | token 828 | (gcal-oauth-token-expires token) ;;not null 829 | (time-less-p (gcal-oauth-token-expires token) (current-time)))) 830 | 831 | ;; Token File I/O 832 | 833 | (defun gcal-oauth-save-token (file token) 834 | (when (and file token) 835 | (with-temp-file file 836 | (pp token (current-buffer))))) 837 | 838 | (defun gcal-oauth-load-token (file) 839 | (when (and file (file-exists-p file)) 840 | (ignore-errors 841 | (with-temp-buffer 842 | (insert-file-contents file) 843 | (read (buffer-string)))))) 844 | 845 | ;; Retrieve Token 846 | 847 | (defun gcal-oauth-auth--retrieve (auth-url 848 | token-url client-id client-secret scope) 849 | "Authenticate with OAuth and obtain an access token. 850 | Returns parsed JSON." 851 | (gcal-oauth-retrieve-token 852 | token-url 853 | (let* ((auth-code-and-uri 854 | (gcal-oauth-get-authorization-code auth-url client-id scope)) 855 | (code (car auth-code-and-uri)) 856 | (redirect-uri (cdr auth-code-and-uri))) 857 | `( 858 | ("client_id" . ,client-id) 859 | ("client_secret" . ,client-secret) 860 | ("redirect_uri" . ,redirect-uri) 861 | ("grant_type" . "authorization_code") 862 | ("code" . ,code))) 863 | "get")) 864 | 865 | (defun gcal-oauth-refresh--retrieve (refresh-token 866 | token-url client-id client-secret) 867 | "Refresh token. 868 | Returns parsed JSON." 869 | (gcal-oauth-retrieve-token 870 | token-url 871 | `( 872 | ("client_id" . ,client-id) 873 | ("client_secret" . ,client-secret) 874 | ("grant_type" . "refresh_token") 875 | ("refresh_token" . ,refresh-token)) 876 | "refresh")) 877 | 878 | (defun gcal-oauth-retrieve-token (token-url params operation) 879 | (gcal-async-let ((response (gcal-retrieve-json-post-form token-url params))) 880 | (gcal-oauth-check-access-token-response 881 | response 882 | operation))) 883 | 884 | (defun gcal-oauth-check-access-token-response (response operation) 885 | "Check the RESPONSE of access token acquisition (or refresh). 886 | 887 | If there is a problem, display an error message and return 888 | nil. If there is no problem, return RESPONSE as is." 889 | ;;(message "%s access token response = %s" operation response) 890 | 891 | (let ((err (alist-get 'error response)) 892 | (err-desc (alist-get 'error_description response)) 893 | (access-token (alist-get 'access_token response))) 894 | (cond 895 | ;; Error 896 | (err 897 | (message "Failed to %s access token (err=%s description=%s)" 898 | operation err err-desc) 899 | nil) 900 | 901 | ;; Not contains access_token 902 | ((null access-token) 903 | (message "Failed to %s access token (response=%s)" 904 | operation response) 905 | nil) 906 | 907 | ;; Succeeded 908 | (t response)))) 909 | 910 | ;; Authorization Code 911 | 912 | (defvar gcal-oauth-use-oob-p nil 913 | "When t, use deprecated OAuth Out of Bound (OOB) Flow.") 914 | 915 | (defun gcal-oauth-get-authorization-code (auth-url client-id scope) 916 | "Open a browser, ask the user to consent, and receive authorization code." 917 | (if gcal-oauth-use-oob-p 918 | (gcal-oauth-get-authorization-code-oob auth-url client-id scope) 919 | (gcal-oauth-get-authorization-code-loopback auth-url client-id scope))) 920 | 921 | (defun gcal-oauth-get-authorization-code-oob (auth-url client-id scope) 922 | "Open a browser, ask the user to consent, and receive authorization code." 923 | (let ((redirect-uri "urn:ietf:wg:oauth:2.0:oob")) 924 | (browse-url 925 | (gcal-http-make-query-url 926 | auth-url 927 | `(("client_id" . ,client-id) 928 | ("response_type" . "code") 929 | ("redirect_uri" . ,redirect-uri) 930 | ("scope" . ,scope)))) 931 | (cons 932 | (read-string "Enter the code your browser displayed: ") 933 | redirect-uri))) 934 | 935 | ;; OAuth Local Server (For Loopback IP Address Flow) 936 | 937 | (defun gcal-oauth-local-server-start () 938 | (make-network-process 939 | :name "gcal-oauth-local-server" 940 | :server t 941 | :host 'local 942 | :service t 943 | :family 'ipv4 944 | :coding 'binary 945 | :filter 'gcal-oauth-local-server-filter 946 | :log 'gcal-oauth-local-server-log)) 947 | 948 | (defun gcal-oauth-local-server-stop (proc) 949 | (when (process-status proc) 950 | (delete-process proc) 951 | ;;(message "Stop local server.") 952 | )) 953 | 954 | (defun gcal-oauth-local-server-log (server proc message) 955 | ;;(message "Log: %s" message) 956 | (gcal-oauth-local-server-connect server proc message)) 957 | 958 | (defun gcal-oauth-local-server-sentinel (proc message) 959 | ;;(message "Sentinel: %s" message) 960 | (unless (string-match-p "^open " message) 961 | (gcal-oauth-local-server-disconnect proc message))) 962 | 963 | (defun gcal-oauth-local-server-connect (server proc _message) 964 | (unless (process-get proc :gcal-oauth-connect-p) 965 | (process-put proc :gcal-oauth-connect-p t) 966 | (process-put proc :gcal-oauth-request-buffer (generate-new-buffer " *gcal-oauth-request*")) 967 | (process-put proc :gcal-oauth-server-proc server) 968 | (set-process-sentinel proc #'gcal-oauth-local-server-sentinel) 969 | ;;(message "Connect") 970 | )) 971 | 972 | (defun gcal-oauth-local-server-disconnect (proc _message) 973 | (when (process-put proc :gcal-oauth-connect-p t) 974 | (process-put proc :gcal-oauth-connect-p nil) 975 | (let ((buffer (process-get proc :gcal-oauth-request-buffer)) 976 | (server (process-get proc :gcal-oauth-server-proc)) 977 | (result (process-get proc :gcal-oauth-result))) 978 | (kill-buffer buffer) 979 | 980 | ;;(message "Result=%s" result) 981 | (when (and result 982 | (null (process-get server :gcal-oauth-post-result-p))) 983 | (process-put server :gcal-oauth-post-result-p t) 984 | (gcal-oauth-local-server-post-result result))) 985 | 986 | ;;(message "Disconnect") 987 | )) 988 | 989 | (defun gcal-oauth-local-server-post-result (result) 990 | (push (cons t (list 'gcal-oauth-local-server-quit result)) 991 | unread-command-events)) 992 | 993 | (defun gcal-oauth-local-server-wait-for-result () 994 | (let (result) 995 | (while (null result) 996 | (let ((event (read-event))) 997 | (when (and (listp event) 998 | (eq (car event) 'gcal-oauth-local-server-quit)) 999 | (setq result (cadr event))))) 1000 | result)) 1001 | 1002 | (defun gcal-oauth-local-server-filter (proc string) 1003 | ;;(message "Filter: --\n%s\n--\n(%schars)" 1004 | ;; string ;;(truncate-string-to-width string 20) 1005 | ;; (length string)) 1006 | (with-current-buffer (process-get proc :gcal-oauth-request-buffer) 1007 | (goto-char (point-max)) 1008 | (save-excursion 1009 | (insert string)) 1010 | 1011 | (let ((request (process-get proc :gcal-oauth-request))) 1012 | 1013 | ;; Reach the end of headers 1014 | (when (and (null request) 1015 | (re-search-forward "\r\n\r\n" nil t));;Reach the end of headers 1016 | ;; Parse & delete start line and headers and separator(blank line) 1017 | (setq request (gcal-oauth-local-server-parse-request-before-content)) 1018 | (process-put proc :gcal-oauth-request request)) 1019 | 1020 | ;; Reach the end of content 1021 | (when (and request ;;Headers already parsed 1022 | (null (alist-get :content request));;No content yet 1023 | (>= (buffer-size) 1024 | (alist-get :content-length request)));;Reach the end of content 1025 | ;; Push the content to the end of the request list 1026 | (nconc request 1027 | (list 1028 | (cons 1029 | :content 1030 | (buffer-substring 1031 | (point-min) 1032 | (+ (point-min) (alist-get :content-length request)))))) 1033 | 1034 | ;; Make response and post result 1035 | (gcal-oauth-local-server-execute-request proc request) 1036 | 1037 | ;; Disconnect 1038 | (process-send-eof proc))))) 1039 | 1040 | (defun gcal-oauth-local-server-execute-request (proc request) 1041 | (let ((content (alist-get :content request)) 1042 | (method (alist-get :method request)) 1043 | (headers (alist-get :headers request)) 1044 | (path (alist-get :path request))) 1045 | (pcase path 1046 | ("/" 1047 | (pcase method 1048 | ("GET" 1049 | (process-put proc 1050 | :gcal-oauth-result 1051 | (alist-get :query-args request)) 1052 | (gcal-oauth-local-server-send-response proc 200 "OK")) 1053 | ("POST" 1054 | (cond 1055 | ((string= 1056 | (alist-get "Content-Type" headers "" nil #'equal) 1057 | "application/x-www-form-urlencoded") 1058 | (process-put proc 1059 | :gcal-oauth-result 1060 | (url-parse-query-string content)) 1061 | (gcal-oauth-local-server-send-response proc 200 "OK")) 1062 | (t 1063 | (gcal-oauth-local-server-send-response 1064 | proc 415 "Unsupported Media Type")))) 1065 | (_ 1066 | (gcal-oauth-local-server-send-response 1067 | proc 405 "Method Not Allowed")))) 1068 | (_ 1069 | (gcal-oauth-local-server-send-response proc 404 "Not Found"))))) 1070 | 1071 | (defun gcal-oauth-local-server-parse-request-before-content () 1072 | (goto-char (point-min)) 1073 | (let* ((method-url (gcal-oauth-local-server-parse-start-line)) 1074 | (method (nth 0 method-url)) 1075 | (url (nth 1 method-url)) 1076 | (headers (gcal-parse-http-headers)) 1077 | (path-and-query (url-path-and-query (url-generic-parse-url url))) 1078 | (path (car path-and-query)) 1079 | (query (cdr path-and-query)) 1080 | (args (when query (url-parse-query-string query))) 1081 | (content-length (string-to-number 1082 | (alist-get 1083 | "Content-Length" headers "0" nil #'equal)))) 1084 | ;; Delete string before content 1085 | (delete-region (point-min) (point)) 1086 | 1087 | (list 1088 | (cons :method method) 1089 | (cons :url url) 1090 | (cons :path path) 1091 | (cons :query query) 1092 | (cons :query-args args) 1093 | (cons :headers headers) 1094 | (cons :content-length content-length)))) 1095 | 1096 | (defun gcal-oauth-local-server-parse-start-line () 1097 | ;;(goto-char (point-min)) 1098 | (unless (looking-at "^\\([A-Z]+\\) *\\([^ ]+\\) *HTTP/[0-9]+\\.[0-9]+\r\n") 1099 | (error "Invalid HTTP Request")) 1100 | (goto-char (match-end 0)) 1101 | (let ((method (match-string 1)) 1102 | (url (match-string 2)) 1103 | ;;(http-version (match-string 3)) 1104 | ) 1105 | (list method url))) 1106 | 1107 | (defun gcal-oauth-local-server-send-response (proc code message) 1108 | (process-send-string 1109 | proc 1110 | (format 1111 | "HTTP/1.1 %s %s\r\nContent-Type: text/plain\r\nContent-Length: %s\r\n\r\n%s" 1112 | code message 1113 | (length message) 1114 | message))) 1115 | 1116 | (defun gcal-oauth-get-authorization-code-loopback (auth-url client-id scope) 1117 | "Open a browser, ask the user to consent, and receive authorization code." 1118 | (let* ((proc (gcal-oauth-local-server-start)) 1119 | (host-port (process-contact proc)) 1120 | (port (cadr host-port)) 1121 | (redirect-uri (format "http://127.0.0.1:%s" port))) 1122 | (unwind-protect 1123 | (progn 1124 | (browse-url 1125 | (gcal-http-make-query-url 1126 | auth-url 1127 | `(("client_id" . ,client-id) 1128 | ("response_type" . "code") 1129 | ("redirect_uri" . ,redirect-uri) 1130 | ("scope" . ,scope)))) 1131 | (message "Please approve the authority on the consent screen displayed in your browser.") 1132 | (let* ((result (gcal-oauth-local-server-wait-for-result)) 1133 | (err (cadr (assoc "error" result))) 1134 | (code (cadr (assoc "code" result)))) 1135 | (when err 1136 | (message "Error: %s" err) 1137 | (error "Error: %s" err)) 1138 | (unless code 1139 | (message "No auth code") 1140 | (error "No auth code")) 1141 | (cons code redirect-uri))) 1142 | 1143 | (gcal-oauth-local-server-stop proc)))) 1144 | 1145 | 1146 | 1147 | ;;;; Google Calendar OAuth 1148 | 1149 | ;; Example: (gcal-access-token) 1150 | 1151 | (defcustom gcal-token-file 1152 | (expand-file-name (concat user-emacs-directory ".gcal-token")) 1153 | "access token file" 1154 | :group 'gcal 1155 | :type 'file) 1156 | 1157 | (defcustom gcal-client-id "" 1158 | "client-id for Google Calendar API" 1159 | :group 'gcal :type 'string) 1160 | 1161 | (defcustom gcal-client-secret "" 1162 | "client-secret for Google Calendar API" 1163 | :group 'gcal :type 'string) 1164 | 1165 | (defconst gcal-auth-url "https://accounts.google.com/o/oauth2/v2/auth") 1166 | (defconst gcal-token-url "https://oauth2.googleapis.com/token") 1167 | (defconst gcal-scope-url "https://www.googleapis.com/auth/calendar") 1168 | 1169 | (defvar gcal-access-token nil) 1170 | 1171 | (defun gcal-access-token (&optional force-update) 1172 | "Return the default access token for the Google Calendar API. 1173 | 1174 | OAuth token is recorded in the `gcal-access-token' variable and 1175 | the file pointed to by `gcal-token-file'. They will be updated as 1176 | necessary. 1177 | 1178 | URLs and client information required for authentication are 1179 | stored in variables `gcal-auth-url', `gcal-token-url', 1180 | `gcal-scope-url', `gcal-client-id' and `gcal-client-secret'. 1181 | 1182 | See `gcal-oauth-token-get' for FORCE-UPDATE." 1183 | (gcal-async-let ((token (gcal-oauth-token-get 1184 | gcal-access-token 1185 | gcal-token-file 1186 | gcal-auth-url gcal-token-url 1187 | gcal-client-id gcal-client-secret 1188 | gcal-scope-url 1189 | force-update))) 1190 | (setq gcal-access-token token) 1191 | ;; Return access token 1192 | (gcal-oauth-token-access gcal-access-token))) 1193 | 1194 | (defun gcal-access-token-params (&optional additional-params) 1195 | (gcal-async-let ((access-token (gcal-access-token))) 1196 | `(("access_token" . ,access-token) 1197 | ,@additional-params))) 1198 | 1199 | 1200 | 1201 | 1202 | ;;;; API URL Builder 1203 | 1204 | (defconst gcal-calendar-url "https://www.googleapis.com/calendar/v3") 1205 | 1206 | (defun gcal-calendar-list-url (&optional calendar-id) 1207 | (concat 1208 | gcal-calendar-url 1209 | "/users/me/calendarList" 1210 | (and calendar-id (concat "/" calendar-id)))) 1211 | 1212 | (defun gcal-calendars-url (&optional calendar-id suffix) 1213 | (concat 1214 | gcal-calendar-url 1215 | "/calendars" 1216 | (and calendar-id (concat "/" calendar-id)) 1217 | (and suffix (concat "/" suffix)))) 1218 | 1219 | (defun gcal-events-url (calendar-id &optional suffix1 suffix2) 1220 | (concat 1221 | (gcal-calendars-url calendar-id "events") 1222 | (and suffix1 (concat "/" suffix1)) 1223 | (and suffix2 (concat "/" suffix2)))) 1224 | 1225 | 1226 | 1227 | ;;;; API Wrapper 1228 | 1229 | ;; API Error 1230 | 1231 | (defun gcal-get-error-code (response-json) 1232 | (when (listp response-json) 1233 | (cdr (assq 'code (cdr (assq 'error response-json)))))) 1234 | 1235 | (defun gcal-succeeded-p (response-json) 1236 | ;; NOTE: Events:delete returns an empty body response if successful. 1237 | (null (gcal-get-error-code response-json))) 1238 | 1239 | (defun gcal-failed-p (response-json) 1240 | ;; NOTE: Events:delete returns an empty body response if successful. 1241 | (not (null (gcal-get-error-code response-json)))) 1242 | 1243 | ;; CalendarList 1244 | 1245 | (defun gcal-calendar-list-list () 1246 | "CalendarList: list 1247 | 1248 | URL `https://developers.google.com/calendar/api/v3/reference/calendarList/list'" 1249 | (gcal-async-let* ((params (gcal-access-token-params)) 1250 | (response (gcal-retrieve-json-get 1251 | (gcal-calendar-list-url) 1252 | params))) 1253 | response)) 1254 | 1255 | ;; Events 1256 | 1257 | (defun gcal-events-list (calendar-id &optional params) 1258 | "Events: list 1259 | 1260 | URL `https://developers.google.com/calendar/api/v3/reference/events/list'" 1261 | (gcal-async-let* ((params (gcal-access-token-params params)) 1262 | (response (gcal-retrieve-json-get 1263 | (gcal-events-url calendar-id) 1264 | params))) 1265 | response)) 1266 | 1267 | (defun gcal-events-get (calendar-id event-id &optional params) 1268 | "Events: get 1269 | 1270 | URL `https://developers.google.com/calendar/api/v3/reference/events/get'" 1271 | (gcal-async-let* ((params (gcal-access-token-params params)) 1272 | (response (gcal-retrieve-json-get 1273 | (gcal-events-url calendar-id event-id) 1274 | params))) 1275 | response)) 1276 | 1277 | (defun gcal-events-quick-add (calendar-id text &optional params) 1278 | "Events: quickAdd 1279 | 1280 | URL `https://developers.google.com/calendar/api/v3/reference/events/quickAdd'" 1281 | (gcal-async-let* ((params (gcal-access-token-params 1282 | (append params `(("text" . ,text))))) 1283 | (response (gcal-retrieve-json-post-json 1284 | (gcal-events-url calendar-id "quickAdd") 1285 | params 1286 | nil))) 1287 | response)) 1288 | 1289 | (defun gcal-events-insert (calendar-id event-data &optional params) 1290 | "Events: insert 1291 | 1292 | URL `https://developers.google.com/calendar/api/v3/reference/events/insert' 1293 | 1294 | Example: 1295 | (gcal-events-insert 1296 | \"xxxxxxxxxxxxx@group.calendar.google.com\" 1297 | `( 1298 | (start (date \"2016-05-25\") ) 1299 | (end (date \"2016-05-26\")) 1300 | (summary . \"First Test Event\") 1301 | ) 1302 | )" 1303 | (gcal-async-let* ((params (gcal-access-token-params params)) 1304 | (response (gcal-retrieve-json-post-json 1305 | (gcal-events-url calendar-id) 1306 | params 1307 | event-data))) 1308 | response)) 1309 | 1310 | (defun gcal-events-patch (calendar-id event-id event-data &optional params) 1311 | "Events: patch 1312 | 1313 | URL `https://developers.google.com/calendar/api/v3/reference/events/patch'" 1314 | (gcal-async-let* ((params (gcal-access-token-params params)) 1315 | (response (gcal-retrieve-json-post-json 1316 | (gcal-events-url calendar-id event-id) 1317 | params 1318 | event-data 1319 | "PATCH"))) 1320 | response)) 1321 | 1322 | (defun gcal-events-update (calendar-id event-id event-data &optional params) 1323 | "Events: update 1324 | 1325 | URL `https://developers.google.com/calendar/api/v3/reference/events/update'" 1326 | (gcal-async-let* ((params (gcal-access-token-params params)) 1327 | (response (gcal-retrieve-json-post-json 1328 | (gcal-events-url calendar-id event-id) 1329 | params 1330 | event-data 1331 | "PUT"))) 1332 | response)) 1333 | 1334 | (defun gcal-events-delete (calendar-id event-id &optional params) 1335 | "Events: delete 1336 | 1337 | URL `https://developers.google.com/calendar/api/v3/reference/events/delete'" 1338 | (gcal-async-let* ((params (gcal-access-token-params params)) 1339 | (response (gcal-retrieve-json 1340 | "DELETE" 1341 | (gcal-events-url calendar-id event-id) 1342 | params))) 1343 | response)) 1344 | 1345 | 1346 | 1347 | ;;;; Time Utilities 1348 | 1349 | ;; 1350 | ;; time = Emacs Internal Time 1351 | ;; (ex: (encode-time 0 0 0 31 4 2016) ) 1352 | ;; gtime = Google Calendar Time 1353 | ;; (ex: ('date . "2016-05-27") ('dateTime . "2016-05-27T12:34:00+09:00")) 1354 | ;; datetime = RFC3339 1355 | ;; (ex: 2016-05-01T12:34:00+09:00) 1356 | ;; 1357 | 1358 | (defcustom gcal-time-zone-name-default nil 1359 | "Default time zone name. 1360 | 1361 | Specify by IANA Time Zone Database name (for example, Asia/Tokyo). 1362 | 1363 | This is optional if you only use one-time events, but it is 1364 | required if you want to include time in repeated events." 1365 | :group 'gcal :type '(choice (const nil) string)) 1366 | 1367 | (defun gcal-time-zone-name-default () 1368 | gcal-time-zone-name-default) 1369 | 1370 | (defun gcal-time-zone-suffix () 1371 | (let ((tz (format-time-string "%z"))) 1372 | (concat (substring tz 0 3) ":" (substring tz 3)))) 1373 | 1374 | (defun gcal-time-format (time date-only) 1375 | (if date-only (format-time-string "%Y-%m-%d" time) 1376 | (concat 1377 | (format-time-string "%Y-%m-%dT%H:%M:%S" time) 1378 | (gcal-time-zone-suffix)))) 1379 | 1380 | (defun gcal-time-from-ymdhm (y m d hh mm) 1381 | (encode-time 0 (or mm 0) (or hh 0) d m y)) 1382 | 1383 | (defun gcal-time-to-gtime (time date-only) 1384 | (append 1385 | (list 1386 | (cons 1387 | (if date-only 'date 'dateTime) 1388 | (gcal-time-format time date-only)) 1389 | (cons 1390 | (if date-only 'dateTime 'date) 1391 | nil)) 1392 | (when-let ((name (gcal-time-zone-name-default))) 1393 | (list (cons 'timeZone name))))) 1394 | 1395 | 1396 | (defun gcal-gtime (y m d &optional hh mm) 1397 | (gcal-time-to-gtime (gcal-time-from-ymdhm y m d hh mm) (null hh))) 1398 | 1399 | 1400 | (defun gcal-datetime (y m d &optional hh mm) 1401 | (gcal-time-format (gcal-time-from-ymdhm y m d hh mm) nil)) 1402 | 1403 | ;; google => emacs 1404 | 1405 | ;;(gcal-time-parse "2014-12-13T10:00:00+09:00") 1406 | ;;(gcal-time-parse "2015-03-06T15:42:32.354Z") 1407 | (defun gcal-time-parse (str) 1408 | (parse-iso8601-time-string str)) 1409 | 1410 | (defun gcal-gtime-date-str (gtime) 1411 | "ex: ((date . \"2016-05-28\")) => \"2016-05-28\" or nil" 1412 | (cdr (assq 'date gtime))) 1413 | 1414 | (defun gcal-gtime-date-time-str (gtime) 1415 | "gcal-gtime-date-time-str 1416 | 1417 | ex: ((dateTime . \"2009-10-25T11:00:54+09:00\")) 1418 | => \"2009-10-25T11:00:54+09:00\" or nil" 1419 | (cdr (assq 'dateTime gtime))) 1420 | 1421 | (defun gcal-time-from-gtime (gtime) 1422 | (let ((date (gcal-gtime-date-str gtime))) 1423 | (if (stringp date) 1424 | (let ((d (parse-time-string date))) 1425 | (encode-time 0 0 0 (nth 3 d)(nth 4 d)(nth 5 d))) 1426 | (let ((datetime (gcal-gtime-date-time-str gtime))) 1427 | (if (stringp datetime) 1428 | (gcal-time-parse datetime)))))) 1429 | 1430 | 1431 | 1432 | (provide 'gcal) 1433 | ;;; gcal.el ends here 1434 | -------------------------------------------------------------------------------- /gcal-org.el: -------------------------------------------------------------------------------- 1 | ;;; gcal-org.el --- Org mode to Google Calendar -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016 AKIYAMA Kouhei 4 | 5 | ;; Author: AKIYAMA Kouhei 6 | ;; Version: 0.9.0 7 | ;; Keywords: convenience 8 | ;; Package-Requires: ((emacs "26.3")) 9 | ;; URL: https://github.com/misohena/gcal 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; 27 | ;; (require 'gcal-org) 28 | ;; 29 | ;; (gcal-org-push-file "example@gmail.com" "~/my-schedule.org") 30 | ;; 31 | 32 | ;;; Code: 33 | 34 | (require 'gcal) 35 | (require 'gcal-id) 36 | (require 'org-id) 37 | (require 'org-element) 38 | 39 | 40 | 41 | ;;;; gcal-oevent object 42 | 43 | 44 | (defun make-gcal-oevent (&rest args) 45 | (let (result) 46 | ;; optionalでnilなプロパティを削除する。 47 | ;; 変化判定に影響を及ぼさないようにするため。 48 | (while args 49 | (setq result (gcal-oevent-set-property result (car args) (cadr args))) 50 | (setq args (cddr args))) 51 | result)) 52 | (defun gcal-oevent-deleted (oevent) (plist-get oevent :deleted)) 53 | (defun gcal-oevent-id (oevent) (plist-get oevent :id)) 54 | (defun gcal-oevent-ord (oevent) (plist-get oevent :ord)) 55 | (defun gcal-oevent-summary (oevent) (plist-get oevent :summary)) 56 | (defun gcal-oevent-ts-prefix (oevent) (plist-get oevent :ts-prefix)) 57 | (defun gcal-oevent-ts-start (oevent) (plist-get oevent :ts-start)) 58 | (defun gcal-oevent-ts-end (oevent) (plist-get oevent :ts-end)) 59 | (defun gcal-oevent-recurrence (oevent) (plist-get oevent :recurrence)) 60 | (defun gcal-oevent-location (oevent) (plist-get oevent :location)) 61 | (defun gcal-oevent-summary-prefix (oevent) (plist-get oevent :summary-prefix)) 62 | 63 | (defun gcal-oevent-set-property (oevent prop value) 64 | (let ((opt-props '(:deleted 65 | :recurrence 66 | :location))) 67 | (if (and (null value) (memq prop opt-props)) 68 | (org-plist-delete oevent prop) 69 | (plist-put oevent prop value)))) 70 | 71 | 72 | 73 | ;;;; Parse org-mode document 74 | 75 | 76 | (defcustom gcal-org-allowed-timestamp-prefix '(nil "SCHEDULED" "DEADLINE") 77 | "Prefixes for timestamps that are considered events when parsing. 78 | 79 | Timestamps with prefixes not included here will be ignored and 80 | not treated as events. 81 | 82 | `nil' means no suffix. 83 | 84 | [lang:ja] 85 | パーズする際にイベントとみなされるタイムスタンプの接頭辞のリスト 86 | です。 87 | 88 | ここに含まれない接頭辞のついたタイムスタンプは無視され、イベント 89 | として扱われません。 90 | 91 | `nil'は接尾辞なしを表わします。" 92 | :group 'gcal 93 | :type '(repeat (choice (const "SCHEDULED") (const "DEADLINE") (const nil)))) 94 | 95 | (defcustom gcal-org-include-parents-header-maximum 0 96 | "The number of levels of ancestor headers to include in the event summary. 97 | 98 | `t' means to include all parent hierarchies. 99 | 100 | [lang:ja] 101 | イベントのsummaryに何階層上までのヘッダを含めるかの数。 102 | 103 | `t'は全ての親階層を含めることを表します。" 104 | :group 'gcal 105 | :type '(choice integer (const t))) 106 | 107 | (defcustom gcal-org-header-separator "/" 108 | "When `gcal-org-include-parents-header-maximum' is not 0, 109 | The string that separates the headers in the event summary. 110 | 111 | [lang:ja] 112 | `gcal-org-include-parents-header-maximum'が0でないときに、イベン 113 | トのsummaryにおいてヘッダを隔てる文字列を表します。" 114 | :group 'gcal 115 | :type 'string) 116 | 117 | (defcustom gcal-org-summary-prefix-ts-prefix-alist 118 | '(("SCHEDULED" . "") 119 | ("DEADLINE" . "DL:") 120 | (nil . "")) 121 | "An alist of strings to be added to the beginning of the event 122 | summary according to the timestamp type (ts-prefix). 123 | 124 | [lang:ja] 125 | タイムスタンプの種類(ts-prefix)に応じたイベントのsummaryの先頭に 126 | 付ける文字列のalist。" 127 | :group 'gcal 128 | :type '(alist 129 | :key-type (choice string (const nil)) 130 | :value-type string)) 131 | 132 | (defcustom gcal-org-remove-invisible-text-from-summary nil 133 | "Specifies whether to remove invisible text from the event summary. 134 | 135 | When `t', removes invisible parts based on the invisible text 136 | property. If your headline contains a hyperlink, you can remove 137 | the brackets and the link destination. This process takes time 138 | because it is necessary to unfold everything (make it visible) 139 | and then confirm the entire font-lock. 140 | 141 | When `link-only', only the invisible part of the link is 142 | removed. It may not be perfect, but in most cases there are no 143 | problems and the process is fast. 144 | 145 | Note: When it is non-nil, if you change the summary on the Google 146 | Calendar side, the invisible part may be deleted on the Org side. 147 | 148 | [lang:ja] 149 | イベントのsummaryから不可視のテキストを除去するかを指定します。 150 | 151 | `t'のときinvisibleテキストプロパティに基づいて見えない部分を除去 152 | します。ハイパーリンクをヘッドラインに含んでいる場合にブラケット 153 | やリンク先の部分を除去できます。この処理は全ての折りたたみを解除 154 | して(可視状態にして)から全体のfont-lockを確定させる必要があるため 155 | 時間がかかります。 156 | 157 | `link-only'のときリンクの不可視部分のみを除去します。完全ではない 158 | かもしれませんが多くの場合は問題が無く、処理は高速です。 159 | 160 | 注意:非nilのとき、Googleカレンダー側でsummaryを変更した場合にOrg 161 | 側で不可視部分が削除されてしまう場合があります。" 162 | :group 'gcal 163 | :type '(choice (const :tag "Do nothing" nil) 164 | (const :tag "Remove only hidden parts of links" link-only) 165 | (const :tag "Remove invisible text" t))) 166 | 167 | (defun gcal-org-parse-file (file) 168 | "Collects events from the specified FILE. 169 | 170 | If there is already a buffer associated with FILE, collect it 171 | from that buffer. 172 | 173 | [lang:ja] 174 | 指定されたFILEからイベントを集めます。 175 | 176 | すでにFILEに関連付けられているファイルがある場合は、そのバッファ 177 | から集めます。" 178 | ;;@todo Use temporary buffer when not visiting file ? 179 | ;; (if-let ((buffer (get-file-buffer file))) 180 | ;; (with-current-buffer buffer 181 | ;; (gcal-org-parse-buffer)) 182 | ;; (with-temp-buffer 183 | ;; (insert-file-contents file) 184 | ;; (org-mode) 185 | ;; (gcal-org-parse-buffer))) 186 | 187 | (with-current-buffer (find-file-noselect file) 188 | (gcal-org-parse-buffer))) 189 | 190 | (defun gcal-org-parse-buffer () 191 | "Collects events from the current buffer. 192 | 193 | Create one event for each timestamp. That's because Agenda's 194 | default (`org-agenda-entry-types' ?) is like that. 195 | 196 | To identify a timestamp, this function records the entry's ID as 197 | well as the ordinal number in which the timestamp appears within 198 | the entry. 199 | 200 | [lang:ja] 201 | 現在のバッファからイベントを集めます。 202 | 203 | タイムスタンプ一つ毎に一つのイベントを作ります。Agendaのデフォル 204 | ト(org-agenda-entry-types ?)がそうなっているからです。 205 | 206 | タイムスタンプを識別するために、この関数はエントリーのIDの他にエ 207 | ントリーの中でタイムスタンプが登場した順序数を記録します。" 208 | (save-excursion 209 | ;; update invisible text properties for the entire buffer 210 | (unless (memq gcal-org-remove-invisible-text-from-summary '(nil link-only)) 211 | ;;@todo use org-fold-core-save-visibility? 212 | (when (fboundp 'org-fold-show-all) ;;Org 9.6 213 | (org-fold-show-all)) 214 | (font-lock-ensure)) 215 | 216 | (goto-char (point-min)) 217 | (let (entries events) 218 | ;; search timestamps 219 | (while (re-search-forward org-ts-regexp nil t) 220 | (goto-char (match-beginning 0)) 221 | (let* ((ts-prefix (if (looking-back "\\(SCHEDULED\\|DEADLINE\\): *" 222 | (line-beginning-position)) 223 | (match-string-no-properties 1))) 224 | (ts-prefix-allowed (member ts-prefix gcal-org-allowed-timestamp-prefix)) 225 | ;; ID is not needed when ts-prefix is not allowed. 226 | (id (when ts-prefix-allowed (org-id-get-create))) ;; change (point) 227 | (location (org-entry-get (point) "LOCATION")) 228 | (summary (gcal-org-parse-buffer--make-summary)) 229 | (ts-node (org-element-timestamp-parser)) 230 | (ts-end-pos (org-element-property :end ts-node)) 231 | (ts-start (list 232 | (org-element-property :year-start ts-node) 233 | (org-element-property :month-start ts-node) 234 | (org-element-property :day-start ts-node) 235 | (org-element-property :hour-start ts-node) 236 | (org-element-property :minute-start ts-node))) 237 | (ts-end (list 238 | (org-element-property :year-end ts-node) 239 | (org-element-property :month-end ts-node) 240 | (org-element-property :day-end ts-node) 241 | (org-element-property :hour-end ts-node) 242 | (org-element-property :minute-end ts-node))) 243 | (recurrence (gcal-org-make-recurrence ts-node)) 244 | (same-entry-info (assoc id entries)) 245 | (same-entry-count (length (nth 1 same-entry-info))) 246 | (summary-prefix (gcal-org-parse-buffer--make-summary-prefix 247 | ts-prefix)) 248 | (oevent (make-gcal-oevent 249 | :id id 250 | :ord same-entry-count 251 | :summary summary 252 | :ts-prefix ts-prefix 253 | :ts-start ts-start 254 | :ts-end ts-end 255 | :recurrence recurrence 256 | :location location 257 | :summary-prefix summary-prefix)) 258 | ) 259 | 260 | (when ts-prefix-allowed 261 | (when (null same-entry-info) ;; New ID found 262 | (setq same-entry-info (list id nil)) 263 | (push same-entry-info entries)) 264 | 265 | (push oevent (nth 1 same-entry-info)) 266 | (push oevent events)) 267 | (goto-char ts-end-pos))) 268 | (nreverse events)))) 269 | 270 | (defun gcal-org-parse-buffer--make-summary () 271 | (substring-no-properties 272 | (funcall 273 | (pcase gcal-org-remove-invisible-text-from-summary 274 | ('nil #'identity) 275 | ('link-only #'gcal-org-remove-link-hidden-parts) 276 | (_ #'gcal-org-visible-string)) 277 | (org-get-heading t t)))) 278 | 279 | (defun gcal-org-visible-string (str) 280 | "Removes invisible parts from STR. 281 | 282 | [lang:ja] 283 | 文字列STRから不可視の部分を除去します。" 284 | (let ((beg 0) 285 | (end (length str)) 286 | (result "")) 287 | (while (/= beg end) 288 | ;; Skip invisible text 289 | (while (and (/= beg end) 290 | (invisible-p (get-char-property beg 'invisible str))) 291 | (setq beg (next-single-char-property-change beg 'invisible str end))) 292 | ;; Get visible text 293 | (let ((next (next-single-char-property-change beg 'invisible str end))) 294 | (setq result (concat result (substring str beg next))) 295 | (setq beg next))) 296 | result)) 297 | 298 | (defun gcal-org-remove-link-hidden-parts (str) 299 | "Removes invisible parts of links from STR. 300 | 301 | [lang:ja] 302 | 文字列STRからリンクの不可視部分を除去します。" 303 | ;; See: `org-link-make-regexps' and `org-activate-links--overlays' 304 | (replace-regexp-in-string org-link-any-re 305 | (lambda (match-str) 306 | (or (match-string 3 match-str) 307 | (match-string 2 match-str) 308 | match-str)) 309 | str 310 | t)) 311 | 312 | (defun gcal-org-parse-buffer--make-summary-prefix (ts-prefix) 313 | "Generates a summary-prefix from the current position (and 314 | information given in arguments). 315 | 316 | [lang:ja] 317 | 現在の位置(と引数で与えられた情報)からsummary-prefixを生成します。" 318 | (concat 319 | ;; ts-prefix 320 | (gcal-org-make-summary-prefix-ts-prefix ts-prefix) 321 | ;; path 322 | (if (eq gcal-org-include-parents-header-maximum 0) 323 | "" 324 | (gcal-org-make-summary-prefix-path 325 | (org-get-outline-path) 326 | gcal-org-header-separator 327 | gcal-org-include-parents-header-maximum)) 328 | )) 329 | 330 | (defun gcal-org-make-summary-prefix-ts-prefix (ts-prefix) 331 | "Generate ts-prefix part of summary-prefix. 332 | 333 | [lang:ja] 334 | summary-prefixのts-prefix部分を生成します。" 335 | (or (cdr (assoc ts-prefix gcal-org-summary-prefix-ts-prefix-alist)) "")) 336 | 337 | (defun gcal-org-make-summary-prefix-path (path separator header-maximum) 338 | "Generates path part of summary-prefix. 339 | Connect PATH with SEPARATOR to depth of HEADER-MAXIMUM. 340 | 341 | [lang:ja] 342 | summary-prefixのpath部分を生成します。 343 | HEADER-MAXIMUMの深さまで、PATHをSEPARATORで繋げます。" 344 | (apply #'concat 345 | (mapcan (lambda (elt) (list elt separator)) 346 | (nthcdr 347 | (if (integerp header-maximum) 348 | (max 349 | (- (length path) header-maximum) 350 | 0) 351 | 0) 352 | path)))) 353 | 354 | (defun gcal-org-make-recurrence (ts-node) 355 | (if-let ((repeater-type (org-element-property :repeater-type ts-node)) 356 | (repeater-unit (org-element-property :repeater-unit ts-node)) 357 | (repeater-value (org-element-property :repeater-value ts-node)) 358 | (repeater-unit-str (cdr (assq 359 | repeater-unit 360 | '((hour . "HOURLY") 361 | (day . "DAILY") 362 | (week . "WEEKLY") 363 | (month . "MONTHLY") 364 | (year . "YEARLY")))))) 365 | ;;@todo check repeater-type? + 'cumulate ++ 'catch-up .+ 'restart 366 | (if (and repeater-unit-str 367 | (>= repeater-value 1)) 368 | (vector 369 | ;; https://tools.ietf.org/html/rfc5545#section-3.8.5 370 | (format "RRULE:FREQ=%s;INTERVAL=%s" repeater-unit-str repeater-value))) 371 | 372 | ;; Get from addtional properties 373 | (gcal-ts-get-additional-property ts-node :recurrence))) 374 | 375 | 376 | 377 | ;;;; Calendar Cache with Org Events 378 | 379 | ;; OCALCACHE object has a list of OEVENT and the following properties: 380 | ;; - :next-sync-token 381 | 382 | (defun gcal-ocalcache-create (oevents &rest plist) 383 | (append 384 | (list 385 | 'gcal-ocalcache 386 | oevents) 387 | plist)) 388 | 389 | (defun gcal-ocalcache-p (ocalcache) 390 | (eq (car ocalcache) 'gcal-ocalcache)) 391 | 392 | (defun gcal-ocalcache-oevents (ocalcache) 393 | (if (gcal-ocalcache-p ocalcache) 394 | (cadr ocalcache) 395 | ;; for compatibility 396 | ocalcache)) 397 | 398 | (defun gcal-ocalcache-set-oevents (ocalcache oevents) 399 | (if (gcal-ocalcache-p ocalcache) 400 | (progn 401 | (setcar (cdr ocalcache) oevents) 402 | ocalcache) 403 | ;; for compatibility 404 | (gcal-ocalcache-create oevents))) 405 | 406 | (defun gcal-ocalcache-next-sync-token (ocalcache) 407 | (gcal-ocalcache-get-property ocalcache :next-sync-token)) 408 | 409 | ;; (defun gcal-ocalcache-updated (ocalcache) 410 | ;; (gcal-ocalcache-get-property ocalcache :updated)) 411 | 412 | (defun gcal-ocalcache-set-next-sync-token (ocalcache next-sync-token) 413 | (gcal-ocalcache-put-property ocalcache :next-sync-token next-sync-token)) 414 | 415 | (defun gcal-ocalcache-get-property (ocalcache prop) 416 | (if (gcal-ocalcache-p ocalcache) 417 | (plist-get (cddr ocalcache) prop) 418 | ;; for compatibility 419 | nil)) 420 | 421 | (defun gcal-ocalcache-put-property (ocalcache prop value) 422 | (if (gcal-ocalcache-p ocalcache) 423 | (progn 424 | (setcdr (cdr ocalcache) 425 | (plist-put (cddr ocalcache) prop value)) 426 | ocalcache) 427 | ;; for compatibility 428 | (gcal-ocalcache-create ocalcache prop value))) 429 | 430 | (defun gcal-ocalcache-save (file ocalcache) 431 | "Save OCALCACHE(a list of oevent and some properties) to FILE." 432 | (let ((coding-system-for-write 'utf-8)) 433 | (with-temp-file file 434 | (pp ocalcache (current-buffer))))) 435 | 436 | (defun gcal-ocalcache-load (file) 437 | "Load ocalcache(a list of oevent and some properties) from FILE." 438 | (if (file-exists-p file) 439 | (ignore-errors 440 | (with-temp-buffer 441 | (insert-file-contents file) 442 | (read (buffer-string)))))) 443 | 444 | 445 | 446 | ;;;; Push org file to Google Calendar 447 | 448 | 449 | (defun gcal-org-push-file (calendar-id file &optional cache-file) 450 | (if cache-file 451 | ;;[Async] 452 | (gcal-org-push-file-specified-cache calendar-id file cache-file) 453 | ;;[Async] 454 | (gcal-org-push-file-global-cache calendar-id file))) 455 | 456 | ;; use specified cache-file 457 | 458 | (defun gcal-org-push-file-specified-cache (calendar-id file cache-file) 459 | (let* ((ocalcache (gcal-ocalcache-load cache-file)) 460 | (old-events (gcal-ocalcache-oevents ocalcache)) 461 | (new-events (gcal-org-parse-file file))) 462 | 463 | (gcal-async-let ((oevents 464 | ;;[Async] 465 | (gcal-org-push-oevents calendar-id 466 | new-events old-events))) 467 | (gcal-ocalcache-save 468 | cache-file 469 | (gcal-ocalcache-set-oevents 470 | ocalcache 471 | oevents))))) 472 | 473 | ;; use global-cache(gcal-org-pushed-events-file) 474 | 475 | (defun gcal-org-push-file-global-cache (calendar-id file) 476 | (let* ((calfile-cache (gcal-org-pushed-events-cache calendar-id file)) 477 | (ocalcache (nth 1 calfile-cache))) 478 | (gcal-async-let ((result-oevents 479 | ;;[Async] 480 | (gcal-org-push-oevents 481 | calendar-id 482 | (gcal-org-parse-file file) ;;new events 483 | (gcal-ocalcache-oevents ocalcache)))) ;;old events 484 | 485 | ;; update ocalcache 486 | (setf (nth 1 calfile-cache) 487 | (gcal-ocalcache-set-oevents ocalcache result-oevents)) 488 | 489 | (gcal-org-pushed-events-save) 490 | 491 | result-oevents))) 492 | 493 | (defvar gcal-org-pushed-events nil) 494 | 495 | (defcustom gcal-org-pushed-events-file 496 | (expand-file-name (concat user-emacs-directory ".gcal-org-pushed-events")) 497 | "" 498 | :group 'gcal 499 | :type 'file) 500 | 501 | (defun gcal-org-pushed-events-save () 502 | (with-temp-file gcal-org-pushed-events-file 503 | (pp gcal-org-pushed-events (current-buffer)))) 504 | 505 | (defun gcal-org-pushed-events-load () 506 | (if (null gcal-org-pushed-events) 507 | (setq gcal-org-pushed-events 508 | (if (file-exists-p gcal-org-pushed-events-file) 509 | (ignore-errors 510 | (with-temp-buffer 511 | (insert-file-contents gcal-org-pushed-events-file) 512 | (read (buffer-string)))))))) 513 | 514 | (defun gcal-org-pushed-events-cache (calendar-id file) 515 | (gcal-org-pushed-events-load) 516 | 517 | (let* ((calfile-key (cons calendar-id (expand-file-name file))) 518 | (calfile-cache (assoc calfile-key gcal-org-pushed-events))) 519 | 520 | (when (null calfile-cache) 521 | (setq calfile-cache (list calfile-key nil)) ;;0:key 1:ocalcache 522 | (push calfile-cache gcal-org-pushed-events)) 523 | 524 | calfile-cache)) 525 | 526 | 527 | 528 | 529 | 530 | ;;;; Push list of org-mode events to Google Calendar 531 | 532 | ;; Usage: 533 | ;; Upload: 534 | ;; (setq my-schedule-pushed-oevents 535 | ;; (gcal-org-push-oevents "example@gmail.com" 536 | ;; (gcal-org-parse-file "~/my-schedule.org") nil)) 537 | ;; 538 | ;; (gcal-ocalcache-save "~/my-schedule.gcal-cache" my-schedule-pushed-oevents) 539 | ;; 540 | ;; Upload delta: 541 | ;; (gcal-org-push-oevents "example@gmail.com" 542 | ;; (gcal-org-parse-file "~/my-schedule.org") 543 | ;; (gcal-org-parse-file "~/my-schedule.org.old")) 544 | ;; 545 | ;; (gcal-org-push-oevents "example@gmail.com" 546 | ;; (gcal-org-parse-file "~/my-schedule.org") 547 | ;; (gcal-ocalcache-load "~/my-schedule.gcal-cache")) 548 | ;; 549 | ;; Delete: 550 | ;; (gcal-org-push-oevents "example@gmail.com" 551 | ;; nil 552 | ;; (gcal-org-parse-file "~/my-schedule.org")) 553 | ;; 554 | 555 | (defun gcal-org-push-oevents (calendar-id new-events old-events) 556 | "Send delta between old-events and new-events to calendar(calendar-id). 557 | old-events will be destroyed." 558 | (let ((result-events)) 559 | 560 | (gcal-async-wait-all 561 | (gcal-oevents-diff 562 | old-events 563 | new-events 564 | ;;(lambda (old-oe new-oe) (insert (format "mod %s\n" (gcal-oevent-summary new-oe)))) 565 | ;;(lambda (new-oe) (insert (format "add %s\n" (gcal-oevent-summary new-oe)))) 566 | ;;(lambda (old-oe) (insert (format "del %s\n" (gcal-oevent-summary old-oe)))) 567 | ;;(lambda (old-oe) (insert (format "eq %s\n" (gcal-oevent-summary old-oe)))) 568 | ;; Change 569 | (lambda (old-oe new-oe) 570 | (message "Change %s" (gcal-oevent-summary new-oe)) 571 | (gcal-async-let ((response 572 | ;;[Async] 573 | (gcal-oevent-patch calendar-id old-oe new-oe))) 574 | (setq result-events (gcal-org-push-oevents--check 575 | response 576 | new-oe old-oe result-events 577 | "update")))) 578 | ;; Add 579 | (lambda (new-oe) 580 | (message "Add %s" (gcal-oevent-summary new-oe)) 581 | (gcal-async-let ((response 582 | ;;[Async] 583 | (gcal-org-push-oevents--insert calendar-id new-oe))) 584 | (setq result-events (gcal-org-push-oevents--check 585 | response 586 | new-oe nil result-events 587 | "insert")))) 588 | ;; Del 589 | (lambda (old-oe) 590 | (message "Delete %s" (gcal-oevent-summary old-oe)) 591 | (gcal-async-let ((response 592 | ;;[Async] 593 | (gcal-oevent-delete calendar-id old-oe))) 594 | (setq result-events (gcal-org-push-oevents--check 595 | response 596 | nil old-oe result-events 597 | "delete")))) 598 | ;; Not Change 599 | (lambda (old-oe) 600 | (push old-oe result-events)) 601 | ) 602 | (nreverse result-events)))) 603 | 604 | (defun gcal-org-push-oevents--check (res succ-oe fail-oe result-events op) 605 | "Check response and add event to result-events list." 606 | (if (gcal-succeeded-p res) 607 | (if succ-oe (cons succ-oe result-events) result-events) 608 | (message "Failed to %s event '%s(id=%s)' err=%s" 609 | op 610 | (gcal-oevent-summary (or succ-oe fail-oe)) 611 | (gcal-oevent-id (or succ-oe fail-oe)) 612 | res) 613 | (if fail-oe (cons fail-oe result-events) result-events))) 614 | 615 | (defun gcal-org-push-oevents--insert (calendar-id new-oe) 616 | (gcal-async-let* 617 | ((response-1 618 | ;;[Async] 619 | (gcal-oevent-insert calendar-id new-oe)) 620 | (response-2 621 | (let ((err (gcal-get-error-code response-1))) 622 | ;; conflict (may be already pushed and deleted(status=cancelled)) 623 | (if (and (integerp err) (= err 409)) 624 | ;;@todo use patch? 625 | ;;[Async] 626 | (gcal-oevent-update calendar-id new-oe) 627 | response-1)))) 628 | response-2)) 629 | 630 | 631 | 632 | ;;;; Pull oevents from Google Calendar 633 | 634 | 635 | (defun gcal-org-pull-oevents (calendar-id &optional params) 636 | "Download calendar events as list of gcal-oevent." 637 | (gcal-async-let ((gevents 638 | ;;[Async] 639 | (gcal-events-list calendar-id params))) 640 | (if (gcal-failed-p gevents) 641 | ;;@todo what to return? 642 | (message "error %s" gevents) 643 | ;; succeeded 644 | (delq 645 | nil 646 | (mapcar #'gcal-oevent-from-gevent (cdr (assq 'items gevents))))))) 647 | 648 | 649 | 650 | ;;;; Pull events to file from Google Calendar 651 | 652 | 653 | (defun gcal-org-pull-to-file (calendar-id 654 | file headline cache-file 655 | &optional params full-sync) 656 | (let* (;;(cur-events (gcal-org-parse-file file)) 657 | (ocalcache (gcal-ocalcache-load cache-file)) 658 | (old-events (gcal-ocalcache-oevents ocalcache)) 659 | (next-sync-token (and 660 | ;; PARAMS does not contain nextSyncToken 661 | (null (assq 'nextSyncToken params)) 662 | ;; full sync is not required 663 | (not full-sync) 664 | ;; Use ocalcache's nextSyncToken 665 | (gcal-ocalcache-next-sync-token ocalcache)))) 666 | (gcal-async-let* 667 | (;; Try using ocalcache's next-sync-token 668 | (gevents-nst (when next-sync-token 669 | ;;[Async] 670 | (gcal-events-list calendar-id 671 | (cons (cons 'nextSyncToken 672 | next-sync-token) 673 | params)))) 674 | ;; Try without using next-sync-token 675 | (gevents (if (or (null gevents-nst) 676 | (when (eq (gcal-get-error-code gevents-nst) 410) 677 | (message "Sync token is no longer valid, a full sync is required.") 678 | t)) 679 | ;;[Async] 680 | (gcal-events-list calendar-id params) 681 | gevents-nst))) 682 | 683 | (when (gcal-failed-p gevents) 684 | (error "gcal-events-list failed %s" gevents)) 685 | 686 | (let* ((new-next-sync-token (cdr (assq 'nextSyncToken gevents))) 687 | (new-events 688 | (mapcar (lambda (gevent) (gcal-oevent-from-gevent gevent t)) 689 | (cdr (assq 'items gevents)))) 690 | result-events) 691 | 692 | ;; merge 693 | (gcal-oevents-diff 694 | old-events 695 | new-events 696 | ;; mod 697 | (lambda (old-oe new-oe) 698 | (if (gcal-oevent-deleted new-oe) 699 | (push (gcal-org-pull--entry-del file old-oe) result-events) 700 | (push (gcal-org-pull--entry-mod file old-oe new-oe) result-events))) 701 | ;; add 702 | (lambda (new-oe) 703 | (if (gcal-oevent-deleted new-oe) 704 | ;; unknown event deleted 705 | nil 706 | (push (gcal-org-pull--entry-add file headline new-oe) result-events))) 707 | ;; del 708 | (lambda (old-oe) 709 | (push (gcal-org-pull--entry-del file old-oe) result-events)) 710 | ;; not change 711 | (lambda (old-oe) 712 | (push old-oe result-events))) 713 | 714 | ;; update ocalcache 715 | (setq ocalcache (gcal-ocalcache-set-oevents 716 | ocalcache 717 | (delq nil (nreverse result-events)))) 718 | (setq ocalcache (gcal-ocalcache-set-next-sync-token 719 | ocalcache 720 | new-next-sync-token)) 721 | 722 | ;; save cache file 723 | (gcal-ocalcache-save cache-file ocalcache))))) 724 | 725 | (defun gcal-org-pull--entry-add (file headline new-oe) 726 | ;; @todo 本当はタイムスタンプ(id,ord)を追加しなければならない。 727 | ;; cache-fileになくてGoogle上にあるエントリーは大抵Google上で追加し 728 | ;; たイベントなので、エントリーを一つ追加する。 729 | (if (org-id-find-id-in-file (gcal-oevent-id new-oe) file) 730 | (progn 731 | (message "Event is already exist '%s'" (gcal-oevent-summary new-oe)) 732 | nil) 733 | (with-current-buffer (find-file-noselect file) 734 | (save-excursion 735 | (gcal-org-insert-string-after-headline (gcal-oevent-format new-oe) headline) 736 | (message "Add event %s" (gcal-oevent-summary new-oe)) 737 | new-oe)))) 738 | 739 | (defun gcal-org-pull--entry-del (file old-oe) 740 | ;; @todo 本当はタイムスタンプ(id,ord)を消さなければならない。 741 | ;; org上のエントリーを削除する。 742 | (gcal-org-with-oevent-entry 743 | old-oe file 744 | (lambda () 745 | (if (y-or-n-p "delete this subtree?") 746 | (progn 747 | (org-cut-subtree) 748 | nil) 749 | old-oe)) 750 | old-oe)) 751 | 752 | (defun gcal-org-pull--entry-mod (file old-oe new-oe) 753 | (gcal-org-with-oevent-entry 754 | old-oe file 755 | (lambda () 756 | ;; summary 757 | (gcal-org-pull-merge-property 758 | "headline" 759 | (gcal-oevent-summary old-oe) ;;old-value 760 | (gcal-oevent-summary new-oe) ;;new-value 761 | (substring-no-properties (org-get-heading t t)) ;;curr-value 762 | (lambda (value) (gcal-org-set-heading-text value)) ;;update org 763 | (lambda (value) (setq old-oe (gcal-oevent-set-property old-oe :summary value)))) ;;update object 764 | ;; location 765 | (gcal-org-pull-merge-property 766 | "location" 767 | (gcal-oevent-location old-oe) ;;old-value 768 | (gcal-oevent-location new-oe) ;;new-value 769 | (org-entry-get (point) "LOCATION") ;;curr-value 770 | (lambda (value) (org-set-property "LOCATION" value)) ;;update org 771 | (lambda (value) (setq old-oe (gcal-oevent-set-property old-oe :location value)))) ;;update object 772 | ;; ts 773 | (let ((new-ts-prefix (gcal-oevent-ts-prefix new-oe))) 774 | (if (stringp new-ts-prefix) 775 | ;; ts-prefixがあるなら、それが指すタイムスタンプを変更する。 776 | (gcal-org-pull-merge-property 777 | (format "timestamp (%s)" new-ts-prefix) 778 | (list (gcal-oevent-ts-start old-oe) (gcal-oevent-ts-end old-oe) (gcal-oevent-recurrence old-oe)) ;;old-value 779 | (list (gcal-oevent-ts-start new-oe) (gcal-oevent-ts-end new-oe) (gcal-oevent-recurrence new-oe)) ;;new-value 780 | (gcal-org-get-schedule-ts-range new-ts-prefix) ;;cur-value 781 | (lambda (value) 782 | (gcal-org-set-schedule-ts-range value new-ts-prefix)) 783 | (lambda (value) 784 | (setq old-oe (gcal-oevent-set-property old-oe :ts-start (nth 0 value))) 785 | (setq old-oe (gcal-oevent-set-property old-oe :ts-end (nth 1 value))) 786 | (setq old-oe (gcal-oevent-set-property old-oe :recurrence (nth 2 value))))) 787 | ;; @todo :ord番目のタイムスタンプを変更する。 788 | )) 789 | old-oe) 790 | old-oe)) 791 | 792 | (defun gcal-org-pull-merge-property (propname old-value new-value curr-value fun-apply-org fun-apply-obj) 793 | "Merge property change." 794 | (cond 795 | ;; not changed (from cache-file to google calendar) 796 | ((equal new-value old-value) 797 | (funcall fun-apply-obj new-value)) 798 | ;; already merged 799 | ((equal new-value curr-value) 800 | (funcall fun-apply-obj new-value)) 801 | (t 802 | (if (y-or-n-p (format "Change %s\n %s to\n %s ?" propname curr-value new-value)) 803 | (progn 804 | (funcall fun-apply-org new-value) 805 | (funcall fun-apply-obj new-value)) 806 | (funcall fun-apply-obj old-value))))) 807 | 808 | (defun gcal-org-with-oevent-entry (oevent file func ret-if-failed) 809 | "Move to the location of OEVENT in FILE and execute FUNC. 810 | 811 | [lang:ja] 812 | FILE内にあるOEVENTがある場所を開いて、FUNCを実行します。" 813 | (let* ((id (gcal-oevent-id oevent)) 814 | (place (org-id-find-id-in-file id file))) 815 | (if place 816 | (with-current-buffer (find-file-noselect (car place)) 817 | (save-excursion 818 | (save-restriction 819 | (widen) 820 | (outline-show-all) 821 | (org-id-goto id) 822 | 823 | (funcall func)))) 824 | ;;not found 825 | ret-if-failed))) 826 | 827 | ;;org内容変更 828 | 829 | (defun gcal-org-set-heading-text (text) 830 | " 831 | [lang:ja] 832 | 見出しテキストを変更します。" 833 | (save-excursion 834 | (org-back-to-heading t) 835 | 836 | (looking-at org-complex-heading-regexp) 837 | (replace-match text t t nil 4))) 838 | 839 | (defun gcal-org-get-schedule-element (&optional keyword) 840 | " 841 | [lang:ja] 842 | CLOSED,DEADLINE,SCHEDULEDのプロパティ値を 843 | org-element-timestamp-parserの戻り値で取得します。日付の範囲表現 844 | も取得できます。" 845 | (save-excursion 846 | (org-back-to-heading t) 847 | (forward-line) 848 | (if (and (org-looking-at-p org-planning-line-re) 849 | (re-search-forward 850 | (format "\\<%s: *" (or keyword "SCHEDULED")) (line-end-position) t)) 851 | (org-element-timestamp-parser)))) 852 | 853 | (defun gcal-org-get-schedule-ts-range (&optional keyword) 854 | " 855 | [lang:ja] 856 | CLOSED,DEADLINE,SCHEDULEDのプロパティ値をgcal-ts値で取得します。" 857 | (let ((ts-node (gcal-org-get-schedule-element keyword))) 858 | (when ts-node 859 | (list 860 | ;; ts-start 861 | (list 862 | (org-element-property :year-start ts-node) 863 | (org-element-property :month-start ts-node) 864 | (org-element-property :day-start ts-node) 865 | (org-element-property :hour-start ts-node) 866 | (org-element-property :minute-start ts-node)) 867 | ;; ts-end 868 | (list 869 | (org-element-property :year-end ts-node) 870 | (org-element-property :month-end ts-node) 871 | (org-element-property :day-end ts-node) 872 | (org-element-property :hour-end ts-node) 873 | (org-element-property :minute-end ts-node)) 874 | ;; recurrence 875 | (gcal-org-make-recurrence ts-node))))) 876 | 877 | (defun gcal-org-set-schedule-ts-range (ts-range &optional keyword) 878 | " 879 | [lang:ja] 880 | CLOSED,DEADLINE,SCHEDULEDのプロパティ値をgcal-ts値から設定します。" 881 | (let* ((recurrence (nth 2 ts-range)) 882 | (ts-text (gcal-ts-format-org-range (nth 0 ts-range) 883 | (nth 1 ts-range) 884 | recurrence)) 885 | ts-end) 886 | (save-excursion 887 | (org-back-to-heading t) 888 | (forward-line) 889 | (if (org-looking-at-p org-planning-line-re) 890 | (if (re-search-forward (format "\\<%s: *" (or keyword "SCHEDULED")) (line-end-position) t) 891 | (let ((ts-node (org-element-timestamp-parser))) 892 | (if ts-node 893 | (progn 894 | (let ((begin (org-element-property :begin ts-node)) 895 | (end (org-element-property :end ts-node))) 896 | ;; keep trailing spaces 897 | (while (and (> end begin) 898 | (member (buffer-substring-no-properties (1- end) end) '(" " "\t"))) 899 | (setq end (1- end))) 900 | (delete-region begin end)) 901 | (insert ts-text)) 902 | (insert ts-text)) 903 | (setq ts-end (point))) 904 | (cond 905 | ((string= keyword "CLOSED") 906 | (re-search-forward " *" (line-end-position) t) 907 | (insert " CLOSED: " ts-text)) 908 | ((string= keyword "DEADLINE") 909 | (if (re-search-forward "\\ 1134 | ;; ((summary . "TestFromGcal2") 1135 | ;; (start 1136 | ;; (date . "2021-02-10") 1137 | ;; (dateTime) 1138 | ;; (timeZone . "Asia/Tokyo")) 1139 | ;; (end 1140 | ;; (date . "2021-02-11") 1141 | ;; (dateTime) 1142 | ;; (timeZone . "Asia/Tokyo")) 1143 | ;; (recurrence) 1144 | ;; (location . "Tokyo") 1145 | ;; (extendedProperties 1146 | ;; (private 1147 | ;; (gcalSummaryPrefix)))) 1148 | 1149 | 1150 | ;;;; Convert between oevent(Org-mode Event) and gevent(Google Calendar Event) 1151 | 1152 | 1153 | (defcustom gcal-ts-prefix-created-on-google "SCHEDULED" 1154 | "Prefix added when pulling a schedule created in Google Calendar. 1155 | 1156 | [lang:ja] 1157 | Google Calendarにおいて作成された予定をpullしたときに付ける接頭辞。" 1158 | :group 'gcal 1159 | :type 'string) 1160 | 1161 | (defun gcal-oevent-to-gevent (oevent) 1162 | "Convert a oevent(gcal-oevent object) to a Google Calendar event." 1163 | (let* ((summary (gcal-oevent-summary oevent)) 1164 | (ts-prefix (gcal-oevent-ts-prefix oevent)) 1165 | (ts-start (gcal-oevent-ts-start oevent)) 1166 | (ts-end (gcal-oevent-ts-end oevent)) 1167 | (recurrence (gcal-oevent-recurrence oevent)) 1168 | (supported-recurrence-p 1169 | (gcal-org-google-supported-recurrence-p recurrence)) 1170 | (location (gcal-oevent-location oevent)) 1171 | (ord (gcal-oevent-ord oevent)) 1172 | (summary-prefix (gcal-oevent-summary-prefix oevent))) 1173 | 1174 | (if (and (stringp summary-prefix) (string-empty-p summary-prefix)) 1175 | (setq summary-prefix nil)) 1176 | 1177 | `((id . ,(gcal-oevent-gevent-id oevent)) 1178 | (status . "confirmed") 1179 | (summary . ,(concat summary-prefix 1180 | summary)) 1181 | (start . ,(gcal-ts-to-gtime ts-start)) 1182 | (end . ,(gcal-ts-to-gtime (gcal-ts-end-exclusive ts-start ts-end))) 1183 | ,@(if (and recurrence supported-recurrence-p) 1184 | `((recurrence . ,recurrence))) 1185 | (extendedProperties 1186 | . ((private 1187 | . (,@(if ts-prefix `((gcalTsPrefix . ,ts-prefix))) 1188 | (gcalOrd . ,ord) 1189 | ,@(if summary-prefix `((gcalSummaryPrefix . ,summary-prefix))) 1190 | ,@(if (and recurrence (not supported-recurrence-p)) 1191 | `((gcalUnsupportedRecurrence . ,(prin1-to-string recurrence)))))))) 1192 | ,@(if location `((location . ,location))) 1193 | ))) 1194 | 1195 | (defun gcal-oevent-from-gevent (gevent &optional include-deleted) 1196 | "Convert a Google Calendar event to a oevent(gcal-oevent object)." 1197 | (let* ((gid (cdr (assq 'id gevent))) 1198 | (id-ord (gcal-oevent-id-ord-from-gevent-id gid)) 1199 | (id (car id-ord)) 1200 | (ord (cdr id-ord)) 1201 | (status (cdr (assq 'status gevent))) 1202 | (start (cdr (assq 'start gevent))) 1203 | (end (cdr (assq 'end gevent))) 1204 | (ts-start (if start (gcal-ts-from-gtime start))) 1205 | (ts-end (if start (gcal-ts-from-gtime end))) 1206 | (recurrence (cdr (assq 'recurrence gevent))) 1207 | ;;(created (cdr (assq 'created gevent))) 1208 | ;;(updated (cdr (assq 'updated gevent))) 1209 | (summary (cdr (assq 'summary gevent))) 1210 | (location (cdr (assq 'location gevent))) 1211 | (ex-props (cdr (assq 'private (cdr (assq 'extendedProperties gevent))))) 1212 | (ex-prop-ord (cdr (assq 'gcalOrd ex-props))) 1213 | (ex-prop-ts-prefix (cdr (assq 'gcalTsPrefix ex-props))) 1214 | (created-on-google (and (null ex-prop-ord) (null ex-prop-ts-prefix))) 1215 | (ts-prefix (if created-on-google gcal-ts-prefix-created-on-google ex-prop-ts-prefix)) 1216 | (summary-prefix (or (cdr (assq 'gcalSummaryPrefix ex-props)) "")) 1217 | (unsupported-recurrence (cdr (assq 'gcalUnsupportedRecurrence ex-props)))) 1218 | (cond 1219 | ((not (stringp id)) 1220 | (message "invalid event id found '%s'" id) 1221 | nil) 1222 | ((string= status "cancelled") 1223 | (if include-deleted 1224 | (make-gcal-oevent :id id :ord ord :deleted t) 1225 | nil)) 1226 | (t 1227 | (make-gcal-oevent 1228 | :id id 1229 | :ord ord 1230 | :summary (gcal-org-remove-summary-prefix summary-prefix summary) 1231 | :ts-prefix ts-prefix 1232 | :ts-start ts-start 1233 | :ts-end (gcal-ts-end-inclusive ts-start ts-end) 1234 | :recurrence (or recurrence 1235 | (if (stringp unsupported-recurrence) 1236 | (read unsupported-recurrence))) 1237 | :location location 1238 | :summary-prefix summary-prefix 1239 | ))))) 1240 | 1241 | (defun gcal-org-remove-summary-prefix (summary-prefix summary) 1242 | "Removes SUMMARY-PREFIX from SUMMARY. 1243 | 1244 | [lang:ja] 1245 | SUMMARYからSUMMARY-PREFIXを取り除きます。" 1246 | (if (string-prefix-p summary-prefix summary) 1247 | (string-remove-prefix summary-prefix summary) 1248 | (display-warning 1249 | :error 1250 | (format "gcal.el: prefix of summary has changed: 1251 | prefix before change: \"%s\" 1252 | summary from google calender: \"%s\"" 1253 | summary-prefix summary)) 1254 | summary)) 1255 | 1256 | (defun gcal-org-google-supported-recurrence-p (recurrence) 1257 | "Returns t if recurrence is supported by Google Calendar. Returns 1258 | t if recurrence is nil. 1259 | 1260 | Google Calendar doesn't seem to support FREQ=HOURLY. I can't find 1261 | any UI to set the timely repetition. 1262 | 1263 | [lang:ja] 1264 | Googleカレンダーがサポートしているrecurrenceならtを返します。 1265 | recurrenceがnilのときはtを返します。 1266 | 1267 | GoogleカレンダーはFREQ=HOURLYをサポートしていないようです。時間毎 1268 | の繰り返しを設定するUIも見当たりません。" 1269 | ;; @todo RRULEの書き方全てを考慮していない。というかどのような書き方ができるか把握していない。全体を;で分割してしまって良いのか不明。 1270 | (not (seq-some 1271 | (lambda (rrule) 1272 | (if (and (stringp rrule) 1273 | (string-prefix-p "RRULE:" rrule)) 1274 | (let* ((props-str (substring rrule (length "RRULE:"))) 1275 | (props (mapcar 1276 | (lambda (prop) 1277 | (if (string-match "\\`\\([^=]+\\)=\\(.*\\)\\'" 1278 | prop) 1279 | (cons 1280 | (match-string-no-properties 1 prop) 1281 | (match-string-no-properties 2 prop)) 1282 | (cons prop nil))) 1283 | (split-string props-str ";"))) 1284 | (freq (cdr (assoc "FREQ" props)))) 1285 | ;; Unsupported FREQ 1286 | (and 1287 | (stringp freq) 1288 | (or 1289 | (string= freq "HOURLY") 1290 | (string= freq "MINUTELY") 1291 | (string= freq "SECONDLY")))) 1292 | ;; not string or not RRULE: 1293 | t)) 1294 | recurrence))) 1295 | 1296 | 1297 | ;; Convert event id 1298 | 1299 | (defun gcal-oevent-id-to-gevent-id (uuid) 1300 | "Converts oevent ID (UUID) to Google Calendar event ID representation. 1301 | Convert to base32hex. 1302 | 1303 | [lang:ja] 1304 | oeventのID(UUID)をGoogle CalendarのイベントID表現へ変換します。 1305 | base32hexへ変換します。" 1306 | (if (gcal-uuid-p uuid) 1307 | (downcase (gcal-uuid-to-base32hex uuid)) 1308 | uuid)) 1309 | 1310 | (defun gcal-oevent-gevent-id (oevent) 1311 | "Obtain the Google Calendar event ID from the gcal-oevent structure OEVENT. 1312 | 1313 | If there are multiple timestamps in the same entry, separate IDs 1314 | will be assigned. 1315 | 1316 | [lang:ja] 1317 | gcal-oevent構造体OEVENTからGoogle CalendarのイベントIDを求めます。 1318 | 同一エントリー内に複数のタイムスタンプがある場合に別々のIDを振り 1319 | ます。" 1320 | (let ((gid (gcal-oevent-id-to-gevent-id (gcal-oevent-id oevent))) 1321 | (ord (gcal-oevent-ord oevent))) 1322 | (if (= ord 0) 1323 | gid ;;0のときはそのまま。代表ID。Google Calendarから取り込んだイベントは必ずこれ。 1324 | (format "%s%05d" gid ord)))) 1325 | 1326 | (defun gcal-oevent-base32hex-uuid-p (id) 1327 | ;; i5o7hja5ch1r14crqmp8g9mv6k 1328 | (and (gcal-base32hex-p id) (= (length id) 26))) 1329 | 1330 | (defun gcal-oevent-base32hex-uuid-with-ord-p (id) 1331 | ;; i5o7hja5ch1r14crqmp8g9mv6k00001 1332 | (and (gcal-base32hex-p id) 1333 | (= (length id) (+ 26 5)) 1334 | (not (seq-some (lambda (c) (not (and (>= c ?0) (<= c ?9)))) 1335 | (substring id 26))))) 1336 | 1337 | (defun gcal-oevent-base32hex-uuid-irreversible-p (id) 1338 | "If ID is a base32hex representation of a UUID, and it does not 1339 | return to ID when converted to UUID and then back to 1340 | base32hex (if it is irreversible), returns t. For some reason, 1341 | events created with Google Calendar sometimes have such IDs. 1342 | 1343 | [lang:ja] 1344 | ID がUUIDのbase32hex表記であり、かつ、UUIDへ変換して再度 1345 | base32hexに変換したときに ID に戻らないなら(不可逆なら) t を返し 1346 | ます。Googleカレンダーで作成した予定はなぜかそのようなIDを持つこ 1347 | とがあります。" 1348 | ;; ex: 08upbl98ch96ef8s14lg3f0r8v => t 1349 | ;; ex: 08upbl98ch96ef8s14lg3f0r8s => nil 1350 | (and (gcal-base32hex-p id) (= (length id) 26) 1351 | ;; 26文字目の5ビットの内下位2ビットが非0のとき、それをUUIDに変 1352 | ;; 換すると元のbase32hex表記に戻らない。 1353 | ;; 26文字目の下位2ビットは変換後の17バイト目の値で捨てられるので。 1354 | (/= 0 (logand 3 (cl-position (upcase (elt id 25)) gcal-base32hex-table))))) 1355 | 1356 | (defun gcal-oevent-id-ord-from-gevent-id (id) 1357 | "Convert Google Calendar's event id to oevent's :id and :ord." 1358 | (cond 1359 | ;; base32hex-uuid + ord 1360 | ;; (ex: i5o7hja5ch1r14crqmp8g9mv6k00001) 31文字 1361 | ((gcal-oevent-base32hex-uuid-with-ord-p id) 1362 | (let ((b32h-id (substring id 0 26)) 1363 | (ord (string-to-number (substring id 26 (+ 26 5))))) 1364 | (if (gcal-oevent-base32hex-uuid-irreversible-p b32h-id) 1365 | ;; 不可逆ならしかたないのでbase32hexのままにする。 1366 | (cons b32h-id ord) ;;(base32hex-uuid(26文字) . ord) 1367 | (cons (gcal-uuid-from-base32hex b32h-id) ord)))) ;;(uuid(36文字) . ord) 1368 | 1369 | ;; base32hex-uuid 1370 | ;; (ex: i5o7hja5ch1r14crqmp8g9mv6k) 26文字 1371 | ((gcal-oevent-base32hex-uuid-p id) 1372 | (if (gcal-oevent-base32hex-uuid-irreversible-p id) 1373 | ;; 不可逆ならしかたないのでbase32hexのままにする。 1374 | (cons id 0) ;;(base32hex-uuid . 0) 1375 | (cons (gcal-uuid-from-base32hex id) 0))) ;;(uuid . 0) 1376 | 1377 | ;; unknown 1378 | (t 1379 | (cons id 0)))) 1380 | 1381 | 1382 | 1383 | 1384 | ;;;; oevent event operation 1385 | 1386 | 1387 | (defun gcal-oevent-insert (calendar-id oevent) 1388 | ;;[Async] 1389 | (gcal-events-insert calendar-id (gcal-oevent-to-gevent oevent))) 1390 | 1391 | (defun gcal-oevent-update (calendar-id oevent) 1392 | ;;[Async] 1393 | (gcal-events-update calendar-id (gcal-oevent-gevent-id oevent) (gcal-oevent-to-gevent oevent))) 1394 | 1395 | (defun gcal-oevent-patch (calendar-id old-oevent new-oevent) 1396 | (if-let ((delta-gevent (gcal-org-diff-gevents 1397 | (gcal-oevent-to-gevent old-oevent) 1398 | (gcal-oevent-to-gevent new-oevent)))) 1399 | (progn 1400 | (gcal-log "gcal-oevent-patch delta=%s" delta-gevent) 1401 | ;;[Async] 1402 | (gcal-events-patch 1403 | calendar-id 1404 | (gcal-oevent-gevent-id new-oevent) 1405 | delta-gevent)) 1406 | ;; No differences (gcal-succeeded-p nil)=>t 1407 | nil)) 1408 | 1409 | (defun gcal-oevent-delete (calendar-id oevent) 1410 | ;;[Async] 1411 | (gcal-events-delete calendar-id (gcal-oevent-gevent-id oevent))) 1412 | 1413 | 1414 | (defun gcal-oevents-insert (calendar-id oevents) 1415 | (gcal-async-wait-all 1416 | (dolist (oevent oevents) 1417 | ;;[Async] 1418 | (gcal-oevent-insert calendar-id oevent)) 1419 | nil)) 1420 | 1421 | (defun gcal-oevents-delete (calendar-id oevents) 1422 | (gcal-async-wait-all 1423 | (dolist (oevent oevents) 1424 | ;;[Async] 1425 | (gcal-oevent-delete calendar-id oevent)) 1426 | nil)) 1427 | 1428 | 1429 | 1430 | 1431 | 1432 | 1433 | 1434 | 1435 | ;;;; oevent timestamp representation 1436 | 1437 | ;; (year month day hour minite) 1438 | ;; 1439 | ;; Examples: 1440 | ;; (gcal-ts-to-time '(2016 5 27 nil nil)) => (22343 3952) 1441 | ;; (gcal-ts-date-only '(2016 5 27 12 34)) => nil 1442 | ;; (gcal-ts-inc '(2016 5 27 12 34)) => (2016 5 27 12 35) 1443 | ;; (gcal-ts-to-gtime '(2016 5 27 12 34)) => ((dateTime . "2016-05-27T12:34:00+09:00") (date)) 1444 | ;; 1445 | 1446 | (defun gcal-ts-to-time (ts) 1447 | "Convert timestamp to emacs internal time." 1448 | (apply 'gcal-time-from-ymdhm ts)) 1449 | 1450 | (defun gcal-ts-from-time (time date-only) 1451 | "Convert emacs internal time to timestamp." 1452 | (if time 1453 | (let ((d (decode-time time))) 1454 | (if date-only (list (nth 5 d) (nth 4 d) (nth 3 d) nil nil) 1455 | (list (nth 5 d) (nth 4 d) (nth 3 d) (nth 2 d) (nth 1 d)))))) 1456 | 1457 | (defun gcal-ts-date-only (ts) 1458 | (null (nth 3 ts))) 1459 | 1460 | (defun gcal-ts-inc (ts) 1461 | (let ((date-only (gcal-ts-date-only ts)) 1462 | (y (nth 0 ts)) 1463 | (m (nth 1 ts)) 1464 | (d (nth 2 ts)) 1465 | (hh (nth 3 ts)) 1466 | (mm (nth 4 ts))) 1467 | (list y m (if date-only (1+ d) d) hh (if date-only mm (1+ mm))))) 1468 | 1469 | (defun gcal-ts-end-exclusive (_ts-start ts-end) 1470 | "Correct the end date TS-END so that it does not include that day itself. 1471 | 1472 | [lang:ja] 1473 | 終了日がその日自身を含まないように補正します。" 1474 | (if (gcal-ts-date-only ts-end) ;;<2016-05-26 Thu>--<2016-05-27 Fri> => 28 1475 | (gcal-ts-inc ts-end) 1476 | ;; <2016-05-26 Thu 15:00-15:00> ;; => 15:00 (not 15:01) 1477 | ;; <2016-05-26 Thu 15:00-16:00> ;; => 16:00 (not 16:01) 1478 | ts-end)) 1479 | 1480 | (defun gcal-ts-end-inclusive (ts-start ts-end) 1481 | "Reverse `gcal-ts-end-exclusive'." 1482 | (if (and ts-end (gcal-ts-date-only ts-end)) 1483 | (let* ((t-start (gcal-ts-to-time ts-start)) 1484 | (t-end (gcal-ts-to-time ts-end)) 1485 | (t-end-1 (time-subtract t-end (seconds-to-time (* 24 60 60))))) 1486 | (gcal-ts-from-time 1487 | (if (time-less-p t-start t-end-1) t-end-1 t-start) t)) 1488 | ts-end)) 1489 | 1490 | 1491 | (defun gcal-ts-to-gtime (ts) 1492 | "Convert timestamp to Google Calendar's event time." 1493 | (gcal-time-to-gtime (gcal-ts-to-time ts) (gcal-ts-date-only ts))) 1494 | 1495 | (defun gcal-ts-from-gtime (gtime) 1496 | "Convert Google Calendar's event time to timestamp." 1497 | (let* ((time (gcal-time-from-gtime gtime)) 1498 | (dect (if time (decode-time time)))) 1499 | (if dect 1500 | (if (gcal-gtime-date-str gtime) 1501 | ;; date-only 1502 | (list (nth 5 dect) (nth 4 dect) (nth 3 dect) nil nil) 1503 | ;; date and time 1504 | (list (nth 5 dect) (nth 4 dect) (nth 3 dect) (nth 2 dect) (nth 1 dect)))))) 1505 | 1506 | 1507 | (defun gcal-ts-equal-date (ts1 ts2) 1508 | (and 1509 | (= (nth 0 ts1) (nth 0 ts2)) 1510 | (= (nth 1 ts1) (nth 1 ts2)) 1511 | (= (nth 2 ts1) (nth 2 ts2)))) 1512 | 1513 | (defun gcal-ts-format-org (ts) 1514 | "ex: <2016-05-28 Sat> or <2016-05-28 Sat 12:34>" 1515 | (format-time-string 1516 | (org-time-stamp-format (not (gcal-ts-date-only ts)) nil) 1517 | (gcal-ts-to-time ts))) 1518 | 1519 | (defun gcal-ts-format-org-range (ts-start ts-end recurrence) 1520 | (gcal-ts-append-repeater 1521 | (cond 1522 | ;; <2016-05-28 Sat> or <2016-05-28 Sat 12:34> 1523 | ((equal ts-start ts-end) 1524 | (gcal-ts-format-org ts-start)) 1525 | ;; <2016-05-28 Sat 01:23-12:34> 1526 | ((and (not (gcal-ts-date-only ts-start)) 1527 | (gcal-ts-equal-date ts-start ts-end)) 1528 | (concat 1529 | (substring (gcal-ts-format-org ts-start) 0 -1) 1530 | (format-time-string "-%H:%M>" (gcal-ts-to-time ts-end)))) 1531 | ;; <2016-05-28 Sat ??:??>--<2016-05-29 Sun ??:??> 1532 | (t 1533 | (concat 1534 | (gcal-ts-format-org ts-start) 1535 | "--" 1536 | (gcal-ts-format-org ts-end)))) 1537 | recurrence)) 1538 | 1539 | (defun gcal-ts-append-repeater (ts-str recurrence) 1540 | "Adds a repeater generated from RECURRENCE to the timestamp string TS-STR. 1541 | 1542 | [lang:ja] 1543 | タイムスタンプ文字列TS-STRにRECURRENCEから生成したリピーターを付 1544 | 加したものを返します。" 1545 | (if recurrence 1546 | (if-let ((repeater (gcal-ts-repeater-from-recurrence recurrence))) 1547 | (concat 1548 | (substring ts-str 0 -1) 1549 | repeater 1550 | (substring ts-str -1)) 1551 | ;;Unsupported recurrence 1552 | ts-str) 1553 | ts-str)) 1554 | 1555 | (defun gcal-ts-repeater-from-recurrence (recurrence) 1556 | "Converts RECURRENCE to the repeater part of a timestamp. 1557 | 1558 | If conversion is not possible (RECURRENCE is nil, unsupported 1559 | specifications, etc.), nil is returned. 1560 | 1561 | [lang:ja] 1562 | RECURRENCEをタイムスタンプのリピーター部分に変換します。 1563 | 1564 | 変換できない場合(RECURRENCEがnil、対応していない指定等)の場合はnilを返します。" 1565 | (if (and (sequencep recurrence) (= (length recurrence) 1)) 1566 | (let ((str (elt recurrence 0))) 1567 | ;;@todo 同じ意味になる様々な表記に対応する。少なくともGoolgeカレンダーで指定が出来てorg-modeのタイムスタンプで対応できる表記は網羅したい。 1568 | ;; - 毎日 "RRULE:FREQ=DAILY" ← OK 1569 | ;; - 毎週月曜日 "RRULE:FREQ=WEEKLY;BYDAY=MO" ←日付が月曜なら +1wにしたい 1570 | ;; - 毎月 "RRULE:FREQ=MONTHLY" ← OK 1571 | ;; - 毎年 "RRULE:FREQ=YEARLY" ← OK 1572 | ;; - 2日おき "RRULE:FREQ=DAILY;INTERVAL=2" ← OK 1573 | ;; - 毎月第1火曜日 "RRULE:FREQ=MONTHLY;BYDAY=1TU" ←無理 1574 | ;; - 毎月第1火曜日(終了日指定あり) "RRULE:FREQ=MONTHLY;UNTIL=20210405T145959Z;BYDAY=1TU" ←無理 1575 | ;; - 毎週月～金 "RRULE:FREQ=WEEKLY;WKST=SU;BYDAY=FR,MO,TH,TU,WE" ←無理 1576 | (if (and (stringp str) 1577 | (string-match 1578 | "\\`RRULE:FREQ=\\([A-Z]+\\)\\(;INTERVAL=\\([0-9]+\\)\\)?\\'" 1579 | str)) 1580 | (let ((freq (match-string 1 str)) 1581 | (interval (match-string 3 str))) 1582 | (if-let ((repeater-suffix 1583 | (cdr 1584 | ;; "SECONDLY" "MINUTELY" are not supported 1585 | (assoc freq '(("HOURLY" . "h") 1586 | ("DAILY" . "d") 1587 | ("WEEKLY" . "w") 1588 | ("MONTHLY" . "m") 1589 | ("YEARLY" . "y")))))) 1590 | 1591 | (concat " +" (or interval "1") repeater-suffix))))))) 1592 | ;;(gcal-ts-repeater-from-recurrence ["RRULE:FREQ=DAILY;INTERVAL=2"]) => " +2d" 1593 | 1594 | (defun gcal-ts-supported-recurrence-p (recurrence) 1595 | "Returns t if the specification is supported by RECURRENCE (can be 1596 | expressed as an org-mode timestamp). 1597 | 1598 | If RECURRENCE is nil, it returns t because it can be expressed as 1599 | a timestamp without a repeater. 1600 | 1601 | [lang:ja] 1602 | RECURRENCEが対応している(org-modeのタイムスタンプで表現できる)指 1603 | 定ならtを返します。 1604 | 1605 | RECURRENCEがnilの場合、リピーターがないタイムスタンプで表現できる 1606 | のでtを返します。" 1607 | (if recurrence 1608 | (not (null (gcal-ts-repeater-from-recurrence recurrence))) 1609 | t)) 1610 | 1611 | 1612 | ;;;; Timestamp Additional Properties 1613 | 1614 | ;; 1615 | ;; e.g. <2021-02-07 Sun>#(:recurrence ["RRULE:FREQ=WEEKLY;WKST=SU;BYDAY=FR,MO"]) 1616 | ;; 1617 | 1618 | (defun gcal-ts-get-additional-properties-range (ts-end) 1619 | "Returns the list starting with #( immediately after TS-END and its range. 1620 | Returns a list of (object begin end). 1621 | 1622 | [lang:ja] 1623 | TS-ENDの直後にある#(で始まるリストとその範囲を返します。 1624 | (object begin end)のリストを返します。" 1625 | (save-excursion 1626 | (if (integerp ts-end) 1627 | (goto-char ts-end)) 1628 | (when (string= (buffer-substring-no-properties (point) 1629 | (min (+ (point) 2) (point-max))) 1630 | "#(") 1631 | (goto-char (1+ (point))) 1632 | (save-restriction 1633 | (if (eq major-mode 'org-mode) 1634 | (org-narrow-to-subtree)) 1635 | (ignore-errors 1636 | (let ((begin (point)) 1637 | (object (read (current-buffer))) 1638 | (end (point))) 1639 | (list object begin end))))))) 1640 | 1641 | (defun gcal-ts-get-additional-properties (ts-node) 1642 | "Returns a list starting with #( immediately after the timestamp TS. 1643 | 1644 | [lang:ja] 1645 | タイムスタンプ直後にある#(で始まるリストを返します。" 1646 | (car 1647 | (gcal-ts-get-additional-properties-range 1648 | (org-element-property :end ts-node)))) 1649 | 1650 | (defun gcal-ts-get-additional-property (ts-node key) 1651 | "Get a value of property KEY from the list starting with #( 1652 | immediately after the timestamp TS. 1653 | 1654 | [lang:ja] 1655 | タイムスタンプ直後にある#(で始まるリストからプロパティを取得します。" 1656 | (plist-get (gcal-ts-get-additional-properties ts-node) key)) 1657 | 1658 | (defun gcal-ts-set-additional-property (ts-end key value) 1659 | "Set a property KEY to VALUE in the list starting with #( 1660 | immediately after TS-END. 1661 | 1662 | [lang:ja] 1663 | TS-ENDの直後にある#(で始まるリストにプロパティを設定します。" 1664 | (let* ((plist-range (gcal-ts-get-additional-properties-range ts-end)) 1665 | (plist (car plist-range)) 1666 | (begin (cadr plist-range)) 1667 | (end (caddr plist-range))) 1668 | (setq plist (plist-put plist key value)) 1669 | ;; Replace 1670 | (save-excursion 1671 | (if (and begin end) 1672 | ;; Delete existing region 1673 | (progn 1674 | (delete-region begin end) 1675 | (goto-char begin)) 1676 | ;; Add new # 1677 | (goto-char ts-end) 1678 | (insert "#")) 1679 | ;; Insert object 1680 | (insert (prin1-to-string plist))))) 1681 | 1682 | (defun gcal-ts-delete-additional-property (ts-end key) 1683 | "Delete property KEY from the list starting with #( immediately after TS-END. 1684 | 1685 | [lang:ja] 1686 | TS-END直後にある#(で始まるリストからプロパティを削除します。" 1687 | (if-let ((plist-range (gcal-ts-get-additional-properties-range ts-end))) 1688 | (let ((plist (car plist-range)) 1689 | (begin (cadr plist-range)) 1690 | (end (caddr plist-range))) 1691 | (setq plist (org-plist-delete plist key)) 1692 | (if (null plist) 1693 | ;; Delete #( to ) 1694 | (delete-region (1- begin) end) 1695 | ;; Replace 1696 | (delete-region begin end) 1697 | (save-excursion 1698 | (goto-char begin) 1699 | (insert (prin1-to-string plist))))))) 1700 | 1701 | (provide 'gcal-org) 1702 | ;;; gcal-org.el ends here 1703 | --------------------------------------------------------------------------------