diff --git a/cl/.gitignore b/cl/.gitignore new file mode 100644 index 0000000..6dd29b7 --- /dev/null +++ b/cl/.gitignore @@ -0,0 +1 @@ +bin/ \ No newline at end of file diff --git a/cl/Makefile b/cl/Makefile new file mode 100644 index 0000000..b0982b5 --- /dev/null +++ b/cl/Makefile @@ -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 diff --git a/cl/build-binary.sh b/cl/build-binary.sh new file mode 100755 index 0000000..a82cd1b --- /dev/null +++ b/cl/build-binary.sh @@ -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)" diff --git a/cl/khal-notify.lisp b/cl/khal-notify.lisp new file mode 100644 index 0000000..f0b1683 --- /dev/null +++ b/cl/khal-notify.lisp @@ -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)))