170 lines
7.6 KiB
Common Lisp
170 lines
7.6 KiB
Common Lisp
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
|
|
(ql:quickload '(with-user-abort chronicity
|
||
|
|
cl-ppcre adopt uiop) :silent t))
|
||
|
|
|
||
|
|
(defpackage :khal-notify
|
||
|
|
(:use :cl)
|
||
|
|
(:export :toplevel))
|
||
|
|
|
||
|
|
(in-package :khal-notify)
|
||
|
|
|
||
|
|
(defun run-khal (&rest args)
|
||
|
|
(multiple-value-bind (out err code)
|
||
|
|
(uiop:run-program `("khal" . ,args)
|
||
|
|
:output :string
|
||
|
|
:error-output nil
|
||
|
|
:ignore-error-status t)
|
||
|
|
(declare (ignore err))
|
||
|
|
(when (= code 0)
|
||
|
|
out)))
|
||
|
|
|
||
|
|
(defun notify-send (summary content &optional (time 0))
|
||
|
|
(uiop:launch-program `("notify-send"
|
||
|
|
"-t" ,(princ-to-string time)
|
||
|
|
,summary ,content)))
|
||
|
|
|
||
|
|
(defun get-calendar-dir-hash-table ()
|
||
|
|
(let ((output (make-hash-table :test 'equal)))
|
||
|
|
(dolist (dir (directory #P"~/.local/share/vdirsyncer/*/*") output)
|
||
|
|
(unless (pathname-match-p dir #P"~/.local/share/vdirsyncer/status/*/")
|
||
|
|
(let ((dir-name (car (last (pathname-directory dir)))))
|
||
|
|
(setf (gethash dir-name output) dir))))))
|
||
|
|
|
||
|
|
(defun remove-trailing-return (str)
|
||
|
|
(let ((len (length str)))
|
||
|
|
(if (eq (char str (1- len)) #\return)
|
||
|
|
(subseq str 0 (1- len))
|
||
|
|
str)))
|
||
|
|
|
||
|
|
(defun get-ics-file-alarms (path)
|
||
|
|
(with-open-file (stream path :direction :input :if-does-not-exist nil)
|
||
|
|
(when stream
|
||
|
|
(loop for line = (read-line stream nil)
|
||
|
|
with in-valarm = nil
|
||
|
|
and alarms = '()
|
||
|
|
and pattern = (ppcre:create-scanner "(-?)[A-Z]+([0-9]+)([DHSM]).*")
|
||
|
|
and summary = ""
|
||
|
|
and current-offset = 0
|
||
|
|
and current-notice = ""
|
||
|
|
while line
|
||
|
|
do (cond
|
||
|
|
((and (not in-valarm) (uiop:string-prefix-p "SUMMARY:" line))
|
||
|
|
(setq summary (subseq (remove-trailing-return line) 8)))
|
||
|
|
((uiop:string-prefix-p "BEGIN:VALARM" line)
|
||
|
|
(setq in-valarm t))
|
||
|
|
((uiop:string-prefix-p "END:VALARM" line)
|
||
|
|
(pushnew (cons current-notice current-offset) alarms)
|
||
|
|
(setq in-valarm nil
|
||
|
|
current-offset 0
|
||
|
|
current-notice ""))
|
||
|
|
((and in-valarm (uiop:string-prefix-p "TRIGGER:" line))
|
||
|
|
(ppcre:register-groups-bind
|
||
|
|
(negative (#'parse-integer num) unit)
|
||
|
|
(pattern (subseq line 8))
|
||
|
|
(setq current-offset
|
||
|
|
(* (if (equal negative "-") -1 1)
|
||
|
|
(cond
|
||
|
|
((equal unit "S") num)
|
||
|
|
((equal unit "M") (* num 60))
|
||
|
|
((equal unit "H") (* num 60 60))
|
||
|
|
((equal unit "D") (* num 60 60 24))
|
||
|
|
(t 0))))))
|
||
|
|
((and in-valarm (uiop:string-prefix-p "DESCRIPTION:" line))
|
||
|
|
(setq current-notice (subseq (remove-trailing-return line)
|
||
|
|
12))))
|
||
|
|
finally (return (mapcar (lambda (alarm)
|
||
|
|
(list (if (uiop:emptyp (car alarm))
|
||
|
|
summary
|
||
|
|
(car alarm))
|
||
|
|
(cdr alarm)
|
||
|
|
summary)) alarms))))))
|
||
|
|
|
||
|
|
(defstruct cal-alarm
|
||
|
|
hash uid time title event-title event-end)
|
||
|
|
|
||
|
|
(defun parse-event-line (calendar-dirs line &optional exclude-before)
|
||
|
|
(unless (uiop:emptyp line)
|
||
|
|
(destructuring-bind
|
||
|
|
(uid calendar start-date start-time end-date end-time &optional alarm-sym)
|
||
|
|
(uiop:split-string line :separator " ")
|
||
|
|
(when alarm-sym
|
||
|
|
(let* ((start (chronicity:parse (concatenate 'string
|
||
|
|
start-date
|
||
|
|
" "
|
||
|
|
start-time)))
|
||
|
|
(end (chronicity:parse (concatenate 'string
|
||
|
|
end-date
|
||
|
|
" "
|
||
|
|
end-time)))
|
||
|
|
(file (merge-pathnames (concatenate 'string uid ".ics")
|
||
|
|
(gethash calendar calendar-dirs)))
|
||
|
|
(alarms (get-ics-file-alarms file)))
|
||
|
|
(when (or (not exclude-before)
|
||
|
|
(local-time:timestamp>= end exclude-before))
|
||
|
|
(mapcar (lambda (alarm)
|
||
|
|
(destructuring-bind (title offset event-title) alarm
|
||
|
|
(let ((alarm-time (local-time:timestamp+ start
|
||
|
|
offset :sec)))
|
||
|
|
(make-cal-alarm :hash (format nil "~A~A~A~A~A"
|
||
|
|
title
|
||
|
|
alarm-time
|
||
|
|
event-title
|
||
|
|
end
|
||
|
|
uid)
|
||
|
|
:title title
|
||
|
|
:time alarm-time
|
||
|
|
:event-title event-title
|
||
|
|
:event-end end
|
||
|
|
:uid uid)))) alarms)))))))
|
||
|
|
|
||
|
|
(defun build-alarm-list (calendar-dirs &optional exclude-before)
|
||
|
|
(let* ((output (run-khal "list"
|
||
|
|
"--day-format"
|
||
|
|
""
|
||
|
|
"--format"
|
||
|
|
"{uid} {calendar} {start-date} {start-time} {end-date} {end-time}{alarm-symbol}"
|
||
|
|
"today"
|
||
|
|
"tomorrow"))
|
||
|
|
(lines (uiop:split-string output :separator '(#\newline)))
|
||
|
|
(result '()))
|
||
|
|
(dolist (line lines result)
|
||
|
|
(uiop:if-let ((alarms (parse-event-line calendar-dirs line exclude-before)))
|
||
|
|
(setq result (concatenate 'list result alarms))))))
|
||
|
|
|
||
|
|
(defun main ()
|
||
|
|
(let* ((calendar-dirs (get-calendar-dir-hash-table))
|
||
|
|
(already-notified (make-hash-table :test 'equal))
|
||
|
|
(program-start-now (local-time:now))
|
||
|
|
(alarms (build-alarm-list calendar-dirs program-start-now))
|
||
|
|
(last-update (local-time:now)))
|
||
|
|
(loop
|
||
|
|
(let ((now (local-time:now)))
|
||
|
|
(when (local-time:timestamp<= (local-time:timestamp+ last-update 1 :minute)
|
||
|
|
now)
|
||
|
|
(setq alarms (build-alarm-list calendar-dirs program-start-now))
|
||
|
|
(let ((new-notified (make-hash-table :test 'equal)))
|
||
|
|
(dolist (alarm alarms)
|
||
|
|
(when (gethash (cal-alarm-hash alarm) already-notified)
|
||
|
|
(setf (gethash (cal-alarm-hash alarm) new-notified) t)))
|
||
|
|
(setq already-notified new-notified
|
||
|
|
last-update (local-time:now))))
|
||
|
|
(dolist (alarm alarms)
|
||
|
|
(when (and (not (gethash (cal-alarm-hash alarm) already-notified))
|
||
|
|
(local-time:timestamp<= (cal-alarm-time alarm) now))
|
||
|
|
(notify-send (concatenate 'string
|
||
|
|
"Alarm for "
|
||
|
|
(cal-alarm-event-title alarm))
|
||
|
|
(cal-alarm-title alarm))
|
||
|
|
(setf (gethash (cal-alarm-hash alarm) already-notified) t)))
|
||
|
|
(sleep 10)))))
|
||
|
|
|
||
|
|
;; interface
|
||
|
|
(defmacro exit-on-ctrl-c (&body body)
|
||
|
|
`(handler-case (with-user-abort:with-user-abort (progn ,@body))
|
||
|
|
(with-user-abort:user-abort () (adopt:exit 130))))
|
||
|
|
|
||
|
|
(defun toplevel ()
|
||
|
|
(sb-ext:disable-debugger)
|
||
|
|
(exit-on-ctrl-c
|
||
|
|
(main)))
|