Zander671/random-scripts
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added cl/khal-notify.lisp

Browse Source
This commit is contained in:
Alexander Rosenberg 2023-09-28 22:28:06 -07:00
parent 8baf8d982d
commit fef6a2f54c
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
4 changed files with 200 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
cl/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
bin/

16
cl/Makefile Normal file
View File

@ -0,0 +1,16 @@
files := $(wildcard *.lisp)
names := $(files:.lisp=)
.PHONY: all clean $(names)
all: $(names)
$(names): %: bin/%
bin/%: %.lisp build-binary.sh Makefile
mkdir -p bin
./build-binary.sh $<
mv $(@F) bin/
clean:
rm -rf bin man

14
cl/build-binary.sh Executable file
View File

@ -0,0 +1,14 @@
#!/bin/sh
if [ "$#" -lt 1 ]; then
echo "No input file!" 1>&2
exit 1
fi
bin_name="$(basename "$1" .lisp)"
sbcl --load "$1" \
--eval "(sb-ext:save-lisp-and-die \"$bin_name\"
:executable t
:save-runtime-options t
:toplevel '$bin_name:toplevel)"

169
cl/khal-notify.lisp Normal file
View File

@ -0,0 +1,169 @@
(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)))