"Fossies" - the Fresh Open Source Software Archive 
Member "alive-2.0.5/src/body.scm" (2 Jan 2022, 12151 Bytes) of package /linux/privat/alive-2.0.5.tar.lz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style:
standard) with prefixed line numbers.
Alternatively you can here
view or
download the uninterpreted source code file.
See also the latest
Fossies "Diffs" side-by-side code changes report for "body.scm":
2.0.4_vs_2.0.5.
1 #!@GUILE@ -s
2 ;;; alive --- periodically ping some hosts
3
4 ;; Copyright (C) 2012, 2013, 2022 Thien-Thi Nguyen
5 ;;
6 ;; This file is part of GNU Alive.
7 ;;
8 ;; GNU Alive is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 3, or (at your option)
11 ;; any later version.
12 ;;
13 ;; GNU Alive is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17 ;;
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Alive. If not, see <https://www.gnu.org/licenses/>.
20 !#
21 ;;; Commentary:
22
23 ;; GNU Alive documentation is available from:
24 ;;
25 ;; - the command-line
26 ;; $ info alive
27 ;;
28 ;; - Emacs
29 ;; evaluate this form w/ ‘M-x eval-last-sexp’: (info "(alive)")
30 ;; or type ‘C-h i d m alive RET’.
31 ;;
32 ;; - possibly other places (search for alive.html or alive.pdf)
33 ;;
34 ;; Report bugs to <@PACKAGE_BUGREPORT@>.
35
36 ;;; Code:
37
38 (define ARGV (list->vector (command-line)))
39 (define ARGC (vector-length ARGV))
40
41 (define (argv n)
42 (vector-ref ARGV n))
43
44 (define (whoami)
45 (basename (argv 0)))
46
47 (and (= 2 ARGC)
48 (let ((me (whoami)))
49 (define (finish . ls)
50 (for-each display ls)
51 (newline)
52 (exit #t))
53 (case (string->symbol (argv 1))
54 ((--version)
55 (finish me " (@PACKAGE_NAME@) @PACKAGE_VERSION@
56 Copyright (C) 2012, 2022 Thien-Thi Nguyen
57 License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>
58 This is free software: you are free to change and redistribute it.
59 There is NO WARRANTY, to the extent permitted by law."))
60 ((--help)
61 (finish "Usage: " me " [option]
62
63 Options:
64 --help Display this message.
65 --version Display version and license info.
66
67 GNU Alive takes no arguments, and instead reads configuration
68 information from files in the \"config directory\", by default
69 $HOME/.alive.d/ -- see manual for details.
70
71 Report bugs to: <@PACKAGE_BUGREPORT@>
72 GNU Alive home page: <@PACKAGE_URL@>
73 General help using GNU software: <https://www.gnu.org/gethelp/>")))))
74
75 (or (= 1 ARGC)
76 (let ((me (whoami)))
77 (for-each display (list me ": Unexpected argument (try --help)"))
78 (newline)
79 (exit #f)))
80
81 (use-modules
82 ((srfi srfi-1) #:select (circular-list
83 length+
84 car+cdr))
85 ((srfi srfi-11) #:select (let-values))
86 ((srfi srfi-13) #:select (string-index
87 substring/shared
88 string-concatenate-reverse))
89 ((srfi srfi-14) #:select (char-set-complement
90 char-set-union
91 char-set:letter+digit
92 char-set))
93 ((ice-9 popen) #:select (open-input-pipe
94 close-pipe))
95 ((ice-9 rdelim) #:select (read-line))
96 ((ice-9 regex) #:select (match:suffix)))
97
98 (define (fs s . args)
99 (apply simple-format #f s args))
100
101 (define (fso s . args)
102 (apply simple-format #t s args))
103
104 (define (at moment)
105 ;; TODO: Make format string a configuration item.
106 (strftime "%F %T" (localtime (or moment (current-time)))))
107
108 (define (ok-dir dir)
109 (and dir
110 (file-exists? dir)
111 dir))
112
113 (define (config-dir-a-la-XDG)
114 (and=> (search-path (parse-path (getenv "PATH"))
115 "xdgdirs")
116 (lambda (xdgdirs)
117 (assq-ref (read (open-input-pipe (string-append xdgdirs
118 " alive")))
119 'config-home))))
120
121 (define config-item
122 (let ((dir (or (ok-dir (in-vicinity (getenv "HOME") ".alive.d"))
123 (ok-dir (config-dir-a-la-XDG))
124 *null-device*)))
125 ;; config-item
126 (lambda (nick)
127 (let ((filename (in-vicinity dir nick))
128 (mtime #f))
129
130 (define (forms)
131 (false-if-exception
132 (call-with-input-file filename
133 (lambda (port)
134 (let loop ((acc '()))
135 (let ((form (read port)))
136 (if (eof-object? form)
137 (reverse! acc)
138 (loop (cons form acc)))))))))
139
140 (define (probe)
141 (define (simply x)
142 (values x #f))
143 (cond ((and (file-exists? filename)
144 (stat:mtime (stat filename)))
145 => (lambda (new-mtime)
146 (cond ((eqv? mtime new-mtime)
147 (simply 'no-change))
148 (else
149 (set! mtime new-mtime)
150 (values mtime (forms))))))
151 ((eqv? 0 mtime)
152 (simply 'still-unspecified))
153 (else
154 (set! mtime 0)
155 (simply 'unspecified))))
156
157 (define (nb! moment s . args)
158 (fso "(~A ~A) " (at moment) nick)
159 (apply fso s args)
160 (newline))
161
162 ;; rv
163 (lambda (command)
164 (case command
165 ((nb!) nb!)
166 (else (call-with-values probe command))))))))
167
168 (define next-host
169 (let* ((ci (config-item "hosts"))
170 (nb! (ci 'nb!))
171 (hosts (cons #f #f)))
172
173 (define (replace! . ls)
174 ;; We can't resist a little coddling.
175 (set-cdr! hosts #f)
176 (set! hosts (apply circular-list ls)))
177
178 (define (lonely! moment reason)
179 (let ((lh "localhost"))
180 (nb! moment (fs "~A, falling back to ~A" reason lh))
181 (replace! lh)))
182
183 (define (re-scan mtime hosts)
184 (case mtime
185 ((still-unspecified no-change)
186 ;; do nothing
187 #f)
188 ((unspecified)
189 (lonely! #f "unspecified"))
190 (else
191 (cond ((string? hosts)
192 (lonely! mtime hosts))
193 ((null? hosts)
194 (lonely! mtime "no hosts"))
195 ((and (pair? hosts)
196 (let ((count (length+ hosts)))
197 (and (integer? count)
198 (and-map (lambda (x)
199 (or (symbol? x)
200 (string? x)))
201 hosts)
202 (fs "~A hosts" count))))
203 => (lambda (blurb)
204 (nb! mtime blurb)
205 (apply replace! hosts)))
206 (else
207 (lonely! mtime "invalid 'hosts' spec"))))))
208
209 ;; next-host
210 (lambda ()
211 (ci re-scan)
212 (let ((one (car hosts)))
213 (set! hosts (cdr hosts))
214 one))))
215
216 (define some-seconds
217 (let* ((ci (config-item "period"))
218 (nb! (ci 'nb!))
219 (period #f))
220
221 (define (random! moment reason)
222 (nb! moment (fs "~A, using random value" reason)))
223
224 (define (range! lo hi)
225 (set! period (cons lo hi)))
226
227 (define (standard-range!)
228 (range! 42 420))
229
230 (define (re-scan mtime spec)
231 (define (well-formed? len)
232 (and (pair? spec)
233 (integer? (length+ spec))
234 (= len (length spec))
235 (and-map integer? spec)
236 (and-map positive? spec)))
237 (case mtime
238 ((still-unspecified no-change)
239 ;; do nothing
240 #f)
241 ((unspecified)
242 (random! #f mtime)
243 (standard-range!))
244 (else
245 (cond ((string? spec)
246 (random! mtime spec)
247 (standard-range!))
248 ((well-formed? 1)
249 (set! period (car spec))
250 (nb! mtime "~A seconds" period))
251 ((and (well-formed? 2)
252 ;; low first, high after
253 (apply <= spec))
254 (apply nb! mtime "random in range [~A, ~A]" spec)
255 (range! (car spec) (cadr spec)))
256 (else
257 (random! mtime "invalid 'period' spec")
258 (standard-range!))))))
259
260 ;; some-seconds
261 (lambda ()
262 (ci re-scan)
263 (if (integer? period)
264 period
265 (let-values (((lo hi) (car+cdr period)))
266 ;; Widen by one for a doubly-inclusive range.
267 (+ lo (random (- hi lo -1))))))))
268
269 (define ping!
270 (let ((rx (make-regexp "^.* from ")))
271
272 (define shell-quote-argument
273 (let ((funky (char-set-complement
274 (char-set-union char-set:letter+digit
275 (char-set #\@ #\/ #\:
276 #\. #\- #\_
277 ;; Add chars here.
278 )))))
279
280 (define (funkiness start string)
281 (string-index string funky start))
282
283 ;; shell-quote-argument
284 (lambda (arg)
285 (let ((string (if (symbol? arg)
286 (symbol->string arg)
287 arg)))
288 (let loop ((start 0) (acc '()))
289 (cond ((funkiness start string)
290 => (lambda (pos)
291
292 (define (subs beg end)
293 (substring/shared string beg end))
294
295 (loop (1+ pos)
296 (cons* (subs pos (1+ pos))
297 "\\"
298 (subs start pos)
299 acc))))
300 (else
301 (string-concatenate-reverse
302 acc (substring/shared string start)))))))))
303
304 ;; ping!
305 (lambda (host)
306 (let* ((port (open-input-pipe
307 ;; TODO: Make ping program (and its output parsing)
308 ;; a configuration item.
309 (fs "@PING@ -n -c 1 ~A 2>&1"
310 (shell-quote-argument host))))
311 ;; first two lines of output
312 (one (read-line port))
313 (two (read-line port)))
314 (close-pipe port)
315 (fso "~A | ~A~%"
316 host (cond
317 ;; error from ping program
318 ((eof-object? two) one)
319 ;; decrufted
320 ((regexp-exec rx two) => match:suffix)
321 ;; raw
322 (else two)))))))
323
324 (define (nb! s . args)
325 (fso "~A: ~A " (whoami) (at (current-time)))
326 (apply fso s args)
327 (newline))
328
329 (set! *random-state* (let ((now (gettimeofday)))
330 (seed->random-state (* (car now)
331 (cdr now)))))
332
333 ;; install signal handlers
334 (let ((numeric-to-symbolic-map
335 ;; FIXME: Guile should provide this!
336 `((,SIGHUP . SIGHUP)
337 (,SIGINT . SIGINT)
338 (,SIGQUIT . SIGQUIT)
339 (,SIGALRM . SIGALRM)
340 (,SIGTERM . SIGTERM)
341 (,SIGUSR1 . SIGUSR1))))
342
343 (define (got-signal signo)
344 ;; FIXME: Guile should provide numeric to named map.
345 (let ((named (assq-ref numeric-to-symbolic-map signo)))
346 (nb! "received signal ~A~A" signo (if named
347 (fs " (~A)" named)
348 ""))
349 named))
350
351 (define (sigactions handler . ls)
352 (for-each (lambda (signo)
353 (sigaction signo handler))
354 ls))
355
356 (sigactions got-signal
357 SIGALRM)
358
359 (sigactions (lambda (signo) ; restart
360 (got-signal signo)
361 (apply execlp (argv 0) (vector->list ARGV)))
362 SIGHUP
363 SIGUSR1)
364
365 (sigactions (lambda (signo) ; exit
366 (got-signal signo)
367 (nb! "exiting")
368 (exit #t))
369 SIGINT
370 SIGQUIT
371 SIGTERM))
372
373 (nb! "restart (pid ~A)~%" (getpid))
374
375 (let loop ()
376 (let* ((secs (some-seconds))
377 (bef (current-time))
378 (aft (+ bef secs)))
379 (ping! (next-host))
380 ;; TODO: Make "verbosity" a configuration item.
381 (fso "(~A)\t~A~%\t~A~%~%" secs (at bef) (at aft))
382 (sleep secs)
383 (loop)))
384
385 ;;; Local variables:
386 ;;; eval: (put 'sigactions 'scheme-indent-function 1)
387 ;;; End:
388
389 ;;; alive ends here