Chore reminder

[Jon Wilson]

Hi,
I've written a little bitty (~100 loc) program which pops up a reminder 
when chores need redoing.  They don't start counting down to timeout 
again until you indicate (by clicking on the "Completed" button) that 
you have finished them.  If anybody would have a use for it, they are 
welcome to use it, but mostly I'm looking for comments.  If you think 
there is a better way to do something that I've done, I'm very much 
interested in hearing about it.  I've decided that I've still got one 
foot in java/c/c++ styles, and that the best way to develop a sense of 
what is "best" in lispy languages is to write some code that I think is 
good and ask for comments.

To use, put the file check-chores.scm somewhere in the system $PATH, and 
make it executable.  Then run the file chore from an [ana]cron job (on 
debian based systems, put it in /etc/cron.daily).  Make a chore group 
and put any users who have chores into it.  Make a directory 
/var/spool/chore owned by root.chore, with permissions drwxrwxr-T.  
Finally, put example.chores.scm into ~/.chores.scm, and modify it to 
your heart's content.

You can run check-chores.scm yourself, or wait for the cron job to run 
chore.  Running check-chores.scm yourself will just check the chores for 
the user you run it as, the cron job simply runs check-chores.scm for 
all users in the chore group.

It won't be any use unless there is an X display on :0 at the time the 
cron job runs.  I've toyed with the idea of using email instead of 
gmessage, but decided that for right now, gmessage was good enough.  
Should work just fine on a single user system.  Oh yeah, and if you 
don't have gxmessage installed, then just change "gmessage" to 
"xmessage" in check-chores.scm.  Unless you don't have xmessage either...
Regards,
Jon

#!/usr/bin/guile \
-e main -s
!#
(use-modules (ice-9 r5rs) (ice-9 optargs) ((srfi srfi-19) :renamer 
(symbol-prefix-proc 'tm:)))

(define (main args)
  (if (zero? (getuid)) (error "Do not run this as root!  We execute untrusted 
code!"))
  (check-chores))

;;; Some utility functions to manipulate dates
(define (local-julian-day jdn)
  (+ jdn (/ (tm:date-zone-offset (tm:current-date)) (* 24 60 60))))

(define (universal-julian-day local-jdn)
  (- local-jdn (/ (tm:date-zone-offset (tm:current-date)) (* 24 60 60))))

(define (julian-local-midnight jdn)
  (universal-julian-day (- (floor (+ (local-julian-day jdn) (/ 2))) (/ 2))))

;;; Some utlity functions involving processes and file loading
(define (process-exists? PID)
  (access? (string-append "/proc/" (number->string PID)) F_OK))

(define (in-another-process thunk)
  (if (zero? (primitive-fork))
        (begin (thunk) (exit))))

(define (load-with-env filename env)
  (let ((real-current-module #f))
        (dynamic-wind
          (lambda () (set! real-current-module (current-module)) 
(set-current-module env))
          (lambda () (load filename))
          (lambda () (set-current-module real-current-module)))))

;;; Make the chore record type and functions to use it
(define chore-type (make-record-type "chore-type" '(text when-next)))
(define make-chore (record-constructor chore-type '(text when-next)))
(define chore-text (record-accessor chore-type 'text))
(define chore-when-next (record-accessor chore-type 'when-next))

;;; a couple of defaults, and a convenience function for making filenames from 
chore names
(define (*default-chore-file*) (string-append (passwd:dir (getpwuid (geteuid))) 
"/.chores.scm"))
(define *spool-dir* "/var/spool/chore")
(define (spool-filename name)
  (string-append *spool-dir* "/" (passwd:name (getpwuid (geteuid))) "." name))

(define (chore-file-module chore-table)
  (let ((m (make-module)))
        (module-define! m 'chore (lambda (name text next-calculator)
                                                           (hash-set! 
chore-table name (make-chore text next-calculator))))
        (module-define! m 'interval (lambda (n) (lambda () n)))
        (module-use! m (null-environment 5))
        m))

;;; Read in the chore list
(define* (get-chore-table #:optional (filename (*default-chore-file*)))
                 (let ((chore-table (make-hash-table)))
                   (if (access? filename R_OK)
                         (load-with-env filename (chore-file-module 
chore-table)))
                   chore-table))

(define (update-chore name chore)
  (let* ((spool-file (open-output-file (spool-filename name)))
                 (next (+ (julian-local-midnight (tm:current-julian-day))
                                  ((chore-when-next chore))))
                 (next-string (tm:date->string (tm:julian-day->date next))))
        (write (list name next next-string) spool-file)
        (close spool-file)
        next-string))

(define (lock-chore name)
  (let ((spool-file (open-output-file (spool-filename name))))
        (write (list name 'LOCKED (getpid)) spool-file)
        (close spool-file)))

(define (chore-expired? name)
  (or (not (access? (spool-filename name) R_OK))
        (let* ((spool-file (open-input-file (spool-filename name)))
                   (data (read spool-file)))
          (close spool-file)
          (or 
                (not (list? data)) ; We expect only a list in the spool file
                (not (= 3 (length data))) ; of length 3
                (if (eq? 'LOCKED (cadr data))
                  (not (process-exists? (caddr data))) ; We only consider the 
chore to be locked if the locking process is still running.
                  (> (julian-local-midnight (tm:current-julian-day)) (cadr 
data))))))) ; Finally, check to see if today is later than the date in the 
spool file.

(define (remind-chore name chore)
  (setenv "DISPLAY" ":0")
  (system* "gmessage"
                   "-buttons" "Completed:0"
                   "-name" (string-append "chore " name)
                   (chore-text chore)))

(define (check-chore name chore) ;; Check one single chore
  (if (chore-expired? name)
        (in-another-process
          (lambda ()
                (close (current-output-port))
                (close (current-error-port))
                (lock-chore name)
                (if (zero? (remind-chore name chore))
                  (update-chore name chore))))))

(define (check-chores) ;; Check all the chores in the chore table
  (hash-for-each check-chore (get-chore-table)))

#!/usr/bin/guile -s
!#
;;; This file gets a list of all the users in the chore group, and then, for 
each user, makes a new process to check each one of that user's tasks, as that 
user (su).
(let ((chore-users (group:mem (getgrnam "chore"))))
 (for-each
  (lambda (username)
   (if (zero? (primitive-fork))
        (execl "/bin/su" "/bin/su" username "-c" "check-chores.scm")))
  chore-users))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Put this file in your home directory under the name ".chores.scm"

(chore "bath-up" "Clean the upstairs bathroom" #:interval 7)
(chore "bath-down" "Clean the downstairs bathroom" #:interval 14)
(chore "kitchen-sweep" "Sweep the kitchen floor" #:interval 3)
(chore "kitchen-mop" "Mop the kitchen floor" #:interval 14)
(chore "sheets-up" "Change the sheets in the upstairs bedroom" #:interval 7)