0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 20 6-2012, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 74 PURPOSE...;; st
0150: 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 59 rftime('%m/%d/%Y
0160: 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 27 %H:%M:%S','now'
0170: 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a 28 ,'localtime')..(
0180: 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 69 use sqlite3 srfi
0190: 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 72 -1 posix regex r
01a0: 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d 36 egex-case srfi-6
01b0: 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 66 6f 9 dot-locking fo
01c0: 72 6d 61 74 29 0a 28 69 6d 70 6f 72 74 20 28 70 rmat).(import (p
01d0: 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 refix sqlite3 sq
01e0: 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c 61 lite3:))..(decla
01f0: 72 65 20 28 75 6e 69 74 20 74 61 73 6b 73 29 29 re (unit tasks))
0200: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0210: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0220: 73 65 73 20 72 6d 74 29 29 0a 28 64 65 63 6c 61 ses rmt)).(decla
0230: 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 re (uses common)
0240: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0250: 20 70 67 64 62 29 29 0a 0a 3b 3b 20 28 69 6d 70 pgdb))..;; (imp
0260: 6f 72 74 20 70 67 64 62 29 20 3b 3b 20 70 67 64 ort pgdb) ;; pgd
0270: 62 20 69 73 20 61 20 6d 6f 64 75 6c 65 0a 0a 28 b is a module..(
0280: 69 6e 63 6c 75 64 65 20 22 74 61 73 6b 5f 72 65 include "task_re
0290: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
02a0: 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 lude "db_records
02b0: 2e 73 63 6d 22 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d .scm")..;;======
02c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
02f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0300: 0a 3b 3b 20 54 61 73 6b 73 20 64 62 0a 3b 3b 3d .;; Tasks db.;;=
0310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 77 61 69 74 20 75 =====..;; wait u
0360: 70 20 74 6f 20 61 70 72 6f 78 20 6e 20 73 65 63 p to aprox n sec
0370: 6f 6e 64 73 20 66 6f 72 20 61 20 6a 6f 75 72 6e onds for a journ
0380: 61 6c 20 74 6f 20 67 6f 20 61 77 61 79 0a 3b 3b al to go away.;;
0390: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
03a0: 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 wait-on-journal
03b0: 70 61 74 68 20 6e 20 23 21 6b 65 79 20 28 72 65 path n #!key (re
03c0: 6d 6f 76 65 20 23 66 29 28 77 61 69 74 69 6e 67 move #f)(waiting
03d0: 2d 6d 73 67 20 23 66 29 29 0a 20 20 28 69 66 20 -msg #f)). (if
03e0: 28 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 70 61 (not (string? pa
03f0: 74 68 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 th)). (debu
0400: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
0410: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0420: 74 2a 20 22 43 61 6c 6c 65 64 20 74 61 73 6b 73 t* "Called tasks
0430: 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c :wait-on-journal
0440: 20 77 69 74 68 20 70 61 74 68 3d 22 20 70 61 74 with path=" pat
0450: 68 20 22 20 28 6e 6f 74 20 61 20 73 74 72 69 6e h " (not a strin
0460: 67 29 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 g)"). (let
0470: 28 28 66 75 6c 6c 70 61 74 68 20 28 63 6f 6e 63 ((fullpath (conc
0480: 20 70 61 74 68 20 22 2d 6a 6f 75 72 6e 61 6c 22 path "-journal"
0490: 29 29 29 0a 09 28 68 61 6e 64 6c 65 2d 65 78 63 )))..(handle-exc
04a0: 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 eptions.. exn..
04b0: 28 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 6e (begin.. (prin
04c0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
04d0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
04e0: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
04f0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0500: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
0510: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
0520: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
0530: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
0540: 65 29 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 e) exn)).. (de
0550: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
0560: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0570: 20 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f exn=" (conditio
0580: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 n->list exn))..
0590: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
05a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
05b0: 72 74 2a 20 22 74 61 73 6b 73 3a 77 61 69 74 2d rt* "tasks:wait-
05c0: 6f 6e 2d 6a 6f 75 72 6e 61 6c 20 66 61 69 6c 65 on-journal faile
05d0: 64 2e 20 43 6f 6e 74 69 6e 75 69 6e 67 20 6f 6e d. Continuing on
05e0: 2c 20 79 6f 75 20 63 61 6e 20 69 67 6e 6f 72 65 , you can ignore
05f0: 20 74 68 69 73 20 63 61 6c 6c 2d 63 68 61 69 6e this call-chain
0600: 22 29 0a 09 20 20 20 23 74 29 20 3b 3b 20 69 66 ").. #t) ;; if
0610: 20 73 74 75 66 66 20 67 6f 65 73 20 77 72 6f 6e stuff goes wron
0620: 67 20 6a 75 73 74 20 61 6c 6c 6f 77 20 69 74 20 g just allow it
0630: 74 6f 20 6d 6f 76 65 20 6f 6e 0a 09 20 28 6c 65 to move on.. (le
0640: 74 20 6c 6f 6f 70 20 28 28 6a 6f 75 72 6e 61 6c t loop ((journal
0650: 2d 65 78 69 73 74 73 20 28 66 69 6c 65 2d 65 78 -exists (file-ex
0660: 69 73 74 73 3f 20 66 75 6c 6c 70 61 74 68 29 29 ists? fullpath))
0670: 0a 09 09 20 20 20 20 28 63 6f 75 6e 74 20 20 20 ... (count
0680: 20 20 20 20 20 20 20 6e 29 29 20 3b 3b 20 77 61 n)) ;; wa
0690: 69 74 20 74 65 6e 20 74 69 6d 65 73 20 2e 2e 2e it ten times ...
06a0: 0a 09 20 20 20 28 69 66 20 6a 6f 75 72 6e 61 6c .. (if journal
06b0: 2d 65 78 69 73 74 73 0a 09 20 20 20 20 20 20 20 -exists..
06c0: 28 62 65 67 69 6e 0a 09 09 20 28 69 66 20 28 61 (begin... (if (a
06d0: 6e 64 20 77 61 69 74 69 6e 67 2d 6d 73 67 0a 09 nd waiting-msg..
06e0: 09 09 20 20 28 65 71 3f 20 28 6d 6f 64 75 6c 6f .. (eq? (modulo
06f0: 20 6e 20 33 30 29 20 30 29 29 0a 09 09 20 20 20 n 30) 0))...
0700: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
0710: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0720: 72 74 2a 20 77 61 69 74 69 6e 67 2d 6d 73 67 29 rt* waiting-msg)
0730: 29 0a 09 09 20 28 69 66 20 28 3e 20 63 6f 75 6e )... (if (> coun
0740: 74 20 30 29 0a 09 09 20 20 20 20 20 28 62 65 67 t 0)... (beg
0750: 69 6e 0a 09 09 20 20 20 20 20 20 20 28 74 68 72 in... (thr
0760: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 ead-sleep! 1)...
0770: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 66 69 (loop (fi
0780: 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 le-exists? fullp
0790: 61 74 68 29 0a 09 09 09 20 20 20 20 20 28 2d 20 ath).... (-
07a0: 63 6f 75 6e 74 20 31 29 29 29 0a 09 09 20 20 20 count 1)))...
07b0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
07c0: 20 20 28 69 66 20 72 65 6d 6f 76 65 20 28 73 79 (if remove (sy
07d0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d stem (conc "rm -
07e0: 72 66 20 22 20 66 75 6c 6c 70 61 74 68 29 29 29 rf " fullpath)))
07f0: 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a ... #f))).
0800: 09 20 20 20 20 20 20 20 23 74 29 29 29 29 29 29 . #t))))))
0810: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
0820: 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 74 :get-task-db-pat
0830: 68 29 0a 20 20 28 6c 65 74 20 28 28 64 62 64 69 h). (let ((dbdi
0840: 72 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a r (or (configf:
0850: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
0860: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 6f 6e 69 t* "setup" "moni
0870: 74 6f 72 64 69 72 22 29 0a 09 09 20 20 20 20 28 tordir")... (
0880: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
0890: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
08a0: 70 22 20 22 64 62 64 69 72 22 29 0a 09 09 20 20 p" "dbdir")...
08b0: 20 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 (conc (configf
08c0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
08d0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e at* "setup" "lin
08e0: 6b 74 72 65 65 22 29 20 22 2f 2e 64 62 22 29 29 ktree") "/.db"))
08f0: 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 )). (handle-e
0900: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 xceptions. e
0910: 78 6e 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 xn. (begin.
0920: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
0930: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
0940: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 ult-log-port* "C
0950: 6f 75 6c 64 6e 27 74 20 63 72 65 61 74 65 20 70 ouldn't create p
0960: 61 74 68 20 74 6f 20 22 20 64 62 64 69 72 29 0a ath to " dbdir).
0970: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
0980: 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 . (if (not (
0990: 64 69 72 65 63 74 6f 72 79 3f 20 64 62 64 69 72 directory? dbdir
09a0: 29 29 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ))(create-direct
09b0: 6f 72 79 20 64 62 64 69 72 20 23 74 29 29 29 0a ory dbdir #t))).
09c0: 20 20 20 20 64 62 64 69 72 29 29 0a 0a 3b 3b 20 dbdir))..;;
09d0: 49 66 20 66 69 6c 65 20 65 78 69 73 74 73 20 41 If file exists A
09e0: 4e 44 0a 3b 3b 20 20 20 20 66 69 6c 65 20 72 65 ND.;; file re
09f0: 61 64 61 62 6c 65 0a 3b 3b 20 20 20 20 20 20 20 adable.;;
0a00: 20 20 3d 3d 3e 20 6f 70 65 6e 20 69 74 0a 3b 3b ==> open it.;;
0a10: 20 49 66 20 66 69 6c 65 20 65 78 69 73 74 73 20 If file exists
0a20: 41 4e 44 0a 3b 3b 20 20 20 20 66 69 6c 65 20 4e AND.;; file N
0a30: 4f 54 20 72 65 61 64 61 62 6c 65 0a 3b 3b 20 20 OT readable.;;
0a40: 20 20 20 20 20 20 20 3d 3d 3e 20 6f 70 65 6e 20 ==> open
0a50: 69 6e 2d 6d 65 6d 20 76 65 72 73 69 6f 6e 0a 3b in-mem version.;
0a60: 3b 20 49 66 20 66 69 6c 65 20 4e 4f 54 20 65 78 ; If file NOT ex
0a70: 69 73 74 73 0a 3b 3b 20 20 20 20 3d 3d 3e 20 6f ists.;; ==> o
0a80: 70 65 6e 20 69 6e 2d 6d 65 6d 20 76 65 72 73 69 pen in-mem versi
0a90: 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 on.;;.(define (t
0aa0: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 23 21 6b asks:open-db #!k
0ab0: 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 34 ey (numretries 4
0ac0: 29 29 0a 20 20 28 69 66 20 2a 74 61 73 6b 2d 64 )). (if *task-d
0ad0: 62 2a 0a 20 20 20 20 20 20 2a 74 61 73 6b 2d 64 b*. *task-d
0ae0: 62 2a 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 b*. (handle
0af0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
0b00: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 28 69 exn. (i
0b10: 66 20 28 3e 20 6e 75 6d 72 65 74 72 69 65 73 20 f (> numretries
0b20: 30 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 0).. (begin..
0b30: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
0b40: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
0b50: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 rror-port))..
0b60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
0b70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0b80: 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 rt* " message: "
0b90: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
0ba0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
0bb0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
0bc0: 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 n)).. (debug
0bd0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
0be0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 65 78 t-log-port* " ex
0bf0: 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e n=" (condition->
0c00: 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 20 list exn))..
0c10: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
0c20: 31 29 0a 09 20 20 20 20 20 28 74 61 73 6b 73 3a 1).. (tasks:
0c30: 6f 70 65 6e 2d 64 62 20 6e 75 6d 72 65 74 72 69 open-db numretri
0c40: 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 es (- numretries
0c50: 20 31 29 29 29 0a 09 20 20 20 28 62 65 67 69 6e 1))).. (begin
0c60: 0a 09 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 .. (print-ca
0c70: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
0c80: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 t-error-port))..
0c90: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0ca0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
0cb0: 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
0cc0: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
0cd0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
0ce0: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
0cf0: 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 64 65 exn)).. (de
0d00: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
0d10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0d20: 20 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f exn=" (conditio
0d30: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 29 29 0a n->list exn)))).
0d40: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 (let* ((d
0d50: 62 70 61 74 68 20 20 20 20 20 20 20 28 74 61 73 bpath (tas
0d60: 6b 73 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 ks:get-task-db-p
0d70: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 64 62 ath)).. (db
0d80: 66 69 6c 65 20 20 20 20 20 20 20 28 63 6f 6e 63 file (conc
0d90: 20 64 62 70 61 74 68 20 22 2f 6d 6f 6e 69 74 6f dbpath "/monito
0da0: 72 2e 64 62 22 29 29 0a 09 20 20 20 20 20 20 28 r.db")).. (
0db0: 61 76 61 69 6c 20 20 20 20 20 20 20 20 28 74 61 avail (ta
0dc0: 73 6b 73 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 sks:wait-on-jour
0dd0: 6e 61 6c 20 64 62 70 61 74 68 20 31 30 29 29 20 nal dbpath 10))
0de0: 3b 3b 20 77 61 69 74 20 75 70 20 74 6f 20 61 62 ;; wait up to ab
0df0: 6f 75 74 20 31 30 20 73 65 63 6f 6e 64 73 20 66 out 10 seconds f
0e00: 6f 72 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 74 or the journal t
0e10: 6f 20 67 6f 20 61 77 61 79 0a 09 20 20 20 20 20 o go away..
0e20: 20 28 65 78 69 73 74 73 20 20 20 20 20 20 20 28 (exists (
0e30: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 70 file-exists? dbp
0e40: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 77 72 ath)).. (wr
0e50: 69 74 65 2d 61 63 63 65 73 73 20 28 66 69 6c 65 ite-access (file
0e60: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 -write-access? d
0e70: 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 bpath)).. (
0e80: 6d 64 62 20 20 20 20 20 20 20 20 20 20 28 63 6f mdb (co
0e90: 6e 64 20 3b 3b 20 77 68 61 74 20 74 68 65 20 68 nd ;; what the h
0ea0: 65 6b 20 69 73 20 2a 74 6f 70 70 61 74 68 2a 20 ek is *toppath*
0eb0: 64 6f 69 6e 67 20 68 65 72 65 3f 0a 09 09 09 20 doing here?....
0ec0: 20 20 20 20 28 28 61 6e 64 20 28 73 74 72 69 6e ((and (strin
0ed0: 67 3f 20 2a 74 6f 70 70 61 74 68 2a 29 28 66 69 g? *toppath*)(fi
0ee0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
0ef0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 09 09 *toppath*))....
0f00: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 6f (sqlite3:o
0f10: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 64 62 66 pen-database dbf
0f20: 69 6c 65 29 29 0a 09 09 09 20 20 20 20 20 28 28 ile)).... ((
0f30: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
0f40: 3f 20 64 62 70 61 74 68 29 20 20 20 20 28 73 71 ? dbpath) (sq
0f50: 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 lite3:open-datab
0f60: 61 73 65 20 64 62 66 69 6c 65 29 29 0a 09 09 09 ase dbfile))....
0f70: 20 20 20 20 20 28 65 6c 73 65 20 28 73 71 6c 69 (else (sqli
0f80: 74 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 te3:open-databas
0f90: 65 20 22 3a 6d 65 6d 6f 72 79 3a 22 29 29 29 29 e ":memory:"))))
0fa0: 20 3b 3b 20 28 6e 65 76 65 72 2d 67 69 76 65 2d ;; (never-give-
0fb0: 75 70 2d 6f 70 65 6e 2d 64 62 20 64 62 70 61 74 up-open-db dbpat
0fc0: 68 29 29 0a 09 20 20 20 20 20 20 28 68 61 6e 64 h)).. (hand
0fd0: 6c 65 72 20 20 20 20 20 20 28 6d 61 6b 65 2d 62 ler (make-b
0fe0: 75 73 79 2d 74 69 6d 65 6f 75 74 20 33 36 30 30 usy-timeout 3600
0ff0: 30 29 29 29 0a 09 20 28 69 66 20 28 61 6e 64 20 0))).. (if (and
1000: 65 78 69 73 74 73 0a 09 09 20 20 28 6e 6f 74 20 exists... (not
1010: 77 72 69 74 65 2d 61 63 63 65 73 73 29 29 0a 09 write-access))..
1020: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 77 (set! *db-w
1030: 72 69 74 65 2d 61 63 63 65 73 73 2a 20 77 72 69 rite-access* wri
1040: 74 65 2d 61 63 63 65 73 73 29 29 20 3b 3b 20 6f te-access)) ;; o
1050: 6e 6c 79 20 75 6e 73 65 74 20 73 6f 20 6f 74 68 nly unset so oth
1060: 65 72 20 64 62 27 73 20 61 6c 73 6f 20 63 61 6e er db's also can
1070: 20 75 73 65 20 74 68 69 73 20 63 6f 6e 74 72 6f use this contro
1080: 6c 0a 09 20 28 73 71 6c 69 74 65 33 3a 73 65 74 l.. (sqlite3:set
1090: 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 6d -busy-handler! m
10a0: 64 62 20 68 61 6e 64 6c 65 72 29 0a 09 20 28 64 db handler).. (d
10b0: 62 3a 73 65 74 2d 73 79 6e 63 20 6d 64 62 29 20 b:set-sync mdb)
10c0: 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 ;; (sqlite3:exec
10d0: 75 74 65 20 6d 64 62 20 28 63 6f 6e 63 20 22 50 ute mdb (conc "P
10e0: 52 41 47 4d 41 20 73 79 6e 63 68 72 6f 6e 6f 75 RAGMA synchronou
10f0: 73 20 3d 20 30 3b 22 29 29 0a 09 20 3b 3b 20 20 s = 0;")).. ;;
1100: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6e 6f (if (or (and (no
1110: 74 20 65 78 69 73 74 73 29 0a 09 20 3b 3b 20 09 t exists).. ;; .
1120: 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 (file-writ
1130: 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 e-access? *toppa
1140: 74 68 2a 29 29 0a 09 20 3b 3b 20 09 20 28 6e 6f th*)).. ;; . (no
1150: 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 t (file-read-acc
1160: 65 73 73 3f 20 64 62 70 61 74 68 29 29 29 0a 09 ess? dbpath)))..
1170: 20 3b 3b 20 20 20 20 20 20 28 62 65 67 69 6e 0a ;; (begin.
1180: 09 20 3b 3b 20 0a 09 20 3b 3b 20 54 41 53 4b 53 . ;; .. ;; TASKS
1190: 20 51 55 45 55 45 20 4d 4f 56 45 44 20 54 4f 20 QUEUE MOVED TO
11a0: 6d 61 69 6e 2e 64 62 0a 09 20 3b 3b 0a 09 20 3b main.db.. ;;.. ;
11b0: 3b 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ; (sqlite3:execu
11c0: 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 20 54 te mdb "CREATE T
11d0: 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 ABLE IF NOT EXIS
11e0: 54 53 20 74 61 73 6b 73 5f 71 75 65 75 65 20 28 TS tasks_queue (
11f0: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
1200: 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 RY KEY,.
1210: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
1220: 20 20 20 20 20 20 20 20 20 20 20 61 63 74 69 6f actio
1230: 6e 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 n TEXT DEFAULT '
1240: 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ',. ;;
1250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1260: 20 20 20 20 20 20 6f 77 6e 65 72 20 54 45 58 54 owner TEXT
1270: 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ,. ;;
1280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1290: 20 20 20 20 20 73 74 61 74 65 20 54 45 58 54 20 state TEXT
12a0: 44 45 46 41 55 4c 54 20 27 6e 65 77 27 2c 0a 20 DEFAULT 'new',.
12b0: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
12c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12d0: 20 20 74 61 72 67 65 74 20 54 45 58 54 20 44 45 target TEXT DE
12e0: 46 41 55 4c 54 20 27 27 2c 0a 20 20 20 20 20 20 FAULT '',.
12f0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 61 6d nam
1310: 65 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 e TEXT DEFAULT '
1320: 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ',. ;;
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1340: 20 20 20 20 20 20 74 65 73 74 70 61 74 74 20 54 testpatt T
1350: 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a EXT DEFAULT '',.
1360: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
1370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1380: 20 20 20 6b 65 79 6c 6f 63 6b 20 54 45 58 54 2c keylock TEXT,
1390: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
13a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13b0: 20 20 20 20 70 61 72 61 6d 73 20 54 45 58 54 2c params TEXT,
13c0: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
13d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13e0: 20 20 20 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d creation_tim
13f0: 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 e TIMESTAMP,.
1400: 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ;;
1410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1420: 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 execution_time T
1430: 49 4d 45 53 54 41 4d 50 29 3b 22 29 0a 09 20 28 IMESTAMP);").. (
1440: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
1450: 6d 64 62 20 22 43 52 45 41 54 45 20 54 41 42 4c mdb "CREATE TABL
1460: 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
1470: 6d 6f 6e 69 74 6f 72 73 20 28 69 64 20 49 4e 54 monitors (id INT
1480: 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 EGER PRIMARY KEY
1490: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
14a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b0: 20 20 70 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 pid INTEGER,.
14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
14e0: 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 tart_time TIMEST
14f0: 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 AMP,.
1500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1510: 20 20 20 20 20 6c 61 73 74 5f 75 70 64 61 74 65 last_update
1520: 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 TIMESTAMP,.
1530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1540: 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 host
1550: 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 20 name TEXT,.
1560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1570: 20 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e usern
1580: 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 ame TEXT,.
1590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15a0: 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 CONSTRA
15b0: 49 4e 54 20 6d 6f 6e 69 74 6f 72 73 5f 63 6f 6e INT monitors_con
15c0: 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 straint UNIQUE (
15d0: 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 29 3b 22 pid,hostname));"
15e0: 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ).. (sqlite3:exe
15f0: 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 cute mdb "CREATE
1600: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
1610: 49 53 54 53 20 73 65 72 76 65 72 73 20 28 69 64 ISTS servers (id
1620: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
1630: 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 KEY,.
1640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1650: 20 20 20 20 20 20 20 20 70 69 64 20 49 4e 54 45 pid INTE
1660: 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 GER,.
1670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1680: 20 20 20 20 20 20 20 69 6e 74 65 72 66 61 63 65 interface
1690: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
16a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16b0: 20 20 20 20 20 20 20 20 20 68 6f 73 74 6e 61 6d hostnam
16c0: 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 e TEXT,.
16d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16e0: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 20 49 port I
16f0: 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
1700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1710: 20 20 20 20 20 20 20 20 20 20 70 75 62 70 6f 72 pubpor
1720: 74 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 t INTEGER,.
1730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 sta
1750: 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d rt_time TIMESTAM
1760: 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 P,.
1770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1780: 20 20 20 20 20 70 72 69 6f 72 69 74 79 20 49 4e priority IN
1790: 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 TEGER,.
17a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17b0: 20 20 20 20 20 20 20 20 20 73 74 61 74 65 20 54 state T
17c0: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 EXT,.
17d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17e0: 20 20 20 20 20 20 20 6d 74 5f 76 65 72 73 69 6f mt_versio
17f0: 6e 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 n TEXT,.
1800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1810: 20 20 20 20 20 20 20 20 20 20 68 65 61 72 74 62 heartb
1820: 65 61 74 20 54 49 4d 45 53 54 41 4d 50 2c 0a 20 eat TIMESTAMP,.
1830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1850: 20 74 72 61 6e 73 70 6f 72 74 20 54 45 58 54 2c transport TEXT,
1860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1880: 20 20 20 72 75 6e 5f 69 64 20 49 4e 54 45 47 45 run_id INTEGE
1890: 52 29 3b 22 29 0a 09 20 3b 3b 20 20 20 20 20 20 R);").. ;;
18a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18b0: 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 CONSTRA
18c0: 49 4e 54 20 73 65 72 76 65 72 73 5f 63 6f 6e 73 INT servers_cons
18d0: 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 70 traint UNIQUE (p
18e0: 69 64 2c 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 id,hostname,port
18f0: 29 29 3b 22 29 0a 09 20 28 73 71 6c 69 74 65 33 ));").. (sqlite3
1900: 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 43 52 :execute mdb "CR
1910: 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f EATE TABLE IF NO
1920: 54 20 45 58 49 53 54 53 20 63 6c 69 65 6e 74 73 T EXISTS clients
1930: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
1940: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
1950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1960: 20 20 20 20 20 20 20 20 20 20 20 20 73 65 72 76 serv
1970: 65 72 5f 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 er_id INTEGER,.
1980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19a0: 20 70 69 64 20 49 4e 54 45 47 45 52 2c 0a 20 20 pid INTEGER,.
19b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19d0: 68 6f 73 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 hostname TEXT,.
19e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a00: 20 63 6d 64 6c 69 6e 65 20 54 45 58 54 2c 0a 20 cmdline TEXT,.
1a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a30: 20 6c 6f 67 69 6e 5f 74 69 6d 65 20 54 49 4d 45 login_time TIME
1a40: 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 STAMP,.
1a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a60: 20 20 20 20 20 20 20 20 20 6c 6f 67 6f 75 74 5f logout_
1a70: 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 time TIMESTAMP D
1a80: 45 46 41 55 4c 54 20 2d 31 2c 0a 20 20 20 20 20 EFAULT -1,.
1a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1aa0: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
1ab0: 52 41 49 4e 54 20 63 6c 69 65 6e 74 73 5f 63 6f RAINT clients_co
1ac0: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
1ad0: 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 29 29 3b (pid,hostname));
1ae0: 22 29 0a 09 20 20 20 20 20 20 20 0a 09 20 20 20 ").. ..
1af0: 20 20 20 20 3b 29 29 0a 09 20 28 73 65 74 21 20 ;)).. (set!
1b00: 2a 74 61 73 6b 2d 64 62 2a 20 28 63 6f 6e 73 20 *task-db* (cons
1b10: 6d 64 62 20 64 62 70 61 74 68 29 29 0a 09 20 2a mdb dbpath)).. *
1b20: 74 61 73 6b 2d 64 62 2a 29 29 29 29 0a 0a 3b 3b task-db*))))..;;
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b70: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 65 72 76 65 72 ======.;; Server
1b80: 20 61 6e 64 20 63 6c 69 65 6e 74 20 6d 61 6e 61 and client mana
1b90: 67 65 6d 65 6e 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d gement.;;=======
1ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1be0: 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 74 6f 72 2d .;; make-vector-
1bf0: 72 65 63 6f 72 64 20 74 61 73 6b 73 20 68 6f 73 record tasks hos
1c00: 74 69 6e 66 6f 20 69 64 20 69 6e 74 65 72 66 61 tinfo id interfa
1c10: 63 65 20 70 6f 72 74 20 70 75 62 70 6f 72 74 20 ce port pubport
1c20: 74 72 61 6e 73 70 6f 72 74 20 70 69 64 20 68 6f transport pid ho
1c30: 73 74 6e 61 6d 65 0a 28 64 65 66 69 6e 65 20 28 stname.(define (
1c40: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
1c50: 65 74 2d 69 64 20 20 20 20 20 20 20 20 20 20 76 et-id v
1c60: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
1c70: 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 66 ef vec 0)).(def
1c80: 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 ine (tasks:hosti
1c90: 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 nfo-get-interfac
1ca0: 65 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 e vec) (vec
1cb0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
1cc0: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
1cd0: 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 hostinfo-get-por
1ce0: 74 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 t vec)
1cf0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
1d00: 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 74 c 2)).(define (t
1d10: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
1d20: 74 2d 70 75 62 70 6f 72 74 20 20 20 20 20 76 65 t-pubport ve
1d30: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
1d40: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
1d50: 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e ne (tasks:hostin
1d60: 66 6f 2d 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 fo-get-transport
1d70: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
1d80: 6f 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a or-ref vec 4)).
1d90: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 (define (tasks:h
1da0: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 69 64 20 ostinfo-get-pid
1db0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
1dc0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
1dd0: 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 5)).(define (ta
1de0: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
1df0: 2d 68 6f 73 74 6e 61 6d 65 20 20 20 20 76 65 63 -hostname vec
1e00: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
1e10: 20 20 76 65 63 20 36 29 29 0a 0a 28 64 65 66 69 vec 6))..(defi
1e20: 6e 65 20 28 74 61 73 6b 73 3a 6e 65 65 64 2d 73 ne (tasks:need-s
1e30: 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a 20 20 erver run-id).
1e40: 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 (equal? (configf
1e50: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
1e60: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 72 65 at* "server" "re
1e70: 71 75 69 72 65 64 22 29 20 22 79 65 73 22 29 29 quired") "yes"))
1e80: 0a 0a 3b 3b 20 6e 6f 20 65 6c 65 67 61 6e 63 65 ..;; no elegance
1e90: 20 68 65 72 65 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 here ....;;.(de
1ea0: 66 69 6e 65 20 28 74 61 73 6b 73 3a 6b 69 6c 6c fine (tasks:kill
1eb0: 2d 73 65 72 76 65 72 20 68 6f 73 74 6e 61 6d 65 -server hostname
1ec0: 20 70 69 64 20 23 21 6b 65 79 20 28 6b 69 6c 6c pid #!key (kill
1ed0: 2d 73 77 69 74 63 68 20 22 22 29 29 0a 20 20 28 -switch "")). (
1ee0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1ef0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1f00: 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 6e port* "Attemptin
1f10: 67 20 74 6f 20 6b 69 6c 6c 20 73 65 72 76 65 72 g to kill server
1f20: 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 20 22 process " pid "
1f30: 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 6e on host " hostn
1f40: 61 6d 65 29 0a 20 20 28 73 65 74 65 6e 76 20 22 ame). (setenv "
1f50: 54 41 52 47 45 54 48 4f 53 54 22 20 68 6f 73 74 TARGETHOST" host
1f60: 6e 61 6d 65 29 0a 20 20 28 73 65 74 65 6e 76 20 name). (setenv
1f70: 22 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 "TARGETHOST_LOGF
1f80: 22 20 22 73 65 72 76 65 72 2d 6b 69 6c 6c 73 2e " "server-kills.
1f90: 6c 6f 67 22 29 0a 20 20 28 73 79 73 74 65 6d 20 log"). (system
1fa0: 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 20 6b 69 (conc "nbfake ki
1fb0: 6c 6c 20 22 6b 69 6c 6c 2d 73 77 69 74 63 68 22 ll "kill-switch"
1fc0: 20 22 70 69 64 29 29 0a 0a 20 20 28 75 6e 73 65 "pid)).. (unse
1fd0: 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 tenv "TARGETHOST
1fe0: 5f 4c 4f 47 46 22 29 0a 20 20 28 75 6e 73 65 74 _LOGF"). (unset
1ff0: 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 env "TARGETHOST"
2000: 29 29 0a 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )). .;;=========
2010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
2050: 20 4d 20 4f 20 4e 20 49 20 54 20 4f 20 52 20 53 M O N I T O R S
2060: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
20a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
20b0: 6e 65 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 65 ne (tasks:remove
20c0: 2d 6d 6f 6e 69 74 6f 72 2d 72 65 63 6f 72 64 20 -monitor-record
20d0: 6d 64 62 29 0a 20 20 28 73 71 6c 69 74 65 33 3a mdb). (sqlite3:
20e0: 65 78 65 63 75 74 65 20 6d 64 62 20 22 44 45 4c execute mdb "DEL
20f0: 45 54 45 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 ETE FROM monitor
2100: 73 20 57 48 45 52 45 20 70 69 64 3d 3f 20 41 4e s WHERE pid=? AN
2110: 44 20 68 6f 73 74 6e 61 6d 65 3d 3f 3b 22 0a 09 D hostname=?;"..
2120: 09 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f . (current-pro
2130: 63 65 73 73 2d 69 64 29 0a 09 09 20 20 20 28 67 cess-id)... (g
2140: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a et-host-name))).
2150: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
2160: 67 65 74 2d 6d 6f 6e 69 74 6f 72 73 20 6d 64 62 get-monitors mdb
2170: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 ). (let ((res '
2180: 28 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 ())). (sqlite
2190: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 3:for-each-row.
21a0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e (lambda (a .
21b0: 20 72 65 6d 29 0a 20 20 20 20 20 20 20 28 73 65 rem). (se
21c0: 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 61 70 t! res (cons (ap
21d0: 70 6c 79 20 76 65 63 74 6f 72 20 61 20 72 65 6d ply vector a rem
21e0: 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 6d 64 ) res))). md
21f0: 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 69 b. "SELECT i
2200: 64 2c 70 69 64 2c 73 74 72 66 74 69 6d 65 28 27 d,pid,strftime('
2210: 25 6d 2f 25 64 2f 25 59 20 25 48 3a 25 4d 27 2c %m/%d/%Y %H:%M',
2220: 64 61 74 65 74 69 6d 65 28 73 74 61 72 74 5f 74 datetime(start_t
2230: 69 6d 65 2c 27 75 6e 69 78 65 70 6f 63 68 27 29 ime,'unixepoch')
2240: 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 2c 73 74 ,'localtime'),st
2250: 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 59 rftime('%m/%d/%Y
2260: 20 25 48 3a 25 4d 3a 25 53 27 2c 64 61 74 65 74 %H:%M:%S',datet
2270: 69 6d 65 28 6c 61 73 74 5f 75 70 64 61 74 65 2c ime(last_update,
2280: 27 75 6e 69 78 65 70 6f 63 68 27 29 2c 27 6c 6f 'unixepoch'),'lo
2290: 63 61 6c 74 69 6d 65 27 29 2c 68 6f 73 74 6e 61 caltime'),hostna
22a0: 6d 65 2c 75 73 65 72 6e 61 6d 65 20 46 52 4f 4d me,username FROM
22b0: 20 6d 6f 6e 69 74 6f 72 73 20 4f 52 44 45 52 20 monitors ORDER
22c0: 42 59 20 6c 61 73 74 5f 75 70 64 61 74 65 20 41 BY last_update A
22d0: 53 43 3b 22 29 0a 20 20 20 20 28 72 65 76 65 72 SC;"). (rever
22e0: 73 65 20 72 65 73 29 0a 20 20 20 20 29 29 0a 0a se res). ))..
22f0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6d (define (tasks:m
2300: 6f 6e 69 74 6f 72 73 2d 3e 74 65 78 74 2d 74 61 onitors->text-ta
2310: 62 6c 65 20 6d 6f 6e 69 74 6f 72 73 29 0a 20 20 ble monitors).
2320: 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 22 7e (let ((fmtstr "~
2330: 34 61 7e 38 61 7e 32 30 61 7e 32 30 61 7e 31 30 4a~8a~20a~20a~10
2340: 61 7e 31 30 61 22 29 29 0a 20 20 20 20 28 63 6f a~10a")). (co
2350: 6e 63 20 28 66 6f 72 6d 61 74 20 23 66 20 66 6d nc (format #f fm
2360: 74 73 74 72 20 22 69 64 22 20 22 70 69 64 22 20 tstr "id" "pid"
2370: 22 73 74 61 72 74 20 74 69 6d 65 22 20 22 6c 61 "start time" "la
2380: 73 74 20 75 70 64 61 74 65 22 20 22 68 6f 73 74 st update" "host
2390: 6e 61 6d 65 22 20 22 75 73 65 72 22 29 20 22 5c name" "user") "\
23a0: 6e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d 69 6e n".. (string-in
23b0: 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 28 tersperse .. (
23c0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6d 6f 6e map (lambda (mon
23d0: 69 74 6f 72 29 0a 09 09 20 20 28 66 6f 72 6d 61 itor)... (forma
23e0: 74 20 23 66 20 66 6d 74 73 74 72 0a 09 09 09 20 t #f fmtstr....
23f0: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d (tasks:monitor-
2400: 67 65 74 2d 69 64 20 20 20 20 20 20 20 20 20 20 get-id
2410: 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 74 monitor).... (t
2420: 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 asks:monitor-get
2430: 2d 70 69 64 20 20 20 20 20 20 20 20 20 6d 6f 6e -pid mon
2440: 69 74 6f 72 29 0a 09 09 09 20 20 28 74 61 73 6b itor).... (task
2450: 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 73 74 s:monitor-get-st
2460: 61 72 74 5f 74 69 6d 65 20 20 6d 6f 6e 69 74 6f art_time monito
2470: 72 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 6d r).... (tasks:m
2480: 6f 6e 69 74 6f 72 2d 67 65 74 2d 6c 61 73 74 5f onitor-get-last_
2490: 75 70 64 61 74 65 20 6d 6f 6e 69 74 6f 72 29 0a update monitor).
24a0: 09 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 ... (tasks:moni
24b0: 74 6f 72 2d 67 65 74 2d 68 6f 73 74 6e 61 6d 65 tor-get-hostname
24c0: 20 20 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 monitor)....
24d0: 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 (tasks:monitor
24e0: 2d 67 65 74 2d 75 73 65 72 6e 61 6d 65 20 20 20 -get-username
24f0: 20 6d 6f 6e 69 74 6f 72 29 29 29 0a 09 09 6d 6f monitor)))...mo
2500: 6e 69 74 6f 72 73 29 0a 09 20 20 20 22 5c 6e 22 nitors).. "\n"
2510: 29 29 29 29 0a 20 20 20 0a 3b 3b 20 75 70 64 61 )))). .;; upda
2520: 74 65 20 74 68 65 20 6c 61 73 74 5f 75 70 64 61 te the last_upda
2530: 74 65 20 66 69 65 6c 64 20 77 69 74 68 20 74 68 te field with th
2540: 65 20 63 75 72 72 65 6e 74 20 74 69 6d 65 20 61 e current time a
2550: 6e 64 0a 3b 3b 20 69 66 20 61 6e 79 20 6d 6f 6e nd.;; if any mon
2560: 69 74 6f 72 73 20 61 70 70 65 61 72 20 64 65 61 itors appear dea
2570: 64 2c 20 72 65 6d 6f 76 65 20 74 68 65 6d 0a 28 d, remove them.(
2580: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6d 6f define (tasks:mo
2590: 6e 69 74 6f 72 73 2d 75 70 64 61 74 65 20 6d 64 nitors-update md
25a0: 62 29 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 b). (sqlite3:ex
25b0: 65 63 75 74 65 20 6d 64 62 20 22 55 50 44 41 54 ecute mdb "UPDAT
25c0: 45 20 6d 6f 6e 69 74 6f 72 73 20 53 45 54 20 6c E monitors SET l
25d0: 61 73 74 5f 75 70 64 61 74 65 3d 73 74 72 66 74 ast_update=strft
25e0: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 20 ime('%s','now')
25f0: 57 48 45 52 45 20 70 69 64 3d 3f 20 41 4e 44 20 WHERE pid=? AND
2600: 68 6f 73 74 6e 61 6d 65 3d 3f 3b 22 0a 09 09 09 hostname=?;"....
2610: 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 (current-proce
2620: 73 73 2d 69 64 29 0a 09 09 09 20 20 28 67 65 74 ss-id).... (get
2630: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 20 20 28 -host-name)). (
2640: 6c 65 74 20 28 28 64 65 61 64 6c 69 73 74 20 27 let ((deadlist '
2650: 28 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 ())). (sqlite
2660: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 20 3:for-each-row.
2670: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 20 (lambda (id
2680: 70 69 64 20 68 6f 73 74 20 6c 61 73 74 2d 75 70 pid host last-up
2690: 64 61 74 65 20 64 65 6c 74 61 29 0a 20 20 20 20 date delta).
26a0: 20 20 20 28 70 72 69 6e 74 20 22 47 6f 69 6e 67 (print "Going
26b0: 20 74 6f 20 64 65 6c 65 74 65 20 73 74 61 6c 65 to delete stale
26c0: 20 72 65 63 6f 72 64 20 66 6f 72 20 6d 6f 6e 69 record for moni
26d0: 74 6f 72 20 77 69 74 68 20 70 69 64 20 22 20 70 tor with pid " p
26e0: 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 id " on host " h
26f0: 6f 73 74 20 22 20 6c 61 73 74 20 75 70 64 61 74 ost " last updat
2700: 65 64 20 22 20 64 65 6c 74 61 20 22 20 73 65 63 ed " delta " sec
2710: 6f 6e 64 73 20 61 67 6f 22 29 0a 20 20 20 20 20 onds ago").
2720: 20 20 28 73 65 74 21 20 64 65 61 64 6c 69 73 74 (set! deadlist
2730: 20 28 63 6f 6e 73 20 69 64 20 64 65 61 64 6c 69 (cons id deadli
2740: 73 74 29 29 29 0a 20 20 20 20 20 6d 64 62 20 0a st))). mdb .
2750: 20 20 20 20 20 22 53 45 4c 45 43 54 20 69 64 2c "SELECT id,
2760: 70 69 64 2c 68 6f 73 74 6e 61 6d 65 2c 6c 61 73 pid,hostname,las
2770: 74 5f 75 70 64 61 74 65 2c 73 74 72 66 74 69 6d t_update,strftim
2780: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 2d 6c 61 e('%s','now')-la
2790: 73 74 5f 75 70 64 61 74 65 20 41 53 20 64 65 6c st_update AS del
27a0: 74 61 20 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 ta FROM monitors
27b0: 20 57 48 45 52 45 20 64 65 6c 74 61 20 3e 20 37 WHERE delta > 7
27c0: 30 30 3b 22 29 0a 20 20 20 20 28 73 71 6c 69 74 00;"). (sqlit
27d0: 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 20 28 e3:execute mdb (
27e0: 63 6f 6e 63 20 22 44 45 4c 45 54 45 20 46 52 4f conc "DELETE FRO
27f0: 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 45 52 45 M monitors WHERE
2800: 20 69 64 20 49 4e 20 28 27 22 20 28 73 74 72 69 id IN ('" (stri
2810: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
2820: 6d 61 70 20 63 6f 6e 63 20 64 65 61 64 6c 69 73 map conc deadlis
2830: 74 29 20 22 27 2c 27 22 29 20 22 27 29 3b 22 29 t) "','") "');")
2840: 29 29 0a 20 20 29 0a 28 64 65 66 69 6e 65 20 28 )). ).(define (
2850: 74 61 73 6b 73 3a 72 65 67 69 73 74 65 72 2d 6d tasks:register-m
2860: 6f 6e 69 74 6f 72 20 64 62 20 70 6f 72 74 29 0a onitor db port).
2870: 20 20 28 6c 65 74 2a 20 28 28 70 69 64 20 28 63 (let* ((pid (c
2880: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
2890: 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 d)).. (hostname
28a0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
28b0: 0a 09 20 28 75 73 65 72 69 6e 66 6f 20 28 75 73 .. (userinfo (us
28c0: 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 er-information (
28d0: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
28e0: 29 29 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 28 )).. (username (
28f0: 63 61 72 20 75 73 65 72 69 6e 66 6f 29 29 29 0a car userinfo))).
2900: 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 (print "Regi
2910: 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 ster monitor, pi
2920: 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f 73 74 d: " pid ", host
2930: 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d 65 name: " hostname
2940: 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 74 ", port: " port
2950: 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 20 ", username: "
2960: 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 73 username). (s
2970: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
2980: 62 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 6d b "INSERT INTO m
2990: 6f 6e 69 74 6f 72 73 20 28 70 69 64 2c 73 74 61 onitors (pid,sta
29a0: 72 74 5f 74 69 6d 65 2c 6c 61 73 74 5f 75 70 64 rt_time,last_upd
29b0: 61 74 65 2c 68 6f 73 74 6e 61 6d 65 2c 75 73 65 ate,hostname,use
29c0: 72 6e 61 6d 65 29 20 56 41 4c 55 45 53 20 28 3f rname) VALUES (?
29d0: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
29e0: 6e 6f 77 27 29 2c 73 74 72 66 74 69 6d 65 28 27 now'),strftime('
29f0: 25 73 27 2c 27 6e 6f 77 27 29 2c 3f 2c 3f 29 3b %s','now'),?,?);
2a00: 22 0a 09 09 20 20 20 20 20 70 69 64 20 68 6f 73 "... pid hos
2a10: 74 6e 61 6d 65 20 75 73 65 72 6e 61 6d 65 29 29 tname username))
2a20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )..(define (task
2a30: 73 3a 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d s:get-num-alive-
2a40: 6d 6f 6e 69 74 6f 72 73 20 6d 64 62 29 0a 20 20 monitors mdb).
2a50: 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 20 (let ((res 0)).
2a60: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
2a70: 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 each-row . (
2a80: 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 20 lambda (count).
2a90: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
2aa0: 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 6d 64 62 count)). mdb
2ab0: 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 63 6f . "SELECT co
2ac0: 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 6d 6f 6e unt(id) FROM mon
2ad0: 69 74 6f 72 73 20 57 48 45 52 45 20 6c 61 73 74 itors WHERE last
2ae0: 5f 75 70 64 61 74 65 20 3c 20 28 73 74 72 66 74 _update < (strft
2af0: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 20 ime('%s','now')
2b00: 2d 20 33 30 30 29 20 41 4e 44 20 75 73 65 72 6e - 300) AND usern
2b10: 61 6d 65 3d 3f 3b 22 0a 20 20 20 20 20 28 63 61 ame=?;". (ca
2b20: 72 20 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 r (user-informat
2b30: 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 ion (current-use
2b40: 72 2d 69 64 29 29 29 29 0a 20 20 20 20 72 65 73 r-id)))). res
2b50: 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ))..;; .(define
2b60: 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 6d 6f 6e (tasks:start-mon
2b70: 69 74 6f 72 20 64 62 20 6d 64 62 29 0a 20 20 28 itor db mdb). (
2b80: 69 66 20 28 3e 20 28 74 61 73 6b 73 3a 67 65 74 if (> (tasks:get
2b90: 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d 6f 6e 69 74 -num-alive-monit
2ba0: 6f 72 73 20 6d 64 62 29 20 32 29 20 3b 3b 20 68 ors mdb) 2) ;; h
2bb0: 61 76 65 20 74 77 6f 20 72 75 6e 6e 69 6e 67 2c ave two running,
2bc0: 20 6e 6f 20 6e 65 65 64 20 66 6f 72 20 6d 6f 72 no need for mor
2bd0: 65 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 e. (debug:p
2be0: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
2bf0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2c00: 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 6d 6f 6e Not starting mon
2c10: 69 74 6f 72 2c 20 61 6c 72 65 61 64 79 20 68 61 itor, already ha
2c20: 76 65 20 6d 6f 72 65 20 74 68 61 6e 20 74 77 6f ve more than two
2c30: 20 72 75 6e 6e 69 6e 67 22 29 0a 20 20 20 20 20 running").
2c40: 20 28 6c 65 74 2a 20 28 28 6d 65 67 61 74 65 73 (let* ((megates
2c50: 74 64 62 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 tdb (conc *t
2c60: 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 oppath* "/megate
2c70: 73 74 2e 64 62 22 29 29 0a 09 20 20 20 20 20 28 st.db")).. (
2c80: 6d 6f 6e 69 74 6f 72 64 62 66 20 20 20 20 20 28 monitordbf (
2c90: 63 6f 6e 63 20 28 64 62 3a 64 62 66 69 6c 65 2d conc (db:dbfile-
2ca0: 70 61 74 68 20 23 66 29 20 22 2f 6d 6f 6e 69 74 path #f) "/monit
2cb0: 6f 72 2e 64 62 22 29 29 0a 09 20 20 20 20 20 28 or.db")).. (
2cc0: 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 65 20 30 last-db-update 0
2cd0: 29 29 20 3b 3b 20 28 66 69 6c 65 2d 6d 6f 64 69 )) ;; (file-modi
2ce0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d 65 fication-time me
2cf0: 67 61 74 65 73 74 64 62 29 29 29 0a 09 28 74 61 gatestdb)))..(ta
2d00: 73 6b 3a 72 65 67 69 73 74 65 72 2d 6d 6f 6e 69 sk:register-moni
2d10: 74 6f 72 20 6d 64 62 29 0a 09 28 6c 65 74 20 6c tor mdb)..(let l
2d20: 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 oop ((count
2d30: 20 30 29 0a 09 09 20 20 20 28 6e 65 78 74 2d 74 0)... (next-t
2d40: 6f 75 63 68 20 30 29 29 20 3b 3b 20 6e 65 78 74 ouch 0)) ;; next
2d50: 2d 74 6f 75 63 68 20 69 73 20 74 68 65 20 74 69 -touch is the ti
2d60: 6d 65 20 77 68 65 72 65 20 77 65 20 6e 65 65 64 me where we need
2d70: 20 74 6f 20 75 70 64 61 74 65 20 6c 61 73 74 5f to update last_
2d80: 75 70 64 61 74 65 0a 09 20 20 3b 3b 20 69 66 20 update.. ;; if
2d90: 74 68 65 20 64 62 20 68 61 73 20 62 65 65 6e 20 the db has been
2da0: 6d 6f 64 69 66 69 65 64 20 77 65 27 64 20 62 65 modified we'd be
2db0: 73 74 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 st look at the t
2dc0: 61 73 6b 20 71 75 65 75 65 0a 09 20 20 28 6c 65 ask queue.. (le
2dd0: 74 20 28 28 6d 6f 64 74 69 6d 65 20 28 66 69 6c t ((modtime (fil
2de0: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
2df0: 69 6d 65 20 6d 65 67 61 74 65 73 74 64 62 70 61 ime megatestdbpa
2e00: 74 68 20 29 29 29 0a 09 20 20 20 20 28 69 66 20 th ))).. (if
2e10: 28 3e 20 6d 6f 64 74 69 6d 65 20 6c 61 73 74 2d (> modtime last-
2e20: 64 62 2d 75 70 64 61 74 65 29 0a 09 09 28 74 61 db-update)...(ta
2e30: 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 sks:process-queu
2e40: 65 20 64 62 29 29 20 3b 3b 20 42 52 4f 4b 45 4e e db)) ;; BROKEN
2e50: 2e 20 6d 64 62 20 6c 61 73 74 2d 64 62 2d 75 70 . mdb last-db-up
2e60: 64 61 74 65 20 6d 65 67 61 74 65 73 74 64 62 20 date megatestdb
2e70: 6e 65 78 74 2d 74 6f 75 63 68 29 29 0a 09 20 20 next-touch))..
2e80: 20 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 50 6f ;; WARNING: Po
2e90: 73 73 69 62 6c 65 20 72 61 63 65 20 63 6f 6e 64 ssible race cond
2ea0: 69 74 6f 6e 20 68 65 72 65 21 21 0a 09 20 20 20 iton here!!..
2eb0: 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 69 73 20 ;; should this
2ec0: 75 70 64 61 74 65 20 62 65 20 69 6d 6d 65 64 69 update be immedi
2ed0: 61 74 65 6c 79 20 61 66 74 65 72 20 74 68 65 20 ately after the
2ee0: 74 61 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 task-get-action
2ef0: 63 61 6c 6c 20 61 62 6f 76 65 3f 0a 09 20 20 20 call above?..
2f00: 20 28 69 66 20 28 3e 20 28 63 75 72 72 65 6e 74 (if (> (current
2f10: 2d 73 65 63 6f 6e 64 73 29 20 6e 65 78 74 2d 74 -seconds) next-t
2f20: 6f 75 63 68 29 0a 09 09 28 62 65 67 69 6e 0a 09 ouch)...(begin..
2f30: 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f . (tasks:monito
2f40: 72 73 2d 75 70 64 61 74 65 20 6d 64 62 29 0a 09 rs-update mdb)..
2f50: 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e . (loop (+ coun
2f60: 74 20 31 29 28 2b 20 28 63 75 72 72 65 6e 74 2d t 1)(+ (current-
2f70: 73 65 63 6f 6e 64 73 29 20 32 34 30 29 29 29 0a seconds) 240))).
2f80: 09 09 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 ..(loop (+ count
2f90: 20 31 29 20 6e 65 78 74 2d 74 6f 75 63 68 29 29 1) next-touch))
2fa0: 29 29 29 29 29 0a 20 20 20 20 20 20 0a 3b 3b 3d ))))). .;;=
2fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ff0: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 53 20 4b =====.;; T A S K
3000: 20 53 20 20 20 51 20 55 20 45 20 55 20 45 0a 3b S Q U E U E.;
3010: 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 3a 20 54 68 ;.;; NOTE:: Th
3020: 65 73 65 20 6f 70 65 72 61 74 65 20 6f 6e 20 74 ese operate on t
3030: 61 73 6b 5f 71 75 65 75 65 20 77 68 69 63 68 20 ask_queue which
3040: 69 73 20 69 6e 20 6d 61 69 6e 2e 64 62 0a 3b 3b is in main.db.;;
3050: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f =========..;; NO
30a0: 54 45 3a 20 49 74 20 6d 69 67 68 74 20 62 65 20 TE: It might be
30b0: 67 6f 6f 64 20 74 6f 20 61 64 64 20 6f 6e 65 20 good to add one
30c0: 6d 6f 72 65 20 6c 61 79 65 72 20 6f 66 20 63 68 more layer of ch
30d0: 65 63 6b 69 6e 67 20 74 6f 20 65 6e 73 75 72 65 ecking to ensure
30e0: 0a 3b 3b 20 20 20 20 20 20 20 74 68 61 74 20 6e .;; that n
30f0: 6f 20 74 61 73 6b 20 67 65 74 73 20 72 75 6e 20 o task gets run
3100: 69 6e 20 70 61 72 61 6c 6c 65 6c 2e 0a 0a 3b 3b in parallel...;;
3110: 20 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d id INTEGER PRIM
3120: 41 52 59 20 4b 45 59 2c 0a 3b 3b 20 61 63 74 69 ARY KEY,.;; acti
3130: 6f 6e 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 on TEXT DEFAULT
3140: 27 27 2c 0a 3b 3b 20 6f 77 6e 65 72 20 54 45 58 '',.;; owner TEX
3150: 54 2c 0a 3b 3b 20 73 74 61 74 65 20 54 45 58 54 T,.;; state TEXT
3160: 20 44 45 46 41 55 4c 54 20 27 6e 65 77 27 2c 0a DEFAULT 'new',.
3170: 3b 3b 20 74 61 72 67 65 74 20 54 45 58 54 20 44 ;; target TEXT D
3180: 45 46 41 55 4c 54 20 27 27 2c 0a 3b 3b 20 6e 61 EFAULT '',.;; na
3190: 6d 65 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 me TEXT DEFAULT
31a0: 27 27 2c 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 '',.;; testpatt
31b0: 54 45 58 54 20 44 45 46 41 55 4c 54 20 27 27 2c TEXT DEFAULT '',
31c0: 0a 3b 3b 20 6b 65 79 6c 6f 63 6b 20 54 45 58 54 .;; keylock TEXT
31d0: 2c 0a 3b 3b 20 70 61 72 61 6d 73 20 54 45 58 54 ,.;; params TEXT
31e0: 2c 0a 3b 3b 20 63 72 65 61 74 69 6f 6e 5f 74 69 ,.;; creation_ti
31f0: 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 me TIMESTAMP DEF
3200: 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 AULT (strftime('
3210: 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 3b 3b 20 %s','now')),.;;
3220: 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 54 execution_time T
3230: 49 4d 45 53 54 41 4d 50 29 3b 0a 0a 0a 3b 3b 20 IMESTAMP);...;;
3240: 72 65 67 69 73 74 65 72 20 61 20 74 61 73 6b 0a register a task.
3250: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 61 (define (tasks:a
3260: 64 64 20 64 62 73 74 72 75 63 74 20 61 63 74 69 dd dbstruct acti
3270: 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 on owner target
3280: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
3290: 20 70 61 72 61 6d 73 29 0a 20 20 28 64 62 3a 77 params). (db:w
32a0: 69 74 68 2d 64 62 20 0a 20 20 20 64 62 73 74 72 ith-db . dbstr
32b0: 75 63 74 20 23 66 20 23 74 0a 20 20 20 28 6c 61 uct #f #t. (la
32c0: 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 28 mbda (db). (
32d0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
32e0: 64 62 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 db "INSERT INTO
32f0: 74 61 73 6b 73 5f 71 75 65 75 65 20 28 61 63 74 tasks_queue (act
3300: 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c ion,owner,state,
3310: 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 target,name,test
3320: 70 61 74 74 2c 70 61 72 61 6d 73 2c 63 72 65 61 patt,params,crea
3330: 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 tion_time,execut
3340: 69 6f 6e 5f 74 69 6d 65 29 0a 20 20 20 20 20 20 ion_time).
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 20 20 20 20 20 20 20 56 41 4c 55 45 53 20 28 3f VALUES (?
3370: 2c 3f 2c 27 6e 65 77 27 2c 3f 2c 3f 2c 3f 2c 3f ,?,'new',?,?,?,?
3380: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
3390: 6e 6f 77 27 29 2c 30 29 3b 22 20 0a 09 09 20 20 now'),0);" ...
33a0: 20 20 20 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 action...
33b0: 20 20 20 6f 77 6e 65 72 0a 09 09 20 20 20 20 20 owner...
33c0: 20 74 61 72 67 65 74 0a 09 09 20 20 20 20 20 20 target...
33d0: 72 75 6e 6e 61 6d 65 0a 09 09 20 20 20 20 20 20 runname...
33e0: 74 65 73 74 70 61 74 74 0a 09 09 20 20 20 20 20 testpatt...
33f0: 20 28 69 66 20 70 61 72 61 6d 73 20 70 61 72 61 (if params para
3400: 6d 73 20 22 22 29 29 29 29 29 0a 0a 28 64 65 66 ms "")))))..(def
3410: 69 6e 65 20 28 6b 65 79 73 3a 6b 65 79 2d 76 61 ine (keys:key-va
3420: 6c 73 2d 68 61 73 68 2d 3e 74 61 72 67 65 74 20 ls-hash->target
3430: 6b 65 79 73 20 6b 65 79 2d 70 61 72 61 6d 73 29 keys key-params)
3440: 0a 20 20 28 6c 65 74 20 28 28 74 6d 70 20 28 68 . (let ((tmp (h
3450: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3460: 66 61 75 6c 74 20 6b 65 79 2d 70 61 72 61 6d 73 fault key-params
3470: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 63 61 (vector-ref (ca
3480: 72 20 6b 65 79 73 29 20 30 29 20 22 22 29 29 29 r keys) 0) "")))
3490: 0a 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e . (if (> (len
34a0: 67 74 68 20 6b 65 79 73 29 20 31 29 0a 09 28 66 gth keys) 1)..(f
34b0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
34c0: 28 6b 65 79 29 0a 09 09 20 20 20 20 28 73 65 74 (key)... (set
34d0: 21 20 74 6d 70 20 28 63 6f 6e 63 20 74 6d 70 20 ! tmp (conc tmp
34e0: 22 2f 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d "/" (hash-table-
34f0: 72 65 66 2f 64 65 66 61 75 6c 74 20 6b 65 79 2d ref/default key-
3500: 70 61 72 61 6d 73 20 28 76 65 63 74 6f 72 2d 72 params (vector-r
3510: 65 66 20 6b 65 79 20 30 29 20 22 22 29 29 29 29 ef key 0) ""))))
3520: 0a 09 09 20 20 28 63 64 72 20 6b 65 79 73 29 29 ... (cdr keys))
3530: 29 0a 20 20 20 20 74 6d 70 29 29 0a 09 09 09 09 ). tmp)).....
3540: 09 09 09 09 0a 3b 3b 20 66 6f 72 20 75 73 65 20 .....;; for use
3550: 66 72 6f 6d 20 74 68 65 20 67 75 69 2c 20 6e 6f from the gui, no
3560: 74 20 70 6f 72 74 65 64 0a 3b 3b 0a 3b 3b 20 28 t ported.;;.;; (
3570: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 61 64 define (tasks:ad
3580: 64 2d 66 72 6f 6d 2d 70 61 72 61 6d 73 20 6d 64 d-from-params md
3590: 62 20 61 63 74 69 6f 6e 20 6b 65 79 73 20 6b 65 b action keys ke
35a0: 79 2d 70 61 72 61 6d 73 20 76 61 72 2d 70 61 72 y-params var-par
35b0: 61 6d 73 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ams).;; (let (
35c0: 28 74 61 72 67 65 74 20 20 20 20 28 6b 65 79 73 (target (keys
35d0: 3a 6b 65 79 2d 76 61 6c 73 2d 68 61 73 68 2d 3e :key-vals-hash->
35e0: 74 61 72 67 65 74 20 6b 65 79 73 20 6b 65 79 2d target keys key-
35f0: 70 61 72 61 6d 73 29 29 0a 3b 3b 20 09 28 6f 77 params)).;; .(ow
3600: 6e 65 72 20 20 20 20 20 28 63 61 72 20 28 75 73 ner (car (us
3610: 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 er-information (
3620: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
3630: 29 29 29 0a 3b 3b 20 09 28 72 75 6e 6e 61 6d 65 ))).;; .(runname
3640: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
3650: 65 66 2f 64 65 66 61 75 6c 74 20 76 61 72 2d 70 ef/default var-p
3660: 61 72 61 6d 73 20 22 72 75 6e 6e 61 6d 65 22 20 arams "runname"
3670: 23 66 29 29 0a 3b 3b 20 09 28 74 65 73 74 70 61 #f)).;; .(testpa
3680: 74 74 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d tts (hash-table-
3690: 72 65 66 2f 64 65 66 61 75 6c 74 20 76 61 72 2d ref/default var-
36a0: 70 61 72 61 6d 73 20 22 74 65 73 74 70 61 74 74 params "testpatt
36b0: 73 22 20 22 25 22 29 29 0a 3b 3b 20 09 28 70 61 s" "%")).;; .(pa
36c0: 72 61 6d 73 20 20 20 20 28 68 61 73 68 2d 74 61 rams (hash-ta
36d0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
36e0: 76 61 72 2d 70 61 72 61 6d 73 20 22 70 61 72 61 var-params "para
36f0: 6d 73 22 20 20 20 20 22 22 29 29 29 0a 3b 3b 20 ms" ""))).;;
3700: 20 20 20 20 28 74 61 73 6b 73 3a 61 64 64 20 6d (tasks:add m
3710: 64 62 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 db action owner
3720: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
3730: 65 73 74 70 61 74 74 73 20 70 61 72 61 6d 73 29 estpatts params)
3740: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 6f 6e ))..;; return on
3750: 65 20 74 61 73 6b 20 66 72 6f 6d 20 74 68 6f 73 e task from thos
3760: 65 20 77 68 6f 20 61 72 65 20 27 6e 65 77 27 20 e who are 'new'
3770: 4f 52 20 27 77 61 69 74 69 6e 67 27 20 41 4e 44 OR 'waiting' AND
3780: 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 73 65 63 more than 10sec
3790: 20 6f 6c 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 old.;;.(define
37a0: 28 74 61 73 6b 73 3a 73 6e 61 67 2d 61 2d 74 61 (tasks:snag-a-ta
37b0: 73 6b 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 sk dbstruct). (
37c0: 6c 65 74 20 28 28 72 65 73 20 20 20 20 23 66 29 let ((res #f)
37d0: 0a 09 28 6b 65 79 74 78 74 20 28 63 6f 6e 63 20 ..(keytxt (conc
37e0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
37f0: 2d 69 64 29 20 22 2d 22 20 28 67 65 74 2d 68 6f -id) "-" (get-ho
3800: 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 61 st-name) "-" (ca
3810: 72 20 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 r (user-informat
3820: 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 ion (current-use
3830: 72 2d 69 64 29 29 29 29 29 29 0a 20 20 20 20 28 r-id)))))). (
3840: 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 db:with-db.
3850: 64 62 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 dbstruct #f #t.
3860: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 (lambda (db)
3870: 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 72 73 74 . ;; first
3880: 20 72 61 6e 64 6f 6d 6c 79 20 73 65 74 20 61 20 randomly set a
3890: 6e 65 77 20 74 6f 20 70 69 64 2d 68 6f 73 74 6e new to pid-hostn
38a0: 61 6d 65 2d 68 6f 73 74 6e 61 6d 65 0a 20 20 20 ame-hostname.
38b0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 (sqlite3:exe
38c0: 63 75 74 65 0a 09 64 62 20 0a 09 22 55 50 44 41 cute..db .."UPDA
38d0: 54 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 TE tasks_queue S
38e0: 45 54 20 6b 65 79 6c 6f 63 6b 3d 3f 20 57 48 45 ET keylock=? WHE
38f0: 52 45 20 69 64 20 49 4e 0a 20 20 20 20 20 20 20 RE id IN.
3900: 20 20 20 20 28 53 45 4c 45 43 54 20 69 64 20 46 (SELECT id F
3910: 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 ROM tasks_queue
3920: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 57 . W
3930: 48 45 52 45 20 73 74 61 74 65 3d 27 6e 65 77 27 HERE state='new'
3940: 20 4f 52 20 0a 20 20 20 20 20 20 20 20 20 20 20 OR .
3950: 20 20 20 20 20 20 20 20 20 28 73 74 61 74 65 3d (state=
3960: 27 77 61 69 74 69 6e 67 27 20 41 4e 44 20 28 73 'waiting' AND (s
3970: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
3980: 77 27 29 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 w')-execution_ti
3990: 6d 65 29 20 3e 20 31 30 29 20 4f 52 0a 20 20 20 me) > 10) OR.
39a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39b0: 20 73 74 61 74 65 3d 27 72 65 73 65 74 27 0a 20 state='reset'.
39c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 4f 52 44 ORD
39d0: 45 52 20 42 59 20 52 41 4e 44 4f 4d 28 29 20 4c ER BY RANDOM() L
39e0: 49 4d 49 54 20 31 29 3b 22 20 6b 65 79 74 78 74 IMIT 1);" keytxt
39f0: 29 0a 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 ).. (sqlit
3a00: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
3a10: 09 28 6c 61 6d 62 64 61 20 28 69 64 20 2e 20 72 .(lambda (id . r
3a20: 65 6d 29 0a 09 20 20 28 73 65 74 21 20 72 65 73 em).. (set! res
3a30: 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 69 (apply vector i
3a40: 64 20 72 65 6d 29 29 29 0a 09 64 62 0a 09 22 53 d rem)))..db.."S
3a50: 45 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c ELECT id,action,
3a60: 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 owner,state,targ
3a70: 65 74 2c 6e 61 6d 65 2c 74 65 73 74 2c 69 74 65 et,name,test,ite
3a80: 6d 2c 70 61 72 61 6d 73 2c 63 72 65 61 74 69 6f m,params,creatio
3a90: 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e n_time,execution
3aa0: 5f 74 69 6d 65 20 46 52 4f 4d 20 74 61 73 6b 73 _time FROM tasks
3ab0: 5f 71 75 65 75 65 20 57 48 45 52 45 20 6b 65 79 _queue WHERE key
3ac0: 6c 6f 63 6b 3d 3f 20 4f 52 44 45 52 20 42 59 20 lock=? ORDER BY
3ad0: 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 20 41 execution_time A
3ae0: 53 43 20 4c 49 4d 49 54 20 31 3b 22 20 6b 65 79 SC LIMIT 1;" key
3af0: 74 78 74 29 0a 20 20 20 20 20 20 20 28 69 66 20 txt). (if
3b00: 72 65 73 20 3b 3b 20 79 65 70 2c 20 68 61 76 65 res ;; yep, have
3b10: 20 77 6f 72 6b 20 74 6f 20 62 65 20 64 6f 6e 65 work to be done
3b20: 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 .. (begin..
3b30: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
3b40: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 61 te db "UPDATE ta
3b50: 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 sks_queue SET st
3b60: 61 74 65 3d 27 69 6e 70 72 6f 67 72 65 73 73 27 ate='inprogress'
3b70: 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d 65 3d ,execution_time=
3b80: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
3b90: 6f 77 27 29 20 57 48 45 52 45 20 69 64 3d 3f 3b ow') WHERE id=?;
3ba0: 22 0a 09 09 09 20 20 20 20 20 20 28 74 61 73 6b ".... (task
3bb0: 73 3a 74 61 73 6b 2d 67 65 74 2d 69 64 20 72 65 s:task-get-id re
3bc0: 73 29 29 0a 09 20 20 20 20 20 72 65 73 29 0a 09 s)).. res)..
3bd0: 20 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 #f)))))..(def
3be0: 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 73 65 74 ine (tasks:reset
3bf0: 2d 73 74 75 63 6b 2d 74 61 73 6b 73 20 64 62 73 -stuck-tasks dbs
3c00: 74 72 75 63 74 29 0a 20 20 28 6c 65 74 20 28 28 truct). (let ((
3c10: 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 64 res '())). (d
3c20: 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 b:with-db. d
3c30: 62 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 bstruct #f #t.
3c40: 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a (lambda (db).
3c50: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
3c60: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c for-each-row..(l
3c70: 61 6d 62 64 61 20 28 69 64 20 64 65 6c 74 61 29 ambda (id delta)
3c80: 0a 09 20 20 28 73 65 74 21 20 72 65 73 20 28 63 .. (set! res (c
3c90: 6f 6e 73 20 69 64 20 72 65 73 29 29 29 0a 09 64 ons id res)))..d
3ca0: 62 0a 09 22 53 45 4c 45 43 54 20 69 64 2c 73 74 b.."SELECT id,st
3cb0: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
3cc0: 27 29 2d 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d ')-execution_tim
3cd0: 65 20 41 53 20 64 65 6c 74 61 20 46 52 4f 4d 20 e AS delta FROM
3ce0: 74 61 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 tasks_queue WHER
3cf0: 45 20 73 74 61 74 65 3d 27 69 6e 70 72 6f 67 72 E state='inprogr
3d00: 65 73 73 27 20 41 4e 44 20 64 65 6c 74 61 3e 37 ess' AND delta>7
3d10: 30 30 20 4f 52 44 45 52 20 42 59 20 64 65 6c 74 00 ORDER BY delt
3d20: 61 20 44 45 53 43 20 4c 49 4d 49 54 20 32 3b 22 a DESC LIMIT 2;"
3d30: 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 ). (sqlite
3d40: 33 3a 65 78 65 63 75 74 65 20 0a 09 64 62 20 0a 3:execute ..db .
3d50: 09 28 63 6f 6e 63 20 22 55 50 44 41 54 45 20 74 .(conc "UPDATE t
3d60: 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 asks_queue SET s
3d70: 74 61 74 65 3d 27 72 65 73 65 74 27 20 57 48 45 tate='reset' WHE
3d80: 52 45 20 69 64 20 49 4e 20 28 27 22 20 28 73 74 RE id IN ('" (st
3d90: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
3da0: 20 28 6d 61 70 20 63 6f 6e 63 20 72 65 73 29 20 (map conc res)
3db0: 22 27 2c 27 22 29 20 22 27 29 3b 22 29 0a 09 29 "','") "');")..)
3dc0: 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 ))))..;; return
3dd0: 61 6c 6c 20 74 61 73 6b 73 20 69 6e 20 74 68 65 all tasks in the
3de0: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 74 61 62 tasks_queue tab
3df0: 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 le.;;.(define (t
3e00: 61 73 6b 73 3a 67 65 74 2d 74 61 73 6b 73 20 64 asks:get-tasks d
3e10: 62 73 74 72 75 63 74 20 74 79 70 65 73 20 73 74 bstruct types st
3e20: 61 74 65 73 29 0a 20 20 28 6c 65 74 20 28 28 72 ates). (let ((r
3e30: 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 64 62 es '())). (db
3e40: 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 20 64 62 :with-db. db
3e50: 73 74 72 75 63 74 20 23 66 20 23 66 0a 20 20 20 struct #f #f.
3e60: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 (lambda (db).
3e70: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 (sqlite3:f
3e80: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 28 6c 61 or-each-row..(la
3e90: 6d 62 64 61 20 28 69 64 20 2e 20 72 65 6d 29 0a mbda (id . rem).
3ea0: 09 20 20 28 73 65 74 21 20 72 65 73 20 28 63 6f . (set! res (co
3eb0: 6e 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f 72 ns (apply vector
3ec0: 20 69 64 20 72 65 6d 29 20 72 65 73 29 29 29 0a id rem) res))).
3ed0: 09 64 62 0a 09 28 63 6f 6e 63 20 22 53 45 4c 45 .db..(conc "SELE
3ee0: 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e CT id,action,own
3ef0: 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c er,state,target,
3f00: 6e 61 6d 65 2c 74 65 73 74 2c 69 74 65 6d 2c 70 name,test,item,p
3f10: 61 72 61 6d 73 2c 63 72 65 61 74 69 6f 6e 5f 74 arams,creation_t
3f20: 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 ime,execution_ti
3f30: 6d 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 me .
3f40: 20 20 20 20 20 20 46 52 4f 4d 20 74 61 73 6b 73 FROM tasks
3f50: 5f 71 75 65 75 65 20 22 0a 09 20 20 20 20 20 20 _queue "..
3f60: 3b 3b 20 57 48 45 52 45 20 20 0a 09 20 20 20 20 ;; WHERE ..
3f70: 20 20 3b 3b 20 20 20 73 74 61 74 65 20 49 4e 20 ;; state IN
3f80: 22 20 73 74 61 74 65 73 73 74 72 20 22 20 41 4e " statesstr " AN
3f90: 44 20 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 61 D .. ;; a
3fa0: 63 74 69 6f 6e 20 49 4e 20 22 20 61 63 74 69 6f ction IN " actio
3fb0: 6e 73 73 74 72 20 0a 09 20 20 20 20 20 20 22 20 nsstr .. "
3fc0: 4f 52 44 45 52 20 42 59 20 63 72 65 61 74 69 6f ORDER BY creatio
3fd0: 6e 5f 74 69 6d 65 20 44 45 53 43 3b 22 29 29 0a n_time DESC;")).
3fe0: 20 20 20 20 20 20 20 72 65 73 29 29 29 29 0a 0a res))))..
3ff0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 67 (define (tasks:g
4000: 65 74 2d 6c 61 73 74 20 64 62 73 74 72 75 63 74 et-last dbstruct
4010: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 29 target runname)
4020: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
4030: 29 29 0a 20 20 20 20 28 64 62 3a 77 69 74 68 2d )). (db:with-
4040: 64 62 0a 20 20 20 20 20 64 62 73 74 72 75 63 74 db. dbstruct
4050: 20 23 66 20 23 66 0a 20 20 20 20 20 28 6c 61 6d #f #f. (lam
4060: 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 20 20 bda (db).
4070: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
4080: 68 2d 72 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 h-row..(lambda (
4090: 69 64 20 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 id . rem).. (se
40a0: 74 21 20 72 65 73 20 28 61 70 70 6c 79 20 76 65 t! res (apply ve
40b0: 63 74 6f 72 20 69 64 20 72 65 6d 29 29 29 0a 09 ctor id rem)))..
40c0: 64 62 0a 09 28 63 6f 6e 63 20 22 53 45 4c 45 43 db..(conc "SELEC
40d0: 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 T id,action,owne
40e0: 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c 6e r,state,target,n
40f0: 61 6d 65 2c 74 65 73 74 70 61 74 74 2c 6b 65 79 ame,testpatt,key
4100: 6c 6f 63 6b 2c 70 61 72 61 6d 73 2c 63 72 65 61 lock,params,crea
4110: 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 tion_time,execut
4120: 69 6f 6e 5f 74 69 6d 65 20 0a 20 20 20 20 20 20 ion_time .
4130: 20 20 20 20 20 20 20 20 20 20 20 20 46 52 4f 4d FROM
4140: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 0a 20 09 tasks_queue . .
4150: 20 20 20 20 20 20 20 57 48 45 52 45 20 20 0a 09 WHERE ..
4160: 20 20 20 20 20 20 20 20 74 61 72 67 65 74 20 3d target =
4170: 20 3f 20 41 4e 44 20 6e 61 6d 65 20 3d 3f 0a 09 ? AND name =?..
4180: 20 20 20 20 20 20 20 4f 52 44 45 52 20 42 59 20 ORDER BY
4190: 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 20 44 45 creation_time DE
41a0: 53 43 20 4c 49 4d 49 54 20 31 3b 22 29 0a 09 74 SC LIMIT 1;")..t
41b0: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 arget runname).
41c0: 20 20 20 20 20 20 72 65 73 29 29 29 29 0a 0a 3b res))))..;
41d0: 3b 20 72 65 6d 6f 76 65 20 74 61 73 6b 73 20 67 ; remove tasks g
41e0: 69 76 65 6e 20 62 79 20 61 20 73 74 72 69 6e 67 iven by a string
41f0: 20 6f 66 20 6e 75 6d 62 65 72 73 20 63 6f 6d 6d of numbers comm
4200: 61 20 73 65 70 61 72 61 74 65 64 0a 28 64 65 66 a separated.(def
4210: 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 6d 6f 76 ine (tasks:remov
4220: 65 2d 71 75 65 75 65 2d 65 6e 74 72 69 65 73 20 e-queue-entries
4230: 64 62 73 74 72 75 63 74 20 74 61 73 6b 2d 69 64 dbstruct task-id
4240: 73 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 s). (db:with-db
4250: 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 . dbstruct #f
4260: 23 74 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 #t. (lambda (d
4270: 62 29 0a 20 20 20 20 20 28 73 71 6c 69 74 65 33 b). (sqlite3
4280: 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 6e :execute db (con
4290: 63 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 74 c "DELETE FROM t
42a0: 61 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 asks_queue WHERE
42b0: 20 69 64 20 49 4e 20 28 22 20 74 61 73 6b 2d 69 id IN (" task-i
42c0: 64 73 20 22 29 3b 22 29 29 29 29 29 0a 0a 28 64 ds ");")))))..(d
42d0: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 70 72 6f efine (tasks:pro
42e0: 63 65 73 73 2d 71 75 65 75 65 20 64 62 73 74 72 cess-queue dbstr
42f0: 75 63 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 uct). (let* ((t
4300: 61 73 6b 20 20 20 28 74 61 73 6b 73 3a 73 6e 61 ask (tasks:sna
4310: 67 2d 61 2d 74 61 73 6b 20 64 62 73 74 72 75 63 g-a-task dbstruc
4320: 74 29 29 0a 09 20 28 61 63 74 69 6f 6e 20 28 69 t)).. (action (i
4330: 66 20 74 61 73 6b 20 28 74 61 73 6b 73 3a 74 61 f task (tasks:ta
4340: 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 sk-get-action ta
4350: 73 6b 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 sk) #f))). (i
4360: 66 20 61 63 74 69 6f 6e 20 28 70 72 69 6e 74 20 f action (print
4370: 22 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 "tasks:process-q
4380: 75 65 75 65 20 74 61 73 6b 3a 20 22 20 74 61 73 ueue task: " tas
4390: 6b 29 29 0a 20 20 20 20 28 69 66 20 61 63 74 69 k)). (if acti
43a0: 6f 6e 0a 09 28 63 61 73 65 20 28 73 74 72 69 6e on..(case (strin
43b0: 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 6f 6e g->symbol action
43c0: 29 0a 09 20 20 28 28 72 75 6e 29 20 20 20 20 20 ).. ((run)
43d0: 20 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 72 (tasks:start-r
43e0: 75 6e 20 20 20 20 20 64 62 73 74 72 75 63 74 20 un dbstruct
43f0: 74 61 73 6b 29 29 0a 09 20 20 28 28 72 65 6d 6f task)).. ((remo
4400: 76 65 29 20 20 20 20 28 74 61 73 6b 73 3a 72 65 ve) (tasks:re
4410: 6d 6f 76 65 2d 72 75 6e 73 20 20 20 64 62 73 74 move-runs dbst
4420: 72 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 ruct task)).. (
4430: 28 6c 6f 63 6b 29 20 20 20 20 20 20 28 74 61 73 (lock) (tas
4440: 6b 73 3a 6c 6f 63 6b 2d 72 75 6e 73 20 20 20 20 ks:lock-runs
4450: 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 dbstruct task))
4460: 0a 09 20 20 3b 3b 20 28 28 6d 6f 6e 69 74 6f 72 .. ;; ((monitor
4470: 29 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 74 ) (tasks:start
4480: 2d 6d 6f 6e 69 74 6f 72 20 64 62 20 74 61 73 6b -monitor db task
4490: 29 29 0a 09 20 20 28 28 72 6f 6c 6c 75 70 29 20 )).. ((rollup)
44a0: 20 20 20 28 74 61 73 6b 73 3a 72 6f 6c 6c 75 70 (tasks:rollup
44b0: 2d 72 75 6e 73 20 20 20 64 62 73 74 72 75 63 74 -runs dbstruct
44c0: 20 74 61 73 6b 29 29 0a 09 20 20 28 28 75 70 64 task)).. ((upd
44d0: 61 74 65 6d 65 74 61 29 28 74 61 73 6b 73 3a 75 atemeta)(tasks:u
44e0: 70 64 61 74 65 2d 6d 65 74 61 20 20 20 64 62 73 pdate-meta dbs
44f0: 74 72 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 truct task))..
4500: 28 28 6b 69 6c 6c 29 20 20 20 20 20 20 28 74 61 ((kill) (ta
4510: 73 6b 73 3a 6b 69 6c 6c 2d 6d 6f 6e 69 74 6f 72 sks:kill-monitor
4520: 73 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 s dbstruct task)
4530: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
4540: 74 61 73 6b 73 3a 74 61 73 6b 73 2d 3e 74 65 78 tasks:tasks->tex
4550: 74 20 74 61 73 6b 73 29 0a 20 20 28 6c 65 74 20 t tasks). (let
4560: 28 28 66 6d 74 73 74 72 20 22 7e 31 30 61 7e 31 ((fmtstr "~10a~1
4570: 30 61 7e 31 30 61 7e 31 32 61 7e 32 30 61 7e 31 0a~10a~12a~20a~1
4580: 32 61 7e 31 32 61 7e 31 30 61 22 29 29 0a 20 20 2a~12a~10a")).
4590: 20 20 28 63 6f 6e 63 20 28 66 6f 72 6d 61 74 20 (conc (format
45a0: 23 66 20 66 6d 74 73 74 72 20 22 69 64 22 20 22 #f fmtstr "id" "
45b0: 61 63 74 69 6f 6e 22 20 22 6f 77 6e 65 72 22 20 action" "owner"
45c0: 22 73 74 61 74 65 22 20 22 74 61 72 67 65 74 22 "state" "target"
45d0: 20 22 72 75 6e 6e 61 6d 65 22 20 22 74 65 73 74 "runname" "test
45e0: 70 61 74 74 73 22 20 22 70 61 72 61 6d 73 22 29 patts" "params")
45f0: 20 22 5c 6e 22 0a 09 20 20 28 73 74 72 69 6e 67 "\n".. (string
4600: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 -intersperse ..
4610: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
4620: 74 61 73 6b 29 0a 09 09 20 20 28 66 6f 72 6d 61 task)... (forma
4630: 74 20 23 66 20 66 6d 74 73 74 72 0a 09 09 09 20 t #f fmtstr....
4640: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
4650: 2d 69 64 20 20 20 20 20 74 61 73 6b 29 0a 09 09 -id task)...
4660: 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 . (tasks:task-g
4670: 65 74 2d 61 63 74 69 6f 6e 20 74 61 73 6b 29 0a et-action task).
4680: 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b ... (tasks:task
4690: 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 6b -get-owner task
46a0: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 ).... (tasks:ta
46b0: 73 6b 2d 67 65 74 2d 73 74 61 74 65 20 20 74 61 sk-get-state ta
46c0: 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a sk).... (tasks:
46d0: 74 61 73 6b 2d 67 65 74 2d 74 61 72 67 65 74 20 task-get-target
46e0: 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b task).... (task
46f0: 73 3a 74 61 73 6b 2d 67 65 74 2d 6e 61 6d 65 20 s:task-get-name
4700: 20 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 task).... (ta
4710: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 65 73 sks:task-get-tes
4720: 74 20 20 20 74 61 73 6b 29 0a 09 09 09 20 20 3b t task).... ;
4730: 3b 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 ; (tasks:task-ge
4740: 74 2d 69 74 65 6d 20 20 20 74 61 73 6b 29 0a 09 t-item task)..
4750: 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d .. (tasks:task-
4760: 67 65 74 2d 70 61 72 61 6d 73 20 74 61 73 6b 29 get-params task)
4770: 29 29 0a 09 09 74 61 73 6b 73 29 20 22 5c 6e 22 ))...tasks) "\n"
4780: 29 29 29 29 0a 20 20 20 0a 28 64 65 66 69 6e 65 )))). .(define
4790: 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 (tasks:set-stat
47a0: 65 20 64 62 73 74 72 75 63 74 20 74 61 73 6b 2d e dbstruct task-
47b0: 69 64 20 73 74 61 74 65 29 0a 20 20 28 64 62 3a id state). (db:
47c0: 77 69 74 68 2d 64 62 20 0a 20 20 20 64 62 73 74 with-db . dbst
47d0: 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 28 6c ruct #f #t. (l
47e0: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
47f0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
4800: 20 64 62 20 22 55 50 44 41 54 45 20 74 61 73 6b db "UPDATE task
4810: 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 61 74 s_queue SET stat
4820: 65 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 e=? WHERE id=?;"
4830: 20 0a 09 09 20 20 20 20 20 20 73 74 61 74 65 20 ... state
4840: 0a 09 09 20 20 20 20 20 20 74 61 73 6b 2d 69 64 ... task-id
4850: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
4860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
48a0: 3b 20 41 63 63 65 73 73 20 75 73 69 6e 67 20 74 ; Access using t
48b0: 61 73 6b 20 6b 65 79 20 28 73 74 6f 72 65 64 20 ask key (stored
48c0: 69 6e 20 70 61 72 61 6d 73 3b 20 28 68 61 73 68 in params; (hash
48d0: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c -table->alist fl
48e0: 61 67 73 29 20 68 6f 73 74 6e 61 6d 65 20 70 69 ags) hostname pi
48f0: 64 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d d.;;============
4900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4940: 69 6e 65 20 28 74 61 73 6b 73 3a 70 61 72 61 6d ine (tasks:param
4950: 2d 6b 65 79 2d 3e 69 64 20 64 62 73 74 72 75 63 -key->id dbstruc
4960: 74 20 74 61 73 6b 2d 70 61 72 61 6d 73 29 0a 20 t task-params).
4970: 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 (db:with-db.
4980: 64 62 73 74 72 75 63 74 20 23 66 20 23 66 0a 20 dbstruct #f #f.
4990: 20 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 (lambda (db).
49a0: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
49b0: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e ptions. exn
49c0: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
49d0: 28 73 71 6c 69 74 65 33 3a 66 69 72 73 74 2d 72 (sqlite3:first-r
49e0: 65 73 75 6c 74 20 64 62 20 22 53 45 4c 45 43 54 esult db "SELECT
49f0: 20 69 64 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 id FROM tasks_q
4a00: 75 65 75 65 20 57 48 45 52 45 20 70 61 72 61 6d ueue WHERE param
4a10: 73 20 4c 49 4b 45 20 3f 3b 22 0a 09 09 09 20 20 s LIKE ?;"....
4a20: 20 20 74 61 73 6b 2d 70 61 72 61 6d 73 29 29 29 task-params)))
4a30: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
4a40: 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 69 76 ks:set-state-giv
4a50: 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 64 62 73 en-param-key dbs
4a60: 74 72 75 63 74 20 70 61 72 61 6d 2d 6b 65 79 20 truct param-key
4a70: 6e 65 77 2d 73 74 61 74 65 29 0a 20 20 28 64 62 new-state). (db
4a80: 3a 77 69 74 68 2d 64 62 0a 20 20 20 64 62 73 74 :with-db. dbst
4a90: 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 28 6c ruct #f #t. (l
4aa0: 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 20 ambda (db).
4ab0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
4ac0: 20 64 62 20 22 55 50 44 41 54 45 20 74 61 73 6b db "UPDATE task
4ad0: 73 5f 71 75 65 75 65 20 53 45 54 20 73 74 61 74 s_queue SET stat
4ae0: 65 3d 3f 20 57 48 45 52 45 20 70 61 72 61 6d 73 e=? WHERE params
4af0: 20 4c 49 4b 45 20 3f 3b 22 20 6e 65 77 2d 73 74 LIKE ?;" new-st
4b00: 61 74 65 20 70 61 72 61 6d 2d 6b 65 79 29 29 29 ate param-key)))
4b10: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )..(define (task
4b20: 73 3a 67 65 74 2d 72 65 63 6f 72 64 73 2d 67 69 s:get-records-gi
4b30: 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 64 62 ven-param-key db
4b40: 73 74 72 75 63 74 20 70 61 72 61 6d 2d 6b 65 79 struct param-key
4b50: 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 state-patt acti
4b60: 6f 6e 2d 70 61 74 74 20 74 65 73 74 2d 70 61 74 on-patt test-pat
4b70: 74 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 t). (db:with-db
4b80: 0a 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 . dbstruct #f
4b90: 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 #f. (lambda (d
4ba0: 62 29 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 2d b). (handle-
4bb0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
4bc0: 20 65 78 6e 0a 20 20 20 20 20 20 27 28 29 0a 20 exn. '().
4bd0: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 (sqlite3:fi
4be0: 72 73 74 2d 72 6f 77 20 64 62 20 22 53 45 4c 45 rst-row db "SELE
4bf0: 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e CT id,action,own
4c00: 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c er,state,target,
4c10: 6e 61 6d 65 2c 74 65 73 74 70 61 74 74 2c 6b 65 name,testpatt,ke
4c20: 79 6c 6f 63 6b 2c 70 61 72 61 6d 73 20 57 48 45 ylock,params WHE
4c30: 52 45 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 RE.
4c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c50: 20 20 70 61 72 61 6d 73 20 4c 49 4b 45 20 3f 20 params LIKE ?
4c60: 41 4e 44 20 73 74 61 74 65 20 4c 49 4b 45 20 3f AND state LIKE ?
4c70: 20 41 4e 44 20 61 63 74 69 6f 6e 20 4c 49 4b 45 AND action LIKE
4c80: 20 3f 20 41 4e 44 20 74 65 73 74 70 61 74 74 20 ? AND testpatt
4c90: 4c 49 4b 45 20 3f 3b 22 0a 09 09 09 20 70 61 72 LIKE ?;".... par
4ca0: 61 6d 2d 6b 65 79 20 73 74 61 74 65 2d 70 61 74 am-key state-pat
4cb0: 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 20 74 65 t action-patt te
4cc0: 73 74 2d 70 61 74 74 29 29 29 29 29 0a 0a 28 64 st-patt)))))..(d
4cd0: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 66 69 6e efine (tasks:fin
4ce0: 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 d-task-queue-rec
4cf0: 6f 72 64 73 20 64 62 73 74 72 75 63 74 20 74 61 ords dbstruct ta
4d00: 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 rget run-name te
4d10: 73 74 2d 70 61 74 74 20 73 74 61 74 65 2d 70 61 st-patt state-pa
4d20: 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 0a tt action-patt).
4d30: 20 20 3b 3b 20 28 68 61 6e 64 6c 65 2d 65 78 63 ;; (handle-exc
4d40: 65 70 74 69 6f 6e 73 0a 20 20 3b 3b 20 20 65 78 eptions. ;; ex
4d50: 6e 0a 20 20 3b 3b 20 20 27 28 29 0a 20 20 3b 3b n. ;; '(). ;;
4d60: 20 20 28 73 71 6c 69 74 65 33 3a 66 69 72 73 74 (sqlite3:first
4d70: 2d 72 6f 77 0a 20 20 28 6c 65 74 20 28 28 64 62 -row. (let ((db
4d80: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
4d90: 73 79 20 28 64 62 3a 67 65 74 2d 64 62 20 64 62 sy (db:get-db db
4da0: 73 74 72 75 63 74 29 29 29 0a 09 28 72 65 73 20 struct)))..(res
4db0: 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c 69 74 '())). (sqlit
4dc0: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 e3:for-each-row
4dd0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
4de0: 20 2e 20 62 29 0a 20 20 20 20 20 20 20 28 73 65 . b). (se
4df0: 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 63 6f t! res (cons (co
4e00: 6e 73 20 61 20 62 29 20 72 65 73 29 29 29 0a 20 ns a b) res))).
4e10: 20 20 20 20 64 62 20 22 53 45 4c 45 43 54 20 69 db "SELECT i
4e20: 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 d,action,owner,s
4e30: 74 61 74 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 tate,target,name
4e40: 2c 74 65 73 74 70 61 74 74 2c 6b 65 79 6c 6f 63 ,testpatt,keyloc
4e50: 6b 2c 70 61 72 61 6d 73 20 46 52 4f 4d 20 74 61 k,params FROM ta
4e60: 73 6b 73 5f 71 75 65 75 65 20 0a 20 20 20 20 20 sks_queue .
4e70: 20 20 20 20 20 20 57 48 45 52 45 0a 20 20 20 20 WHERE.
4e80: 20 20 20 20 20 20 20 20 20 20 74 61 72 67 65 74 target
4e90: 20 3d 20 3f 20 41 4e 44 20 6e 61 6d 65 20 3d 20 = ? AND name =
4ea0: 3f 20 41 4e 44 20 73 74 61 74 65 20 4c 49 4b 45 ? AND state LIKE
4eb0: 20 3f 20 41 4e 44 20 61 63 74 69 6f 6e 20 4c 49 ? AND action LI
4ec0: 4b 45 20 3f 20 41 4e 44 20 74 65 73 74 70 61 74 KE ? AND testpat
4ed0: 74 20 4c 49 4b 45 20 3f 3b 22 0a 20 20 20 20 20 t LIKE ?;".
4ee0: 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 target run-name
4ef0: 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f state-patt actio
4f00: 6e 2d 70 61 74 74 20 74 65 73 74 2d 70 61 74 74 n-patt test-patt
4f10: 29 0a 20 20 20 20 72 65 73 29 29 20 3b 3b 20 29 ). res)) ;; )
4f20: 0a 0a 3b 3b 20 6b 69 6c 6c 20 61 6e 79 20 72 75 ..;; kill any ru
4f30: 6e 6e 65 72 20 70 72 6f 63 65 73 73 65 73 20 28 nner processes (
4f40: 69 2e 65 2e 20 70 72 6f 63 65 73 73 65 73 20 68 i.e. processes h
4f50: 61 6e 64 6c 69 6e 67 20 2d 72 75 6e 74 65 73 74 andling -runtest
4f60: 73 29 20 74 68 61 74 20 6d 61 74 63 68 20 74 61 s) that match ta
4f70: 72 67 65 74 2f 72 75 6e 6e 61 6d 65 0a 3b 3b 20 rget/runname.;;
4f80: 0a 3b 3b 20 64 6f 20 61 20 72 65 6d 6f 74 65 20 .;; do a remote
4f90: 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 68 65 20 call to get the
4fa0: 74 61 73 6b 20 71 75 65 75 65 20 69 6e 66 6f 20 task queue info
4fb0: 62 75 74 20 64 6f 20 74 68 65 20 6b 69 6c 6c 69 but do the killi
4fc0: 6e 67 20 61 73 20 73 65 6c 66 20 68 65 72 65 2e ng as self here.
4fd0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 .;;.(define (tas
4fe0: 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 72 20 74 ks:kill-runner t
4ff0: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 arget run-name t
5000: 65 73 74 70 61 74 74 29 0a 20 20 28 6c 65 74 20 estpatt). (let
5010: 28 28 72 65 63 6f 72 64 73 20 20 20 20 28 72 6d ((records (rm
5020: 74 3a 74 61 73 6b 73 2d 66 69 6e 64 2d 74 61 73 t:tasks-find-tas
5030: 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 k-queue-records
5040: 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 target run-name
5050: 74 65 73 74 70 61 74 74 20 22 72 75 6e 6e 69 6e testpatt "runnin
5060: 67 22 20 22 72 75 6e 2d 74 65 73 74 73 22 29 29 g" "run-tests"))
5070: 0a 09 28 68 6f 73 74 70 69 64 2d 72 78 20 28 72 ..(hostpid-rx (r
5080: 65 67 65 78 70 20 22 5c 5c 73 2b 28 5c 5c 77 2b egexp "\\s+(\\w+
5090: 29 5c 5c 73 2b 28 5c 5c 64 2b 29 24 22 29 29 29 )\\s+(\\d+)$")))
50a0: 20 3b 3b 20 68 6f 73 74 20 70 69 64 20 69 73 20 ;; host pid is
50b0: 61 74 20 65 6e 64 20 6f 66 20 70 61 72 61 6d 20 at end of param
50c0: 73 74 72 69 6e 67 0a 20 20 20 20 28 69 66 20 28 string. (if (
50d0: 6e 75 6c 6c 3f 20 72 65 63 6f 72 64 73 29 0a 09 null? records)..
50e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
50f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5100: 2a 20 22 4e 6f 20 72 75 6e 20 6c 61 75 6e 63 68 * "No run launch
5110: 69 6e 67 20 70 72 6f 63 65 73 73 65 73 20 66 6f ing processes fo
5120: 75 6e 64 20 66 6f 72 20 22 20 74 61 72 67 65 74 und for " target
5130: 20 22 20 2f 20 22 20 72 75 6e 2d 6e 61 6d 65 20 " / " run-name
5140: 22 20 77 69 74 68 20 74 65 73 74 70 61 74 74 20 " with testpatt
5150: 22 20 28 6f 72 20 74 65 73 74 70 61 74 74 20 22 " (or testpatt "
5160: 2a 20 6e 6f 20 74 65 73 74 70 61 74 74 20 73 70 * no testpatt sp
5170: 65 63 69 66 69 65 64 21 20 2a 22 29 29 0a 09 28 ecified! *"))..(
5180: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
5190: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
51a0: 20 22 46 6f 75 6e 64 20 22 20 28 6c 65 6e 67 74 "Found " (lengt
51b0: 68 20 72 65 63 6f 72 64 73 29 20 22 20 72 75 6e h records) " run
51c0: 28 73 29 20 74 6f 20 6b 69 6c 6c 2e 22 29 29 0a (s) to kill.")).
51d0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
51e0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 63 (lambda (rec
51f0: 6f 72 64 29 0a 20 20 20 20 20 20 20 28 6c 65 74 ord). (let
5200: 2a 20 28 28 70 61 72 61 6d 2d 6b 65 79 20 28 6c * ((param-key (l
5210: 69 73 74 2d 72 65 66 20 72 65 63 6f 72 64 20 38 ist-ref record 8
5220: 29 29 0a 09 20 20 20 20 20 20 28 6d 61 74 63 68 )).. (match
5230: 2d 64 61 74 20 28 73 74 72 69 6e 67 2d 73 65 61 -dat (string-sea
5240: 72 63 68 20 68 6f 73 74 70 69 64 2d 72 78 20 70 rch hostpid-rx p
5250: 61 72 61 6d 2d 6b 65 79 29 29 29 0a 09 20 28 69 aram-key))).. (i
5260: 66 20 6d 61 74 63 68 2d 64 61 74 0a 09 20 20 20 f match-dat..
5270: 20 20 28 6c 65 74 20 28 28 68 6f 73 74 6e 61 6d (let ((hostnam
5280: 65 20 20 28 63 61 64 72 20 6d 61 74 63 68 2d 64 e (cadr match-d
5290: 61 74 29 29 0a 09 09 20 20 20 28 70 69 64 20 20 at))... (pid
52a0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
52b0: 6d 62 65 72 20 28 63 61 64 64 72 20 6d 61 74 63 mber (caddr matc
52c0: 68 2d 64 61 74 29 29 29 29 0a 09 20 20 20 20 20 h-dat))))..
52d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
52e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
52f0: 72 74 2a 20 22 53 65 6e 64 69 6e 67 20 53 49 47 rt* "Sending SIG
5300: 49 4e 54 20 74 6f 20 70 72 6f 63 65 73 73 20 22 INT to process "
5310: 20 70 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 pid " on host "
5320: 20 68 6f 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 hostname)..
5330: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 (if (equal? (
5340: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 68 get-host-name) h
5350: 6f 73 74 6e 61 6d 65 29 0a 09 09 20 20 20 28 69 ostname)... (i
5360: 66 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 f (process:alive
5370: 3f 20 70 69 64 29 0a 09 09 20 20 20 20 20 20 20 ? pid)...
5380: 28 62 65 67 69 6e 0a 09 09 09 20 28 68 61 6e 64 (begin.... (hand
5390: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
53a0: 09 20 20 65 78 6e 0a 09 09 09 20 20 28 62 65 67 . exn.... (beg
53b0: 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 in.... (debug
53c0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
53d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 69 6c t-log-port* "Kil
53e0: 6c 20 6f 66 20 70 72 6f 63 65 73 73 20 22 20 70 l of process " p
53f0: 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 id " on host " h
5400: 6f 73 74 6e 61 6d 65 20 22 20 66 61 69 6c 65 64 ostname " failed
5410: 2e 22 29 0a 09 09 09 20 20 20 20 28 64 65 62 75 .").... (debu
5420: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
5430: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
5440: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
5450: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
5460: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
5470: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 ssage) exn))....
5480: 20 20 20 20 23 74 29 0a 09 09 09 20 20 28 70 72 #t).... (pr
5490: 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 70 69 64 ocess-signal pid
54a0: 20 73 69 67 6e 61 6c 2f 69 6e 74 29 0a 09 09 09 signal/int)....
54b0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
54c0: 20 35 29 0a 09 09 09 20 20 28 69 66 20 28 70 72 5).... (if (pr
54d0: 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 69 64 ocess:alive? pid
54e0: 29 0a 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 ).... (proc
54f0: 65 73 73 2d 73 69 67 6e 61 6c 20 70 69 64 20 73 ess-signal pid s
5500: 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 0a ignal/kill))))).
5510: 09 09 20 20 20 3b 3b 20 20 28 63 61 6c 6c 2d 77 .. ;; (call-w
5520: 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d ith-environment-
5530: 76 61 72 69 61 62 6c 65 73 0a 09 09 20 20 20 28 variables... (
5540: 6c 65 74 20 28 28 6f 6c 64 2d 74 61 72 67 65 74 let ((old-target
5550: 68 6f 73 74 20 28 67 65 74 65 6e 76 20 22 54 41 host (getenv "TA
5560: 52 47 45 54 48 4f 53 54 22 29 29 29 0a 09 09 20 RGETHOST")))...
5570: 20 20 20 20 28 73 65 74 65 6e 76 20 22 54 41 52 (setenv "TAR
5580: 47 45 54 48 4f 53 54 22 20 68 6f 73 74 6e 61 6d GETHOST" hostnam
5590: 65 29 0a 09 09 20 20 20 20 20 28 73 65 74 65 6e e)... (seten
55a0: 76 20 22 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f v "TARGETHOST_LO
55b0: 47 46 22 20 22 73 65 72 76 65 72 2d 6b 69 6c 6c GF" "server-kill
55c0: 73 2e 6c 6f 67 22 29 0a 09 09 20 20 20 20 20 28 s.log")... (
55d0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6e 62 system (conc "nb
55e0: 66 61 6b 65 20 6b 69 6c 6c 20 22 20 70 69 64 29 fake kill " pid)
55f0: 29 0a 09 09 20 20 20 20 20 28 69 66 20 6f 6c 64 )... (if old
5600: 2d 74 61 72 67 65 74 68 6f 73 74 20 28 73 65 74 -targethost (set
5610: 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 env "TARGETHOST"
5620: 20 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 74 29 old-targethost)
5630: 29 0a 09 09 20 20 20 20 20 28 75 6e 73 65 74 65 )... (unsete
5640: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 29 nv "TARGETHOST")
5650: 0a 09 09 20 20 20 20 20 28 75 6e 73 65 74 65 6e ... (unseten
5660: 76 20 22 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f v "TARGETHOST_LO
5670: 47 46 22 29 29 29 29 0a 09 20 20 20 20 20 28 64 GF")))).. (d
5680: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
5690: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
56a0: 70 6f 72 74 2a 20 22 6e 6f 20 72 65 63 6f 72 64 port* "no record
56b0: 20 6f 72 20 69 6d 70 72 6f 70 65 72 20 72 65 63 or improper rec
56c0: 6f 72 64 20 66 6f 72 20 22 20 74 61 72 67 65 74 ord for " target
56d0: 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 "/" run-name "
56e0: 69 6e 20 74 61 73 6b 73 5f 71 75 65 75 65 20 69 in tasks_queue i
56f0: 6e 20 6d 61 69 6e 2e 64 62 22 29 29 29 29 0a 20 n main.db")))).
5700: 20 20 20 20 72 65 63 6f 72 64 73 29 29 29 0a 0a records)))..
5710: 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b ;; (define (task
5720: 73 3a 73 74 61 72 74 2d 72 75 6e 20 64 62 73 74 s:start-run dbst
5730: 72 75 63 74 20 6d 64 62 20 74 61 73 6b 29 0a 3b ruct mdb task).;
5740: 3b 20 20 20 28 6c 65 74 20 28 28 66 6c 61 67 73 ; (let ((flags
5750: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
5760: 65 29 29 29 0a 3b 3b 20 20 20 20 20 28 68 61 73 e))).;; (has
5770: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 h-table-set! fla
5780: 67 73 20 22 2d 72 65 72 75 6e 22 20 22 4e 4f 54 gs "-rerun" "NOT
5790: 5f 53 54 41 52 54 45 44 22 29 0a 3b 3b 20 20 20 _STARTED").;;
57a0: 20 20 28 69 66 20 28 6e 6f 74 20 28 73 74 72 69 (if (not (stri
57b0: 6e 67 3d 3f 20 28 74 61 73 6b 73 3a 74 61 73 6b ng=? (tasks:task
57c0: 2d 67 65 74 2d 70 61 72 61 6d 73 20 74 61 73 6b -get-params task
57d0: 29 20 22 22 29 29 0a 3b 3b 20 09 28 68 61 73 68 ) "")).;; .(hash
57e0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 -table-set! flag
57f0: 73 20 22 2d 73 65 74 76 61 72 73 22 20 28 74 61 s "-setvars" (ta
5800: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 70 61 72 sks:task-get-par
5810: 61 6d 73 20 74 61 73 6b 29 29 29 0a 3b 3b 20 20 ams task))).;;
5820: 20 20 20 28 70 72 69 6e 74 20 22 53 74 61 72 74 (print "Start
5830: 69 6e 67 20 72 75 6e 20 22 20 74 61 73 6b 29 0a ing run " task).
5840: 3b 3b 20 20 20 20 20 3b 3b 20 73 69 6c 6c 79 6e ;; ;; sillyn
5850: 65 73 73 2c 20 6a 75 73 74 20 63 61 6c 6c 20 74 ess, just call t
5860: 68 65 20 64 61 6d 6e 20 72 6f 75 74 69 6e 65 20 he damn routine
5870: 77 69 74 68 20 74 68 65 20 74 61 73 6b 20 76 65 with the task ve
5880: 63 74 6f 72 20 61 6e 64 20 62 65 20 64 6f 6e 65 ctor and be done
5890: 20 77 69 74 68 20 69 74 2e 20 46 49 58 4d 45 20 with it. FIXME
58a0: 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 20 20 20 28 SOMEDAY.;; (
58b0: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 runs:run-tests d
58c0: 62 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 73 6b b.;; .. (task
58d0: 73 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 67 65 s:task-get-targe
58e0: 74 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 t task).;; ..
58f0: 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 (tasks:task-get
5900: 2d 6e 61 6d 65 20 20 20 74 61 73 6b 29 0a 3b 3b -name task).;;
5910: 20 09 09 20 20 20 20 28 74 61 73 6b 73 3a 74 61 .. (tasks:ta
5920: 73 6b 2d 67 65 74 2d 74 65 73 74 20 20 20 74 61 sk-get-test ta
5930: 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 sk).;; .. (ta
5940: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 74 65 sks:task-get-ite
5950: 6d 20 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 m task).;; ..
5960: 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 (tasks:task-g
5970: 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 6b 29 0a et-owner task).
5980: 3b 3b 20 09 09 20 20 20 20 66 6c 61 67 73 29 0a ;; .. flags).
5990: 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 ;; (tasks:se
59a0: 74 2d 73 74 61 74 65 20 6d 64 62 20 28 74 61 73 t-state mdb (tas
59b0: 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 64 20 74 ks:task-get-id t
59c0: 61 73 6b 29 20 22 77 61 69 74 69 6e 67 22 29 29 ask) "waiting"))
59d0: 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 ).;; .;; (define
59e0: 20 28 74 61 73 6b 73 3a 72 6f 6c 6c 75 70 2d 72 (tasks:rollup-r
59f0: 75 6e 73 20 64 62 20 6d 64 62 20 74 61 73 6b 29 uns db mdb task)
5a00: 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 66 6c .;; (let* ((fl
5a10: 61 67 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ags (make-hash-t
5a20: 61 62 6c 65 29 29 20 0a 3b 3b 20 09 20 28 6b 65 able)) .;; . (ke
5a30: 79 73 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 ys (db:get-keys
5a40: 20 64 62 29 29 0a 3b 3b 20 09 20 28 6b 65 79 76 db)).;; . (keyv
5a50: 61 6c 73 20 28 6b 65 79 73 3a 74 61 72 67 65 74 als (keys:target
5a60: 2d 6b 65 79 76 61 6c 20 6b 65 79 73 20 28 74 61 -keyval keys (ta
5a70: 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 sks:task-get-tar
5a80: 67 65 74 20 74 61 73 6b 29 29 29 29 0a 3b 3b 20 get task)))).;;
5a90: 20 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 ;; (hash-tab
5aa0: 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 20 22 2d le-set! flags "-
5ab0: 72 65 72 75 6e 22 20 22 4e 4f 54 5f 53 54 41 52 rerun" "NOT_STAR
5ac0: 54 45 44 22 29 0a 3b 3b 20 20 20 20 20 28 70 72 TED").;; (pr
5ad0: 69 6e 74 20 22 53 74 61 72 74 69 6e 67 20 72 6f int "Starting ro
5ae0: 6c 6c 75 70 20 22 20 74 61 73 6b 29 0a 3b 3b 20 llup " task).;;
5af0: 20 20 20 20 3b 3b 20 73 69 6c 6c 79 6e 65 73 73 ;; sillyness
5b00: 2c 20 6a 75 73 74 20 63 61 6c 6c 20 74 68 65 20 , just call the
5b10: 64 61 6d 6e 20 72 6f 75 74 69 6e 65 20 77 69 74 damn routine wit
5b20: 68 20 74 68 65 20 74 61 73 6b 20 76 65 63 74 6f h the task vecto
5b30: 72 20 61 6e 64 20 62 65 20 64 6f 6e 65 20 77 69 r and be done wi
5b40: 74 68 20 69 74 2e 20 46 49 58 4d 45 20 53 4f 4d th it. FIXME SOM
5b50: 45 44 41 59 0a 3b 3b 20 20 20 20 20 28 72 75 6e EDAY.;; (run
5b60: 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 64 62 0a s:rollup-run db.
5b70: 3b 3b 20 09 09 20 20 20 20 20 6b 65 79 73 20 0a ;; .. keys .
5b80: 3b 3b 20 09 09 20 20 20 20 20 6b 65 79 76 61 6c ;; .. keyval
5b90: 73 0a 3b 3b 20 09 09 20 20 20 20 20 28 74 61 73 s.;; .. (tas
5ba0: 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e 61 6d 65 ks:task-get-name
5bb0: 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 task).;; ..
5bc0: 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 (tasks:task-ge
5bd0: 74 2d 6f 77 6e 65 72 20 20 74 61 73 6b 29 29 0a t-owner task)).
5be0: 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 ;; (tasks:se
5bf0: 74 2d 73 74 61 74 65 20 6d 64 62 20 28 74 61 73 t-state mdb (tas
5c00: 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 64 20 74 ks:task-get-id t
5c10: 61 73 6b 29 20 22 77 61 69 74 69 6e 67 22 29 29 ask) "waiting"))
5c20: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
5c70: 53 20 59 20 4e 20 43 20 20 20 54 20 4f 20 20 20 S Y N C T O
5c80: 50 20 4f 20 53 20 54 20 47 20 52 20 45 20 53 20 P O S T G R E S
5c90: 51 20 4c 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d Q L.;;==========
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
5ce0: 20 49 6e 20 74 68 65 20 73 70 69 72 69 74 20 6f In the spirit o
5cf0: 66 20 22 64 75 6d 70 20 79 6f 75 72 20 6a 75 6e f "dump your jun
5d00: 6b 20 69 6e 20 74 68 65 20 74 61 73 6b 73 20 6d k in the tasks m
5d10: 6f 64 75 6c 65 22 20 49 27 6c 6c 20 70 75 74 20 odule" I'll put
5d20: 74 68 65 0a 3b 3b 20 73 79 6e 63 20 74 6f 20 70 the.;; sync to p
5d30: 6f 73 74 67 72 65 73 20 68 65 72 65 20 66 6f 72 ostgres here for
5d40: 20 6e 6f 77 2e 0a 0a 3b 3b 20 61 74 74 65 6d 70 now...;; attemp
5d50: 74 20 74 6f 20 61 75 74 6f 6d 61 74 69 63 61 6c t to automatical
5d60: 6c 79 20 73 65 74 20 75 70 20 61 6e 20 61 72 65 ly set up an are
5d70: 61 2e 20 63 61 6c 6c 20 6f 6e 6c 79 20 69 66 20 a. call only if
5d80: 67 65 74 20 61 72 65 61 20 62 79 20 70 61 74 68 get area by path
5d90: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 6e 61 75 67 .;; returns naug
5da0: 68 74 20 6f 66 20 69 6e 74 65 72 65 73 74 0a 3b ht of interest.;
5db0: 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ;.(define (tasks
5dc0: 3a 73 65 74 2d 61 72 65 61 20 64 62 68 20 63 6f :set-area dbh co
5dd0: 6e 66 69 67 64 61 74 20 23 21 6b 65 79 20 28 74 nfigdat #!key (t
5de0: 6f 70 70 61 74 68 20 23 66 29 29 20 3b 3b 20 63 oppath #f)) ;; c
5df0: 6f 75 6c 64 20 49 20 73 61 66 65 6c 79 20 70 75 ould I safely pu
5e00: 74 20 2a 74 6f 70 70 61 74 68 2a 20 69 6e 20 66 t *toppath* in f
5e10: 6f 72 20 74 68 65 20 64 65 66 61 75 6c 74 20 66 or the default f
5e20: 6f 72 20 74 6f 70 70 61 74 68 3f 20 77 68 65 6e or toppath? when
5e30: 20 77 6f 75 6c 64 20 69 74 20 62 65 20 65 76 61 would it be eva
5e40: 6c 75 61 74 65 64 3f 0a 20 20 28 6c 65 74 20 6c luated?. (let l
5e50: 6f 6f 70 20 28 28 61 72 65 61 2d 6e 61 6d 65 20 oop ((area-name
5e60: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
5e70: 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 73 kup configdat "s
5e80: 65 74 75 70 22 20 22 61 72 65 61 2d 6e 61 6d 65 etup" "area-name
5e90: 22 29 0a 09 09 09 20 20 20 20 28 63 6f 6d 6d 6f ").... (commo
5ea0: 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 29 n:get-area-name)
5eb0: 29 29 0a 09 20 20 20 20 20 28 6d 6f 64 69 66 69 )).. (modifi
5ec0: 65 72 20 20 27 6e 6f 6e 65 29 29 0a 20 20 20 20 er 'none)).
5ed0: 28 6c 65 74 20 28 28 73 75 63 63 65 73 73 20 28 (let ((success (
5ee0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
5ef0: 73 0a 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 s... exn..
5f00: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
5f10: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
5f20: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5f30: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e ort* "ERROR: can
5f40: 6e 6f 74 20 63 72 65 61 74 65 20 61 72 65 61 20 not create area
5f50: 65 6e 74 72 79 2c 20 22 20 28 28 63 6f 6e 64 69 entry, " ((condi
5f60: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
5f70: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
5f80: 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 20 sage) exn))....
5f90: 23 66 29 20 3b 3b 20 46 49 58 4d 45 3a 20 49 20 #f) ;; FIXME: I
5fa0: 64 6f 6e 27 74 20 63 61 72 65 20 66 6f 72 20 6e don't care for n
5fb0: 6f 77 20 62 75 74 20 49 20 73 68 6f 75 6c 64 20 ow but I should
5fc0: 6c 6f 6f 6b 20 61 74 20 2a 77 68 79 2a 20 74 68 look at *why* th
5fd0: 65 72 65 20 77 61 73 20 61 6e 20 65 78 63 65 70 ere was an excep
5fe0: 74 69 6f 6e 0a 09 09 20 20 20 20 20 28 70 67 64 tion... (pgd
5ff0: 62 3a 61 64 64 2d 61 72 65 61 20 64 62 68 20 61 b:add-area dbh a
6000: 72 65 61 2d 6e 61 6d 65 20 28 6f 72 20 74 6f 70 rea-name (or top
6010: 70 61 74 68 20 2a 74 6f 70 70 61 74 68 2a 29 29 path *toppath*))
6020: 29 29 29 0a 20 20 20 20 20 20 28 6f 72 20 73 75 ))). (or su
6030: 63 63 65 73 73 0a 09 20 20 28 63 61 73 65 20 6d ccess.. (case m
6040: 6f 64 69 66 69 65 72 0a 09 20 20 20 20 28 28 6e odifier.. ((n
6050: 6f 6e 65 29 28 6c 6f 6f 70 20 28 63 6f 6e 63 20 one)(loop (conc
6060: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
6070: 6d 65 29 20 22 5f 22 20 61 72 65 61 2d 6e 61 6d me) "_" area-nam
6080: 65 29 20 27 75 73 65 72 29 29 0a 09 20 20 20 20 e) 'user))..
6090: 28 28 75 73 65 72 29 28 6c 6f 6f 70 20 28 63 6f ((user)(loop (co
60a0: 6e 63 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 nc (substring (c
60b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 ommon:get-area-p
60c0: 61 74 68 2d 73 69 67 6e 61 74 75 72 65 29 20 30 ath-signature) 0
60d0: 20 34 29 0a 09 09 09 20 20 20 20 20 20 20 61 72 4).... ar
60e0: 65 61 2d 6e 61 6d 65 29 20 27 61 72 65 61 73 69 ea-name) 'areasi
60f0: 67 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 23 g)).. (else #
6100: 66 29 29 29 29 29 29 20 3b 3b 20 67 69 76 65 20 f)))))) ;; give
6110: 75 70 0a 0a 3b 3b 20 67 65 74 73 20 6d 74 70 67 up..;; gets mtpg
6120: 2d 72 75 6e 2d 69 64 20 61 6e 64 20 73 79 6e 63 -run-id and sync
6130: 73 20 74 68 65 20 72 65 63 6f 72 64 20 69 66 20 s the record if
6140: 64 69 66 66 65 72 65 6e 74 0a 3b 3b 0a 28 64 65 different.;;.(de
6150: 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 75 6e 2d fine (tasks:run-
6160: 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 id->mtpg-run-id
6170: 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 dbh cached-info
6180: 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 run-id). (let*
6190: 28 28 72 75 6e 73 2d 68 74 20 28 68 61 73 68 2d ((runs-ht (hash-
61a0: 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 table-ref cached
61b0: 2d 69 6e 66 6f 20 27 72 75 6e 73 29 29 0a 09 20 -info 'runs))..
61c0: 28 72 75 6e 69 6e 66 20 20 28 68 61 73 68 2d 74 (runinf (hash-t
61d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
61e0: 20 72 75 6e 73 2d 68 74 20 72 75 6e 2d 69 64 20 runs-ht run-id
61f0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 72 75 #f))). (if ru
6200: 6e 69 6e 66 0a 09 72 75 6e 69 6e 66 20 3b 3b 20 ninf..runinf ;;
6210: 61 6c 72 65 61 64 79 20 63 61 63 68 65 64 0a 09 already cached..
6220: 28 6c 65 74 2a 20 28 28 6b 65 79 74 61 72 67 20 (let* ((keytarg
6230: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
6240: 73 70 65 72 73 65 20 28 72 6d 74 3a 67 65 74 2d sperse (rmt:get-
6250: 6b 65 79 73 29 20 22 2f 22 29 29 20 3b 3b 20 65 keys) "/")) ;; e
6260: 2e 67 2e 20 76 65 72 73 69 6f 6e 2f 69 74 65 72 .g. version/iter
6270: 61 74 69 6f 6e 2f 70 6c 61 74 66 6f 72 6d 0a 09 ation/platform..
6280: 20 20 20 20 20 20 20 28 73 70 65 63 2d 69 64 20 (spec-id
6290: 20 20 20 28 70 67 64 62 3a 67 65 74 2d 74 74 79 (pgdb:get-tty
62a0: 70 65 20 64 62 68 20 6b 65 79 74 61 72 67 29 29 pe dbh keytarg))
62b0: 0a 09 20 20 20 20 20 20 20 28 74 61 72 67 65 74 .. (target
62c0: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 61 (rmt:get-ta
62d0: 72 67 65 74 20 72 75 6e 2d 69 64 29 29 20 20 20 rget run-id))
62e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
62f0: 20 65 2e 67 2e 20 76 31 2e 36 33 2f 61 33 65 31 e.g. v1.63/a3e1
6300: 2f 75 62 75 6e 74 75 0a 09 20 20 20 20 20 20 20 /ubuntu..
6310: 28 72 75 6e 2d 64 61 74 20 20 20 20 28 72 6d 74 (run-dat (rmt
6320: 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 :get-run-info ru
6330: 6e 2d 69 64 29 29 20 20 20 20 20 20 20 20 20 20 n-id))
6340: 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 67 65 ;; NOTE: ge
6350: 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 65 74 75 72 t-run-info retur
6360: 6e 73 20 61 20 76 65 63 74 6f 72 20 3c 20 72 6f ns a vector < ro
6370: 77 20 68 65 61 64 65 72 20 3e 0a 09 20 20 20 20 w header >..
6380: 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 20 28 (run-name (
6390: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 rmt:get-run-name
63a0: 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 29 -from-id run-id)
63b0: 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d 72 ).. (new-r
63c0: 75 6e 2d 69 64 20 28 70 67 64 62 3a 67 65 74 2d un-id (pgdb:get-
63d0: 72 75 6e 2d 69 64 20 64 62 68 20 73 70 65 63 2d run-id dbh spec-
63e0: 69 64 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 id target run-na
63f0: 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 72 6f me)).. (ro
6400: 77 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 w (db:get
6410: 2d 72 6f 77 73 20 72 75 6e 2d 64 61 74 29 29 20 -rows run-dat))
6420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6430: 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 72 ;; yes, this r
6440: 65 74 75 72 6e 73 20 61 20 73 69 6e 67 6c 65 20 eturns a single
6450: 72 6f 77 0a 09 20 20 20 20 20 20 20 28 68 65 61 row.. (hea
6460: 64 65 72 20 20 20 20 20 28 64 62 3a 67 65 74 2d der (db:get-
6470: 68 65 61 64 65 72 20 72 75 6e 2d 64 61 74 29 29 header run-dat))
6480: 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 65 20 .. (state
6490: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c (db:get-val
64a0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
64b0: 20 68 65 61 64 65 72 20 22 73 74 61 74 65 20 22 header "state "
64c0: 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 )).. (stat
64d0: 75 73 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 us (db:get-v
64e0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
64f0: 6f 77 20 68 65 61 64 65 72 20 22 73 74 61 74 75 ow header "statu
6500: 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 6f 77 s")).. (ow
6510: 6e 65 72 20 20 20 20 20 20 28 64 62 3a 67 65 74 ner (db:get
6520: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
6530: 20 72 6f 77 20 68 65 61 64 65 72 20 22 6f 77 6e row header "own
6540: 65 72 22 29 29 0a 09 20 20 20 20 20 20 20 28 65 er")).. (e
6550: 76 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a 67 65 vent-time (db:ge
6560: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
6570: 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 65 76 r row header "ev
6580: 65 6e 74 5f 74 69 6d 65 22 29 29 0a 09 20 20 20 ent_time"))..
6590: 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 (comment
65a0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
65b0: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
65c0: 65 72 20 22 63 6f 6d 6d 65 6e 74 22 29 29 0a 09 er "comment"))..
65d0: 20 20 20 20 20 20 20 28 66 61 69 6c 2d 63 6f 75 (fail-cou
65e0: 6e 74 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 nt (db:get-value
65f0: 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 -by-header row h
6600: 65 61 64 65 72 20 22 66 61 69 6c 5f 63 6f 75 6e eader "fail_coun
6610: 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 t")).. (pa
6620: 73 73 2d 63 6f 75 6e 74 20 28 64 62 3a 67 65 74 ss-count (db:get
6630: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
6640: 20 72 6f 77 20 68 65 61 64 65 72 20 22 70 61 73 row header "pas
6650: 73 5f 63 6f 75 6e 74 22 29 29 0a 09 20 20 20 20 s_count"))..
6660: 20 20 20 3b 3b 20 28 61 72 65 61 2d 69 64 20 20 ;; (area-id
6670: 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d (db:get-value-
6680: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
6690: 61 64 65 72 20 22 61 72 65 61 5f 69 64 29 22 29 ader "area_id)")
66a0: 29 0a 09 20 20 20 20 20 20 20 29 0a 09 20 20 28 ).. ).. (
66b0: 69 66 20 6e 65 77 2d 72 75 6e 2d 69 64 0a 09 20 if new-run-id..
66c0: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
66d0: 65 74 20 28 28 72 75 6e 2d 72 65 63 6f 72 64 20 et ((run-record
66e0: 28 70 67 64 62 3a 67 65 74 2d 72 75 6e 2d 69 6e (pgdb:get-run-in
66f0: 66 6f 20 64 62 68 20 6e 65 77 2d 72 75 6e 2d 69 fo dbh new-run-i
6700: 64 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c d))...(hash-tabl
6710: 65 2d 73 65 74 21 20 72 75 6e 73 2d 68 74 20 72 e-set! runs-ht r
6720: 75 6e 2d 69 64 20 6e 65 77 2d 72 75 6e 2d 69 64 un-id new-run-id
6730: 29 0a 09 09 3b 3b 20 65 6e 73 75 72 65 20 6b 65 )...;; ensure ke
6740: 79 20 66 69 65 6c 64 73 20 61 72 65 20 75 70 20 y fields are up
6750: 74 6f 20 64 61 74 65 0a 09 09 28 70 67 64 62 3a to date...(pgdb:
6760: 72 65 66 72 65 73 68 2d 72 75 6e 2d 69 6e 66 6f refresh-run-info
6770: 0a 09 09 20 64 62 68 0a 09 09 20 6e 65 77 2d 72 ... dbh... new-r
6780: 75 6e 2d 69 64 0a 09 09 20 73 74 61 74 65 20 73 un-id... state s
6790: 74 61 74 75 73 20 6f 77 6e 65 72 20 65 76 65 6e tatus owner even
67a0: 74 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 66 t-time comment f
67b0: 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d 63 ail-count pass-c
67c0: 6f 75 6e 74 29 0a 09 09 6e 65 77 2d 72 75 6e 2d ount)...new-run-
67d0: 69 64 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 id).. (if (
67e0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
67f0: 73 0a 09 09 20 20 20 20 20 20 65 78 6e 0a 09 09 s... exn...
6800: 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 70 72 (begin (pr
6810: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 20 int-call-chain)
6820: 23 66 29 0a 09 09 20 20 20 20 28 70 67 64 62 3a #f)... (pgdb:
6830: 69 6e 73 65 72 74 2d 72 75 6e 0a 09 09 20 20 20 insert-run...
6840: 20 20 64 62 68 0a 09 09 20 20 20 20 20 73 70 65 dbh... spe
6850: 63 2d 69 64 20 74 61 72 67 65 74 20 72 75 6e 2d c-id target run-
6860: 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 name state statu
6870: 73 20 6f 77 6e 65 72 20 65 76 65 6e 74 2d 74 69 s owner event-ti
6880: 6d 65 20 63 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d me comment fail-
6890: 63 6f 75 6e 74 20 70 61 73 73 2d 63 6f 75 6e 74 count pass-count
68a0: 29 29 20 3b 3b 20 61 72 65 61 2d 69 64 29 29 0a )) ;; area-id)).
68b0: 09 09 20 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 .. (tasks:run-i
68c0: 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 d->mtpg-run-id d
68d0: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 bh cached-info r
68e0: 75 6e 2d 69 64 29 0a 09 09 20 20 23 66 29 29 29 un-id)... #f)))
68f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 )))..(define (ta
6900: 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 73 2d 64 sks:sync-tests-d
6910: 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d 69 ata dbh cached-i
6920: 6e 66 6f 20 74 65 73 74 2d 69 64 73 29 0a 20 20 nfo test-ids).
6930: 28 6c 65 74 20 28 28 74 65 73 74 2d 68 74 20 28 (let ((test-ht (
6940: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 hash-table-ref c
6950: 61 63 68 65 64 2d 69 6e 66 6f 20 27 74 65 73 74 ached-info 'test
6960: 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 s))). (for-ea
6970: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
6980: 28 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 (test-id).
6990: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 69 6e (let* ((test-in
69a0: 66 6f 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 fo (rmt:get-t
69b0: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 est-info-by-id #
69c0: 66 20 74 65 73 74 2d 69 64 29 29 0a 09 20 20 20 f test-id))..
69d0: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 (run-id
69e0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
69f0: 6e 5f 69 64 20 20 20 20 74 65 73 74 2d 69 6e 66 n_id test-inf
6a00: 6f 29 29 20 3b 3b 20 6c 6f 6f 6b 20 74 68 65 73 o)) ;; look thes
6a10: 65 20 75 70 20 69 6e 20 64 62 5f 72 65 63 6f 72 e up in db_recor
6a20: 64 73 2e 73 63 6d 0a 09 20 20 20 20 20 20 28 74 ds.scm.. (t
6a30: 65 73 74 2d 69 64 20 20 20 20 20 20 28 64 62 3a est-id (db:
6a40: 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 20 test-get-id
6a50: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
6a60: 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 (test-name
6a70: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
6a80: 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 2d -testname test-
6a90: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 69 info)).. (i
6aa0: 74 65 6d 2d 70 61 74 68 20 20 20 20 28 64 62 3a tem-path (db:
6ab0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
6ac0: 74 68 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 th test-info))..
6ad0: 20 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 (state
6ae0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
6af0: 2d 73 74 61 74 65 20 20 20 20 20 74 65 73 74 2d -state test-
6b00: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 info)).. (s
6b10: 74 61 74 75 73 20 20 20 20 20 20 20 28 64 62 3a tatus (db:
6b20: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
6b30: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
6b40: 20 20 20 20 20 20 28 68 6f 73 74 20 20 20 20 20 (host
6b50: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
6b60: 2d 68 6f 73 74 20 20 20 20 20 20 74 65 73 74 2d -host test-
6b70: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 63 info)).. (c
6b80: 70 75 6c 6f 61 64 20 20 20 20 20 20 28 64 62 3a puload (db:
6b90: 74 65 73 74 2d 67 65 74 2d 63 70 75 6c 6f 61 64 test-get-cpuload
6ba0: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
6bb0: 20 20 20 20 20 20 28 64 69 73 6b 66 72 65 65 20 (diskfree
6bc0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
6bd0: 2d 64 69 73 6b 66 72 65 65 20 20 74 65 73 74 2d -diskfree test-
6be0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 75 info)).. (u
6bf0: 6e 61 6d 65 20 20 20 20 20 20 20 20 28 64 62 3a name (db:
6c00: 74 65 73 74 2d 67 65 74 2d 75 6e 61 6d 65 20 20 test-get-uname
6c10: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
6c20: 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 20 (run-dir
6c30: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
6c40: 2d 72 75 6e 64 69 72 20 20 20 20 74 65 73 74 2d -rundir test-
6c50: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 6c info)).. (l
6c60: 6f 67 2d 66 69 6c 65 20 20 20 20 20 28 64 62 3a og-file (db:
6c70: 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f 6c test-get-final_l
6c80: 6f 67 66 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a ogf test-info)).
6c90: 09 20 20 20 20 20 20 28 72 75 6e 2d 64 75 72 61 . (run-dura
6ca0: 74 69 6f 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 tion (db:test-ge
6cb0: 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 t-run_duration t
6cc0: 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 est-info))..
6cd0: 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 (comment
6ce0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f 6d (db:test-get-com
6cf0: 6d 65 6e 74 20 20 20 74 65 73 74 2d 69 6e 66 6f ment test-info
6d00: 29 29 0a 09 20 20 20 20 20 20 28 65 76 65 6e 74 )).. (event
6d10: 2d 74 69 6d 65 20 20 20 28 64 62 3a 74 65 73 74 -time (db:test
6d20: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
6d30: 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 test-info))..
6d40: 20 20 20 28 61 72 63 68 69 76 65 64 20 20 20 20 (archived
6d50: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 61 72 (db:test-get-ar
6d60: 63 68 69 76 65 64 20 20 74 65 73 74 2d 69 6e 66 chived test-inf
6d70: 6f 29 29 0a 09 20 20 20 20 20 20 28 70 67 64 62 o)).. (pgdb
6d80: 2d 72 75 6e 2d 69 64 20 20 28 74 61 73 6b 73 3a -run-id (tasks:
6d90: 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e run-id->mtpg-run
6da0: 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 -id dbh cached-i
6db0: 6e 66 6f 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 nfo run-id))..
6dc0: 20 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d 69 (pgdb-test-i
6dd0: 64 20 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 d (pgdb:get-test
6de0: 2d 69 64 20 64 62 68 20 70 67 64 62 2d 72 75 6e -id dbh pgdb-run
6df0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
6e00: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 3b 3b 20 em-path))).. ;;
6e10: 22 69 64 22 20 20 20 20 20 20 20 20 20 20 20 22 "id" "
6e20: 72 75 6e 5f 69 64 22 20 20 20 20 20 20 20 20 22 run_id" "
6e30: 74 65 73 74 6e 61 6d 65 22 20 20 22 73 74 61 74 testname" "stat
6e40: 65 22 20 20 20 20 20 20 22 73 74 61 74 75 73 22 e" "status"
6e50: 20 20 20 20 20 20 22 65 76 65 6e 74 5f 74 69 6d "event_tim
6e60: 65 22 0a 09 20 3b 3b 20 22 68 6f 73 74 22 20 20 e".. ;; "host"
6e70: 20 20 20 20 20 20 20 22 63 70 75 6c 6f 61 64 22 "cpuload"
6e80: 20 20 20 20 20 20 20 22 64 69 73 6b 66 72 65 65 "diskfree
6e90: 22 20 20 22 75 6e 61 6d 65 22 20 20 20 20 20 20 " "uname"
6ea0: 22 72 75 6e 64 69 72 22 20 20 20 20 20 20 22 69 "rundir" "i
6eb0: 74 65 6d 5f 70 61 74 68 22 0a 09 20 3b 3b 20 22 tem_path".. ;; "
6ec0: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 22 20 22 66 run_duration" "f
6ed0: 69 6e 61 6c 5f 6c 6f 67 66 22 20 20 20 20 22 63 inal_logf" "c
6ee0: 6f 6d 6d 65 6e 74 22 20 20 20 22 73 68 6f 72 74 omment" "short
6ef0: 64 69 72 22 20 20 20 22 61 74 74 65 6d 70 74 6e dir" "attemptn
6f00: 75 6d 22 20 20 22 61 72 63 68 69 76 65 64 22 0a um" "archived".
6f10: 09 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d . (if pgdb-test-
6f20: 69 64 20 3b 3b 20 68 61 76 65 20 61 20 72 65 63 id ;; have a rec
6f30: 6f 72 64 0a 09 20 20 20 20 20 28 62 65 67 69 6e ord.. (begin
6f40: 20 3b 3b 20 6c 65 74 20 28 28 6b 65 79 2d 6e 61 ;; let ((key-na
6f50: 6d 65 20 28 63 6f 6e 63 20 72 75 6e 2d 69 64 20 me (conc run-id
6f60: 22 2f 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f "/" test-name "/
6f70: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
6f80: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
6f90: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 68 74 20 le-set! test-ht
6fa0: 74 65 73 74 2d 69 64 20 70 67 64 62 2d 74 65 73 test-id pgdb-tes
6fb0: 74 2d 69 64 29 0a 09 20 20 20 20 20 20 20 28 70 t-id).. (p
6fc0: 72 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 65 rint "Updating e
6fd0: 78 69 73 74 69 6e 67 20 74 65 73 74 20 77 69 74 xisting test wit
6fe0: 68 20 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d h run-id: " run-
6ff0: 69 64 20 22 20 61 6e 64 20 74 65 73 74 2d 69 64 id " and test-id
7000: 3a 20 22 20 74 65 73 74 2d 69 64 29 0a 09 20 20 : " test-id)..
7010: 20 20 20 20 20 28 70 67 64 62 3a 75 70 64 61 74 (pgdb:updat
7020: 65 2d 74 65 73 74 20 64 62 68 20 70 67 64 62 2d e-test dbh pgdb-
7030: 74 65 73 74 2d 69 64 20 70 67 64 62 2d 72 75 6e test-id pgdb-run
7040: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
7050: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 em-path state st
7060: 61 74 75 73 20 68 6f 73 74 20 63 70 75 6c 6f 61 atus host cpuloa
7070: 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 6d 65 d diskfree uname
7080: 20 72 75 6e 2d 64 69 72 20 6c 6f 67 2d 66 69 6c run-dir log-fil
7090: 65 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 63 e run-duration c
70a0: 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 2d 74 69 6d omment event-tim
70b0: 65 20 61 72 63 68 69 76 65 64 29 29 0a 09 20 20 e archived))..
70c0: 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d (pgdb:insert-
70d0: 74 65 73 74 20 64 62 68 20 70 67 64 62 2d 72 75 test dbh pgdb-ru
70e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
70f0: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 tem-path state s
7100: 74 61 74 75 73 20 68 6f 73 74 20 63 70 75 6c 6f tatus host cpulo
7110: 61 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 6d ad diskfree unam
7120: 65 20 72 75 6e 2d 64 69 72 20 6c 6f 67 2d 66 69 e run-dir log-fi
7130: 6c 65 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 le run-duration
7140: 63 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 2d 74 69 comment event-ti
7150: 6d 65 20 61 72 63 68 69 76 65 64 29 29 0a 09 20 me archived))..
7160: 29 29 0a 20 20 20 20 20 74 65 73 74 2d 69 64 73 )). test-ids
7170: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 72 75 6e 73 )))..;; get runs
7180: 20 63 68 61 6e 67 65 64 20 73 69 6e 63 65 20 6c changed since l
7190: 61 73 74 20 73 79 6e 63 0a 3b 3b 20 28 64 65 66 ast sync.;; (def
71a0: 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d ine (tasks:sync-
71b0: 74 65 73 74 2d 64 61 74 61 20 64 62 68 20 63 61 test-data dbh ca
71c0: 63 68 65 64 2d 69 6e 66 6f 20 61 72 65 61 2d 69 ched-info area-i
71d0: 6e 66 6f 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 nfo).;; (let*
71e0: 28 28 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ((..(define (tas
71f0: 6b 73 3a 73 79 6e 63 2d 74 6f 2d 70 6f 73 74 67 ks:sync-to-postg
7200: 72 65 73 20 63 6f 6e 66 69 67 64 61 74 20 64 65 res configdat de
7210: 73 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 st). (let* ((db
7220: 68 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a h (pgdb:
7230: 6f 70 65 6e 20 63 6f 6e 66 69 67 64 61 74 20 64 open configdat d
7240: 62 6e 61 6d 65 3a 20 64 65 73 74 29 29 0a 09 20 bname: dest))..
7250: 28 61 72 65 61 2d 69 6e 66 6f 20 20 20 28 70 67 (area-info (pg
7260: 64 62 3a 67 65 74 2d 61 72 65 61 2d 62 79 2d 70 db:get-area-by-p
7270: 61 74 68 20 64 62 68 20 2a 74 6f 70 70 61 74 68 ath dbh *toppath
7280: 2a 29 29 0a 09 20 28 63 61 63 68 65 64 2d 69 6e *)).. (cached-in
7290: 66 6f 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 fo (make-hash-ta
72a0: 62 6c 65 29 29 0a 09 20 28 73 74 61 72 74 20 20 ble)).. (start
72b0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 (current-se
72c0: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 66 6f conds))). (fo
72d0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
72e0: 64 74 79 70 65 29 0a 09 09 28 68 61 73 68 2d 74 dtype)...(hash-t
72f0: 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 64 able-set! cached
7300: 2d 69 6e 66 6f 20 64 74 79 70 65 20 28 6d 61 6b -info dtype (mak
7310: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
7320: 09 20 20 20 20 20 20 27 28 72 75 6e 73 20 74 61 . '(runs ta
7330: 72 67 65 74 73 20 74 65 73 74 73 29 29 0a 20 20 rgets tests)).
7340: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
7350: 74 21 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 t! cached-info '
7360: 73 74 61 72 74 20 73 74 61 72 74 29 20 3b 3b 20 start start) ;;
7370: 77 68 65 6e 20 64 6f 6e 65 20 77 65 27 6c 6c 20 when done we'll
7380: 73 65 74 20 73 79 6e 63 20 74 69 6d 65 73 20 74 set sync times t
7390: 6f 20 74 68 69 73 0a 20 20 20 20 28 69 66 20 61 o this. (if a
73a0: 72 65 61 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 rea-info..(let*
73b0: 28 28 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 ((last-sync-time
73c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 (vector-ref are
73d0: 61 2d 69 6e 66 6f 20 33 29 29 0a 09 20 20 20 20 a-info 3))..
73e0: 20 20 20 28 63 68 61 6e 67 65 64 20 20 20 20 20 (changed
73f0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 63 68 61 6e (rmt:get-chan
7400: 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 20 6c ged-record-ids l
7410: 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 0a ast-sync-time)).
7420: 09 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 73 . (run-ids
7430: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
7440: 65 66 20 27 72 75 6e 73 20 20 20 20 20 20 20 63 ef 'runs c
7450: 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 20 hanged))..
7460: 20 28 74 65 73 74 2d 69 64 73 20 20 20 20 20 20 (test-ids
7470: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 65 73 (alist-ref 'tes
7480: 74 73 20 20 20 20 20 20 63 68 61 6e 67 65 64 29 ts changed)
7490: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
74a0: 73 74 65 70 2d 69 64 73 20 20 28 61 6c 69 73 74 step-ids (alist
74b0: 2d 72 65 66 20 27 74 65 73 74 5f 73 74 65 70 73 -ref 'test_steps
74c0: 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 changed))..
74d0: 20 20 20 28 74 65 73 74 2d 64 61 74 61 2d 69 64 (test-data-id
74e0: 73 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 s (alist-ref 't
74f0: 65 73 74 5f 64 61 74 61 20 20 63 68 61 6e 67 65 est_data change
7500: 64 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e d)).. (run
7510: 2d 73 74 61 74 2d 69 64 73 20 20 20 28 61 6c 69 -stat-ids (ali
7520: 73 74 2d 72 65 66 20 27 72 75 6e 5f 73 74 61 74 st-ref 'run_stat
7530: 73 20 20 63 68 61 6e 67 65 64 29 29 29 0a 09 20 s changed)))..
7540: 20 28 70 72 69 6e 74 20 22 61 72 65 61 2d 69 6e (print "area-in
7550: 66 6f 3a 20 22 20 61 72 65 61 2d 69 6e 66 6f 29 fo: " area-info)
7560: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 .. (if (not (nu
7570: 6c 6c 3f 20 74 65 73 74 2d 69 64 73 29 29 0a 09 ll? test-ids))..
7580: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
7590: 70 72 69 6e 74 20 22 53 79 6e 63 69 6e 67 20 22 print "Syncing "
75a0: 20 28 6c 65 6e 67 74 68 20 74 65 73 74 2d 69 64 (length test-id
75b0: 73 29 20 22 20 63 68 61 6e 67 65 64 20 74 65 73 s) " changed tes
75c0: 74 73 22 29 0a 09 09 28 74 61 73 6b 73 3a 73 79 ts")...(tasks:sy
75d0: 6e 63 2d 74 65 73 74 73 2d 64 61 74 61 20 64 62 nc-tests-data db
75e0: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 h cached-info te
75f0: 73 74 2d 69 64 73 29 29 29 0a 09 20 20 28 70 67 st-ids))).. (pg
7600: 64 62 3a 77 72 69 74 65 2d 73 79 6e 63 2d 74 69 db:write-sync-ti
7610: 6d 65 20 64 62 68 20 61 72 65 61 2d 69 6e 66 6f me dbh area-info
7620: 20 73 74 61 72 74 29 29 0a 09 28 69 66 20 28 74 start))..(if (t
7630: 61 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 62 asks:set-area db
7640: 68 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 20 20 h configdat)..
7650: 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f (tasks:sync-to
7660: 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 67 -postgres config
7670: 64 61 74 20 64 65 73 74 29 0a 09 20 20 20 20 28 dat dest).. (
7680: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
7690: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
76a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
76b0: 45 52 52 4f 52 3a 20 75 6e 61 62 6c 65 20 74 6f ERROR: unable to
76c0: 20 63 72 65 61 74 65 20 61 6e 20 61 72 65 61 20 create an area
76d0: 72 65 63 6f 72 64 22 29 0a 09 20 20 20 20 20 20 record")..
76e0: 23 66 29 29 29 29 29 0a 0a #f)))))..