#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do cron-walk)' -s $0 "$@" # -*- scheme -*-
!#
;;; cron-walk
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;; 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version. There is NO WARRANTY. See file COPYING for details.
;;; Commentary:
;; Usage: cron-walk [OPTIONS] WHEN [DIR...]
;;
;; Options (detailed description below):
;; --debug -- enable some more output than usual
;; -l, --load FILE -- load FILE prior to starting
;; -c, --config FILE -- set options and DIRs from FILE
;;
;; Find executable .cron files under DIR(s), skipping all symlinks, and
;; load them DFS-style (parent dir last) w/ single arg WHEN, first changing
;; to that directory. Output is collected and mailed out only on failure.
;; Loading is done into a child process, with the ‘command-line’ proc
;; rewritten. At least one DIR must be specified (but see "-c" below).
;;
;; Command-line option "--load FILE" (or "-l FILE" for short) loads FILE
;; prior to doing the walk. This option can be given multiple times.
;;
;; Command-line option "--config FILE" (or "-c FILE" for short) means to
;; read FILE to set options and directories. The configuration file is
;; series of forms, the first of which is an alist supporting keys:
;;
;; * templates (required)
;; The value is a sub-alist with keys ‘lock’ and ‘log’. The
;; associated value is a string, with exactly one "~A" in it which
;; will be substituted with WHEN, which specifies a filename for
;; the lockfile and the logfile, respectively.
;; * debug (optional)
;; If specified and the value is non-‘#f’, equivalent to
;; specifying --debug on the command line.
;; * load (optional)
;; The value is a list of files to be loaded, equivalent to
;; specifying --load FILE1 --load FILE2... on the command line.
;;
;; The rest of the configuration file are a series of flat lists of the
;; form: (WHEN DIR...), where WHEN is a symbol and each DIR a string.
;;
;; Dependencies: Env var "DEBUG_CRON_WALK" set causes output logs to be mailed
;; regardless of .cron return value. This can also be enabled w/ command-line
;; option "--debug". Env vars "MAILTO", "USER" and "LOGNAME" are consulted in
;; that order to determine the mail recipient.
;;
;; Env var CRON_WALK_CONFIGURATION with value FILE is the same as specifying
;; --config FILE. However, the command-line option takes precedence.
;;; Code:
(define-module (ttn-do cron-walk)
#:export-syntax (cron!)
#:export (main)
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((ttn-do mogrify) #:select (editing-buffer))
#:use-module ((ice-9 popen) #:select (open-output-pipe close-pipe))
#:use-module ((srfi srfi-1) #:select (any take drop))
#:use-module ((ice-9 ftw) #:select (nftw))
#:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-port))
#:use-module ((ttn-do zzz publishing) #:select (flatten-to smhdwy))
#:use-module ((ttn-do zzz personally) #:select (whatever
FE fs fso fse make-fso))
#:use-module ((ttn-do zzz filesystem) #:select (safe-rewind
temporary-file-port
dir-exists?
filename-components
filename-components-append
expand-file-name)))
(define META-PID (getpid))
(define kids (make-object-property))
;; rfc: reversed filename components, "/home/ttn/foo" <=> (foo ttn home)
(define (rfc<- source kls)
(let ((rfc (if (string? source)
(reverse! (map string->symbol (filename-components source)))
source)))
(set! (kids rfc) kls)
rfc))
(define (filename<- rfc)
(filename-components-append (reverse! (map symbol->string rfc))))
(define-macro (pushnew x place) ; TODO: Move up.
`(or (member ,x ,place)
(set! ,place (cons ,x ,place))))
(define (find-roots dirs)
(let ((roots (list))
(pchain (list)))
(define (find! filename statinfo flag base level)
(and (eq? 'directory flag)
(access? (string-append filename "/.cron") X_OK)
(let* ((rfc (rfc<- filename '()))
(rlen (length rfc)))
;; Find parent and add as kid there.
;; If no parent, add to ‘roots’.
(let loop ((ls pchain))
(let* ((par ((if (null? ls) identity car) ls))
(len (length par)))
(cond ((null? ls)
(pushnew rfc roots)
(set! pchain (list rfc)))
((any (lambda (i)
(and (equal? par (take (drop rfc i) len))
(rfc<- (take rfc i) '())))
(map 1+ (iota (- rlen len))))
=> (lambda (sub)
(pushnew sub (kids par))
(set! pchain (cons sub ls))))
(else
(loop (cdr ls))))))))
#t)
(FE dirs (lambda (dir)
(nftw dir find! 'physical)))
roots))
(define (cron-walk spewful? job-type dirs)
(define (w/tree prefix tree)
(string-append prefix (filename<- tree)))
(define (timestamp! log blurb)
((make-fso log) "| ~A: ~A~%" blurb (gettimeofday)))
(define ((child dir) sub)
(let ((subdir (w/tree dir sub))
(log (temporary-file-port))
(pid (whatever)))
(setvbuf log _IOLBF)
(timestamp! log 'BEG)
(set! pid (primitive-fork))
(cond ((zero? pid)
(go! dir sub)
(set-current-output-port log)
(set-current-error-port log)
;; Protect these bindings.
(let ((exit exit) (quit quit))
(chdir subdir)
(load-from-path (expand-file-name ".cron"))
(quit #t)))
(else
(and spewful? (fso "KICK:\t~A\t~A\t~A~%" (getpid) pid subdir))
;; This is a "rec"ommenced "rec"ursion "rec"ord (yuk yuk).
(cons* pid log subdir)))))
;; Accessors for a ‘child’s rv.
(define (-pid rec) (car rec)) ; integer
(define (-log rec) (cadr rec)) ; rw port
(define (-sub rec) (cddr rec)) ; string
(define (go! prefix tree)
(let* ((dir (w/tree prefix tree))
(recs (map (child dir) (kids tree))))
(and spewful?
(or (null? recs)
(fso "F[~A]: ~S ~S~%" (getpid) dir
(map cons
(map -pid recs)
(map reverse (kids tree))))))
(let loop ()
(cond ((null? recs)
(and spewful?
(or (null? (kids tree))
(fso "G[~A]: ~S~%" (getpid) dir))))
((waitpid WAIT_MYPGRP)
=> (lambda (x)
(let* ((me (getpid))
(pid (car x))
(rec (assq pid recs))
(log (-log rec))
(res (cdr x)))
(timestamp! log 'END)
((make-fso log) "| res: ~A~%" res)
(fso "~A\t~A\t~A\t ~A ~A~%" res me pid
(if (= META-PID me) #\* #\space)
(-sub rec))
(or (and (not spewful?)
(zero? res))
(let ((p (open-output-pipe
(fs "mail -s'~A~A (~A) ~A' ~A"
(if spewful? "(DEBUG_CRON_WALK) " "")
job-type res (-sub rec)
(or (getenv "MAILTO")
(getenv "USER")
(getenv "LOGNAME")
"root")))))
(safe-rewind log)
(editing-buffer log
(write-to-port p))
(force-output p)
(close-pipe p)))
(set! recs (assq-remove! recs pid))
(loop))))
(else
(loop))))))
(define ((spew indent) x)
(let ((subs (kids x))
(dir (filename<- x)))
(fso "\t\t\t | ~A~A~%" (make-string indent #\space) dir)
(FE subs (spew (+ indent (string-length dir))))))
;; Do it!
(let ((roots (find-roots dirs)))
(fso "~A cron-walk: pid ~A~%~%" job-type META-PID)
(FE roots (spew 0))
(or (null? roots)
(fso "~%retval\tparent\tchild\t(* root) directory~%"))
(go! "" (rfc<- '() roots))))
(define (lockwalk jfile spewful? job-type dirs)
(define (pretty-time seconds)
(strftime "%a %F %T" (localtime seconds)))
(let ((lock-file (jfile 'lock))
(tmp (temporary-file-port)))
;; lock
(cond ((file-exists? lock-file)
(fse "cron-walk: found lock file ~A (~A)~%"
lock-file (pretty-time (stat:mtime (stat lock-file))))
(exit #f)))
(with-output-to-file lock-file
(lambda () (fso "pid: ~A~%" (getpid))))
;; do the job
(let ((cur-out (current-output-port))
(cur-err (current-error-port)))
(setvbuf tmp _IONBF)
(set-current-output-port tmp)
(set-current-error-port tmp)
(cron-walk spewful? job-type dirs)
(set-current-output-port cur-out)
(set-current-error-port cur-err))
;; record time spent
(let* ((beg (stat:mtime (stat lock-file)))
(end (current-time))
(dt (- end beg))
(log (open-output-file (jfile 'log)))
(flog (make-fso log)))
(FE (sort (environ) string<?) (lambda (v) (flog "~A~%" v)))
(flog "------~%")
(flog "beg: ~A (~A)~%" beg (pretty-time beg))
(flog "end: ~A (~A)~%" end (pretty-time end))
(flatten-to log (list "dur: "
(smhdwy dt " ")
(fs " (~As)~%~%" dt)))
(safe-rewind tmp)
(editing-buffer tmp
(write-to-port log))
(close-port tmp)
(close-port log))
;; remove lock
(delete-file lock-file)))
(define (main/qop qop)
(define (badness s . args)
(apply fse (string-append "cron-walk: " s "~%") args)
(exit #f))
(let ((cl (qop '()))
(config #f))
(and (null? cl) (badness "Missing required arg WHEN"))
(and=> (or (qop 'config) (getenv "CRON_WALK_CONFIGURATION"))
(lambda (filename)
(let* ((port (open-input-file filename))
;; Guile 1.4.1.119 and later provide more useful information,
;; so we will be able to use ‘catch’, then. For now...
(forms (or (false-if-exception (forms<-port port))
(begin
(fse "~A:~A: read error~%" filename
(1+ (port-line port)))
(badness "Bad config")))))
(close-port port)
(set! config (car forms))
(let* ((when (string->symbol (car cl)))
(dirs (or (assq-ref (cdr forms) when)
(badness "No ‘~A’ config in ~A"
when filename))))
(set-cdr! cl dirs)))))
(or (< 1 (length cl))
(badness "No directories specified"))
(let ((when (car cl))
(dirs (cdr cl)))
(define (check-dir dir)
(let ((full (expand-file-name dir)))
(or (dir-exists? full)
(badness "No such directory: ~A" dir))
full))
(define (check/load ls)
(FE ls (lambda (filename)
(let ((full (expand-file-name filename)))
(or (access? full F_OK)
(badness "No such file: ~A" filename))
(or (access? full R_OK)
(badness "Cannot read: ~A" filename))
(load-from-path full)))))
(set! dirs (map check-dir dirs))
(and=> (and config (assq-ref config 'load)) check/load)
(qop 'load check/load)
(set! command-line (lambda ()
(list ".cron" when)))
(let ((common-args (list (or (getenv "DEBUG_CRON_WALK")
(and config (assq-ref config 'debug))
(qop 'debug))
when dirs)))
(if config
(apply lockwalk
(let ((templates (assq-ref config 'templates)))
(lambda (x)
(fs (expand-file-name (assq-ref templates x)) when)))
common-args)
(apply cron-walk common-args))))
#t))
(define (main args)
(check-hv args '((package . "ttn-do")
(version . "2.6")
;; 2.6 -- support ‘--config’ / CRON_WALK_CONFIGURATION
;; 2.5 -- bugfix: set stdout unbuffered
;; 2.4 -- recursion, baby! + ‘cron!’ simplification
;; 2.3 -- ‘cron!’ supports CRON_BANG_ANNOUNCE
;; 2.2 -- (for scheme) provide ‘cron!’
;; 2.1 -- display simple stats if --debug
;; 2.0 -- use "load" instead of "system", support ‘--load’
;; 1.2 -- supports command-line option ‘--debug’
;; 1.1 -- supports env var ‘DEBUG_CRON_WALK’
;; 1.0 -- plain
(help . commentary)))
(setvbuf (current-output-port) _IONBF)
(main/qop
(qop<-args
args '((debug)
(config (single-char #\c) (value #t))
(load (single-char #\l) (value #t)
(merge-multiple? #t))))))
;; (Actually, this is a special-form, not a procedure.)
;;
;; Examine @code{(command-line)} and invoke one of the @var{handlers}.
;;
;; @var{handlers} is one or more forms:
;; @lisp
;; ((KEY) BODY...)
;; @end lisp
;;
;; @var{key} is one or more symbols.
;; @var{body} is one or more forms, to be evaluated in order if
;; @code{(cadr (command-line))} matches @var{key}.
;;
;; If @code{(command-line)} does not return a list of exactly two
;; elements, display a usage message and throw an error. If
;; no matching key is found, exit successfully, otherwise, exit with the
;; value of the last body form evaluated. For example:
;;
;; @example
;; #!/usr/local/bin/guile -s
;; !#
;; (use-modules ((ttn-do cron-walk) #:select (cron!)))
;; (cron! ((hourly) (display "yawn, stretch") (newline))
;; ((daily) (display "zonk") (newline)))
;; @end example
;;
(define-macro (cron! . handlers)
(and (null? handlers)
(error "cron!: No handlers specified."))
`(let* ((triggers ',(apply append (map car handlers)))
(fs ,fs)
(cl (command-line))
(x (if (null? (cdr cl))
(error (fs "~A~%Usage: ~A JOB~% jobs: ~A"
"No job type specified"
(car cl) triggers))
(string->symbol (cadr cl)))))
(and (getenv "CRON_BANG_ANNOUNCE")
(display (fs ";;; ~A ~A ~S~%" (car cl) x triggers)))
(exit (case x
,@handlers
(else #t)))))
;;; cron-walk ends here