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 35 20 2a 64 65 66 bug:print 5 *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 63 6f 6d 6d 6f 6e 3a -exists (common:
0660: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
0670: 6c 70 61 74 68 29 29 0a 09 09 20 20 20 20 28 63 lpath))... (c
0680: 6f 75 6e 74 20 20 20 20 20 20 20 20 20 20 6e 29 ount n)
0690: 29 20 3b 3b 20 77 61 69 74 20 74 65 6e 20 74 69 ) ;; wait ten ti
06a0: 6d 65 73 20 2e 2e 2e 0a 09 20 20 20 28 69 66 20 mes ..... (if
06b0: 6a 6f 75 72 6e 61 6c 2d 65 78 69 73 74 73 0a 09 journal-exists..
06c0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
06d0: 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 69 6e (if (and waitin
06e0: 67 2d 6d 73 67 0a 09 09 09 20 20 28 65 71 3f 20 g-msg.... (eq?
06f0: 28 6d 6f 64 75 6c 6f 20 6e 20 33 30 29 20 30 29 (modulo n 30) 0)
0700: 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a )... (debug:
0710: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0720: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 77 61 69 74 69 -log-port* waiti
0730: 6e 67 2d 6d 73 67 29 29 0a 09 09 20 28 69 66 20 ng-msg))... (if
0740: 28 3e 20 63 6f 75 6e 74 20 30 29 0a 09 09 20 20 (> count 0)...
0750: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
0760: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
0770: 21 20 31 29 0a 09 09 20 20 20 20 20 20 20 28 6c ! 1)... (l
0780: 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 oop (common:file
0790: 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 61 74 -exists? fullpat
07a0: 68 29 0a 09 09 09 20 20 20 20 20 28 2d 20 63 6f h).... (- co
07b0: 75 6e 74 20 31 29 29 29 0a 09 09 20 20 20 20 20 unt 1)))...
07c0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 (begin...
07d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
07e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
07f0: 2a 20 22 45 52 52 4f 52 3a 20 72 65 6d 6f 76 69 * "ERROR: removi
0800: 6e 67 20 74 68 65 20 6a 6f 75 72 6e 61 6c 20 66 ng the journal f
0810: 69 6c 65 20 22 20 66 75 6c 6c 70 61 74 68 20 22 ile " fullpath "
0820: 2c 20 74 68 69 73 20 69 73 20 6e 6f 74 20 67 6f , this is not go
0830: 6f 64 2e 20 4c 6f 6f 6b 20 66 6f 72 20 64 69 73 od. Look for dis
0840: 6b 20 66 75 6c 6c 2c 20 77 72 69 74 65 20 61 63 k full, write ac
0850: 63 65 73 73 20 61 6e 64 20 6f 74 68 65 72 20 69 cess and other i
0860: 73 73 75 65 73 2e 22 29 0a 09 09 20 20 20 20 20 ssues.")...
0870: 20 20 28 69 66 20 72 65 6d 6f 76 65 20 28 73 79 (if remove (sy
0880: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d stem (conc "rm -
0890: 72 66 20 22 20 66 75 6c 6c 70 61 74 68 29 29 29 rf " fullpath)))
08a0: 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a ... #f))).
08b0: 09 20 20 20 20 20 20 20 23 74 29 29 29 29 29 29 . #t))))))
08c0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
08d0: 3a 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 74 :get-task-db-pat
08e0: 68 29 0a 20 20 28 6c 65 74 20 28 28 64 62 64 69 h). (let ((dbdi
08f0: 72 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a r (or (configf:
0900: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
0910: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 6f 6e 69 t* "setup" "moni
0920: 74 6f 72 64 69 72 22 29 0a 09 09 20 20 20 20 28 tordir")... (
0930: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
0940: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
0950: 70 22 20 22 64 62 64 69 72 22 29 0a 09 09 20 20 p" "dbdir")...
0960: 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a (conc (common:
0970: 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 20 22 2f get-linktree) "/
0980: 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 68 61 .db")))). (ha
0990: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
09a0: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 exn. (b
09b0: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 egin. (deb
09c0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
09d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
09e0: 72 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 72 rt* "Couldn't cr
09f0: 65 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 64 eate path to " d
0a00: 62 64 69 72 29 0a 20 20 20 20 20 20 20 28 65 78 bdir). (ex
0a10: 69 74 20 31 29 29 0a 20 20 20 20 20 28 69 66 20 it 1)). (if
0a20: 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 3f (not (directory?
0a30: 20 64 62 64 69 72 29 29 28 63 72 65 61 74 65 2d dbdir))(create-
0a40: 64 69 72 65 63 74 6f 72 79 20 64 62 64 69 72 20 directory dbdir
0a50: 23 74 29 29 29 0a 20 20 20 20 64 62 64 69 72 29 #t))). dbdir)
0a60: 29 0a 0a 3b 3b 20 49 66 20 66 69 6c 65 20 65 78 )..;; If file ex
0a70: 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 20 66 ists AND.;; f
0a80: 69 6c 65 20 72 65 61 64 61 62 6c 65 0a 3b 3b 20 ile readable.;;
0a90: 20 20 20 20 20 20 20 20 3d 3d 3e 20 6f 70 65 6e ==> open
0aa0: 20 69 74 0a 3b 3b 20 49 66 20 66 69 6c 65 20 65 it.;; If file e
0ab0: 78 69 73 74 73 20 41 4e 44 0a 3b 3b 20 20 20 20 xists AND.;;
0ac0: 66 69 6c 65 20 4e 4f 54 20 72 65 61 64 61 62 6c file NOT readabl
0ad0: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 3d 3d 3e e.;; ==>
0ae0: 20 6f 70 65 6e 20 69 6e 2d 6d 65 6d 20 76 65 72 open in-mem ver
0af0: 73 69 6f 6e 0a 3b 3b 20 49 66 20 66 69 6c 65 20 sion.;; If file
0b00: 4e 4f 54 20 65 78 69 73 74 73 0a 3b 3b 20 20 20 NOT exists.;;
0b10: 20 3d 3d 3e 20 6f 70 65 6e 20 69 6e 2d 6d 65 6d ==> open in-mem
0b20: 20 76 65 72 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 version.;;.(def
0b30: 69 6e 65 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d ine (tasks:open-
0b40: 64 62 20 23 21 6b 65 79 20 28 6e 75 6d 72 65 74 db #!key (numret
0b50: 72 69 65 73 20 34 29 29 0a 20 20 28 69 66 20 2a ries 4)). (if *
0b60: 74 61 73 6b 2d 64 62 2a 0a 20 20 20 20 20 20 2a task-db*. *
0b70: 74 61 73 6b 2d 64 62 2a 0a 20 20 20 20 20 20 28 task-db*. (
0b80: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
0b90: 73 0a 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 s. exn.
0ba0: 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 (if (> numre
0bb0: 74 72 69 65 73 20 30 29 0a 09 20 20 20 28 62 65 tries 0).. (be
0bc0: 67 69 6e 0a 09 20 20 20 20 20 28 70 72 69 6e 74 gin.. (print
0bd0: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
0be0: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
0bf0: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
0c00: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
0c10: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
0c20: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
0c30: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
0c40: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
0c50: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 ge) exn))..
0c60: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a (debug:print 5 *
0c70: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0c80: 2a 20 22 20 65 78 6e 3d 22 20 28 63 6f 6e 64 69 * " exn=" (condi
0c90: 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 tion->list exn))
0ca0: 0a 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
0cb0: 6c 65 65 70 21 20 31 29 0a 09 20 20 20 20 20 28 leep! 1).. (
0cc0: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 6e 75 tasks:open-db nu
0cd0: 6d 72 65 74 72 69 65 73 20 28 2d 20 6e 75 6d 72 mretries (- numr
0ce0: 65 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 etries 1)))..
0cf0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 70 72 (begin.. (pr
0d00: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
0d10: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
0d20: 72 74 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 rt)).. (debu
0d30: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
0d40: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
0d50: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
0d60: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0d70: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
0d80: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 ssage) exn))..
0d90: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0da0: 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 5 *default-log-p
0db0: 6f 72 74 2a 20 22 20 65 78 6e 3d 22 20 28 63 6f ort* " exn=" (co
0dc0: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
0dd0: 6e 29 29 29 29 0a 20 20 20 20 20 20 20 28 6c 65 n)))). (le
0de0: 74 2a 20 28 28 64 62 70 61 74 68 20 20 20 20 20 t* ((dbpath
0df0: 20 20 20 28 64 62 3a 64 62 66 69 6c 65 2d 70 61 (db:dbfile-pa
0e00: 74 68 20 29 29 20 3b 3b 20 28 74 61 73 6b 73 3a th )) ;; (tasks:
0e10: 67 65 74 2d 74 61 73 6b 2d 64 62 2d 70 61 74 68 get-task-db-path
0e20: 29 29 0a 09 20 20 20 20 20 20 28 64 62 66 69 6c )).. (dbfil
0e30: 65 20 20 20 20 20 20 20 28 63 6f 6e 63 20 64 62 e (conc db
0e40: 70 61 74 68 20 22 2f 6d 6f 6e 69 74 6f 72 2e 64 path "/monitor.d
0e50: 62 22 29 29 0a 09 20 20 20 20 20 20 28 61 76 61 b")).. (ava
0e60: 69 6c 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 il (tasks
0e70: 3a 77 61 69 74 2d 6f 6e 2d 6a 6f 75 72 6e 61 6c :wait-on-journal
0e80: 20 64 62 70 61 74 68 20 31 30 29 29 20 3b 3b 20 dbpath 10)) ;;
0e90: 77 61 69 74 20 75 70 20 74 6f 20 61 62 6f 75 74 wait up to about
0ea0: 20 31 30 20 73 65 63 6f 6e 64 73 20 66 6f 72 20 10 seconds for
0eb0: 74 68 65 20 6a 6f 75 72 6e 61 6c 20 74 6f 20 67 the journal to g
0ec0: 6f 20 61 77 61 79 0a 09 20 20 20 20 20 20 28 65 o away.. (e
0ed0: 78 69 73 74 73 20 20 20 20 20 20 20 28 63 6f 6d xists (com
0ee0: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
0ef0: 20 64 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 dbpath))..
0f00: 20 28 77 72 69 74 65 2d 61 63 63 65 73 73 20 28 (write-access (
0f10: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
0f20: 73 3f 20 64 62 70 61 74 68 29 29 0a 09 20 20 20 s? dbpath))..
0f30: 20 20 20 28 6d 64 62 20 20 20 20 20 20 20 20 20 (mdb
0f40: 20 28 63 6f 6e 64 20 3b 3b 20 77 68 61 74 20 74 (cond ;; what t
0f50: 68 65 20 68 65 6b 20 69 73 20 2a 74 6f 70 70 61 he hek is *toppa
0f60: 74 68 2a 20 64 6f 69 6e 67 20 68 65 72 65 3f 0a th* doing here?.
0f70: 09 09 09 20 20 20 20 20 28 28 61 6e 64 20 28 73 ... ((and (s
0f80: 74 72 69 6e 67 3f 20 2a 74 6f 70 70 61 74 68 2a tring? *toppath*
0f90: 29 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 )(file-write-acc
0fa0: 65 73 73 3f 20 2a 74 6f 70 70 61 74 68 2a 29 29 ess? *toppath*))
0fb0: 0a 09 09 09 20 20 20 20 20 20 28 73 71 6c 69 74 .... (sqlit
0fc0: 65 33 3a 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 e3:open-database
0fd0: 20 64 62 66 69 6c 65 29 29 0a 09 09 09 20 20 20 dbfile))....
0fe0: 20 20 28 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 ((file-read-ac
0ff0: 63 65 73 73 3f 20 64 62 70 61 74 68 29 20 20 20 cess? dbpath)
1000: 20 28 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 (sqlite3:open-d
1010: 61 74 61 62 61 73 65 20 64 62 66 69 6c 65 29 29 atabase dbfile))
1020: 0a 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 28 .... (else (
1030: 73 71 6c 69 74 65 33 3a 6f 70 65 6e 2d 64 61 74 sqlite3:open-dat
1040: 61 62 61 73 65 20 22 3a 6d 65 6d 6f 72 79 3a 22 abase ":memory:"
1050: 29 29 29 29 20 3b 3b 20 28 6e 65 76 65 72 2d 67 )))) ;; (never-g
1060: 69 76 65 2d 75 70 2d 6f 70 65 6e 2d 64 62 20 64 ive-up-open-db d
1070: 62 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 bpath)).. (
1080: 68 61 6e 64 6c 65 72 20 20 20 20 20 20 28 6d 61 handler (ma
1090: 6b 65 2d 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 ke-busy-timeout
10a0: 33 36 30 30 30 29 29 29 0a 09 20 28 69 66 20 28 36000))).. (if (
10b0: 61 6e 64 20 65 78 69 73 74 73 0a 09 09 20 20 28 and exists... (
10c0: 6e 6f 74 20 77 72 69 74 65 2d 61 63 63 65 73 73 not write-access
10d0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 2a )).. (set! *
10e0: 64 62 2d 77 72 69 74 65 2d 61 63 63 65 73 73 2a db-write-access*
10f0: 20 77 72 69 74 65 2d 61 63 63 65 73 73 29 29 20 write-access))
1100: 3b 3b 20 6f 6e 6c 79 20 75 6e 73 65 74 20 73 6f ;; only unset so
1110: 20 6f 74 68 65 72 20 64 62 27 73 20 61 6c 73 6f other db's also
1120: 20 63 61 6e 20 75 73 65 20 74 68 69 73 20 63 6f can use this co
1130: 6e 74 72 6f 6c 0a 09 20 28 73 71 6c 69 74 65 33 ntrol.. (sqlite3
1140: 3a 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 :set-busy-handle
1150: 72 21 20 6d 64 62 20 68 61 6e 64 6c 65 72 29 0a r! mdb handler).
1160: 09 20 28 64 62 3a 73 65 74 2d 73 79 6e 63 20 6d . (db:set-sync m
1170: 64 62 29 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a db) ;; (sqlite3:
1180: 65 78 65 63 75 74 65 20 6d 64 62 20 28 63 6f 6e execute mdb (con
1190: 63 20 22 50 52 41 47 4d 41 20 73 79 6e 63 68 72 c "PRAGMA synchr
11a0: 6f 6e 6f 75 73 20 3d 20 30 3b 22 29 29 0a 09 20 onous = 0;"))..
11b0: 3b 3b 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 ;; (if (or (and
11c0: 20 28 6e 6f 74 20 65 78 69 73 74 73 29 0a 09 20 (not exists)..
11d0: 3b 3b 20 09 20 20 20 20 20 20 28 66 69 6c 65 2d ;; . (file-
11e0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 write-access? *t
11f0: 6f 70 70 61 74 68 2a 29 29 0a 09 20 3b 3b 20 09 oppath*)).. ;; .
1200: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 (not (file-read
1210: 2d 61 63 63 65 73 73 3f 20 64 62 70 61 74 68 29 -access? dbpath)
1220: 29 29 0a 09 20 3b 3b 20 20 20 20 20 20 28 62 65 )).. ;; (be
1230: 67 69 6e 0a 09 20 3b 3b 20 0a 09 20 3b 3b 20 54 gin.. ;; .. ;; T
1240: 41 53 4b 53 20 51 55 45 55 45 20 4d 4f 56 45 44 ASKS QUEUE MOVED
1250: 20 54 4f 20 6d 61 69 6e 2e 64 62 0a 09 20 3b 3b TO main.db.. ;;
1260: 0a 09 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 65 .. ;; (sqlite3:e
1270: 78 65 63 75 74 65 20 6d 64 62 20 22 43 52 45 41 xecute mdb "CREA
1280: 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 TE TABLE IF NOT
1290: 45 58 49 53 54 53 20 74 61 73 6b 73 5f 71 75 65 EXISTS tasks_que
12a0: 75 65 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 ue (id INTEGER P
12b0: 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 RIMARY KEY,.
12c0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 ;;
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 a
12e0: 63 74 69 6f 6e 20 54 45 58 54 20 44 45 46 41 55 ction TEXT DEFAU
12f0: 4c 54 20 27 27 2c 0a 20 20 20 20 20 20 20 20 20 LT '',.
1300: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
1310: 20 20 20 20 20 20 20 20 20 20 6f 77 6e 65 72 20 owner
1320: 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 3b TEXT,. ;
1330: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
1340: 20 20 20 20 20 20 20 20 20 73 74 61 74 65 20 54 state T
1350: 45 58 54 20 44 45 46 41 55 4c 54 20 27 6e 65 77 EXT DEFAULT 'new
1360: 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ',. ;;
1370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1380: 20 20 20 20 20 20 74 61 72 67 65 74 20 54 45 58 target TEX
1390: 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a 20 20 T DEFAULT '',.
13a0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c0: 20 6e 61 6d 65 20 54 45 58 54 20 44 45 46 41 55 name TEXT DEFAU
13d0: 4c 54 20 27 27 2c 0a 20 20 20 20 20 20 20 20 20 LT '',.
13e0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
13f0: 20 20 20 20 20 20 20 20 20 20 74 65 73 74 70 61 testpa
1400: 74 74 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 tt TEXT DEFAULT
1410: 27 27 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 '',. ;;
1420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1430: 20 20 20 20 20 20 20 6b 65 79 6c 6f 63 6b 20 54 keylock T
1440: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b EXT,. ;;
1450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1460: 20 20 20 20 20 20 20 20 70 61 72 61 6d 73 20 54 params T
1470: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 3b 3b EXT,. ;;
1480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1490: 20 20 20 20 20 20 20 20 63 72 65 61 74 69 6f 6e creation
14a0: 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 2c _time TIMESTAMP,
14b0: 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 . ;;
14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14d0: 20 20 20 20 65 78 65 63 75 74 69 6f 6e 5f 74 69 execution_ti
14e0: 6d 65 20 54 49 4d 45 53 54 41 4d 50 29 3b 22 29 me TIMESTAMP);")
14f0: 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 .. (sqlite3:exec
1500: 75 74 65 20 6d 64 62 20 22 43 52 45 41 54 45 20 ute mdb "CREATE
1510: 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
1520: 53 54 53 20 6d 6f 6e 69 74 6f 72 73 20 28 69 64 STS monitors (id
1530: 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
1540: 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 KEY,.
1550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1560: 20 20 20 20 20 20 70 69 64 20 49 4e 54 45 47 45 pid INTEGE
1570: 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 R,.
1580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1590: 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 start_time TI
15a0: 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 MESTAMP,.
15b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15c0: 20 20 20 20 20 20 20 20 20 6c 61 73 74 5f 75 70 last_up
15d0: 64 61 74 65 20 54 49 4d 45 53 54 41 4d 50 2c 0a date TIMESTAMP,.
15e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1600: 68 6f 73 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 hostname TEXT,.
1610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 u
1630: 73 65 72 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 sername TEXT,.
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 20 20 20 20 20 43 4f 4e CON
1660: 53 54 52 41 49 4e 54 20 6d 6f 6e 69 74 6f 72 73 STRAINT monitors
1670: 5f 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 _constraint UNIQ
1680: 55 45 20 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 UE (pid,hostname
1690: 29 29 3b 22 29 0a 09 20 28 73 71 6c 69 74 65 33 ));").. (sqlite3
16a0: 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 43 52 :execute mdb "CR
16b0: 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f EATE TABLE IF NO
16c0: 54 20 45 58 49 53 54 53 20 73 65 72 76 65 72 73 T EXISTS servers
16d0: 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
16e0: 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 MARY KEY,.
16f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1700: 20 20 20 20 20 20 20 20 20 20 20 20 70 69 64 20 pid
1710: 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
1720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1730: 20 20 20 20 20 20 20 20 20 20 20 69 6e 74 65 72 inter
1740: 66 61 63 65 20 54 45 58 54 2c 0a 20 20 20 20 20 face TEXT,.
1750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1760: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 hos
1770: 74 6e 61 6d 65 20 54 45 58 54 2c 0a 20 20 20 20 tname TEXT,.
1780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 6f po
17a0: 72 74 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 rt INTEGER,.
17b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 75 pu
17d0: 62 70 6f 72 74 20 49 4e 54 45 47 45 52 2c 0a 20 bport INTEGER,.
17e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1800: 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 start_time TIME
1810: 53 54 41 4d 50 2c 0a 20 20 20 20 20 20 20 20 20 STAMP,.
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1830: 20 20 20 20 20 20 20 20 20 70 72 69 6f 72 69 74 priorit
1840: 79 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 y INTEGER,.
1850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1860: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 sta
1870: 74 65 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 te TEXT,.
1880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1890: 20 20 20 20 20 20 20 20 20 20 20 6d 74 5f 76 65 mt_ve
18a0: 72 73 69 6f 6e 20 54 45 58 54 2c 0a 20 20 20 20 rsion TEXT,.
18b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 65 he
18d0: 61 72 74 62 65 61 74 20 54 49 4d 45 53 54 41 4d artbeat TIMESTAM
18e0: 50 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 P,.
18f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1900: 20 20 20 20 20 74 72 61 6e 73 70 6f 72 74 20 54 transport T
1910: 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 EXT,.
1920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1930: 20 20 20 20 20 20 20 72 75 6e 5f 69 64 20 49 4e run_id IN
1940: 54 45 47 45 52 29 3b 22 29 0a 09 20 3b 3b 20 20 TEGER);").. ;;
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 20 43 4f 4e CON
1970: 53 54 52 41 49 4e 54 20 73 65 72 76 65 72 73 5f STRAINT servers_
1980: 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 constraint UNIQU
1990: 45 20 28 70 69 64 2c 68 6f 73 74 6e 61 6d 65 2c E (pid,hostname,
19a0: 70 6f 72 74 29 29 3b 22 29 0a 09 20 28 73 71 6c port));").. (sql
19b0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 ite3:execute mdb
19c0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
19d0: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 63 6c 69 F NOT EXISTS cli
19e0: 65 6e 74 73 20 28 69 64 20 49 4e 54 45 47 45 52 ents (id INTEGER
19f0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 PRIMARY KEY,.
1a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a20: 73 65 72 76 65 72 5f 69 64 20 49 4e 54 45 47 45 server_id INTEGE
1a30: 52 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 R,.
1a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a50: 20 20 20 20 20 70 69 64 20 49 4e 54 45 47 45 52 pid INTEGER
1a60: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,.
1a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a80: 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 54 45 58 hostname TEX
1a90: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 T,.
1aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ab0: 20 20 20 20 20 63 6d 64 6c 69 6e 65 20 54 45 58 cmdline TEX
1ac0: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 T,.
1ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ae0: 20 20 20 20 20 6c 6f 67 69 6e 5f 74 69 6d 65 20 login_time
1af0: 54 49 4d 45 53 54 41 4d 50 2c 0a 20 20 20 20 20 TIMESTAMP,.
1b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 67 log
1b20: 6f 75 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 out_time TIMESTA
1b30: 4d 50 20 44 45 46 41 55 4c 54 20 2d 31 2c 0a 20 MP DEFAULT -1,.
1b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 43 C
1b60: 4f 4e 53 54 52 41 49 4e 54 20 63 6c 69 65 6e 74 ONSTRAINT client
1b70: 73 5f 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 s_constraint UNI
1b80: 51 55 45 20 28 70 69 64 2c 68 6f 73 74 6e 61 6d QUE (pid,hostnam
1b90: 65 29 29 3b 22 29 0a 09 20 20 20 20 20 20 20 0a e));").. .
1ba0: 09 20 20 20 20 20 20 20 3b 29 29 0a 09 20 28 73 . ;)).. (s
1bb0: 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 28 63 et! *task-db* (c
1bc0: 6f 6e 73 20 6d 64 62 20 64 62 70 61 74 68 29 29 ons mdb dbpath))
1bd0: 0a 09 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 29 .. *task-db*))))
1be0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 65 ==========.;; Se
1c30: 72 76 65 72 20 61 6e 64 20 63 6c 69 65 6e 74 20 rver and client
1c40: 6d 61 6e 61 67 65 6d 65 6e 74 0a 3b 3b 3d 3d 3d management.;;===
1c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c90: 3d 3d 3d 0a 0a 3b 3b 20 6d 61 6b 65 2d 76 65 63 ===..;; make-vec
1ca0: 74 6f 72 2d 72 65 63 6f 72 64 20 74 61 73 6b 73 tor-record tasks
1cb0: 20 68 6f 73 74 69 6e 66 6f 20 69 64 20 69 6e 74 hostinfo id int
1cc0: 65 72 66 61 63 65 20 70 6f 72 74 20 70 75 62 70 erface port pubp
1cd0: 6f 72 74 20 74 72 61 6e 73 70 6f 72 74 20 70 69 ort transport pi
1ce0: 64 20 68 6f 73 74 6e 61 6d 65 0a 28 64 65 66 69 d hostname.(defi
1cf0: 6e 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e ne (tasks:hostin
1d00: 66 6f 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 fo-get-id
1d10: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
1d20: 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a or-ref vec 0)).
1d30: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 (define (tasks:h
1d40: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 ostinfo-get-inte
1d50: 72 66 61 63 65 20 20 20 76 65 63 29 20 20 20 20 rface vec)
1d60: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
1d70: 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 1)).(define (ta
1d80: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
1d90: 2d 70 6f 72 74 20 20 20 20 20 20 20 20 76 65 63 -port vec
1da0: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
1db0: 20 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e vec 2)).(defin
1dc0: 65 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 e (tasks:hostinf
1dd0: 6f 2d 67 65 74 2d 70 75 62 70 6f 72 74 20 20 20 o-get-pubport
1de0: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
1df0: 72 2d 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 r-ref vec 3)).(
1e00: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 68 6f define (tasks:ho
1e10: 73 74 69 6e 66 6f 2d 67 65 74 2d 74 72 61 6e 73 stinfo-get-trans
1e20: 70 6f 72 74 20 20 20 76 65 63 29 20 20 20 20 28 port vec) (
1e30: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
1e40: 34 29 29 0a 28 64 65 66 69 6e 65 20 28 74 61 73 4)).(define (tas
1e50: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
1e60: 70 69 64 20 20 20 20 20 20 20 20 20 76 65 63 29 pid vec)
1e70: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
1e80: 20 76 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 vec 5)).(define
1e90: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
1ea0: 2d 67 65 74 2d 68 6f 73 74 6e 61 6d 65 20 20 20 -get-hostname
1eb0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
1ec0: 2d 72 65 66 20 20 76 65 63 20 36 29 29 0a 0a 28 -ref vec 6))..(
1ed0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6e 65 define (tasks:ne
1ee0: 65 64 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 ed-server run-id
1ef0: 29 0a 20 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e ). (equal? (con
1f00: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
1f10: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
1f20: 20 22 72 65 71 75 69 72 65 64 22 29 20 22 79 65 "required") "ye
1f30: 73 22 29 29 0a 0a 3b 3b 20 6e 6f 20 65 6c 65 67 s"))..;; no eleg
1f40: 61 6e 63 65 20 68 65 72 65 20 2e 2e 2e 0a 3b 3b ance here ....;;
1f50: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
1f60: 6b 69 6c 6c 2d 73 65 72 76 65 72 20 68 6f 73 74 kill-server host
1f70: 6e 61 6d 65 20 70 69 64 20 23 21 6b 65 79 20 28 name pid #!key (
1f80: 6b 69 6c 6c 2d 73 77 69 74 63 68 20 22 22 29 29 kill-switch ""))
1f90: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1fa0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1fb0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d log-port* "Attem
1fc0: 70 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 73 65 pting to kill se
1fd0: 72 76 65 72 20 70 72 6f 63 65 73 73 20 22 20 70 rver process " p
1fe0: 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 id " on host " h
1ff0: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 73 65 74 65 ostname). (sete
2000: 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 22 20 nv "TARGETHOST"
2010: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
2020: 2a 20 28 28 6c 6f 67 64 69 72 20 28 69 66 20 28 * ((logdir (if (
2030: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2040: 3f 20 22 6c 6f 67 73 22 29 0a 20 20 20 20 20 20 ? "logs").
2050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 6c "l
2060: 6f 67 73 2f 22 0a 20 20 20 20 20 20 20 20 20 20 ogs/".
2070: 20 20 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 "")).
2080: 20 20 20 20 20 20 20 20 28 6c 6f 67 66 69 6c 65 (logfile
2090: 20 28 69 66 20 6c 6f 67 64 69 72 20 28 63 6f 6e (if logdir (con
20a0: 63 20 22 6c 6f 67 73 2f 73 65 72 76 65 72 2d 22 c "logs/server-"
20b0: 70 69 64 22 2d 22 68 6f 73 74 6e 61 6d 65 22 2e pid"-"hostname".
20c0: 6c 6f 67 22 29 20 23 66 29 29 0a 20 20 20 20 20 log") #f)).
20d0: 20 20 20 20 28 67 7a 66 69 6c 65 20 20 28 69 66 (gzfile (if
20e0: 20 6c 6f 67 66 69 6c 65 20 28 63 6f 6e 63 20 6c logfile (conc l
20f0: 6f 67 66 69 6c 65 20 22 2e 67 7a 22 29 29 29 29 ogfile ".gz"))))
2100: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 54 41 . (setenv "TA
2110: 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 28 RGETHOST_LOGF" (
2120: 63 6f 6e 63 20 6c 6f 67 64 69 72 20 22 73 65 72 conc logdir "ser
2130: 76 65 72 2d 6b 69 6c 6c 73 2e 6c 6f 67 22 29 29 ver-kills.log"))
2140: 0a 0a 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 .. (system (c
2150: 6f 6e 63 20 22 6e 62 66 61 6b 65 20 6b 69 6c 6c onc "nbfake kill
2160: 20 22 6b 69 6c 6c 2d 73 77 69 74 63 68 22 20 22 "kill-switch" "
2170: 70 69 64 29 29 0a 0a 20 20 20 20 28 77 68 65 6e pid)).. (when
2180: 20 6c 6f 67 66 69 6c 65 0a 20 20 20 20 20 20 28 logfile. (
2190: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
21a0: 35 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 5). (if (co
21b0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
21c0: 3f 20 67 7a 66 69 6c 65 29 20 28 64 65 6c 65 74 ? gzfile) (delet
21d0: 65 2d 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 0a e-file gzfile)).
21e0: 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 (system (c
21f0: 6f 6e 63 20 22 67 7a 69 70 20 22 20 6c 6f 67 66 onc "gzip " logf
2200: 69 6c 65 29 29 0a 20 20 20 20 20 20 0a 20 20 20 ile)). .
2210: 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 54 41 (unsetenv "TA
2220: 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 29 0a RGETHOST_LOGF").
2230: 20 20 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 (unsetenv
2240: 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 29 29 "TARGETHOST"))))
2250: 0a 20 20 20 20 0a 20 0a 3b 3b 3d 3d 3d 3d 3d 3d . . .;;======
2260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22a0: 0a 3b 3b 20 4d 20 4f 20 4e 20 49 20 54 20 4f 20 .;; M O N I T O
22b0: 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R S.;;==========
22c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
2300: 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 6d efine (tasks:rem
2310: 6f 76 65 2d 6d 6f 6e 69 74 6f 72 2d 72 65 63 6f ove-monitor-reco
2320: 72 64 20 6d 64 62 29 0a 20 20 28 73 71 6c 69 74 rd mdb). (sqlit
2330: 65 33 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 e3:execute mdb "
2340: 44 45 4c 45 54 45 20 46 52 4f 4d 20 6d 6f 6e 69 DELETE FROM moni
2350: 74 6f 72 73 20 57 48 45 52 45 20 70 69 64 3d 3f tors WHERE pid=?
2360: 20 41 4e 44 20 68 6f 73 74 6e 61 6d 65 3d 3f 3b AND hostname=?;
2370: 22 0a 09 09 20 20 20 28 63 75 72 72 65 6e 74 2d "... (current-
2380: 70 72 6f 63 65 73 73 2d 69 64 29 0a 09 09 20 20 process-id)...
2390: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
23a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 ))..(define (tas
23b0: 6b 73 3a 67 65 74 2d 6d 6f 6e 69 74 6f 72 73 20 ks:get-monitors
23c0: 6d 64 62 29 0a 20 20 28 6c 65 74 20 28 28 72 65 mdb). (let ((re
23d0: 73 20 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c s '())). (sql
23e0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
23f0: 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 w. (lambda (
2400: 61 20 2e 20 72 65 6d 29 0a 20 20 20 20 20 20 20 a . rem).
2410: 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
2420: 28 61 70 70 6c 79 20 76 65 63 74 6f 72 20 61 20 (apply vector a
2430: 72 65 6d 29 20 72 65 73 29 29 29 0a 20 20 20 20 rem) res))).
2440: 20 6d 64 62 0a 20 20 20 20 20 22 53 45 4c 45 43 mdb. "SELEC
2450: 54 20 69 64 2c 70 69 64 2c 73 74 72 66 74 69 6d T id,pid,strftim
2460: 65 28 27 25 6d 2f 25 64 2f 25 59 20 25 48 3a 25 e('%m/%d/%Y %H:%
2470: 4d 27 2c 64 61 74 65 74 69 6d 65 28 73 74 61 72 M',datetime(star
2480: 74 5f 74 69 6d 65 2c 27 75 6e 69 78 65 70 6f 63 t_time,'unixepoc
2490: 68 27 29 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 h'),'localtime')
24a0: 2c 73 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 ,strftime('%m/%d
24b0: 2f 25 59 20 25 48 3a 25 4d 3a 25 53 27 2c 64 61 /%Y %H:%M:%S',da
24c0: 74 65 74 69 6d 65 28 6c 61 73 74 5f 75 70 64 61 tetime(last_upda
24d0: 74 65 2c 27 75 6e 69 78 65 70 6f 63 68 27 29 2c te,'unixepoch'),
24e0: 27 6c 6f 63 61 6c 74 69 6d 65 27 29 2c 68 6f 73 'localtime'),hos
24f0: 74 6e 61 6d 65 2c 75 73 65 72 6e 61 6d 65 20 46 tname,username F
2500: 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 4f 52 44 ROM monitors ORD
2510: 45 52 20 42 59 20 6c 61 73 74 5f 75 70 64 61 74 ER BY last_updat
2520: 65 20 41 53 43 3b 22 29 0a 20 20 20 20 28 72 65 e ASC;"). (re
2530: 76 65 72 73 65 20 72 65 73 29 0a 20 20 20 20 29 verse res). )
2540: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )..(define (task
2550: 73 3a 6d 6f 6e 69 74 6f 72 73 2d 3e 74 65 78 74 s:monitors->text
2560: 2d 74 61 62 6c 65 20 6d 6f 6e 69 74 6f 72 73 29 -table monitors)
2570: 0a 20 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 . (let ((fmtstr
2580: 20 22 7e 34 61 7e 38 61 7e 32 30 61 7e 32 30 61 "~4a~8a~20a~20a
2590: 7e 31 30 61 7e 31 30 61 22 29 29 0a 20 20 20 20 ~10a~10a")).
25a0: 28 63 6f 6e 63 20 28 66 6f 72 6d 61 74 20 23 66 (conc (format #f
25b0: 20 66 6d 74 73 74 72 20 22 69 64 22 20 22 70 69 fmtstr "id" "pi
25c0: 64 22 20 22 73 74 61 72 74 20 74 69 6d 65 22 20 d" "start time"
25d0: 22 6c 61 73 74 20 75 70 64 61 74 65 22 20 22 68 "last update" "h
25e0: 6f 73 74 6e 61 6d 65 22 20 22 75 73 65 72 22 29 ostname" "user")
25f0: 20 22 5c 6e 22 0a 09 20 20 28 73 74 72 69 6e 67 "\n".. (string
2600: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 -intersperse ..
2610: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
2620: 6d 6f 6e 69 74 6f 72 29 0a 09 09 20 20 28 66 6f monitor)... (fo
2630: 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 0a 09 rmat #f fmtstr..
2640: 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 .. (tasks:monit
2650: 6f 72 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 or-get-id
2660: 20 20 20 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 monitor)....
2670: 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d (tasks:monitor-
2680: 67 65 74 2d 70 69 64 20 20 20 20 20 20 20 20 20 get-pid
2690: 6d 6f 6e 69 74 6f 72 29 0a 09 09 09 20 20 28 74 monitor).... (t
26a0: 61 73 6b 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 asks:monitor-get
26b0: 2d 73 74 61 72 74 5f 74 69 6d 65 20 20 6d 6f 6e -start_time mon
26c0: 69 74 6f 72 29 0a 09 09 09 20 20 28 74 61 73 6b itor).... (task
26d0: 73 3a 6d 6f 6e 69 74 6f 72 2d 67 65 74 2d 6c 61 s:monitor-get-la
26e0: 73 74 5f 75 70 64 61 74 65 20 6d 6f 6e 69 74 6f st_update monito
26f0: 72 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 6d r).... (tasks:m
2700: 6f 6e 69 74 6f 72 2d 67 65 74 2d 68 6f 73 74 6e onitor-get-hostn
2710: 61 6d 65 20 20 20 20 6d 6f 6e 69 74 6f 72 29 0a ame monitor).
2720: 09 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e 69 ... (tasks:moni
2730: 74 6f 72 2d 67 65 74 2d 75 73 65 72 6e 61 6d 65 tor-get-username
2740: 20 20 20 20 6d 6f 6e 69 74 6f 72 29 29 29 0a 09 monitor)))..
2750: 09 6d 6f 6e 69 74 6f 72 73 29 0a 09 20 20 20 22 .monitors).. "
2760: 5c 6e 22 29 29 29 29 0a 20 20 20 0a 3b 3b 20 75 \n")))). .;; u
2770: 70 64 61 74 65 20 74 68 65 20 6c 61 73 74 5f 75 pdate the last_u
2780: 70 64 61 74 65 20 66 69 65 6c 64 20 77 69 74 68 pdate field with
2790: 20 74 68 65 20 63 75 72 72 65 6e 74 20 74 69 6d the current tim
27a0: 65 20 61 6e 64 0a 3b 3b 20 69 66 20 61 6e 79 20 e and.;; if any
27b0: 6d 6f 6e 69 74 6f 72 73 20 61 70 70 65 61 72 20 monitors appear
27c0: 64 65 61 64 2c 20 72 65 6d 6f 76 65 20 74 68 65 dead, remove the
27d0: 6d 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 m.(define (tasks
27e0: 3a 6d 6f 6e 69 74 6f 72 73 2d 75 70 64 61 74 65 :monitors-update
27f0: 20 6d 64 62 29 0a 20 20 28 73 71 6c 69 74 65 33 mdb). (sqlite3
2800: 3a 65 78 65 63 75 74 65 20 6d 64 62 20 22 55 50 :execute mdb "UP
2810: 44 41 54 45 20 6d 6f 6e 69 74 6f 72 73 20 53 45 DATE monitors SE
2820: 54 20 6c 61 73 74 5f 75 70 64 61 74 65 3d 73 74 T last_update=st
2830: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
2840: 27 29 20 57 48 45 52 45 20 70 69 64 3d 3f 20 41 ') WHERE pid=? A
2850: 4e 44 20 68 6f 73 74 6e 61 6d 65 3d 3f 3b 22 0a ND hostname=?;".
2860: 09 09 09 20 20 28 63 75 72 72 65 6e 74 2d 70 72 ... (current-pr
2870: 6f 63 65 73 73 2d 69 64 29 0a 09 09 09 20 20 28 ocess-id).... (
2880: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
2890: 20 20 28 6c 65 74 20 28 28 64 65 61 64 6c 69 73 (let ((deadlis
28a0: 74 20 27 28 29 29 29 0a 20 20 20 20 28 73 71 6c t '())). (sql
28b0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
28c0: 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 w. (lambda (
28d0: 69 64 20 70 69 64 20 68 6f 73 74 20 6c 61 73 74 id pid host last
28e0: 2d 75 70 64 61 74 65 20 64 65 6c 74 61 29 0a 20 -update delta).
28f0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 47 6f (print "Go
2900: 69 6e 67 20 74 6f 20 64 65 6c 65 74 65 20 73 74 ing to delete st
2910: 61 6c 65 20 72 65 63 6f 72 64 20 66 6f 72 20 6d ale record for m
2920: 6f 6e 69 74 6f 72 20 77 69 74 68 20 70 69 64 20 onitor with pid
2930: 22 20 70 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 " pid " on host
2940: 22 20 68 6f 73 74 20 22 20 6c 61 73 74 20 75 70 " host " last up
2950: 64 61 74 65 64 20 22 20 64 65 6c 74 61 20 22 20 dated " delta "
2960: 73 65 63 6f 6e 64 73 20 61 67 6f 22 29 0a 20 20 seconds ago").
2970: 20 20 20 20 20 28 73 65 74 21 20 64 65 61 64 6c (set! deadl
2980: 69 73 74 20 28 63 6f 6e 73 20 69 64 20 64 65 61 ist (cons id dea
2990: 64 6c 69 73 74 29 29 29 0a 20 20 20 20 20 6d 64 dlist))). md
29a0: 62 20 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 b . "SELECT
29b0: 69 64 2c 70 69 64 2c 68 6f 73 74 6e 61 6d 65 2c id,pid,hostname,
29c0: 6c 61 73 74 5f 75 70 64 61 74 65 2c 73 74 72 66 last_update,strf
29d0: 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 time('%s','now')
29e0: 2d 6c 61 73 74 5f 75 70 64 61 74 65 20 41 53 20 -last_update AS
29f0: 64 65 6c 74 61 20 46 52 4f 4d 20 6d 6f 6e 69 74 delta FROM monit
2a00: 6f 72 73 20 57 48 45 52 45 20 64 65 6c 74 61 20 ors WHERE delta
2a10: 3e 20 37 30 30 3b 22 29 0a 20 20 20 20 28 73 71 > 700;"). (sq
2a20: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 6d 64 lite3:execute md
2a30: 62 20 28 63 6f 6e 63 20 22 44 45 4c 45 54 45 20 b (conc "DELETE
2a40: 46 52 4f 4d 20 6d 6f 6e 69 74 6f 72 73 20 57 48 FROM monitors WH
2a50: 45 52 45 20 69 64 20 49 4e 20 28 27 22 20 28 73 ERE id IN ('" (s
2a60: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
2a70: 65 20 28 6d 61 70 20 63 6f 6e 63 20 64 65 61 64 e (map conc dead
2a80: 6c 69 73 74 29 20 22 27 2c 27 22 29 20 22 27 29 list) "','") "')
2a90: 3b 22 29 29 29 0a 20 20 29 0a 28 64 65 66 69 6e ;"))). ).(defin
2aa0: 65 20 28 74 61 73 6b 73 3a 72 65 67 69 73 74 65 e (tasks:registe
2ab0: 72 2d 6d 6f 6e 69 74 6f 72 20 64 62 20 70 6f 72 r-monitor db por
2ac0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 64 t). (let* ((pid
2ad0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
2ae0: 73 2d 69 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 s-id)).. (hostna
2af0: 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d me (get-host-nam
2b00: 65 29 29 0a 09 20 28 75 73 65 72 69 6e 66 6f 20 e)).. (userinfo
2b10: 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f (user-informatio
2b20: 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d n (current-user-
2b30: 69 64 29 29 29 0a 09 20 28 75 73 65 72 6e 61 6d id))).. (usernam
2b40: 65 20 28 63 61 72 20 75 73 65 72 69 6e 66 6f 29 e (car userinfo)
2b50: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 )). (print "R
2b60: 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c egister monitor,
2b70: 20 70 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 pid: " pid ", h
2b80: 6f 73 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e ostname: " hostn
2b90: 61 6d 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 ame ", port: " p
2ba0: 6f 72 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a ort ", username:
2bb0: 20 22 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 " username).
2bc0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
2bd0: 65 20 64 62 20 22 49 4e 53 45 52 54 20 49 4e 54 e db "INSERT INT
2be0: 4f 20 6d 6f 6e 69 74 6f 72 73 20 28 70 69 64 2c O monitors (pid,
2bf0: 73 74 61 72 74 5f 74 69 6d 65 2c 6c 61 73 74 5f start_time,last_
2c00: 75 70 64 61 74 65 2c 68 6f 73 74 6e 61 6d 65 2c update,hostname,
2c10: 75 73 65 72 6e 61 6d 65 29 20 56 41 4c 55 45 53 username) VALUES
2c20: 20 28 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 (?,strftime('%s
2c30: 27 2c 27 6e 6f 77 27 29 2c 73 74 72 66 74 69 6d ','now'),strftim
2c40: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 2c 3f 2c e('%s','now'),?,
2c50: 3f 29 3b 22 0a 09 09 20 20 20 20 20 70 69 64 20 ?);"... pid
2c60: 68 6f 73 74 6e 61 6d 65 20 75 73 65 72 6e 61 6d hostname usernam
2c70: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 e)))..(define (t
2c80: 61 73 6b 73 3a 67 65 74 2d 6e 75 6d 2d 61 6c 69 asks:get-num-ali
2c90: 76 65 2d 6d 6f 6e 69 74 6f 72 73 20 6d 64 62 29 ve-monitors mdb)
2ca0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 30 29 . (let ((res 0)
2cb0: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ). (sqlite3:f
2cc0: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 or-each-row .
2cd0: 20 20 28 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 (lambda (count
2ce0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
2cf0: 65 73 20 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 es count)).
2d00: 6d 64 62 0a 20 20 20 20 20 22 53 45 4c 45 43 54 mdb. "SELECT
2d10: 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 count(id) FROM
2d20: 6d 6f 6e 69 74 6f 72 73 20 57 48 45 52 45 20 6c monitors WHERE l
2d30: 61 73 74 5f 75 70 64 61 74 65 20 3c 20 28 73 74 ast_update < (st
2d40: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
2d50: 27 29 20 2d 20 33 30 30 29 20 41 4e 44 20 75 73 ') - 300) AND us
2d60: 65 72 6e 61 6d 65 3d 3f 3b 22 0a 20 20 20 20 20 ername=?;".
2d70: 28 63 61 72 20 28 75 73 65 72 2d 69 6e 66 6f 72 (car (user-infor
2d80: 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d mation (current-
2d90: 75 73 65 72 2d 69 64 29 29 29 29 0a 20 20 20 20 user-id)))).
2da0: 72 65 73 29 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 res))..;; .(defi
2db0: 6e 65 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d ne (tasks:start-
2dc0: 6d 6f 6e 69 74 6f 72 20 64 62 20 6d 64 62 29 0a monitor db mdb).
2dd0: 20 20 28 69 66 20 28 3e 20 28 74 61 73 6b 73 3a (if (> (tasks:
2de0: 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 2d 6d 6f get-num-alive-mo
2df0: 6e 69 74 6f 72 73 20 6d 64 62 29 20 32 29 20 3b nitors mdb) 2) ;
2e00: 3b 20 68 61 76 65 20 74 77 6f 20 72 75 6e 6e 69 ; have two runni
2e10: 6e 67 2c 20 6e 6f 20 6e 65 65 64 20 66 6f 72 20 ng, no need for
2e20: 6d 6f 72 65 0a 20 20 20 20 20 20 28 64 65 62 75 more. (debu
2e30: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
2e40: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2e50: 2a 20 22 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 * "Not starting
2e60: 6d 6f 6e 69 74 6f 72 2c 20 61 6c 72 65 61 64 79 monitor, already
2e70: 20 68 61 76 65 20 6d 6f 72 65 20 74 68 61 6e 20 have more than
2e80: 74 77 6f 20 72 75 6e 6e 69 6e 67 22 29 0a 20 20 two running").
2e90: 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 65 67 61 (let* ((mega
2ea0: 74 65 73 74 64 62 20 20 20 20 20 28 63 6f 6e 63 testdb (conc
2eb0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 *toppath* "/meg
2ec0: 61 74 65 73 74 2e 64 62 22 29 29 0a 09 20 20 20 atest.db"))..
2ed0: 20 20 28 6d 6f 6e 69 74 6f 72 64 62 66 20 20 20 (monitordbf
2ee0: 20 20 28 63 6f 6e 63 20 28 64 62 3a 64 62 66 69 (conc (db:dbfi
2ef0: 6c 65 2d 70 61 74 68 20 23 66 29 20 22 2f 6d 6f le-path #f) "/mo
2f00: 6e 69 74 6f 72 2e 64 62 22 29 29 0a 09 20 20 20 nitor.db"))..
2f10: 20 20 28 6c 61 73 74 2d 64 62 2d 75 70 64 61 74 (last-db-updat
2f20: 65 20 30 29 29 20 3b 3b 20 28 66 69 6c 65 2d 6d e 0)) ;; (file-m
2f30: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
2f40: 20 6d 65 67 61 74 65 73 74 64 62 29 29 29 0a 09 megatestdb)))..
2f50: 28 74 61 73 6b 3a 72 65 67 69 73 74 65 72 2d 6d (task:register-m
2f60: 6f 6e 69 74 6f 72 20 6d 64 62 29 0a 09 28 6c 65 onitor mdb)..(le
2f70: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 t loop ((count
2f80: 20 20 20 20 30 29 0a 09 09 20 20 20 28 6e 65 78 0)... (nex
2f90: 74 2d 74 6f 75 63 68 20 30 29 29 20 3b 3b 20 6e t-touch 0)) ;; n
2fa0: 65 78 74 2d 74 6f 75 63 68 20 69 73 20 74 68 65 ext-touch is the
2fb0: 20 74 69 6d 65 20 77 68 65 72 65 20 77 65 20 6e time where we n
2fc0: 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 6c 61 eed to update la
2fd0: 73 74 5f 75 70 64 61 74 65 0a 09 20 20 3b 3b 20 st_update.. ;;
2fe0: 69 66 20 74 68 65 20 64 62 20 68 61 73 20 62 65 if the db has be
2ff0: 65 6e 20 6d 6f 64 69 66 69 65 64 20 77 65 27 64 en modified we'd
3000: 20 62 65 73 74 20 6c 6f 6f 6b 20 61 74 20 74 68 best look at th
3010: 65 20 74 61 73 6b 20 71 75 65 75 65 0a 09 20 20 e task queue..
3020: 28 6c 65 74 20 28 28 6d 6f 64 74 69 6d 65 20 28 (let ((modtime (
3030: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
3040: 6e 2d 74 69 6d 65 20 6d 65 67 61 74 65 73 74 64 n-time megatestd
3050: 62 70 61 74 68 20 29 29 29 0a 09 20 20 20 20 28 bpath ))).. (
3060: 69 66 20 28 3e 20 6d 6f 64 74 69 6d 65 20 6c 61 if (> modtime la
3070: 73 74 2d 64 62 2d 75 70 64 61 74 65 29 0a 09 09 st-db-update)...
3080: 28 74 61 73 6b 73 3a 70 72 6f 63 65 73 73 2d 71 (tasks:process-q
3090: 75 65 75 65 20 64 62 29 29 20 3b 3b 20 42 52 4f ueue db)) ;; BRO
30a0: 4b 45 4e 2e 20 6d 64 62 20 6c 61 73 74 2d 64 62 KEN. mdb last-db
30b0: 2d 75 70 64 61 74 65 20 6d 65 67 61 74 65 73 74 -update megatest
30c0: 64 62 20 6e 65 78 74 2d 74 6f 75 63 68 29 29 0a db next-touch)).
30d0: 09 20 20 20 20 3b 3b 20 57 41 52 4e 49 4e 47 3a . ;; WARNING:
30e0: 20 50 6f 73 73 69 62 6c 65 20 72 61 63 65 20 63 Possible race c
30f0: 6f 6e 64 69 74 6f 6e 20 68 65 72 65 21 21 0a 09 onditon here!!..
3100: 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 20 74 68 ;; should th
3110: 69 73 20 75 70 64 61 74 65 20 62 65 20 69 6d 6d is update be imm
3120: 65 64 69 61 74 65 6c 79 20 61 66 74 65 72 20 74 ediately after t
3130: 68 65 20 74 61 73 6b 2d 67 65 74 2d 61 63 74 69 he task-get-acti
3140: 6f 6e 20 63 61 6c 6c 20 61 62 6f 76 65 3f 0a 09 on call above?..
3150: 20 20 20 20 28 69 66 20 28 3e 20 28 63 75 72 72 (if (> (curr
3160: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6e 65 78 ent-seconds) nex
3170: 74 2d 74 6f 75 63 68 29 0a 09 09 28 62 65 67 69 t-touch)...(begi
3180: 6e 0a 09 09 20 20 28 74 61 73 6b 73 3a 6d 6f 6e n... (tasks:mon
3190: 69 74 6f 72 73 2d 75 70 64 61 74 65 20 6d 64 62 itors-update mdb
31a0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 )... (loop (+ c
31b0: 6f 75 6e 74 20 31 29 28 2b 20 28 63 75 72 72 65 ount 1)(+ (curre
31c0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 32 34 30 29 nt-seconds) 240)
31d0: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 2b 20 63 6f ))...(loop (+ co
31e0: 75 6e 74 20 31 29 20 6e 65 78 74 2d 74 6f 75 63 unt 1) next-touc
31f0: 68 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a h))))))). .
3200: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3240: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 ========.;; T A
3250: 53 20 4b 20 53 20 20 20 51 20 55 20 45 20 55 20 S K S Q U E U
3260: 45 0a 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 3a E.;;.;; NOTE::
3270: 20 54 68 65 73 65 20 6f 70 65 72 61 74 65 20 6f These operate o
3280: 6e 20 74 61 73 6b 5f 71 75 65 75 65 20 77 68 69 n task_queue whi
3290: 63 68 20 69 73 20 69 6e 20 6d 61 69 6e 2e 64 62 ch is in main.db
32a0: 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;.;;==========
32b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
32f0: 20 4e 4f 54 45 3a 20 49 74 20 6d 69 67 68 74 20 NOTE: It might
3300: 62 65 20 67 6f 6f 64 20 74 6f 20 61 64 64 20 6f be good to add o
3310: 6e 65 20 6d 6f 72 65 20 6c 61 79 65 72 20 6f 66 ne more layer of
3320: 20 63 68 65 63 6b 69 6e 67 20 74 6f 20 65 6e 73 checking to ens
3330: 75 72 65 0a 3b 3b 20 20 20 20 20 20 20 74 68 61 ure.;; tha
3340: 74 20 6e 6f 20 74 61 73 6b 20 67 65 74 73 20 72 t no task gets r
3350: 75 6e 20 69 6e 20 70 61 72 61 6c 6c 65 6c 2e 0a un in parallel..
3360: 0a 3b 3b 20 69 64 20 49 4e 54 45 47 45 52 20 50 .;; id INTEGER P
3370: 52 49 4d 41 52 59 20 4b 45 59 2c 0a 3b 3b 20 61 RIMARY KEY,.;; a
3380: 63 74 69 6f 6e 20 54 45 58 54 20 44 45 46 41 55 ction TEXT DEFAU
3390: 4c 54 20 27 27 2c 0a 3b 3b 20 6f 77 6e 65 72 20 LT '',.;; owner
33a0: 54 45 58 54 2c 0a 3b 3b 20 73 74 61 74 65 20 54 TEXT,.;; state T
33b0: 45 58 54 20 44 45 46 41 55 4c 54 20 27 6e 65 77 EXT DEFAULT 'new
33c0: 27 2c 0a 3b 3b 20 74 61 72 67 65 74 20 54 45 58 ',.;; target TEX
33d0: 54 20 44 45 46 41 55 4c 54 20 27 27 2c 0a 3b 3b T DEFAULT '',.;;
33e0: 20 6e 61 6d 65 20 54 45 58 54 20 44 45 46 41 55 name TEXT DEFAU
33f0: 4c 54 20 27 27 2c 0a 3b 3b 20 74 65 73 74 70 61 LT '',.;; testpa
3400: 74 74 20 54 45 58 54 20 44 45 46 41 55 4c 54 20 tt TEXT DEFAULT
3410: 27 27 2c 0a 3b 3b 20 6b 65 79 6c 6f 63 6b 20 54 '',.;; keylock T
3420: 45 58 54 2c 0a 3b 3b 20 70 61 72 61 6d 73 20 54 EXT,.;; params T
3430: 45 58 54 2c 0a 3b 3b 20 63 72 65 61 74 69 6f 6e EXT,.;; creation
3440: 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 _time TIMESTAMP
3450: 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d DEFAULT (strftim
3460: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a e('%s','now')),.
3470: 3b 3b 20 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d ;; execution_tim
3480: 65 20 54 49 4d 45 53 54 41 4d 50 29 3b 0a 0a 0a e TIMESTAMP);...
3490: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 61 ;; register a ta
34a0: 73 6b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b sk.(define (task
34b0: 73 3a 61 64 64 20 64 62 73 74 72 75 63 74 20 61 s:add dbstruct a
34c0: 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 ction owner targ
34d0: 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 et runname testp
34e0: 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 64 att params). (d
34f0: 62 3a 77 69 74 68 2d 64 62 20 0a 20 20 20 64 62 b:with-db . db
3500: 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 20 struct #f #t.
3510: 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 (lambda (db).
3520: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
3530: 74 65 20 64 62 20 22 49 4e 53 45 52 54 20 49 4e te db "INSERT IN
3540: 54 4f 20 74 61 73 6b 73 5f 71 75 65 75 65 20 28 TO tasks_queue (
3550: 61 63 74 69 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 action,owner,sta
3560: 74 65 2c 74 61 72 67 65 74 2c 6e 61 6d 65 2c 74 te,target,name,t
3570: 65 73 74 70 61 74 74 2c 70 61 72 61 6d 73 2c 63 estpatt,params,c
3580: 72 65 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 reation_time,exe
3590: 63 75 74 69 6f 6e 5f 74 69 6d 65 29 0a 20 20 20 cution_time).
35a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35b0: 20 20 20 20 20 20 20 20 20 20 56 41 4c 55 45 53 VALUES
35c0: 20 28 3f 2c 3f 2c 27 6e 65 77 27 2c 3f 2c 3f 2c (?,?,'new',?,?,
35d0: 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 ?,?,strftime('%s
35e0: 27 2c 27 6e 6f 77 27 29 2c 30 29 3b 22 20 0a 09 ','now'),0);" ..
35f0: 09 20 20 20 20 20 20 61 63 74 69 6f 6e 0a 09 09 . action...
3600: 20 20 20 20 20 20 6f 77 6e 65 72 0a 09 09 20 20 owner...
3610: 20 20 20 20 74 61 72 67 65 74 0a 09 09 20 20 20 target...
3620: 20 20 20 72 75 6e 6e 61 6d 65 0a 09 09 20 20 20 runname...
3630: 20 20 20 74 65 73 74 70 61 74 74 0a 09 09 20 20 testpatt...
3640: 20 20 20 20 28 69 66 20 70 61 72 61 6d 73 20 70 (if params p
3650: 61 72 61 6d 73 20 22 22 29 29 29 29 29 0a 0a 28 arams "")))))..(
3660: 64 65 66 69 6e 65 20 28 6b 65 79 73 3a 6b 65 79 define (keys:key
3670: 2d 76 61 6c 73 2d 68 61 73 68 2d 3e 74 61 72 67 -vals-hash->targ
3680: 65 74 20 6b 65 79 73 20 6b 65 79 2d 70 61 72 61 et keys key-para
3690: 6d 73 29 0a 20 20 28 6c 65 74 20 28 28 74 6d 70 ms). (let ((tmp
36a0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
36b0: 2f 64 65 66 61 75 6c 74 20 6b 65 79 2d 70 61 72 /default key-par
36c0: 61 6d 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ams (vector-ref
36d0: 28 63 61 72 20 6b 65 79 73 29 20 30 29 20 22 22 (car keys) 0) ""
36e0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 ))). (if (> (
36f0: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 31 29 0a length keys) 1).
3700: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
3710: 64 61 20 28 6b 65 79 29 0a 09 09 20 20 20 20 28 da (key)... (
3720: 73 65 74 21 20 74 6d 70 20 28 63 6f 6e 63 20 74 set! tmp (conc t
3730: 6d 70 20 22 2f 22 20 28 68 61 73 68 2d 74 61 62 mp "/" (hash-tab
3740: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6b le-ref/default k
3750: 65 79 2d 70 61 72 61 6d 73 20 28 76 65 63 74 6f ey-params (vecto
3760: 72 2d 72 65 66 20 6b 65 79 20 30 29 20 22 22 29 r-ref key 0) "")
3770: 29 29 29 0a 09 09 20 20 28 63 64 72 20 6b 65 79 )))... (cdr key
3780: 73 29 29 29 0a 20 20 20 20 74 6d 70 29 29 0a 09 s))). tmp))..
3790: 09 09 09 09 09 09 09 0a 3b 3b 20 66 6f 72 20 75 ........;; for u
37a0: 73 65 20 66 72 6f 6d 20 74 68 65 20 67 75 69 2c se from the gui,
37b0: 20 6e 6f 74 20 70 6f 72 74 65 64 0a 3b 3b 0a 3b not ported.;;.;
37c0: 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ; (define (tasks
37d0: 3a 61 64 64 2d 66 72 6f 6d 2d 70 61 72 61 6d 73 :add-from-params
37e0: 20 6d 64 62 20 61 63 74 69 6f 6e 20 6b 65 79 73 mdb action keys
37f0: 20 6b 65 79 2d 70 61 72 61 6d 73 20 76 61 72 2d key-params var-
3800: 70 61 72 61 6d 73 29 0a 3b 3b 20 20 20 28 6c 65 params).;; (le
3810: 74 20 28 28 74 61 72 67 65 74 20 20 20 20 28 6b t ((target (k
3820: 65 79 73 3a 6b 65 79 2d 76 61 6c 73 2d 68 61 73 eys:key-vals-has
3830: 68 2d 3e 74 61 72 67 65 74 20 6b 65 79 73 20 6b h->target keys k
3840: 65 79 2d 70 61 72 61 6d 73 29 29 0a 3b 3b 20 09 ey-params)).;; .
3850: 28 6f 77 6e 65 72 20 20 20 20 20 28 63 61 72 20 (owner (car
3860: 28 75 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f (user-informatio
3870: 6e 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d n (current-user-
3880: 69 64 29 29 29 29 0a 3b 3b 20 09 28 72 75 6e 6e id)))).;; .(runn
3890: 61 6d 65 20 20 20 28 68 61 73 68 2d 74 61 62 6c ame (hash-tabl
38a0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 76 61 e-ref/default va
38b0: 72 2d 70 61 72 61 6d 73 20 22 72 75 6e 6e 61 6d r-params "runnam
38c0: 65 22 20 23 66 29 29 0a 3b 3b 20 09 28 74 65 73 e" #f)).;; .(tes
38d0: 74 70 61 74 74 73 20 28 68 61 73 68 2d 74 61 62 tpatts (hash-tab
38e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 76 le-ref/default v
38f0: 61 72 2d 70 61 72 61 6d 73 20 22 74 65 73 74 70 ar-params "testp
3900: 61 74 74 73 22 20 22 25 22 29 29 0a 3b 3b 20 09 atts" "%")).;; .
3910: 28 70 61 72 61 6d 73 20 20 20 20 28 68 61 73 68 (params (hash
3920: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3930: 6c 74 20 76 61 72 2d 70 61 72 61 6d 73 20 22 70 lt var-params "p
3940: 61 72 61 6d 73 22 20 20 20 20 22 22 29 29 29 0a arams" ""))).
3950: 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 3a 61 64 ;; (tasks:ad
3960: 64 20 6d 64 62 20 61 63 74 69 6f 6e 20 6f 77 6e d mdb action own
3970: 65 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d er target runnam
3980: 65 20 74 65 73 74 70 61 74 74 73 20 70 61 72 61 e testpatts para
3990: 6d 73 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e ms)))..;; return
39a0: 20 6f 6e 65 20 74 61 73 6b 20 66 72 6f 6d 20 74 one task from t
39b0: 68 6f 73 65 20 77 68 6f 20 61 72 65 20 27 6e 65 hose who are 'ne
39c0: 77 27 20 4f 52 20 27 77 61 69 74 69 6e 67 27 20 w' OR 'waiting'
39d0: 41 4e 44 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 AND more than 10
39e0: 73 65 63 20 6f 6c 64 0a 3b 3b 0a 28 64 65 66 69 sec old.;;.(defi
39f0: 6e 65 20 28 74 61 73 6b 73 3a 73 6e 61 67 2d 61 ne (tasks:snag-a
3a00: 2d 74 61 73 6b 20 64 62 73 74 72 75 63 74 29 0a -task dbstruct).
3a10: 20 20 28 6c 65 74 20 28 28 72 65 73 20 20 20 20 (let ((res
3a20: 23 66 29 0a 09 28 6b 65 79 74 78 74 20 28 63 6f #f)..(keytxt (co
3a30: 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 nc (current-proc
3a40: 65 73 73 2d 69 64 29 20 22 2d 22 20 28 67 65 74 ess-id) "-" (get
3a50: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 -host-name) "-"
3a60: 28 63 61 72 20 28 75 73 65 72 2d 69 6e 66 6f 72 (car (user-infor
3a70: 6d 61 74 69 6f 6e 20 28 63 75 72 72 65 6e 74 2d mation (current-
3a80: 75 73 65 72 2d 69 64 29 29 29 29 29 29 0a 20 20 user-id)))))).
3a90: 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 (db:with-db.
3aa0: 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 dbstruct #f #
3ab0: 74 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 t. (lambda (
3ac0: 64 62 29 0a 20 20 20 20 20 20 20 3b 3b 20 66 69 db). ;; fi
3ad0: 72 73 74 20 72 61 6e 64 6f 6d 6c 79 20 73 65 74 rst randomly set
3ae0: 20 61 20 6e 65 77 20 74 6f 20 70 69 64 2d 68 6f a new to pid-ho
3af0: 73 74 6e 61 6d 65 2d 68 6f 73 74 6e 61 6d 65 0a stname-hostname.
3b00: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
3b10: 65 78 65 63 75 74 65 0a 09 64 62 20 0a 09 22 55 execute..db .."U
3b20: 50 44 41 54 45 20 74 61 73 6b 73 5f 71 75 65 75 PDATE tasks_queu
3b30: 65 20 53 45 54 20 6b 65 79 6c 6f 63 6b 3d 3f 20 e SET keylock=?
3b40: 57 48 45 52 45 20 69 64 20 49 4e 0a 20 20 20 20 WHERE id IN.
3b50: 20 20 20 20 20 20 20 28 53 45 4c 45 43 54 20 69 (SELECT i
3b60: 64 20 46 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 d FROM tasks_que
3b70: 75 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ue .
3b80: 20 20 57 48 45 52 45 20 73 74 61 74 65 3d 27 6e WHERE state='n
3b90: 65 77 27 20 4f 52 20 0a 20 20 20 20 20 20 20 20 ew' OR .
3ba0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 61 (sta
3bb0: 74 65 3d 27 77 61 69 74 69 6e 67 27 20 41 4e 44 te='waiting' AND
3bc0: 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c (strftime('%s',
3bd0: 27 6e 6f 77 27 29 2d 65 78 65 63 75 74 69 6f 6e 'now')-execution
3be0: 5f 74 69 6d 65 29 20 3e 20 31 30 29 20 4f 52 0a _time) > 10) OR.
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c00: 20 20 20 20 73 74 61 74 65 3d 27 72 65 73 65 74 state='reset
3c10: 27 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 '.
3c20: 4f 52 44 45 52 20 42 59 20 52 41 4e 44 4f 4d 28 ORDER BY RANDOM(
3c30: 29 20 4c 49 4d 49 54 20 31 29 3b 22 20 6b 65 79 ) LIMIT 1);" key
3c40: 74 78 74 29 0a 0a 20 20 20 20 20 20 20 28 73 71 txt).. (sq
3c50: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
3c60: 6f 77 0a 09 28 6c 61 6d 62 64 61 20 28 69 64 20 ow..(lambda (id
3c70: 2e 20 72 65 6d 29 0a 09 20 20 28 73 65 74 21 20 . rem).. (set!
3c80: 72 65 73 20 28 61 70 70 6c 79 20 76 65 63 74 6f res (apply vecto
3c90: 72 20 69 64 20 72 65 6d 29 29 29 0a 09 64 62 0a r id rem)))..db.
3ca0: 09 22 53 45 4c 45 43 54 20 69 64 2c 61 63 74 69 ."SELECT id,acti
3cb0: 6f 6e 2c 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 on,owner,state,t
3cc0: 61 72 67 65 74 2c 6e 61 6d 65 2c 74 65 73 74 2c arget,name,test,
3cd0: 69 74 65 6d 2c 70 61 72 61 6d 73 2c 63 72 65 61 item,params,crea
3ce0: 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 tion_time,execut
3cf0: 69 6f 6e 5f 74 69 6d 65 20 46 52 4f 4d 20 74 61 ion_time FROM ta
3d00: 73 6b 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 sks_queue WHERE
3d10: 6b 65 79 6c 6f 63 6b 3d 3f 20 4f 52 44 45 52 20 keylock=? ORDER
3d20: 42 59 20 65 78 65 63 75 74 69 6f 6e 5f 74 69 6d BY execution_tim
3d30: 65 20 41 53 43 20 4c 49 4d 49 54 20 31 3b 22 20 e ASC LIMIT 1;"
3d40: 6b 65 79 74 78 74 29 0a 20 20 20 20 20 20 20 28 keytxt). (
3d50: 69 66 20 72 65 73 20 3b 3b 20 79 65 70 2c 20 68 if res ;; yep, h
3d60: 61 76 65 20 77 6f 72 6b 20 74 6f 20 62 65 20 64 ave work to be d
3d70: 6f 6e 65 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 one.. (begin..
3d80: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
3d90: 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 ecute db "UPDATE
3da0: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 tasks_queue SET
3db0: 20 73 74 61 74 65 3d 27 69 6e 70 72 6f 67 72 65 state='inprogre
3dc0: 73 73 27 2c 65 78 65 63 75 74 69 6f 6e 5f 74 69 ss',execution_ti
3dd0: 6d 65 3d 73 74 72 66 74 69 6d 65 28 27 25 73 27 me=strftime('%s'
3de0: 2c 27 6e 6f 77 27 29 20 57 48 45 52 45 20 69 64 ,'now') WHERE id
3df0: 3d 3f 3b 22 0a 09 09 09 20 20 20 20 20 20 28 74 =?;".... (t
3e00: 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 64 asks:task-get-id
3e10: 20 72 65 73 29 29 0a 09 20 20 20 20 20 72 65 73 res)).. res
3e20: 29 0a 09 20 20 20 23 66 29 29 29 29 29 0a 0a 28 ).. #f)))))..(
3e30: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 define (tasks:re
3e40: 73 65 74 2d 73 74 75 63 6b 2d 74 61 73 6b 73 20 set-stuck-tasks
3e50: 64 62 73 74 72 75 63 74 29 0a 20 20 28 6c 65 74 dbstruct). (let
3e60: 20 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 ((res '())).
3e70: 20 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 (db:with-db.
3e80: 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 74 dbstruct #f #t
3e90: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 . (lambda (d
3ea0: 62 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 b). (sqlit
3eb0: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
3ec0: 09 28 6c 61 6d 62 64 61 20 28 69 64 20 64 65 6c .(lambda (id del
3ed0: 74 61 29 0a 09 20 20 28 73 65 74 21 20 72 65 73 ta).. (set! res
3ee0: 20 28 63 6f 6e 73 20 69 64 20 72 65 73 29 29 29 (cons id res)))
3ef0: 0a 09 64 62 0a 09 22 53 45 4c 45 43 54 20 69 64 ..db.."SELECT id
3f00: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
3f10: 6e 6f 77 27 29 2d 65 78 65 63 75 74 69 6f 6e 5f now')-execution_
3f20: 74 69 6d 65 20 41 53 20 64 65 6c 74 61 20 46 52 time AS delta FR
3f30: 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 57 OM tasks_queue W
3f40: 48 45 52 45 20 73 74 61 74 65 3d 27 69 6e 70 72 HERE state='inpr
3f50: 6f 67 72 65 73 73 27 20 41 4e 44 20 64 65 6c 74 ogress' AND delt
3f60: 61 3e 37 30 30 20 4f 52 44 45 52 20 42 59 20 64 a>700 ORDER BY d
3f70: 65 6c 74 61 20 44 45 53 43 20 4c 49 4d 49 54 20 elta DESC LIMIT
3f80: 32 3b 22 29 0a 20 20 20 20 20 20 20 28 73 71 6c 2;"). (sql
3f90: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 64 ite3:execute ..d
3fa0: 62 20 0a 09 28 63 6f 6e 63 20 22 55 50 44 41 54 b ..(conc "UPDAT
3fb0: 45 20 74 61 73 6b 73 5f 71 75 65 75 65 20 53 45 E tasks_queue SE
3fc0: 54 20 73 74 61 74 65 3d 27 72 65 73 65 74 27 20 T state='reset'
3fd0: 57 48 45 52 45 20 69 64 20 49 4e 20 28 27 22 20 WHERE id IN ('"
3fe0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
3ff0: 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 72 65 rse (map conc re
4000: 73 29 20 22 27 2c 27 22 29 20 22 27 29 3b 22 29 s) "','") "');")
4010: 0a 09 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 ..)))))..;; retu
4020: 72 6e 20 61 6c 6c 20 74 61 73 6b 73 20 69 6e 20 rn all tasks in
4030: 74 68 65 20 74 61 73 6b 73 5f 71 75 65 75 65 20 the tasks_queue
4040: 74 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 table.;;.(define
4050: 20 28 74 61 73 6b 73 3a 67 65 74 2d 74 61 73 6b (tasks:get-task
4060: 73 20 64 62 73 74 72 75 63 74 20 74 79 70 65 73 s dbstruct types
4070: 20 73 74 61 74 65 73 29 0a 20 20 28 6c 65 74 20 states). (let
4080: 28 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 ((res '())).
4090: 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 20 (db:with-db.
40a0: 20 64 62 73 74 72 75 63 74 20 23 66 20 23 66 0a dbstruct #f #f.
40b0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 (lambda (db
40c0: 29 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 ). (sqlite
40d0: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 3:for-each-row..
40e0: 28 6c 61 6d 62 64 61 20 28 69 64 20 2e 20 72 65 (lambda (id . re
40f0: 6d 29 0a 09 20 20 28 73 65 74 21 20 72 65 73 20 m).. (set! res
4100: 28 63 6f 6e 73 20 28 61 70 70 6c 79 20 76 65 63 (cons (apply vec
4110: 74 6f 72 20 69 64 20 72 65 6d 29 20 72 65 73 29 tor id rem) res)
4120: 29 29 0a 09 64 62 0a 09 28 63 6f 6e 63 20 22 53 ))..db..(conc "S
4130: 45 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c ELECT id,action,
4140: 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 owner,state,targ
4150: 65 74 2c 6e 61 6d 65 2c 74 65 73 74 2c 69 74 65 et,name,test,ite
4160: 6d 2c 70 61 72 61 6d 73 2c 63 72 65 61 74 69 6f m,params,creatio
4170: 6e 5f 74 69 6d 65 2c 65 78 65 63 75 74 69 6f 6e n_time,execution
4180: 5f 74 69 6d 65 20 0a 20 20 20 20 20 20 20 20 20 _time .
4190: 20 20 20 20 20 20 20 20 20 46 52 4f 4d 20 74 61 FROM ta
41a0: 73 6b 73 5f 71 75 65 75 65 20 22 0a 09 20 20 20 sks_queue "..
41b0: 20 20 20 3b 3b 20 57 48 45 52 45 20 20 0a 09 20 ;; WHERE ..
41c0: 20 20 20 20 20 3b 3b 20 20 20 73 74 61 74 65 20 ;; state
41d0: 49 4e 20 22 20 73 74 61 74 65 73 73 74 72 20 22 IN " statesstr "
41e0: 20 41 4e 44 20 0a 09 20 20 20 20 20 20 3b 3b 20 AND .. ;;
41f0: 20 20 61 63 74 69 6f 6e 20 49 4e 20 22 20 61 63 action IN " ac
4200: 74 69 6f 6e 73 73 74 72 20 0a 09 20 20 20 20 20 tionsstr ..
4210: 20 22 20 4f 52 44 45 52 20 42 59 20 63 72 65 61 " ORDER BY crea
4220: 74 69 6f 6e 5f 74 69 6d 65 20 44 45 53 43 3b 22 tion_time DESC;"
4230: 29 29 0a 20 20 20 20 20 20 20 72 65 73 29 29 29 )). res)))
4240: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b )..(define (task
4250: 73 3a 67 65 74 2d 6c 61 73 74 20 64 62 73 74 72 s:get-last dbstr
4260: 75 63 74 20 74 61 72 67 65 74 20 72 75 6e 6e 61 uct target runna
4270: 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 me). (let ((res
4280: 20 23 66 29 29 0a 20 20 20 20 28 64 62 3a 77 69 #f)). (db:wi
4290: 74 68 2d 64 62 0a 20 20 20 20 20 64 62 73 74 72 th-db. dbstr
42a0: 75 63 74 20 23 66 20 23 66 0a 20 20 20 20 20 28 uct #f #f. (
42b0: 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 20 20 lambda (db).
42c0: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
42d0: 65 61 63 68 2d 72 6f 77 0a 09 28 6c 61 6d 62 64 each-row..(lambd
42e0: 61 20 28 69 64 20 2e 20 72 65 6d 29 0a 09 20 20 a (id . rem)..
42f0: 28 73 65 74 21 20 72 65 73 20 28 61 70 70 6c 79 (set! res (apply
4300: 20 76 65 63 74 6f 72 20 69 64 20 72 65 6d 29 29 vector id rem))
4310: 29 0a 09 64 62 0a 09 28 63 6f 6e 63 20 22 53 45 )..db..(conc "SE
4320: 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f LECT id,action,o
4330: 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 65 wner,state,targe
4340: 74 2c 6e 61 6d 65 2c 74 65 73 74 70 61 74 74 2c t,name,testpatt,
4350: 6b 65 79 6c 6f 63 6b 2c 70 61 72 61 6d 73 2c 63 keylock,params,c
4360: 72 65 61 74 69 6f 6e 5f 74 69 6d 65 2c 65 78 65 reation_time,exe
4370: 63 75 74 69 6f 6e 5f 74 69 6d 65 20 0a 20 20 20 cution_time .
4380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 46 F
4390: 52 4f 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 ROM tasks_queue
43a0: 0a 20 09 20 20 20 20 20 20 20 57 48 45 52 45 20 . . WHERE
43b0: 20 0a 09 20 20 20 20 20 20 20 20 74 61 72 67 65 .. targe
43c0: 74 20 3d 20 3f 20 41 4e 44 20 6e 61 6d 65 20 3d t = ? AND name =
43d0: 3f 0a 09 20 20 20 20 20 20 20 4f 52 44 45 52 20 ?.. ORDER
43e0: 42 59 20 63 72 65 61 74 69 6f 6e 5f 74 69 6d 65 BY creation_time
43f0: 20 44 45 53 43 20 4c 49 4d 49 54 20 31 3b 22 29 DESC LIMIT 1;")
4400: 0a 09 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 ..target runname
4410: 29 0a 20 20 20 20 20 20 20 72 65 73 29 29 29 29 ). res))))
4420: 0a 0a 3b 3b 20 72 65 6d 6f 76 65 20 74 61 73 6b ..;; remove task
4430: 73 20 67 69 76 65 6e 20 62 79 20 61 20 73 74 72 s given by a str
4440: 69 6e 67 20 6f 66 20 6e 75 6d 62 65 72 73 20 63 ing of numbers c
4450: 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 0a 28 omma separated.(
4460: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 65 define (tasks:re
4470: 6d 6f 76 65 2d 71 75 65 75 65 2d 65 6e 74 72 69 move-queue-entri
4480: 65 73 20 64 62 73 74 72 75 63 74 20 74 61 73 6b es dbstruct task
4490: 2d 69 64 73 29 0a 20 20 28 64 62 3a 77 69 74 68 -ids). (db:with
44a0: 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 -db. dbstruct
44b0: 23 66 20 23 74 0a 20 20 20 28 6c 61 6d 62 64 61 #f #t. (lambda
44c0: 20 28 64 62 29 0a 20 20 20 20 20 28 73 71 6c 69 (db). (sqli
44d0: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 te3:execute db (
44e0: 63 6f 6e 63 20 22 44 45 4c 45 54 45 20 46 52 4f conc "DELETE FRO
44f0: 4d 20 74 61 73 6b 73 5f 71 75 65 75 65 20 57 48 M tasks_queue WH
4500: 45 52 45 20 69 64 20 49 4e 20 28 22 20 74 61 73 ERE id IN (" tas
4510: 6b 2d 69 64 73 20 22 29 3b 22 29 29 29 29 29 0a k-ids ");"))))).
4520: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
4530: 70 72 6f 63 65 73 73 2d 71 75 65 75 65 20 64 62 process-queue db
4540: 73 74 72 75 63 74 29 0a 20 20 28 6c 65 74 2a 20 struct). (let*
4550: 28 28 74 61 73 6b 20 20 20 28 74 61 73 6b 73 3a ((task (tasks:
4560: 73 6e 61 67 2d 61 2d 74 61 73 6b 20 64 62 73 74 snag-a-task dbst
4570: 72 75 63 74 29 29 0a 09 20 28 61 63 74 69 6f 6e ruct)).. (action
4580: 20 28 69 66 20 74 61 73 6b 20 28 74 61 73 6b 73 (if task (tasks
4590: 3a 74 61 73 6b 2d 67 65 74 2d 61 63 74 69 6f 6e :task-get-action
45a0: 20 74 61 73 6b 29 20 23 66 29 29 29 0a 20 20 20 task) #f))).
45b0: 20 28 69 66 20 61 63 74 69 6f 6e 20 28 70 72 69 (if action (pri
45c0: 6e 74 20 22 74 61 73 6b 73 3a 70 72 6f 63 65 73 nt "tasks:proces
45d0: 73 2d 71 75 65 75 65 20 74 61 73 6b 3a 20 22 20 s-queue task: "
45e0: 74 61 73 6b 29 29 0a 20 20 20 20 28 69 66 20 61 task)). (if a
45f0: 63 74 69 6f 6e 0a 09 28 63 61 73 65 20 28 73 74 ction..(case (st
4600: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 ring->symbol act
4610: 69 6f 6e 29 0a 09 20 20 28 28 72 75 6e 29 20 20 ion).. ((run)
4620: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 74 61 72 (tasks:star
4630: 74 2d 72 75 6e 20 20 20 20 20 64 62 73 74 72 75 t-run dbstru
4640: 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 28 72 ct task)).. ((r
4650: 65 6d 6f 76 65 29 20 20 20 20 28 74 61 73 6b 73 emove) (tasks
4660: 3a 72 65 6d 6f 76 65 2d 72 75 6e 73 20 20 20 64 :remove-runs d
4670: 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a 09 bstruct task))..
4680: 20 20 28 28 6c 6f 63 6b 29 20 20 20 20 20 20 28 ((lock) (
4690: 74 61 73 6b 73 3a 6c 6f 63 6b 2d 72 75 6e 73 20 tasks:lock-runs
46a0: 20 20 20 20 64 62 73 74 72 75 63 74 20 74 61 73 dbstruct tas
46b0: 6b 29 29 0a 09 20 20 3b 3b 20 28 28 6d 6f 6e 69 k)).. ;; ((moni
46c0: 74 6f 72 29 20 20 20 28 74 61 73 6b 73 3a 73 74 tor) (tasks:st
46d0: 61 72 74 2d 6d 6f 6e 69 74 6f 72 20 64 62 20 74 art-monitor db t
46e0: 61 73 6b 29 29 0a 09 20 20 28 28 72 6f 6c 6c 75 ask)).. ((rollu
46f0: 70 29 20 20 20 20 28 74 61 73 6b 73 3a 72 6f 6c p) (tasks:rol
4700: 6c 75 70 2d 72 75 6e 73 20 20 20 64 62 73 74 72 lup-runs dbstr
4710: 75 63 74 20 74 61 73 6b 29 29 0a 09 20 20 28 28 uct task)).. ((
4720: 75 70 64 61 74 65 6d 65 74 61 29 28 74 61 73 6b updatemeta)(task
4730: 73 3a 75 70 64 61 74 65 2d 6d 65 74 61 20 20 20 s:update-meta
4740: 64 62 73 74 72 75 63 74 20 74 61 73 6b 29 29 0a dbstruct task)).
4750: 09 20 20 28 28 6b 69 6c 6c 29 20 20 20 20 20 20 . ((kill)
4760: 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 6d 6f 6e 69 (tasks:kill-moni
4770: 74 6f 72 73 20 64 62 73 74 72 75 63 74 20 74 61 tors dbstruct ta
4780: 73 6b 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e sk))))))..(defin
4790: 65 20 28 74 61 73 6b 73 3a 74 61 73 6b 73 2d 3e e (tasks:tasks->
47a0: 74 65 78 74 20 74 61 73 6b 73 29 0a 20 20 28 6c text tasks). (l
47b0: 65 74 20 28 28 66 6d 74 73 74 72 20 22 7e 31 30 et ((fmtstr "~10
47c0: 61 7e 31 30 61 7e 31 30 61 7e 31 32 61 7e 32 30 a~10a~10a~12a~20
47d0: 61 7e 31 32 61 7e 31 32 61 7e 31 30 61 22 29 29 a~12a~12a~10a"))
47e0: 0a 20 20 20 20 28 63 6f 6e 63 20 28 66 6f 72 6d . (conc (form
47f0: 61 74 20 23 66 20 66 6d 74 73 74 72 20 22 69 64 at #f fmtstr "id
4800: 22 20 22 61 63 74 69 6f 6e 22 20 22 6f 77 6e 65 " "action" "owne
4810: 72 22 20 22 73 74 61 74 65 22 20 22 74 61 72 67 r" "state" "targ
4820: 65 74 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 74 et" "runname" "t
4830: 65 73 74 70 61 74 74 73 22 20 22 70 61 72 61 6d estpatts" "param
4840: 73 22 29 20 22 5c 6e 22 0a 09 20 20 28 73 74 72 s") "\n".. (str
4850: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
4860: 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 .. (map (lambd
4870: 61 20 28 74 61 73 6b 29 0a 09 09 20 20 28 66 6f a (task)... (fo
4880: 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 0a 09 rmat #f fmtstr..
4890: 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d .. (tasks:task-
48a0: 67 65 74 2d 69 64 20 20 20 20 20 74 61 73 6b 29 get-id task)
48b0: 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 73 .... (tasks:tas
48c0: 6b 2d 67 65 74 2d 61 63 74 69 6f 6e 20 74 61 73 k-get-action tas
48d0: 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 k).... (tasks:t
48e0: 61 73 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 ask-get-owner t
48f0: 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 6b 73 ask).... (tasks
4900: 3a 74 61 73 6b 2d 67 65 74 2d 73 74 61 74 65 20 :task-get-state
4910: 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 61 73 task).... (tas
4920: 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 61 72 67 ks:task-get-targ
4930: 65 74 20 74 61 73 6b 29 0a 09 09 09 20 20 28 74 et task).... (t
4940: 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e 61 asks:task-get-na
4950: 6d 65 20 20 20 74 61 73 6b 29 0a 09 09 09 20 20 me task)....
4960: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
4970: 74 65 73 74 20 20 20 74 61 73 6b 29 0a 09 09 09 test task)....
4980: 20 20 3b 3b 20 28 74 61 73 6b 73 3a 74 61 73 6b ;; (tasks:task
4990: 2d 67 65 74 2d 69 74 65 6d 20 20 20 74 61 73 6b -get-item task
49a0: 29 0a 09 09 09 20 20 28 74 61 73 6b 73 3a 74 61 ).... (tasks:ta
49b0: 73 6b 2d 67 65 74 2d 70 61 72 61 6d 73 20 74 61 sk-get-params ta
49c0: 73 6b 29 29 29 0a 09 09 74 61 73 6b 73 29 20 22 sk)))...tasks) "
49d0: 5c 6e 22 29 29 29 29 0a 20 20 20 0a 28 64 65 66 \n")))). .(def
49e0: 69 6e 65 20 28 74 61 73 6b 73 3a 73 65 74 2d 73 ine (tasks:set-s
49f0: 74 61 74 65 20 64 62 73 74 72 75 63 74 20 74 61 tate dbstruct ta
4a00: 73 6b 2d 69 64 20 73 74 61 74 65 29 0a 20 20 28 sk-id state). (
4a10: 64 62 3a 77 69 74 68 2d 64 62 20 0a 20 20 20 64 db:with-db . d
4a20: 62 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 bstruct #f #t.
4a30: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
4a40: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
4a50: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
4a60: 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 asks_queue SET s
4a70: 74 61 74 65 3d 3f 20 57 48 45 52 45 20 69 64 3d tate=? WHERE id=
4a80: 3f 3b 22 20 0a 09 09 20 20 20 20 20 20 73 74 61 ?;" ... sta
4a90: 74 65 20 0a 09 09 20 20 20 20 20 20 74 61 73 6b te ... task
4aa0: 2d 69 64 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d -id))))..;;=====
4ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4af0: 3d 0a 3b 3b 20 41 63 63 65 73 73 20 75 73 69 6e =.;; Access usin
4b00: 67 20 74 61 73 6b 20 6b 65 79 20 28 73 74 6f 72 g task key (stor
4b10: 65 64 20 69 6e 20 70 61 72 61 6d 73 3b 20 28 68 ed in params; (h
4b20: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
4b30: 20 66 6c 61 67 73 29 20 68 6f 73 74 6e 61 6d 65 flags) hostname
4b40: 20 70 69 64 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d pid.;;=========
4b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
4b90: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 70 61 define (tasks:pa
4ba0: 72 61 6d 2d 6b 65 79 2d 3e 69 64 20 64 62 73 74 ram-key->id dbst
4bb0: 72 75 63 74 20 74 61 73 6b 2d 70 61 72 61 6d 73 ruct task-params
4bc0: 29 0a 20 20 28 64 62 3a 77 69 74 68 2d 64 62 0a ). (db:with-db.
4bd0: 20 20 20 64 62 73 74 72 75 63 74 20 23 66 20 23 dbstruct #f #
4be0: 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 64 62 f. (lambda (db
4bf0: 29 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ). (handle-e
4c00: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
4c10: 65 78 6e 0a 20 20 20 20 20 20 23 66 0a 20 20 20 exn. #f.
4c20: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 72 73 (sqlite3:firs
4c30: 74 2d 72 65 73 75 6c 74 20 64 62 20 22 53 45 4c t-result db "SEL
4c40: 45 43 54 20 69 64 20 46 52 4f 4d 20 74 61 73 6b ECT id FROM task
4c50: 73 5f 71 75 65 75 65 20 57 48 45 52 45 20 70 61 s_queue WHERE pa
4c60: 72 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 0a 09 09 rams LIKE ?;"...
4c70: 09 20 20 20 20 74 61 73 6b 2d 70 61 72 61 6d 73 . task-params
4c80: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
4c90: 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d tasks:set-state-
4ca0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
4cb0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 2d 6b dbstruct param-k
4cc0: 65 79 20 6e 65 77 2d 73 74 61 74 65 29 0a 20 20 ey new-state).
4cd0: 28 64 62 3a 77 69 74 68 2d 64 62 0a 20 20 20 64 (db:with-db. d
4ce0: 62 73 74 72 75 63 74 20 23 66 20 23 74 0a 20 20 bstruct #f #t.
4cf0: 20 28 6c 61 6d 62 64 61 20 28 64 62 29 0a 20 20 (lambda (db).
4d00: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
4d10: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
4d20: 61 73 6b 73 5f 71 75 65 75 65 20 53 45 54 20 73 asks_queue SET s
4d30: 74 61 74 65 3d 3f 20 57 48 45 52 45 20 70 61 72 tate=? WHERE par
4d40: 61 6d 73 20 4c 49 4b 45 20 3f 3b 22 20 6e 65 77 ams LIKE ?;" new
4d50: 2d 73 74 61 74 65 20 70 61 72 61 6d 2d 6b 65 79 -state param-key
4d60: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
4d70: 61 73 6b 73 3a 67 65 74 2d 72 65 63 6f 72 64 73 asks:get-records
4d80: 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 -given-param-key
4d90: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 2d dbstruct param-
4da0: 6b 65 79 20 73 74 61 74 65 2d 70 61 74 74 20 61 key state-patt a
4db0: 63 74 69 6f 6e 2d 70 61 74 74 20 74 65 73 74 2d ction-patt test-
4dc0: 70 61 74 74 29 0a 20 20 28 64 62 3a 77 69 74 68 patt). (db:with
4dd0: 2d 64 62 0a 20 20 20 64 62 73 74 72 75 63 74 20 -db. dbstruct
4de0: 23 66 20 23 66 0a 20 20 20 28 6c 61 6d 62 64 61 #f #f. (lambda
4df0: 20 28 64 62 29 0a 20 20 20 20 20 28 68 61 6e 64 (db). (hand
4e00: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
4e10: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 27 28 exn. '(
4e20: 29 0a 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 ). (sqlite3
4e30: 3a 66 69 72 73 74 2d 72 6f 77 20 64 62 20 22 53 :first-row db "S
4e40: 45 4c 45 43 54 20 69 64 2c 61 63 74 69 6f 6e 2c ELECT id,action,
4e50: 6f 77 6e 65 72 2c 73 74 61 74 65 2c 74 61 72 67 owner,state,targ
4e60: 65 74 2c 6e 61 6d 65 2c 74 65 73 74 70 61 74 74 et,name,testpatt
4e70: 2c 6b 65 79 6c 6f 63 6b 2c 70 61 72 61 6d 73 20 ,keylock,params
4e80: 57 48 45 52 45 0a 20 20 20 20 20 20 20 20 20 20 WHERE.
4e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ea0: 20 20 20 20 20 70 61 72 61 6d 73 20 4c 49 4b 45 params LIKE
4eb0: 20 3f 20 41 4e 44 20 73 74 61 74 65 20 4c 49 4b ? AND state LIK
4ec0: 45 20 3f 20 41 4e 44 20 61 63 74 69 6f 6e 20 4c E ? AND action L
4ed0: 49 4b 45 20 3f 20 41 4e 44 20 74 65 73 74 70 61 IKE ? AND testpa
4ee0: 74 74 20 4c 49 4b 45 20 3f 3b 22 0a 09 09 09 20 tt LIKE ?;"....
4ef0: 70 61 72 61 6d 2d 6b 65 79 20 73 74 61 74 65 2d param-key state-
4f00: 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 patt action-patt
4f10: 20 74 65 73 74 2d 70 61 74 74 29 29 29 29 29 0a test-patt))))).
4f20: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a .(define (tasks:
4f30: 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d find-task-queue-
4f40: 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 63 74 records dbstruct
4f50: 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 target run-name
4f60: 20 74 65 73 74 2d 70 61 74 74 20 73 74 61 74 65 test-patt state
4f70: 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 -patt action-pat
4f80: 74 29 0a 20 20 3b 3b 20 28 68 61 6e 64 6c 65 2d t). ;; (handle-
4f90: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 3b 3b 20 exceptions. ;;
4fa0: 20 65 78 6e 0a 20 20 3b 3b 20 20 27 28 29 0a 20 exn. ;; '().
4fb0: 20 3b 3b 20 20 28 73 71 6c 69 74 65 33 3a 66 69 ;; (sqlite3:fi
4fc0: 72 73 74 2d 72 6f 77 0a 20 20 28 6c 65 74 20 28 rst-row. (let (
4fd0: 28 64 62 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 (db (db:delay-if
4fe0: 2d 62 75 73 79 20 28 64 62 3a 67 65 74 2d 64 62 -busy (db:get-db
4ff0: 20 64 62 73 74 72 75 63 74 29 29 29 0a 09 28 72 dbstruct)))..(r
5000: 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 73 71 es '())). (sq
5010: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
5020: 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ow . (lambda
5030: 20 28 61 20 2e 20 62 29 0a 20 20 20 20 20 20 20 (a . b).
5040: 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
5050: 28 63 6f 6e 73 20 61 20 62 29 20 72 65 73 29 29 (cons a b) res))
5060: 29 0a 20 20 20 20 20 64 62 20 22 53 45 4c 45 43 ). db "SELEC
5070: 54 20 69 64 2c 61 63 74 69 6f 6e 2c 6f 77 6e 65 T id,action,owne
5080: 72 2c 73 74 61 74 65 2c 74 61 72 67 65 74 2c 6e r,state,target,n
5090: 61 6d 65 2c 74 65 73 74 70 61 74 74 2c 6b 65 79 ame,testpatt,key
50a0: 6c 6f 63 6b 2c 70 61 72 61 6d 73 20 46 52 4f 4d lock,params FROM
50b0: 20 74 61 73 6b 73 5f 71 75 65 75 65 20 0a 20 20 tasks_queue .
50c0: 20 20 20 20 20 20 20 20 20 57 48 45 52 45 0a 20 WHERE.
50d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 74 61 72 tar
50e0: 67 65 74 20 3d 20 3f 20 41 4e 44 20 6e 61 6d 65 get = ? AND name
50f0: 20 3d 20 3f 20 41 4e 44 20 73 74 61 74 65 20 4c = ? AND state L
5100: 49 4b 45 20 3f 20 41 4e 44 20 61 63 74 69 6f 6e IKE ? AND action
5110: 20 4c 49 4b 45 20 3f 20 41 4e 44 20 74 65 73 74 LIKE ? AND test
5120: 70 61 74 74 20 4c 49 4b 45 20 3f 3b 22 0a 20 20 patt LIKE ?;".
5130: 20 20 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 target run-na
5140: 6d 65 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 me state-patt ac
5150: 74 69 6f 6e 2d 70 61 74 74 20 74 65 73 74 2d 70 tion-patt test-p
5160: 61 74 74 29 0a 20 20 20 20 72 65 73 29 29 20 3b att). res)) ;
5170: 3b 20 29 0a 0a 3b 3b 20 6b 69 6c 6c 20 61 6e 79 ; )..;; kill any
5180: 20 72 75 6e 6e 65 72 20 70 72 6f 63 65 73 73 65 runner processe
5190: 73 20 28 69 2e 65 2e 20 70 72 6f 63 65 73 73 65 s (i.e. processe
51a0: 73 20 68 61 6e 64 6c 69 6e 67 20 2d 72 75 6e 74 s handling -runt
51b0: 65 73 74 73 29 20 74 68 61 74 20 6d 61 74 63 68 ests) that match
51c0: 20 74 61 72 67 65 74 2f 72 75 6e 6e 61 6d 65 0a target/runname.
51d0: 3b 3b 20 0a 3b 3b 20 64 6f 20 61 20 72 65 6d 6f ;; .;; do a remo
51e0: 74 65 20 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 te call to get t
51f0: 68 65 20 74 61 73 6b 20 71 75 65 75 65 20 69 6e he task queue in
5200: 66 6f 20 62 75 74 20 64 6f 20 74 68 65 20 6b 69 fo but do the ki
5210: 6c 6c 69 6e 67 20 61 73 20 73 65 6c 66 20 68 65 lling as self he
5220: 72 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 re..;;.(define (
5230: 74 61 73 6b 73 3a 6b 69 6c 6c 2d 72 75 6e 6e 65 tasks:kill-runne
5240: 72 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d r target run-nam
5250: 65 20 74 65 73 74 70 61 74 74 29 0a 20 20 28 6c e testpatt). (l
5260: 65 74 20 28 28 72 65 63 6f 72 64 73 20 20 20 20 et ((records
5270: 28 72 6d 74 3a 74 61 73 6b 73 2d 66 69 6e 64 2d (rmt:tasks-find-
5280: 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 task-queue-recor
5290: 64 73 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 ds target run-na
52a0: 6d 65 20 74 65 73 74 70 61 74 74 20 22 72 75 6e me testpatt "run
52b0: 6e 69 6e 67 22 20 22 72 75 6e 2d 74 65 73 74 73 ning" "run-tests
52c0: 22 29 29 0a 09 28 68 6f 73 74 70 69 64 2d 72 78 "))..(hostpid-rx
52d0: 20 28 72 65 67 65 78 70 20 22 5c 5c 73 2b 28 5c (regexp "\\s+(\
52e0: 5c 77 2b 29 5c 5c 73 2b 28 5c 5c 64 2b 29 24 22 \w+)\\s+(\\d+)$"
52f0: 29 29 29 20 3b 3b 20 68 6f 73 74 20 70 69 64 20 ))) ;; host pid
5300: 69 73 20 61 74 20 65 6e 64 20 6f 66 20 70 61 72 is at end of par
5310: 61 6d 20 73 74 72 69 6e 67 0a 20 20 20 20 28 69 am string. (i
5320: 66 20 28 6e 75 6c 6c 3f 20 72 65 63 6f 72 64 73 f (null? records
5330: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
5340: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5350: 6f 72 74 2a 20 22 4e 6f 20 72 75 6e 20 6c 61 75 ort* "No run lau
5360: 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 65 73 nching processes
5370: 20 66 6f 75 6e 64 20 66 6f 72 20 22 20 74 61 72 found for " tar
5380: 67 65 74 20 22 20 2f 20 22 20 72 75 6e 2d 6e 61 get " / " run-na
5390: 6d 65 20 22 20 77 69 74 68 20 74 65 73 74 70 61 me " with testpa
53a0: 74 74 20 22 20 28 6f 72 20 74 65 73 74 70 61 74 tt " (or testpat
53b0: 74 20 22 2a 20 6e 6f 20 74 65 73 74 70 61 74 74 t "* no testpatt
53c0: 20 73 70 65 63 69 66 69 65 64 21 20 2a 22 29 29 specified! *"))
53d0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
53e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
53f0: 72 74 2a 20 22 46 6f 75 6e 64 20 22 20 28 6c 65 rt* "Found " (le
5400: 6e 67 74 68 20 72 65 63 6f 72 64 73 29 20 22 20 ngth records) "
5410: 72 75 6e 28 73 29 20 74 6f 20 6b 69 6c 6c 2e 22 run(s) to kill."
5420: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
5430: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
5440: 72 65 63 6f 72 64 29 0a 20 20 20 20 20 20 20 28 record). (
5450: 6c 65 74 2a 20 28 28 70 61 72 61 6d 2d 6b 65 79 let* ((param-key
5460: 20 28 6c 69 73 74 2d 72 65 66 20 72 65 63 6f 72 (list-ref recor
5470: 64 20 38 29 29 0a 09 20 20 20 20 20 20 28 6d 61 d 8)).. (ma
5480: 74 63 68 2d 64 61 74 20 28 73 74 72 69 6e 67 2d tch-dat (string-
5490: 73 65 61 72 63 68 20 68 6f 73 74 70 69 64 2d 72 search hostpid-r
54a0: 78 20 70 61 72 61 6d 2d 6b 65 79 29 29 29 0a 09 x param-key)))..
54b0: 20 28 69 66 20 6d 61 74 63 68 2d 64 61 74 0a 09 (if match-dat..
54c0: 20 20 20 20 20 28 6c 65 74 20 28 28 68 6f 73 74 (let ((host
54d0: 6e 61 6d 65 20 20 28 63 61 64 72 20 6d 61 74 63 name (cadr matc
54e0: 68 2d 64 61 74 29 29 0a 09 09 20 20 20 28 70 69 h-dat))... (pi
54f0: 64 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d d (string-
5500: 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 6d >number (caddr m
5510: 61 74 63 68 2d 64 61 74 29 29 29 29 0a 09 20 20 atch-dat))))..
5520: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
5530: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
5540: 2d 70 6f 72 74 2a 20 22 53 65 6e 64 69 6e 67 20 -port* "Sending
5550: 53 49 47 49 4e 54 20 74 6f 20 70 72 6f 63 65 73 SIGINT to proces
5560: 73 20 22 20 70 69 64 20 22 20 6f 6e 20 68 6f 73 s " pid " on hos
5570: 74 20 22 20 68 6f 73 74 6e 61 6d 65 29 0a 09 20 t " hostname)..
5580: 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c (if (equal
5590: 3f 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 ? (get-host-name
55a0: 29 20 68 6f 73 74 6e 61 6d 65 29 0a 09 09 20 20 ) hostname)...
55b0: 20 28 69 66 20 28 70 72 6f 63 65 73 73 3a 61 6c (if (process:al
55c0: 69 76 65 3f 20 70 69 64 29 0a 09 09 20 20 20 20 ive? pid)...
55d0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 68 (begin.... (h
55e0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
55f0: 0a 09 09 09 20 20 65 78 6e 0a 09 09 09 20 20 28 .... exn.... (
5600: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 64 65 begin.... (de
5610: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
5620: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5630: 4b 69 6c 6c 20 6f 66 20 70 72 6f 63 65 73 73 20 Kill of process
5640: 22 20 70 69 64 20 22 20 6f 6e 20 68 6f 73 74 20 " pid " on host
5650: 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 66 61 69 " hostname " fai
5660: 6c 65 64 2e 22 29 0a 09 09 09 20 20 20 20 28 64 led.").... (d
5670: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5680: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5690: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
56a0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
56b0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
56c0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
56d0: 09 09 09 20 20 20 20 23 74 29 0a 09 09 09 20 20 ... #t)....
56e0: 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 (process-signal
56f0: 70 69 64 20 73 69 67 6e 61 6c 2f 69 6e 74 29 0a pid signal/int).
5700: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
5710: 65 70 21 20 35 29 0a 09 09 09 20 20 28 69 66 20 ep! 5).... (if
5720: 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 (process:alive?
5730: 70 69 64 29 0a 09 09 09 20 20 20 20 20 20 28 70 pid).... (p
5740: 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 70 69 rocess-signal pi
5750: 64 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 d signal/kill)))
5760: 29 29 0a 09 09 20 20 20 3b 3b 20 20 28 63 61 6c ))... ;; (cal
5770: 6c 2d 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 l-with-environme
5780: 6e 74 2d 76 61 72 69 61 62 6c 65 73 0a 09 09 20 nt-variables...
5790: 20 20 28 6c 65 74 20 28 28 6f 6c 64 2d 74 61 72 (let ((old-tar
57a0: 67 65 74 68 6f 73 74 20 28 67 65 74 65 6e 76 20 gethost (getenv
57b0: 22 54 41 52 47 45 54 48 4f 53 54 22 29 29 29 0a "TARGETHOST"))).
57c0: 09 09 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 .. (setenv "
57d0: 54 41 52 47 45 54 48 4f 53 54 22 20 68 6f 73 74 TARGETHOST" host
57e0: 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 28 73 65 name)... (se
57f0: 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 tenv "TARGETHOST
5800: 5f 4c 4f 47 46 22 20 22 73 65 72 76 65 72 2d 6b _LOGF" "server-k
5810: 69 6c 6c 73 2e 6c 6f 67 22 29 0a 09 09 20 20 20 ills.log")...
5820: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
5830: 22 6e 62 66 61 6b 65 20 6b 69 6c 6c 20 22 20 70 "nbfake kill " p
5840: 69 64 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 id))... (if
5850: 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 74 20 28 old-targethost (
5860: 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f setenv "TARGETHO
5870: 53 54 22 20 6f 6c 64 2d 74 61 72 67 65 74 68 6f ST" old-targetho
5880: 73 74 29 29 0a 09 09 20 20 20 20 20 28 75 6e 73 st))... (uns
5890: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
58a0: 54 22 29 0a 09 09 20 20 20 20 20 28 75 6e 73 65 T")... (unse
58b0: 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 54 tenv "TARGETHOST
58c0: 5f 4c 4f 47 46 22 29 29 29 29 0a 09 20 20 20 20 _LOGF"))))..
58d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
58e0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
58f0: 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 72 65 63 og-port* "no rec
5900: 6f 72 64 20 6f 72 20 69 6d 70 72 6f 70 65 72 20 ord or improper
5910: 72 65 63 6f 72 64 20 66 6f 72 20 22 20 74 61 72 record for " tar
5920: 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 get "/" run-name
5930: 20 22 20 69 6e 20 74 61 73 6b 73 5f 71 75 65 75 " in tasks_queu
5940: 65 20 69 6e 20 6d 61 69 6e 2e 64 62 22 29 29 29 e in main.db")))
5950: 29 0a 20 20 20 20 20 72 65 63 6f 72 64 73 29 29 ). records))
5960: 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 )..;; (define (t
5970: 61 73 6b 73 3a 73 74 61 72 74 2d 72 75 6e 20 64 asks:start-run d
5980: 62 73 74 72 75 63 74 20 6d 64 62 20 74 61 73 6b bstruct mdb task
5990: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 66 6c ).;; (let ((fl
59a0: 61 67 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ags (make-hash-t
59b0: 61 62 6c 65 29 29 29 0a 3b 3b 20 20 20 20 20 28 able))).;; (
59c0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
59d0: 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 22 flags "-rerun" "
59e0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 3b 3b NOT_STARTED").;;
59f0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 (if (not (s
5a00: 74 72 69 6e 67 3d 3f 20 28 74 61 73 6b 73 3a 74 tring=? (tasks:t
5a10: 61 73 6b 2d 67 65 74 2d 70 61 72 61 6d 73 20 74 ask-get-params t
5a20: 61 73 6b 29 20 22 22 29 29 0a 3b 3b 20 09 28 68 ask) "")).;; .(h
5a30: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 66 ash-table-set! f
5a40: 6c 61 67 73 20 22 2d 73 65 74 76 61 72 73 22 20 lags "-setvars"
5a50: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
5a60: 70 61 72 61 6d 73 20 74 61 73 6b 29 29 29 0a 3b params task))).;
5a70: 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 53 74 ; (print "St
5a80: 61 72 74 69 6e 67 20 72 75 6e 20 22 20 74 61 73 arting run " tas
5a90: 6b 29 0a 3b 3b 20 20 20 20 20 3b 3b 20 73 69 6c k).;; ;; sil
5aa0: 6c 79 6e 65 73 73 2c 20 6a 75 73 74 20 63 61 6c lyness, just cal
5ab0: 6c 20 74 68 65 20 64 61 6d 6e 20 72 6f 75 74 69 l the damn routi
5ac0: 6e 65 20 77 69 74 68 20 74 68 65 20 74 61 73 6b ne with the task
5ad0: 20 76 65 63 74 6f 72 20 61 6e 64 20 62 65 20 64 vector and be d
5ae0: 6f 6e 65 20 77 69 74 68 20 69 74 2e 20 46 49 58 one with it. FIX
5af0: 4d 45 20 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 20 ME SOMEDAY.;;
5b00: 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 (runs:run-test
5b10: 73 20 64 62 0a 3b 3b 20 09 09 20 20 20 20 28 74 s db.;; .. (t
5b20: 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 74 61 asks:task-get-ta
5b30: 72 67 65 74 20 74 61 73 6b 29 0a 3b 3b 20 09 09 rget task).;; ..
5b40: 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b 2d (tasks:task-
5b50: 67 65 74 2d 6e 61 6d 65 20 20 20 74 61 73 6b 29 get-name task)
5b60: 0a 3b 3b 20 09 09 20 20 20 20 28 74 61 73 6b 73 .;; .. (tasks
5b70: 3a 74 61 73 6b 2d 67 65 74 2d 74 65 73 74 20 20 :task-get-test
5b80: 20 74 61 73 6b 29 0a 3b 3b 20 09 09 20 20 20 20 task).;; ..
5b90: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
5ba0: 69 74 65 6d 20 20 20 74 61 73 6b 29 0a 3b 3b 20 item task).;;
5bb0: 09 09 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 .. (tasks:tas
5bc0: 6b 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 k-get-owner tas
5bd0: 6b 29 0a 3b 3b 20 09 09 20 20 20 20 66 6c 61 67 k).;; .. flag
5be0: 73 29 0a 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 s).;; (tasks
5bf0: 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 62 20 28 :set-state mdb (
5c00: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 tasks:task-get-i
5c10: 64 20 74 61 73 6b 29 20 22 77 61 69 74 69 6e 67 d task) "waiting
5c20: 22 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 "))).;; .;; (def
5c30: 69 6e 65 20 28 74 61 73 6b 73 3a 72 6f 6c 6c 75 ine (tasks:rollu
5c40: 70 2d 72 75 6e 73 20 64 62 20 6d 64 62 20 74 61 p-runs db mdb ta
5c50: 73 6b 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 sk).;; (let* (
5c60: 28 66 6c 61 67 73 20 28 6d 61 6b 65 2d 68 61 73 (flags (make-has
5c70: 68 2d 74 61 62 6c 65 29 29 20 0a 3b 3b 20 09 20 h-table)) .;; .
5c80: 28 6b 65 79 73 20 20 28 64 62 3a 67 65 74 2d 6b (keys (db:get-k
5c90: 65 79 73 20 64 62 29 29 0a 3b 3b 20 09 20 28 6b eys db)).;; . (k
5ca0: 65 79 76 61 6c 73 20 28 6b 65 79 73 3a 74 61 72 eyvals (keys:tar
5cb0: 67 65 74 2d 6b 65 79 76 61 6c 20 6b 65 79 73 20 get-keyval keys
5cc0: 28 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d (tasks:task-get-
5cd0: 74 61 72 67 65 74 20 74 61 73 6b 29 29 29 29 0a target task)))).
5ce0: 3b 3b 20 20 20 20 20 3b 3b 20 28 68 61 73 68 2d ;; ;; (hash-
5cf0: 74 61 62 6c 65 2d 73 65 74 21 20 66 6c 61 67 73 table-set! flags
5d00: 20 22 2d 72 65 72 75 6e 22 20 22 4e 4f 54 5f 53 "-rerun" "NOT_S
5d10: 54 41 52 54 45 44 22 29 0a 3b 3b 20 20 20 20 20 TARTED").;;
5d20: 28 70 72 69 6e 74 20 22 53 74 61 72 74 69 6e 67 (print "Starting
5d30: 20 72 6f 6c 6c 75 70 20 22 20 74 61 73 6b 29 0a rollup " task).
5d40: 3b 3b 20 20 20 20 20 3b 3b 20 73 69 6c 6c 79 6e ;; ;; sillyn
5d50: 65 73 73 2c 20 6a 75 73 74 20 63 61 6c 6c 20 74 ess, just call t
5d60: 68 65 20 64 61 6d 6e 20 72 6f 75 74 69 6e 65 20 he damn routine
5d70: 77 69 74 68 20 74 68 65 20 74 61 73 6b 20 76 65 with the task ve
5d80: 63 74 6f 72 20 61 6e 64 20 62 65 20 64 6f 6e 65 ctor and be done
5d90: 20 77 69 74 68 20 69 74 2e 20 46 49 58 4d 45 20 with it. FIXME
5da0: 53 4f 4d 45 44 41 59 0a 3b 3b 20 20 20 20 20 28 SOMEDAY.;; (
5db0: 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 runs:rollup-run
5dc0: 64 62 0a 3b 3b 20 09 09 20 20 20 20 20 6b 65 79 db.;; .. key
5dd0: 73 20 0a 3b 3b 20 09 09 20 20 20 20 20 6b 65 79 s .;; .. key
5de0: 76 61 6c 73 0a 3b 3b 20 09 09 20 20 20 20 20 28 vals.;; .. (
5df0: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 6e tasks:task-get-n
5e00: 61 6d 65 20 20 74 61 73 6b 29 0a 3b 3b 20 09 09 ame task).;; ..
5e10: 20 20 20 20 20 28 74 61 73 6b 73 3a 74 61 73 6b (tasks:task
5e20: 2d 67 65 74 2d 6f 77 6e 65 72 20 20 74 61 73 6b -get-owner task
5e30: 29 29 0a 3b 3b 20 20 20 20 20 28 74 61 73 6b 73 )).;; (tasks
5e40: 3a 73 65 74 2d 73 74 61 74 65 20 6d 64 62 20 28 :set-state mdb (
5e50: 74 61 73 6b 73 3a 74 61 73 6b 2d 67 65 74 2d 69 tasks:task-get-i
5e60: 64 20 74 61 73 6b 29 20 22 77 61 69 74 69 6e 67 d task) "waiting
5e70: 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
5e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
5ec0: 3b 20 20 53 20 59 20 4e 20 43 20 20 20 54 20 4f ; S Y N C T O
5ed0: 20 20 20 50 20 4f 20 53 20 54 20 47 20 52 20 45 P O S T G R E
5ee0: 20 53 20 51 20 4c 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S Q L.;;=======
5ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5f30: 0a 3b 3b 20 49 6e 20 74 68 65 20 73 70 69 72 69 .;; In the spiri
5f40: 74 20 6f 66 20 22 64 75 6d 70 20 79 6f 75 72 20 t of "dump your
5f50: 6a 75 6e 6b 20 69 6e 20 74 68 65 20 74 61 73 6b junk in the task
5f60: 73 20 6d 6f 64 75 6c 65 22 20 49 27 6c 6c 20 70 s module" I'll p
5f70: 75 74 20 74 68 65 0a 3b 3b 20 73 79 6e 63 20 74 ut the.;; sync t
5f80: 6f 20 70 6f 73 74 67 72 65 73 20 68 65 72 65 20 o postgres here
5f90: 66 6f 72 20 6e 6f 77 2e 0a 0a 3b 3b 20 61 74 74 for now...;; att
5fa0: 65 6d 70 74 20 74 6f 20 61 75 74 6f 6d 61 74 69 empt to automati
5fb0: 63 61 6c 6c 79 20 73 65 74 20 75 70 20 61 6e 20 cally set up an
5fc0: 61 72 65 61 2e 20 63 61 6c 6c 20 6f 6e 6c 79 20 area. call only
5fd0: 69 66 20 67 65 74 20 61 72 65 61 20 62 79 20 70 if get area by p
5fe0: 61 74 68 0a 3b 3b 20 72 65 74 75 72 6e 73 20 6e ath.;; returns n
5ff0: 61 75 67 68 74 20 6f 66 20 69 6e 74 65 72 65 73 aught of interes
6000: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 t.;;.(define (ta
6010: 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 62 68 sks:set-area dbh
6020: 20 63 6f 6e 66 69 67 64 61 74 20 23 21 6b 65 79 configdat #!key
6030: 20 28 74 6f 70 70 61 74 68 20 23 66 29 29 20 3b (toppath #f)) ;
6040: 3b 20 63 6f 75 6c 64 20 49 20 73 61 66 65 6c 79 ; could I safely
6050: 20 70 75 74 20 2a 74 6f 70 70 61 74 68 2a 20 69 put *toppath* i
6060: 6e 20 66 6f 72 20 74 68 65 20 64 65 66 61 75 6c n for the defaul
6070: 74 20 66 6f 72 20 74 6f 70 70 61 74 68 3f 20 77 t for toppath? w
6080: 68 65 6e 20 77 6f 75 6c 64 20 69 74 20 62 65 20 hen would it be
6090: 65 76 61 6c 75 61 74 65 64 3f 0a 20 20 28 6c 65 evaluated?. (le
60a0: 74 20 6c 6f 6f 70 20 28 28 61 72 65 61 2d 6e 61 t loop ((area-na
60b0: 6d 65 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a me (or (configf:
60c0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
60d0: 20 22 73 65 74 75 70 22 20 22 61 72 65 61 2d 6e "setup" "area-n
60e0: 61 6d 65 22 29 0a 09 09 09 20 20 20 20 28 63 6f ame").... (co
60f0: 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 mmon:get-area-na
6100: 6d 65 29 29 29 0a 09 20 20 20 20 20 28 6d 6f 64 me))).. (mod
6110: 69 66 69 65 72 20 20 27 6e 6f 6e 65 29 29 0a 20 ifier 'none)).
6120: 20 20 20 28 6c 65 74 20 28 28 73 75 63 63 65 73 (let ((succes
6130: 73 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 s (handle-except
6140: 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 20 65 78 ions... ex
6150: 6e 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 n... (begi
6160: 6e 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 n.... (debug:pri
6170: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
6180: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
6190: 63 61 6e 6e 6f 74 20 63 72 65 61 74 65 20 61 72 cannot create ar
61a0: 65 61 20 65 6e 74 72 79 2c 20 22 20 28 28 63 6f ea entry, " ((co
61b0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
61c0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
61d0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 message) exn))..
61e0: 09 09 20 23 66 29 20 3b 3b 20 46 49 58 4d 45 3a .. #f) ;; FIXME:
61f0: 20 49 20 64 6f 6e 27 74 20 63 61 72 65 20 66 6f I don't care fo
6200: 72 20 6e 6f 77 20 62 75 74 20 49 20 73 68 6f 75 r now but I shou
6210: 6c 64 20 6c 6f 6f 6b 20 61 74 20 2a 77 68 79 2a ld look at *why*
6220: 20 74 68 65 72 65 20 77 61 73 20 61 6e 20 65 78 there was an ex
6230: 63 65 70 74 69 6f 6e 0a 09 09 20 20 20 20 20 28 ception... (
6240: 70 67 64 62 3a 61 64 64 2d 61 72 65 61 20 64 62 pgdb:add-area db
6250: 68 20 61 72 65 61 2d 6e 61 6d 65 20 28 6f 72 20 h area-name (or
6260: 74 6f 70 70 61 74 68 20 2a 74 6f 70 70 61 74 68 toppath *toppath
6270: 2a 29 29 29 29 29 0a 20 20 20 20 20 20 28 6f 72 *))))). (or
6280: 20 73 75 63 63 65 73 73 0a 09 20 20 28 63 61 73 success.. (cas
6290: 65 20 6d 6f 64 69 66 69 65 72 0a 09 20 20 20 20 e modifier..
62a0: 28 28 6e 6f 6e 65 29 28 6c 6f 6f 70 20 28 63 6f ((none)(loop (co
62b0: 6e 63 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 nc (current-user
62c0: 2d 6e 61 6d 65 29 20 22 5f 22 20 61 72 65 61 2d -name) "_" area-
62d0: 6e 61 6d 65 29 20 27 75 73 65 72 29 29 0a 09 20 name) 'user))..
62e0: 20 20 20 28 28 75 73 65 72 29 28 6c 6f 6f 70 20 ((user)(loop
62f0: 28 63 6f 6e 63 20 28 73 75 62 73 74 72 69 6e 67 (conc (substring
6300: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 (common:get-are
6310: 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 72 65 a-path-signature
6320: 29 20 30 20 34 29 0a 09 09 09 20 20 20 20 20 20 ) 0 4)....
6330: 20 61 72 65 61 2d 6e 61 6d 65 29 20 27 61 72 65 area-name) 'are
6340: 61 73 69 67 29 29 0a 09 20 20 20 20 28 65 6c 73 asig)).. (els
6350: 65 20 23 66 29 29 29 29 29 29 20 3b 3b 20 67 69 e #f)))))) ;; gi
6360: 76 65 20 75 70 0a 0a 3b 3b 20 67 65 74 73 20 6d ve up..;; gets m
6370: 74 70 67 2d 72 75 6e 2d 69 64 20 61 6e 64 20 73 tpg-run-id and s
6380: 79 6e 63 73 20 74 68 65 20 72 65 63 6f 72 64 20 yncs the record
6390: 69 66 20 64 69 66 66 65 72 65 6e 74 0a 3b 3b 0a if different.;;.
63a0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 72 (define (tasks:r
63b0: 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d un-id->mtpg-run-
63c0: 69 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e id dbh cached-in
63d0: 66 6f 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 fo run-id). (le
63e0: 74 2a 20 28 28 72 75 6e 73 2d 68 74 20 28 68 61 t* ((runs-ht (ha
63f0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 sh-table-ref cac
6400: 68 65 64 2d 69 6e 66 6f 20 27 72 75 6e 73 29 29 hed-info 'runs))
6410: 0a 09 20 28 72 75 6e 69 6e 66 20 20 28 68 61 73 .. (runinf (has
6420: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
6430: 75 6c 74 20 72 75 6e 73 2d 68 74 20 72 75 6e 2d ult runs-ht run-
6440: 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 id #f))). (if
6450: 20 72 75 6e 69 6e 66 0a 09 72 75 6e 69 6e 66 20 runinf..runinf
6460: 3b 3b 20 61 6c 72 65 61 64 79 20 63 61 63 68 65 ;; already cache
6470: 64 0a 09 28 6c 65 74 2a 20 28 28 72 75 6e 2d 64 d..(let* ((run-d
6480: 61 74 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 at (rmt:get-r
6490: 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 29 un-info run-id))
64a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
64b0: 3b 20 4e 4f 54 45 3a 20 67 65 74 2d 72 75 6e 2d ; NOTE: get-run-
64c0: 69 6e 66 6f 20 72 65 74 75 72 6e 73 20 61 20 76 info returns a v
64d0: 65 63 74 6f 72 20 3c 20 72 6f 77 20 68 65 61 64 ector < row head
64e0: 65 72 20 3e 0a 09 20 20 20 20 20 20 20 28 72 75 er >.. (ru
64f0: 6e 2d 6e 61 6d 65 20 20 20 28 72 6d 74 3a 67 65 n-name (rmt:ge
6500: 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d t-run-name-from-
6510: 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 id run-id))..
6520: 20 20 20 20 28 72 6f 77 20 20 20 20 20 20 20 20 (row
6530: 28 64 62 3a 67 65 74 2d 72 6f 77 73 20 72 75 6e (db:get-rows run
6540: 2d 64 61 74 29 29 20 20 20 20 20 20 20 20 20 20 -dat))
6550: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
6560: 20 74 68 69 73 20 72 65 74 75 72 6e 73 20 61 20 this returns a
6570: 73 69 6e 67 6c 65 20 72 6f 77 0a 09 20 20 20 20 single row..
6580: 20 20 20 28 68 65 61 64 65 72 20 20 20 20 20 28 (header (
6590: 64 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 db:get-header ru
65a0: 6e 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 n-dat))..
65b0: 28 73 74 61 74 65 20 20 20 20 20 20 28 64 62 3a (state (db:
65c0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
65d0: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
65e0: 73 74 61 74 65 20 22 29 29 0a 09 20 20 20 20 20 state "))..
65f0: 20 20 28 73 74 61 74 75 73 20 20 20 20 20 28 64 (status (d
6600: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
6610: 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 eader row header
6620: 20 22 73 74 61 74 75 73 22 29 29 0a 09 20 20 20 "status"))..
6630: 20 20 20 20 28 6f 77 6e 65 72 20 20 20 20 20 20 (owner
6640: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
6650: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
6660: 65 72 20 22 6f 77 6e 65 72 22 29 29 0a 09 20 20 er "owner"))..
6670: 20 20 20 20 20 28 65 76 65 6e 74 2d 74 69 6d 65 (event-time
6680: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
6690: 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 y-header row hea
66a0: 64 65 72 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 der "event_time"
66b0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6d 6d )).. (comm
66c0: 65 6e 74 20 20 20 20 28 64 62 3a 67 65 74 2d 76 ent (db:get-v
66d0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
66e0: 6f 77 20 68 65 61 64 65 72 20 22 63 6f 6d 6d 65 ow header "comme
66f0: 6e 74 22 29 29 0a 09 20 20 20 20 20 20 20 28 66 nt")).. (f
6700: 61 69 6c 2d 63 6f 75 6e 74 20 28 64 62 3a 67 65 ail-count (db:ge
6710: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
6720: 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 66 61 r row header "fa
6730: 69 6c 5f 63 6f 75 6e 74 22 29 29 0a 09 20 20 20 il_count"))..
6740: 20 20 20 20 28 70 61 73 73 2d 63 6f 75 6e 74 20 (pass-count
6750: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
6760: 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 -header row head
6770: 65 72 20 22 70 61 73 73 5f 63 6f 75 6e 74 22 29 er "pass_count")
6780: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 74 6f ).. (conto
6790: 75 72 20 20 20 20 28 69 66 20 28 61 72 67 73 3a ur (if (args:
67a0: 67 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e get-arg "-prepen
67b0: 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 64 62 3a d-contour") (db:
67c0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
67d0: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
67e0: 63 6f 6e 74 6f 75 72 22 29 29 29 0a 09 20 20 20 contour")))..
67f0: 20 20 20 20 28 6b 65 79 74 61 72 67 20 20 20 20 (keytarg
6800: 28 69 66 20 28 6f 72 20 28 61 72 67 73 3a 67 65 (if (or (args:ge
6810: 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 2d t-arg "-prepend-
6820: 63 6f 6e 74 6f 75 72 22 29 20 28 61 72 67 73 3a contour") (args:
6830: 67 65 74 2d 61 72 67 20 22 2d 70 72 65 66 69 78 get-arg "-prefix
6840: 2d 74 61 72 67 65 74 22 29 29 0a 09 20 20 20 20 -target"))..
6850: 20 20 20 09 09 09 28 63 6f 6e 63 20 22 4d 54 5f ...(conc "MT_
6860: 43 4f 4e 54 4f 55 52 2f 4d 54 5f 41 52 45 41 2f CONTOUR/MT_AREA/
6870: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
6880: 70 65 72 73 65 20 28 72 6d 74 3a 67 65 74 2d 6b perse (rmt:get-k
6890: 65 79 73 29 20 22 2f 22 29 29 20 28 73 74 72 69 eys) "/")) (stri
68a0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
68b0: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 20 22 2f rmt:get-keys) "/
68c0: 22 29 29 29 20 3b 3b 20 65 2e 67 2e 20 76 65 72 "))) ;; e.g. ver
68d0: 73 69 6f 6e 2f 69 74 65 72 61 74 69 6f 6e 2f 70 sion/iteration/p
68e0: 6c 61 74 66 6f 72 6d 0a 09 20 20 20 20 20 20 20 latform..
68f0: 28 74 61 72 67 65 74 20 20 20 20 20 28 69 66 20 (target (if
6900: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
6910: 67 20 22 2d 70 72 65 70 65 6e 64 2d 63 6f 6e 74 g "-prepend-cont
6920: 6f 75 72 22 29 20 28 61 72 67 73 3a 67 65 74 2d our") (args:get-
6930: 61 72 67 20 22 2d 70 72 65 66 69 78 2d 74 61 72 arg "-prefix-tar
6940: 67 65 74 22 29 29 20 0a 09 20 20 20 20 20 20 20 get")) ..
6950: 09 09 09 28 63 6f 6e 63 20 28 6f 72 20 28 61 72 ...(conc (or (ar
6960: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
6970: 66 69 78 2d 74 61 72 67 65 74 22 29 20 28 63 6f fix-target") (co
6980: 6e 63 20 63 6f 6e 74 6f 75 72 20 22 2f 22 20 28 nc contour "/" (
6990: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d common:get-area-
69a0: 6e 61 6d 65 29 20 22 2f 22 29 29 20 28 72 6d 74 name) "/")) (rmt
69b0: 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d :get-target run-
69c0: 69 64 29 29 20 28 72 6d 74 3a 67 65 74 2d 74 61 id)) (rmt:get-ta
69d0: 72 67 65 74 20 72 75 6e 2d 69 64 29 29 29 20 20 rget run-id)))
69e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
69f0: 3b 20 65 2e 67 2e 20 76 31 2e 36 33 2f 61 33 65 ; e.g. v1.63/a3e
6a00: 31 2f 75 62 75 6e 74 75 0a 09 20 20 20 20 20 20 1/ubuntu..
6a10: 20 28 73 70 65 63 2d 69 64 20 20 20 20 28 70 67 (spec-id (pg
6a20: 64 62 3a 67 65 74 2d 74 74 79 70 65 20 64 62 68 db:get-ttype dbh
6a30: 20 6b 65 79 74 61 72 67 29 29 0a 09 20 20 20 20 keytarg))..
6a40: 20 20 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 28 (new-run-id (
6a50: 70 67 64 62 3a 67 65 74 2d 72 75 6e 2d 69 64 20 pgdb:get-run-id
6a60: 64 62 68 20 73 70 65 63 2d 69 64 20 74 61 72 67 dbh spec-id targ
6a70: 65 74 20 72 75 6e 2d 6e 61 6d 65 29 29 0a 0a 0a et run-name))...
6a80: 0a 09 20 20 20 20 20 20 20 3b 3b 20 28 61 72 65 .. ;; (are
6a90: 61 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d a-id (db:get-
6aa0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
6ab0: 72 6f 77 20 68 65 61 64 65 72 20 22 61 72 65 61 row header "area
6ac0: 5f 69 64 29 22 29 29 0a 09 20 20 20 20 20 20 20 _id)"))..
6ad0: 29 0a 09 20 20 28 69 66 20 6e 65 77 2d 72 75 6e ).. (if new-run
6ae0: 2d 69 64 0a 09 20 20 20 20 20 20 28 62 65 67 69 -id.. (begi
6af0: 6e 20 3b 3b 20 6c 65 74 20 28 28 72 75 6e 2d 72 n ;; let ((run-r
6b00: 65 63 6f 72 64 20 28 70 67 64 62 3a 67 65 74 2d ecord (pgdb:get-
6b10: 72 75 6e 2d 69 6e 66 6f 20 64 62 68 20 6e 65 77 run-info dbh new
6b20: 2d 72 75 6e 2d 69 64 29 29 0a 09 09 28 68 61 73 -run-id))...(has
6b30: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 75 6e h-table-set! run
6b40: 73 2d 68 74 20 72 75 6e 2d 69 64 20 6e 65 77 2d s-ht run-id new-
6b50: 72 75 6e 2d 69 64 29 0a 09 09 3b 3b 20 65 6e 73 run-id)...;; ens
6b60: 75 72 65 20 6b 65 79 20 66 69 65 6c 64 73 20 61 ure key fields a
6b70: 72 65 20 75 70 20 74 6f 20 64 61 74 65 0a 09 09 re up to date...
6b80: 28 70 67 64 62 3a 72 65 66 72 65 73 68 2d 72 75 (pgdb:refresh-ru
6b90: 6e 2d 69 6e 66 6f 0a 09 09 20 64 62 68 0a 09 09 n-info... dbh...
6ba0: 20 6e 65 77 2d 72 75 6e 2d 69 64 0a 09 09 20 73 new-run-id... s
6bb0: 74 61 74 65 20 73 74 61 74 75 73 20 6f 77 6e 65 tate status owne
6bc0: 72 20 65 76 65 6e 74 2d 74 69 6d 65 20 63 6f 6d r event-time com
6bd0: 6d 65 6e 74 20 66 61 69 6c 2d 63 6f 75 6e 74 20 ment fail-count
6be0: 70 61 73 73 2d 63 6f 75 6e 74 29 0a 09 09 6e 65 pass-count)...ne
6bf0: 77 2d 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 w-run-id)..
6c00: 20 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 78 63 (if (handle-exc
6c10: 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 eptions...
6c20: 65 78 6e 0a 09 09 20 20 20 20 20 20 28 62 65 67 exn... (beg
6c30: 69 6e 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 in (print-call-c
6c40: 68 61 69 6e 29 20 23 66 29 0a 09 09 20 20 20 20 hain) #f)...
6c50: 28 70 67 64 62 3a 69 6e 73 65 72 74 2d 72 75 6e (pgdb:insert-run
6c60: 0a 09 09 20 20 20 20 20 64 62 68 0a 09 09 20 20 ... dbh...
6c70: 20 20 20 73 70 65 63 2d 69 64 20 74 61 72 67 65 spec-id targe
6c80: 74 20 72 75 6e 2d 6e 61 6d 65 20 73 74 61 74 65 t run-name state
6c90: 20 73 74 61 74 75 73 20 6f 77 6e 65 72 20 65 76 status owner ev
6ca0: 65 6e 74 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 ent-time comment
6cb0: 20 66 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 fail-count pass
6cc0: 2d 63 6f 75 6e 74 29 29 20 3b 3b 20 61 72 65 61 -count)) ;; area
6cd0: 2d 69 64 29 29 0a 09 09 20 20 28 74 61 73 6b 73 -id))... (tasks
6ce0: 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 :run-id->mtpg-ru
6cf0: 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 2d n-id dbh cached-
6d00: 69 6e 66 6f 20 72 75 6e 2d 69 64 29 0a 09 09 20 info run-id)...
6d10: 20 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 69 #f))))))..(defi
6d20: 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 ne (tasks:sync-t
6d30: 65 73 74 73 2d 64 61 74 61 20 64 62 68 20 63 61 ests-data dbh ca
6d40: 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 69 ched-info test-i
6d50: 64 73 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 ds). (let ((tes
6d60: 74 2d 68 74 20 28 68 61 73 68 2d 74 61 62 6c 65 t-ht (hash-table
6d70: 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e 66 6f -ref cached-info
6d80: 20 27 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 'tests))). (
6d90: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
6da0: 61 6d 62 64 61 20 28 74 65 73 74 2d 69 64 29 0a ambda (test-id).
6db0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
6dc0: 65 73 74 2d 69 6e 66 6f 20 20 20 20 28 72 6d 74 est-info (rmt
6dd0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
6de0: 79 2d 69 64 20 23 66 20 74 65 73 74 2d 69 64 29 y-id #f test-id)
6df0: 29 0a 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 ).. (run-id
6e00: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
6e10: 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 20 74 65 get-run_id te
6e20: 73 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 6c 6f 6f st-info)) ;; loo
6e30: 6b 20 74 68 65 73 65 20 75 70 20 69 6e 20 64 62 k these up in db
6e40: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 0a 09 20 20 _records.scm..
6e50: 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 (test-id
6e60: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
6e70: 64 20 20 20 20 20 20 20 20 74 65 73 74 2d 69 6e d test-in
6e80: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 fo)).. (tes
6e90: 74 2d 6e 61 6d 65 20 20 20 20 28 64 62 3a 74 65 t-name (db:te
6ea0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
6eb0: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
6ec0: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 (item-path
6ed0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
6ee0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 69 6e tem-path test-in
6ef0: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 74 61 fo)).. (sta
6f00: 74 65 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 te (db:te
6f10: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 st-get-state
6f20: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
6f30: 20 20 20 20 28 73 74 61 74 75 73 20 20 20 20 20 (status
6f40: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
6f50: 74 61 74 75 73 20 20 20 20 74 65 73 74 2d 69 6e tatus test-in
6f60: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 68 6f 73 fo)).. (hos
6f70: 74 20 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 t (db:te
6f80: 73 74 2d 67 65 74 2d 68 6f 73 74 20 20 20 20 20 st-get-host
6f90: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
6fa0: 20 20 20 20 28 63 70 75 6c 6f 61 64 20 20 20 20 (cpuload
6fb0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 (db:test-get-c
6fc0: 70 75 6c 6f 61 64 20 20 20 74 65 73 74 2d 69 6e puload test-in
6fd0: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 64 69 73 fo)).. (dis
6fe0: 6b 66 72 65 65 20 20 20 20 20 28 64 62 3a 74 65 kfree (db:te
6ff0: 73 74 2d 67 65 74 2d 64 69 73 6b 66 72 65 65 20 st-get-diskfree
7000: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
7010: 20 20 20 20 28 75 6e 61 6d 65 20 20 20 20 20 20 (uname
7020: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 75 (db:test-get-u
7030: 6e 61 6d 65 20 20 20 20 20 74 65 73 74 2d 69 6e name test-in
7040: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 72 75 6e fo)).. (run
7050: 2d 64 69 72 20 20 20 20 20 20 28 64 62 3a 74 65 -dir (db:te
7060: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 20 20 st-get-rundir
7070: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
7080: 20 20 20 20 28 6c 6f 67 2d 66 69 6c 65 20 20 20 (log-file
7090: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 (db:test-get-f
70a0: 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 69 inal_logf test-i
70b0: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 72 75 nfo)).. (ru
70c0: 6e 2d 64 75 72 61 74 69 6f 6e 20 28 64 62 3a 74 n-duration (db:t
70d0: 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 est-get-run_dura
70e0: 74 69 6f 6e 20 74 65 73 74 2d 69 6e 66 6f 29 29 tion test-info))
70f0: 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e 74 .. (comment
7100: 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
7110: 65 74 2d 63 6f 6d 6d 65 6e 74 20 20 20 74 65 73 et-comment tes
7120: 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 t-info))..
7130: 28 65 76 65 6e 74 2d 74 69 6d 65 20 20 20 28 64 (event-time (d
7140: 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 b:test-get-event
7150: 5f 74 69 6d 65 20 74 65 73 74 2d 69 6e 66 6f 29 _time test-info)
7160: 29 0a 09 20 20 20 20 20 20 28 61 72 63 68 69 76 ).. (archiv
7170: 65 64 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d ed (db:test-
7180: 67 65 74 2d 61 72 63 68 69 76 65 64 20 20 74 65 get-archived te
7190: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
71a0: 20 28 70 67 64 62 2d 72 75 6e 2d 69 64 20 20 28 (pgdb-run-id (
71b0: 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 tasks:run-id->mt
71c0: 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 pg-run-id dbh ca
71d0: 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 ched-info run-id
71e0: 29 29 0a 09 20 20 20 20 20 20 28 70 67 64 62 2d )).. (pgdb-
71f0: 74 65 73 74 2d 69 64 20 28 70 67 64 62 3a 67 65 test-id (pgdb:ge
7200: 74 2d 74 65 73 74 2d 69 64 20 64 62 68 20 70 67 t-test-id dbh pg
7210: 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db-run-id test-n
7220: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
7230: 0a 09 20 3b 3b 20 22 69 64 22 20 20 20 20 20 20 .. ;; "id"
7240: 20 20 20 20 20 22 72 75 6e 5f 69 64 22 20 20 20 "run_id"
7250: 20 20 20 20 20 22 74 65 73 74 6e 61 6d 65 22 20 "testname"
7260: 20 22 73 74 61 74 65 22 20 20 20 20 20 20 22 73 "state" "s
7270: 74 61 74 75 73 22 20 20 20 20 20 20 22 65 76 65 tatus" "eve
7280: 6e 74 5f 74 69 6d 65 22 0a 09 20 3b 3b 20 22 68 nt_time".. ;; "h
7290: 6f 73 74 22 20 20 20 20 20 20 20 20 20 22 63 70 ost" "cp
72a0: 75 6c 6f 61 64 22 20 20 20 20 20 20 20 22 64 69 uload" "di
72b0: 73 6b 66 72 65 65 22 20 20 22 75 6e 61 6d 65 22 skfree" "uname"
72c0: 20 20 20 20 20 20 22 72 75 6e 64 69 72 22 20 20 "rundir"
72d0: 20 20 20 20 22 69 74 65 6d 5f 70 61 74 68 22 0a "item_path".
72e0: 09 20 3b 3b 20 22 72 75 6e 5f 64 75 72 61 74 69 . ;; "run_durati
72f0: 6f 6e 22 20 22 66 69 6e 61 6c 5f 6c 6f 67 66 22 on" "final_logf"
7300: 20 20 20 20 22 63 6f 6d 6d 65 6e 74 22 20 20 20 "comment"
7310: 22 73 68 6f 72 74 64 69 72 22 20 20 20 22 61 74 "shortdir" "at
7320: 74 65 6d 70 74 6e 75 6d 22 20 20 22 61 72 63 68 temptnum" "arch
7330: 69 76 65 64 22 0a 09 20 28 69 66 20 70 67 64 62 ived".. (if pgdb
7340: 2d 74 65 73 74 2d 69 64 20 3b 3b 20 68 61 76 65 -test-id ;; have
7350: 20 61 20 72 65 63 6f 72 64 0a 09 20 20 20 20 20 a record..
7360: 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 28 28 (begin ;; let ((
7370: 6b 65 79 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 72 key-name (conc r
7380: 75 6e 2d 69 64 20 22 2f 22 20 74 65 73 74 2d 6e un-id "/" test-n
7390: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
73a0: 68 29 29 29 0a 09 20 20 20 20 20 20 20 28 68 61 h))).. (ha
73b0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
73c0: 73 74 2d 68 74 20 74 65 73 74 2d 69 64 20 70 67 st-ht test-id pg
73d0: 64 62 2d 74 65 73 74 2d 69 64 29 0a 09 20 20 20 db-test-id)..
73e0: 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 (print "Upda
73f0: 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 74 65 ting existing te
7400: 73 74 20 77 69 74 68 20 72 75 6e 2d 69 64 3a 20 st with run-id:
7410: 22 20 72 75 6e 2d 69 64 20 22 20 61 6e 64 20 74 " run-id " and t
7420: 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 est-id: " test-i
7430: 64 29 0a 09 20 20 20 20 20 20 20 28 70 67 64 62 d).. (pgdb
7440: 3a 75 70 64 61 74 65 2d 74 65 73 74 20 64 62 68 :update-test dbh
7450: 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 70 67 pgdb-test-id pg
7460: 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db-run-id test-n
7470: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
7480: 61 74 65 20 73 74 61 74 75 73 20 68 6f 73 74 20 ate status host
7490: 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
74a0: 20 75 6e 61 6d 65 20 72 75 6e 2d 64 69 72 20 6c uname run-dir l
74b0: 6f 67 2d 66 69 6c 65 20 72 75 6e 2d 64 75 72 61 og-file run-dura
74c0: 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 20 65 76 65 tion comment eve
74d0: 6e 74 2d 74 69 6d 65 20 61 72 63 68 69 76 65 64 nt-time archived
74e0: 29 29 0a 09 20 20 20 20 20 28 70 67 64 62 3a 69 )).. (pgdb:i
74f0: 6e 73 65 72 74 2d 74 65 73 74 20 64 62 68 20 70 nsert-test dbh p
7500: 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d gdb-run-id test-
7510: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 name item-path s
7520: 74 61 74 65 20 73 74 61 74 75 73 20 68 6f 73 74 tate status host
7530: 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
7540: 65 20 75 6e 61 6d 65 20 72 75 6e 2d 64 69 72 20 e uname run-dir
7550: 6c 6f 67 2d 66 69 6c 65 20 72 75 6e 2d 64 75 72 log-file run-dur
7560: 61 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 20 65 76 ation comment ev
7570: 65 6e 74 2d 74 69 6d 65 20 61 72 63 68 69 76 65 ent-time archive
7580: 64 29 29 0a 09 20 29 29 0a 20 20 20 20 20 74 65 d)).. )). te
7590: 73 74 2d 69 64 73 29 29 29 0a 0a 3b 3b 20 67 65 st-ids)))..;; ge
75a0: 74 20 72 75 6e 73 20 63 68 61 6e 67 65 64 20 73 t runs changed s
75b0: 69 6e 63 65 20 6c 61 73 74 20 73 79 6e 63 0a 3b ince last sync.;
75c0: 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ; (define (tasks
75d0: 3a 73 79 6e 63 2d 74 65 73 74 2d 64 61 74 61 20 :sync-test-data
75e0: 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 dbh cached-info
75f0: 61 72 65 61 2d 69 6e 66 6f 29 0a 3b 3b 20 20 20 area-info).;;
7600: 28 6c 65 74 2a 20 28 28 0a 0a 28 64 65 66 69 6e (let* ((..(defin
7610: 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f e (tasks:sync-to
7620: 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 67 -postgres config
7630: 64 61 74 20 64 65 73 74 29 0a 20 20 28 6c 65 74 dat dest). (let
7640: 2a 20 28 28 64 62 68 20 20 20 20 20 20 20 20 20 * ((dbh
7650: 28 70 67 64 62 3a 6f 70 65 6e 20 63 6f 6e 66 69 (pgdb:open confi
7660: 67 64 61 74 20 64 62 6e 61 6d 65 3a 20 64 65 73 gdat dbname: des
7670: 74 29 29 0a 09 20 28 61 72 65 61 2d 69 6e 66 6f t)).. (area-info
7680: 20 20 20 28 70 67 64 62 3a 67 65 74 2d 61 72 65 (pgdb:get-are
7690: 61 2d 62 79 2d 70 61 74 68 20 64 62 68 20 2a 74 a-by-path dbh *t
76a0: 6f 70 70 61 74 68 2a 29 29 0a 09 20 28 63 61 63 oppath*)).. (cac
76b0: 68 65 64 2d 69 6e 66 6f 20 28 6d 61 6b 65 2d 68 hed-info (make-h
76c0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 73 ash-table)).. (s
76d0: 74 61 72 74 20 20 20 20 20 20 20 28 63 75 72 72 tart (curr
76e0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 ent-seconds))).
76f0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
7700: 6d 62 64 61 20 28 64 74 79 70 65 29 0a 09 09 28 mbda (dtype)...(
7710: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
7720: 63 61 63 68 65 64 2d 69 6e 66 6f 20 64 74 79 70 cached-info dtyp
7730: 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 e (make-hash-tab
7740: 6c 65 29 29 29 0a 09 20 20 20 20 20 20 27 28 72 le))).. '(r
7750: 75 6e 73 20 74 61 72 67 65 74 73 20 74 65 73 74 uns targets test
7760: 73 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 s)). (hash-ta
7770: 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 64 2d ble-set! cached-
7780: 69 6e 66 6f 20 27 73 74 61 72 74 20 73 74 61 72 info 'start star
7790: 74 29 20 3b 3b 20 77 68 65 6e 20 64 6f 6e 65 20 t) ;; when done
77a0: 77 65 27 6c 6c 20 73 65 74 20 73 79 6e 63 20 74 we'll set sync t
77b0: 69 6d 65 73 20 74 6f 20 74 68 69 73 0a 20 20 20 imes to this.
77c0: 20 28 69 66 20 61 72 65 61 2d 69 6e 66 6f 0a 09 (if area-info..
77d0: 28 6c 65 74 2a 20 28 28 6c 61 73 74 2d 73 79 6e (let* ((last-syn
77e0: 63 2d 74 69 6d 65 20 28 76 65 63 74 6f 72 2d 72 c-time (vector-r
77f0: 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 33 29 29 ef area-info 3))
7800: 0a 09 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 .. (change
7810: 64 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 d (rmt:ge
7820: 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 t-changed-record
7830: 2d 69 64 73 20 6c 61 73 74 2d 73 79 6e 63 2d 74 -ids last-sync-t
7840: 69 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 72 ime)).. (r
7850: 75 6e 2d 69 64 73 20 20 20 20 20 20 20 20 28 61 un-ids (a
7860: 6c 69 73 74 2d 72 65 66 20 27 72 75 6e 73 20 20 list-ref 'runs
7870: 20 20 20 20 20 63 68 61 6e 67 65 64 29 29 0a 09 changed))..
7880: 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 73 (test-ids
7890: 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 (alist-re
78a0: 66 20 27 74 65 73 74 73 20 20 20 20 20 20 63 68 f 'tests ch
78b0: 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 20 20 anged))..
78c0: 28 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 20 (test-step-ids
78d0: 28 61 6c 69 73 74 2d 72 65 66 20 27 74 65 73 74 (alist-ref 'test
78e0: 5f 73 74 65 70 73 20 63 68 61 6e 67 65 64 29 29 _steps changed))
78f0: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 .. (test-d
7900: 61 74 61 2d 69 64 73 20 20 28 61 6c 69 73 74 2d ata-ids (alist-
7910: 72 65 66 20 27 74 65 73 74 5f 64 61 74 61 20 20 ref 'test_data
7920: 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 changed))..
7930: 20 20 28 72 75 6e 2d 73 74 61 74 2d 69 64 73 20 (run-stat-ids
7940: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 (alist-ref 'ru
7950: 6e 5f 73 74 61 74 73 20 20 63 68 61 6e 67 65 64 n_stats changed
7960: 29 29 29 0a 09 20 20 28 70 72 69 6e 74 20 22 61 ))).. (print "a
7970: 72 65 61 2d 69 6e 66 6f 3a 20 22 20 61 72 65 61 rea-info: " area
7980: 2d 69 6e 66 6f 29 0a 09 20 20 28 69 66 20 28 6e -info).. (if (n
7990: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 69 ot (null? test-i
79a0: 64 73 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 ds)).. (beg
79b0: 69 6e 0a 09 09 28 70 72 69 6e 74 20 22 53 79 6e in...(print "Syn
79c0: 63 69 6e 67 20 22 20 28 6c 65 6e 67 74 68 20 74 cing " (length t
79d0: 65 73 74 2d 69 64 73 29 20 22 20 63 68 61 6e 67 est-ids) " chang
79e0: 65 64 20 74 65 73 74 73 22 29 0a 09 09 28 74 61 ed tests")...(ta
79f0: 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 73 2d 64 sks:sync-tests-d
7a00: 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d 69 ata dbh cached-i
7a10: 6e 66 6f 20 74 65 73 74 2d 69 64 73 29 29 29 0a nfo test-ids))).
7a20: 09 20 20 28 70 67 64 62 3a 77 72 69 74 65 2d 73 . (pgdb:write-s
7a30: 79 6e 63 2d 74 69 6d 65 20 64 62 68 20 61 72 65 ync-time dbh are
7a40: 61 2d 69 6e 66 6f 20 73 74 61 72 74 29 29 0a 09 a-info start))..
7a50: 28 69 66 20 28 74 61 73 6b 73 3a 73 65 74 2d 61 (if (tasks:set-a
7a60: 72 65 61 20 64 62 68 20 63 6f 6e 66 69 67 64 61 rea dbh configda
7a70: 74 29 0a 09 20 20 20 20 28 74 61 73 6b 73 3a 73 t).. (tasks:s
7a80: 79 6e 63 2d 74 6f 2d 70 6f 73 74 67 72 65 73 20 ync-to-postgres
7a90: 63 6f 6e 66 69 67 64 61 74 20 64 65 73 74 29 0a configdat dest).
7aa0: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
7ab0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7ac0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7ad0: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 75 6e 61 ort* "ERROR: una
7ae0: 62 6c 65 20 74 6f 20 63 72 65 61 74 65 20 61 6e ble to create an
7af0: 20 61 72 65 61 20 72 65 63 6f 72 64 22 29 0a 09 area record")..
7b00: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a #f)))))..