0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 72 6d 74 6d 6f 64 29 29 0a 0a 28 unit rmtmod))..(
03a0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 61 70 declare (uses ap
03b0: 69 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 imod)).(declare
03c0: 28 75 73 65 73 20 63 6c 69 65 6e 74 6d 6f 64 29 (uses clientmod)
03d0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03e0: 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 64 65 commonmod)).(de
03f0: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 clare (uses conf
0400: 69 67 66 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 igfmod)).(declar
0410: 65 20 28 75 73 65 73 20 64 62 6d 6f 64 29 29 0a e (uses dbmod)).
0420: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
0430: 65 62 75 67 70 72 69 6e 74 29 29 0a 28 64 65 63 ebugprint)).(dec
0440: 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 lare (uses items
0450: 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mod)).(declare (
0460: 75 73 65 73 20 6d 74 61 72 67 73 29 29 0a 28 64 uses mtargs)).(d
0470: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 76 eclare (uses mtv
0480: 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 er)).(declare (u
0490: 73 65 73 20 70 67 64 62 29 29 0a 28 64 65 63 6c ses pgdb)).(decl
04a0: 61 72 65 20 28 75 73 65 73 20 70 6f 72 74 6c 6f are (uses portlo
04b0: 67 67 65 72 6d 6f 64 29 29 0a 28 64 65 63 6c 61 ggermod)).(decla
04c0: 72 65 20 28 75 73 65 73 20 73 65 72 76 65 72 6d re (uses serverm
04d0: 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 od)).(declare (u
04e0: 73 65 73 20 74 61 73 6b 73 6d 6f 64 29 29 0a 0a ses tasksmod))..
04f0: 28 6d 6f 64 75 6c 65 20 72 6d 74 6d 6f 64 0a 09 (module rmtmod..
0500: 2a 0a 09 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 *...(import sche
0510: 6d 65 0a 09 09 0a 09 63 68 69 63 6b 65 6e 2e 62 me.....chicken.b
0520: 61 73 65 0a 09 63 68 69 63 6b 65 6e 2e 63 6f 6e ase..chicken.con
0530: 64 69 74 69 6f 6e 0a 09 63 68 69 63 6b 65 6e 2e dition..chicken.
0540: 66 69 6c 65 0a 09 63 68 69 63 6b 65 6e 2e 66 69 file..chicken.fi
0550: 6c 65 2e 70 6f 73 69 78 0a 09 63 68 69 63 6b 65 le.posix..chicke
0560: 6e 2e 66 6f 72 6d 61 74 0a 09 63 68 69 63 6b 65 n.format..chicke
0570: 6e 2e 69 6f 0a 09 63 68 69 63 6b 65 6e 2e 70 61 n.io..chicken.pa
0580: 74 68 6e 61 6d 65 0a 09 63 68 69 63 6b 65 6e 2e thname..chicken.
0590: 70 6f 72 74 0a 09 63 68 69 63 6b 65 6e 2e 70 72 port..chicken.pr
05a0: 65 74 74 79 2d 70 72 69 6e 74 0a 09 63 68 69 63 etty-print..chic
05b0: 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 63 68 69 ken.process..chi
05c0: 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 6f 6e cken.process-con
05d0: 74 65 78 74 0a 09 63 68 69 63 6b 65 6e 2e 70 72 text..chicken.pr
05e0: 6f 63 65 73 73 2d 63 6f 6e 74 65 78 74 2e 70 6f ocess-context.po
05f0: 73 69 78 0a 09 63 68 69 63 6b 65 6e 2e 73 6f 72 six..chicken.sor
0600: 74 0a 09 63 68 69 63 6b 65 6e 2e 73 74 72 69 6e t..chicken.strin
0610: 67 0a 09 63 68 69 63 6b 65 6e 2e 74 63 70 09 63 g..chicken.tcp.c
0620: 68 69 63 6b 65 6e 2e 72 61 6e 64 6f 6d 0a 09 63 hicken.random..c
0630: 68 69 63 6b 65 6e 2e 74 69 6d 65 0a 09 63 68 69 hicken.time..chi
0640: 63 6b 65 6e 2e 74 69 6d 65 2e 70 6f 73 69 78 0a cken.time.posix.
0650: 09 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 .(prefix sqlite3
0660: 20 73 71 6c 69 74 65 33 3a 29 0a 09 0a 09 64 69 sqlite3:)....di
0670: 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 0a 09 3b rectory-utils..;
0680: 3b 20 68 74 74 70 2d 63 6c 69 65 6e 74 0a 09 3b ; http-client..;
0690: 3b 20 69 6e 74 61 72 77 65 62 0a 09 6d 61 74 63 ; intarweb..matc
06a0: 68 61 62 6c 65 0a 09 6d 64 35 0a 09 6d 65 73 73 hable..md5..mess
06b0: 61 67 65 2d 64 69 67 65 73 74 0a 09 28 70 72 65 age-digest..(pre
06c0: 66 69 78 20 62 61 73 65 36 34 20 62 61 73 65 36 fix base64 base6
06d0: 34 3a 29 0a 09 28 70 72 65 66 69 78 20 73 71 6c 4:)..(prefix sql
06e0: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 ite3 sqlite3:)..
06f0: 72 65 67 65 78 0a 09 73 31 31 6e 0a 09 3b 3b 20 regex..s11n..;;
0700: 73 70 69 66 66 79 0a 09 3b 3b 20 73 70 69 66 66 spiffy..;; spiff
0710: 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 y-directory-list
0720: 69 6e 67 0a 09 3b 3b 20 73 70 69 66 66 79 2d 72 ing..;; spiffy-r
0730: 65 71 75 65 73 74 2d 76 61 72 73 0a 09 73 72 66 equest-vars..srf
0740: 69 2d 31 0a 09 73 72 66 69 2d 31 33 0a 09 73 72 i-1..srfi-13..sr
0750: 66 69 2d 31 38 0a 09 73 72 66 69 2d 36 39 0a 09 fi-18..srfi-69..
0760: 73 74 61 63 6b 0a 09 73 79 73 74 65 6d 2d 69 6e stack..system-in
0770: 66 6f 72 6d 61 74 69 6f 6e 0a 09 74 63 70 36 0a formation..tcp6.
0780: 09 74 79 70 65 64 2d 72 65 63 6f 72 64 73 0a 09 .typed-records..
0790: 75 72 69 2d 63 6f 6d 6d 6f 6e 0a 09 7a 33 0a 20 uri-common..z3.
07a0: 20 20 20 20 20 20 0a 09 61 70 69 6d 6f 64 0a 09 ..apimod..
07b0: 63 6c 69 65 6e 74 6d 6f 64 0a 09 63 6f 6d 6d 6f clientmod..commo
07c0: 6e 6d 6f 64 0a 09 63 6f 6e 66 69 67 66 6d 6f 64 nmod..configfmod
07d0: 0a 09 64 62 6d 6f 64 0a 09 64 65 62 75 67 70 72 ..dbmod..debugpr
07e0: 69 6e 74 0a 09 69 74 65 6d 73 6d 6f 64 0a 09 6d int..itemsmod..m
07f0: 74 76 65 72 0a 09 70 67 64 62 0a 09 70 6b 74 73 tver..pgdb..pkts
0800: 0a 09 70 6f 72 74 6c 6f 67 67 65 72 6d 6f 64 0a ..portloggermod.
0810: 09 28 70 72 65 66 69 78 20 6d 74 61 72 67 73 20 .(prefix mtargs
0820: 61 72 67 73 3a 29 0a 09 73 65 72 76 65 72 6d 6f args:)..servermo
0830: 64 0a 09 73 74 6d 6c 32 0a 09 74 61 73 6b 73 6d d..stml2..tasksm
0840: 6f 64 0a 09 29 0a 0a 28 64 65 66 73 74 72 75 63 od..)..(defstruc
0850: 74 20 61 6c 6c 64 61 74 0a 20 20 28 61 72 65 61 t alldat. (area
0860: 70 61 74 68 20 23 66 29 0a 20 20 28 75 6c 65 78 path #f). (ulex
0870: 64 61 74 20 20 23 66 29 0a 20 20 29 0a 0a 0a 3b dat #f). )...;
0880: 3b 20 28 72 65 71 75 69 72 65 2d 65 78 74 65 6e ; (require-exten
0890: 73 69 6f 6e 20 28 73 72 66 69 20 31 38 29 20 65 sion (srfi 18) e
08a0: 78 74 72 61 73 20 74 63 70 20 73 31 31 6e 29 0a xtras tcp s11n).
08b0: 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 75 73 65 20 ;; .;; .;; (use
08c0: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
08d0: 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 gex regex-case s
08e0: 72 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 rfi-69 hostinfo
08f0: 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 md5 message-dige
0900: 73 74 20 70 6f 73 69 78 2d 65 78 74 72 61 73 29 st posix-extras)
0910: 0a 3b 3b 20 0a 3b 3b 20 28 75 73 65 20 73 70 69 .;; .;; (use spi
0920: 66 66 79 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 ffy uri-common i
0930: 6e 74 61 72 77 65 62 20 68 74 74 70 2d 63 6c 69 ntarweb http-cli
0940: 65 6e 74 20 73 70 69 66 66 79 2d 72 65 71 75 65 ent spiffy-reque
0950: 73 74 2d 76 61 72 73 20 69 6e 74 61 72 77 65 62 st-vars intarweb
0960: 20 73 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 spiffy-director
0970: 79 2d 6c 69 73 74 69 6e 67 29 0a 3b 3b 20 0a 3b y-listing).;; .;
0980: 3b 20 43 6f 6e 66 69 67 75 72 61 74 69 6f 6e 73 ; Configurations
0990: 20 66 6f 72 20 73 65 72 76 65 72 0a 3b 3b 20 28 for server.;; (
09a0: 74 63 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 tcp-buffer-size
09b0: 32 30 34 38 29 0a 3b 3b 20 28 6d 61 78 2d 63 6f 2048).;; (max-co
09c0: 6e 6e 65 63 74 69 6f 6e 73 20 32 30 34 38 29 20 nnections 2048)
09d0: 0a 0a 3b 3b 20 69 6e 66 6f 20 61 62 6f 75 74 20 ..;; info about
09e0: 6d 65 20 61 73 20 61 20 73 65 72 76 65 72 0a 3b me as a server.;
09f0: 3b 0a 28 64 65 66 73 74 72 75 63 74 20 73 65 72 ;.(defstruct ser
0a00: 76 64 61 74 0a 20 20 28 68 6f 73 74 20 23 66 29 vdat. (host #f)
0a10: 0a 20 20 28 70 6f 72 74 20 23 66 29 0a 20 20 28 . (port #f). (
0a20: 75 75 69 64 20 23 66 29 0a 20 20 28 64 62 66 69 uuid #f). (dbfi
0a30: 6c 65 20 23 66 29 0a 20 20 28 61 70 69 2d 75 72 le #f). (api-ur
0a40: 6c 20 23 66 29 0a 20 20 28 61 70 69 2d 75 72 69 l #f). (api-uri
0a50: 20 23 66 29 0a 20 20 28 61 70 69 2d 72 65 71 20 #f). (api-req
0a60: 23 66 29 0a 20 20 28 73 74 61 74 75 73 20 27 73 #f). (status 's
0a70: 74 61 72 74 69 6e 67 29 0a 20 20 28 74 72 79 6e tarting). (tryn
0a80: 75 6d 20 30 29 20 3b 3b 20 63 6f 75 6e 74 20 74 um 0) ;; count t
0a90: 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 70 6f 72 he number of por
0aa0: 74 73 20 77 65 27 76 65 20 74 72 69 65 64 0a 20 ts we've tried.
0ab0: 20 29 20 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ) ..(define (se
0ac0: 72 76 64 61 74 2d 3e 75 72 6c 20 73 64 61 74 29 rvdat->url sdat)
0ad0: 0a 20 20 28 63 6f 6e 63 20 28 73 65 72 76 64 61 . (conc (servda
0ae0: 74 2d 68 6f 73 74 20 73 64 61 74 29 22 3a 22 28 t-host sdat)":"(
0af0: 73 65 72 76 64 61 74 2d 70 6f 72 74 20 73 64 61 servdat-port sda
0b00: 74 29 29 29 0a 0a 0a 3b 3b 20 67 65 6e 65 72 61 t)))...;; genera
0b10: 74 65 20 65 6e 74 72 69 65 73 20 66 6f 72 20 7e te entries for ~
0b20: 2f 2e 6d 65 67 61 74 65 73 74 72 63 20 77 69 74 /.megatestrc wit
0b30: 68 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a h the following.
0b40: 3b 3b 0a 3b 3b 20 20 67 72 65 70 20 64 65 66 69 ;;.;; grep defi
0b50: 6e 65 20 2e 2e 2f 72 6d 74 2e 73 63 6d 20 7c 20 ne ../rmt.scm |
0b60: 67 72 65 70 20 72 6d 74 3a 20 7c 70 65 72 6c 20 grep rmt: |perl
0b70: 2d 70 69 20 2d 65 20 27 73 2f 5c 28 64 65 66 69 -pi -e 's/\(defi
0b80: 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 5c 57 2e 2a ne\s+\((\S+)\W.*
0b90: 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 2d 75 0a 0a $/\1/'|sort -u..
0ba0: 28 64 65 66 73 74 72 75 63 74 20 72 6d 74 3a 72 (defstruct rmt:r
0bb0: 65 6d 6f 74 65 0a 20 20 28 63 6f 6e 6e 73 20 28 emote. (conns (
0bc0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0bd0: 29 20 3b 3b 20 61 70 61 74 68 2f 64 62 6e 61 6d ) ;; apath/dbnam
0be0: 65 20 3d 3e 20 72 6d 74 3a 63 6f 6e 6e 0a 20 20 e => rmt:conn.
0bf0: 29 0a 0a 28 64 65 66 73 74 72 75 63 74 20 72 6d )..(defstruct rm
0c00: 74 3a 63 6f 6e 6e 0a 20 20 28 61 70 61 74 68 20 t:conn. (apath
0c10: 20 20 20 23 66 29 0a 20 20 28 64 62 6e 61 6d 65 #f). (dbname
0c20: 20 20 20 23 66 29 0a 20 20 28 66 75 6c 6c 6e 61 #f). (fullna
0c30: 6d 65 20 23 66 29 0a 20 20 28 68 6f 73 74 70 6f me #f). (hostpo
0c40: 72 74 20 23 66 29 0a 20 20 28 69 70 61 64 64 72 rt #f). (ipaddr
0c50: 20 20 20 23 66 29 0a 20 20 28 70 6f 72 74 20 20 #f). (port
0c60: 20 20 20 23 66 29 0a 20 20 28 73 72 76 70 6b 74 #f). (srvpkt
0c70: 20 20 20 23 66 29 0a 20 20 28 6c 61 73 74 6d 73 #f). (lastms
0c80: 67 20 20 30 29 0a 20 20 28 65 78 70 69 72 65 73 g 0). (expires
0c90: 20 20 30 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 0))..;;=======
0ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0ce0: 3b 3b 20 20 53 20 55 20 50 20 50 20 4f 20 52 20 ;; S U P P O R
0cf0: 54 20 20 20 46 20 55 20 4e 20 43 20 54 20 49 20 T F U N C T I
0d00: 4f 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d O N S.;;========
0d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0d50: 3b 3b 20 72 65 70 6c 61 63 65 73 20 2a 72 75 6e ;; replaces *run
0d60: 72 65 6d 6f 74 65 2a 0a 28 64 65 66 69 6e 65 20 remote*.(define
0d70: 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 28 6d 61 *rmt:remote* (ma
0d80: 6b 65 2d 72 6d 74 3a 72 65 6d 6f 74 65 29 29 0a ke-rmt:remote)).
0d90: 0a 3b 3b 20 2d 3e 20 68 74 74 70 3a 2f 2f 61 62 .;; -> http://ab
0da0: 63 2e 63 6f 6d 3a 39 30 30 2f 3c 65 6e 74 72 79 c.com:900/<entry
0db0: 70 6f 69 6e 74 3e 0a 3b 3b 0a 28 64 65 66 69 6e point>.;;.(defin
0dc0: 65 20 28 72 6d 74 3a 63 6f 6e 6e 2d 3e 75 72 69 e (rmt:conn->uri
0dd0: 20 63 6f 6e 6e 20 65 6e 74 72 79 70 6f 69 6e 74 conn entrypoint
0de0: 29 0a 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a ). (conc "http:
0df0: 2f 2f 22 28 72 6d 74 3a 63 6f 6e 6e 2d 69 70 61 //"(rmt:conn-ipa
0e00: 64 64 72 20 63 6f 6e 6e 29 22 3a 22 28 72 6d 74 ddr conn)":"(rmt
0e10: 3a 63 6f 6e 6e 2d 70 6f 72 74 20 63 6f 6e 6e 29 :conn-port conn)
0e20: 22 2f 22 65 6e 74 72 79 70 6f 69 6e 74 29 29 0a "/"entrypoint)).
0e30: 0a 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 61 .;; set up the a
0e40: 70 69 20 70 72 6f 63 2c 20 73 65 65 6d 73 20 6c pi proc, seems l
0e50: 69 6b 65 20 74 68 65 72 65 20 73 68 6f 75 6c 64 ike there should
0e60: 20 62 65 20 61 20 62 65 74 74 65 72 20 70 6c 61 be a better pla
0e70: 63 65 20 66 6f 72 20 74 68 69 73 3f 0a 28 64 65 ce for this?.(de
0e80: 66 69 6e 65 20 61 70 69 2d 70 72 6f 63 20 28 6d fine api-proc (m
0e90: 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 20 63 6f ake-parameter co
0ea0: 6e 63 29 29 0a 28 61 70 69 2d 70 72 6f 63 20 61 nc)).(api-proc a
0eb0: 70 69 3a 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi:process-reque
0ec0: 73 74 29 0a 0a 3b 3b 20 64 6f 20 77 65 20 68 61 st)..;; do we ha
0ed0: 76 65 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 ve a connection
0ee0: 74 6f 20 61 70 61 74 68 20 64 62 6e 61 6d 65 20 to apath dbname
0ef0: 61 6e 64 0a 3b 3b 20 69 73 20 69 74 20 6e 6f 74 and.;; is it not
0f00: 20 65 78 70 69 72 65 64 3f 20 74 68 65 6e 20 72 expired? then r
0f10: 65 74 75 72 6e 20 69 74 0a 3b 3b 0a 3b 3b 20 65 eturn it.;;.;; e
0f20: 6c 73 65 20 73 65 74 75 70 20 61 20 63 6f 6e 6e lse setup a conn
0f30: 65 63 74 69 6f 6e 0a 3b 3b 0a 3b 3b 20 69 66 20 ection.;;.;; if
0f40: 74 68 61 74 20 66 61 69 6c 73 2c 20 72 65 74 75 that fails, retu
0f50: 72 6e 20 27 28 23 66 20 22 73 6f 6d 65 20 72 65 rn '(#f "some re
0f60: 61 73 6f 6e 22 29 20 3b 3b 20 4e 42 2f 2f 20 63 ason") ;; NB// c
0f70: 6f 6e 76 65 72 74 20 74 6f 20 72 61 69 73 69 6e onvert to raisin
0f80: 67 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 0a 3b g an exception.;
0f90: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ;.(define (rmt:g
0fa0: 65 74 2d 63 6f 6e 6e 20 72 65 6d 6f 74 65 20 61 et-conn remote a
0fb0: 70 61 74 68 20 64 62 6e 61 6d 65 29 0a 20 20 28 path dbname). (
0fc0: 6c 65 74 2a 20 28 28 66 75 6c 6c 6e 61 6d 65 20 let* ((fullname
0fd0: 28 64 62 3a 64 62 6e 61 6d 65 2d 3e 70 61 74 68 (db:dbname->path
0fe0: 20 61 70 61 74 68 20 64 62 6e 61 6d 65 29 29 20 apath dbname))
0ff0: 3b 3b 20 77 65 27 6c 6c 20 73 77 69 74 63 68 20 ;; we'll switch
1000: 74 6f 20 66 75 6c 6c 20 6e 61 6d 65 20 6c 61 74 to full name lat
1010: 65 72 0a 09 20 28 63 6f 6e 6e 20 20 20 20 20 28 er.. (conn (
1020: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1030: 65 66 61 75 6c 74 20 28 72 6d 74 3a 72 65 6d 6f efault (rmt:remo
1040: 74 65 2d 63 6f 6e 6e 73 20 72 65 6d 6f 74 65 29 te-conns remote)
1050: 20 64 62 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 dbname #f))).
1060: 20 20 28 69 66 20 28 61 6e 64 20 63 6f 6e 6e 0a (if (and conn.
1070: 09 20 20 20 20 20 28 3c 20 28 63 75 72 72 65 6e . (< (curren
1080: 74 2d 73 65 63 6f 6e 64 73 29 20 28 72 6d 74 3a t-seconds) (rmt:
1090: 63 6f 6e 6e 2d 65 78 70 69 72 65 73 20 63 6f 6e conn-expires con
10a0: 6e 29 29 29 0a 09 63 6f 6e 6e 0a 09 23 66 29 29 n)))..conn..#f))
10b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
10c0: 66 69 6e 64 2d 6d 61 69 6e 2d 73 65 72 76 65 72 find-main-server
10d0: 20 61 70 61 74 68 20 64 62 6e 61 6d 65 29 0a 20 apath dbname).
10e0: 20 28 6c 65 74 2a 20 28 28 70 6b 74 73 64 69 72 (let* ((pktsdir
10f0: 20 20 20 20 20 28 67 65 74 2d 70 6b 74 73 2d 64 (get-pkts-d
1100: 69 72 20 61 70 61 74 68 29 29 0a 09 20 28 61 6c ir apath)).. (al
1110: 6c 2d 73 72 76 70 6b 74 73 20 28 67 65 74 2d 61 l-srvpkts (get-a
1120: 6c 6c 2d 73 65 72 76 65 72 2d 70 6b 74 73 20 70 ll-server-pkts p
1130: 6b 74 73 64 69 72 20 2a 73 72 76 70 6b 74 73 70 ktsdir *srvpktsp
1140: 65 63 2a 29 29 0a 09 20 3b 3b 20 28 64 62 70 61 ec*)).. ;; (dbpa
1150: 74 68 20 20 20 20 20 20 28 63 6f 6e 63 20 61 70 th (conc ap
1160: 61 74 68 20 22 2f 22 20 64 62 6e 61 6d 65 29 29 ath "/" dbname))
1170: 0a 09 20 28 76 69 61 62 6c 65 2d 73 72 76 73 20 .. (viable-srvs
1180: 28 67 65 74 2d 76 69 61 62 6c 65 2d 73 65 72 76 (get-viable-serv
1190: 65 72 73 20 61 6c 6c 2d 73 72 76 70 6b 74 73 20 ers all-srvpkts
11a0: 64 62 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 67 dbname))). (g
11b0: 65 74 2d 74 68 65 2d 73 65 72 76 65 72 20 61 70 et-the-server ap
11c0: 61 74 68 20 76 69 61 62 6c 65 2d 73 72 76 73 29 ath viable-srvs)
11d0: 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 73 20 66 6f 72 ))..;; looks for
11e0: 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f a connection to
11f0: 20 6d 61 69 6e 0a 3b 3b 20 63 6f 6e 6e 65 63 74 main.;; connect
1200: 69 6f 6e 73 20 66 6f 72 20 6f 74 68 65 72 20 73 ions for other s
1210: 65 72 76 65 72 73 20 68 61 70 70 65 6e 73 20 62 ervers happens b
1220: 79 20 72 65 71 75 65 73 74 69 6e 67 20 66 72 6f y requesting fro
1230: 6d 20 6d 61 69 6e 0a 3b 3b 0a 3b 3b 20 54 4f 44 m main.;;.;; TOD
1240: 4f 3a 20 54 68 69 73 20 69 73 20 75 6e 6e 65 63 O: This is unnec
1250: 65 73 73 61 72 69 6c 79 20 72 65 2d 63 72 65 61 essarily re-crea
1260: 74 69 6e 67 20 74 68 65 20 72 65 63 6f 72 64 20 ting the record
1270: 69 6e 20 74 68 65 20 68 61 73 68 20 74 61 62 6c in the hash tabl
1280: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d e.;;.(define (rm
1290: 74 3a 6f 70 65 6e 2d 6d 61 69 6e 2d 63 6f 6e 6e t:open-main-conn
12a0: 65 63 74 69 6f 6e 20 72 65 6d 6f 74 65 20 61 70 ection remote ap
12b0: 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ath). (let* ((d
12c0: 62 6e 61 6d 65 20 20 20 20 20 20 20 20 20 28 64 bname (d
12d0: 62 3a 72 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 b:run-id->dbname
12e0: 20 23 66 29 29 0a 09 20 28 74 68 65 2d 73 72 76 #f)).. (the-srv
12f0: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e (rmt:fin
1300: 64 2d 6d 61 69 6e 2d 73 65 72 76 65 72 20 61 70 d-main-server ap
1310: 61 74 68 20 64 62 6e 61 6d 65 29 29 0a 09 20 28 ath dbname)).. (
1320: 73 74 61 72 74 2d 6d 61 69 6e 2d 73 72 76 20 28 start-main-srv (
1330: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
1340: 3b 3b 20 73 72 76 20 6e 6f 74 20 72 65 61 64 79 ;; srv not ready
1350: 2c 20 64 65 6c 61 79 20 61 20 6c 69 74 74 6c 65 , delay a little
1360: 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a 09 and try again..
1370: 09 09 20 20 20 28 61 70 69 3a 72 75 6e 2d 73 65 .. (api:run-se
1380: 72 76 65 72 2d 70 72 6f 63 65 73 73 20 61 70 61 rver-process apa
1390: 74 68 20 64 62 6e 61 6d 65 29 0a 09 09 09 20 20 th dbname)....
13a0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
13b0: 34 29 0a 09 09 09 20 20 20 28 72 6d 74 3a 6f 70 4).... (rmt:op
13c0: 65 6e 2d 6d 61 69 6e 2d 63 6f 6e 6e 65 63 74 69 en-main-connecti
13d0: 6f 6e 20 72 65 6d 6f 74 65 20 61 70 61 74 68 29 on remote apath)
13e0: 20 3b 3b 20 54 4f 44 4f 3a 20 41 64 64 20 6c 69 ;; TODO: Add li
13f0: 6d 69 74 20 74 6f 20 6e 75 6d 62 65 72 20 6f 66 mit to number of
1400: 20 74 72 69 65 73 0a 09 09 09 20 20 20 29 29 29 tries.... )))
1410: 0a 20 20 20 20 28 69 66 20 74 68 65 2d 73 72 76 . (if the-srv
1420: 20 3b 3b 20 79 65 73 2c 20 77 65 20 68 61 76 65 ;; yes, we have
1430: 20 61 20 73 65 72 76 65 72 2c 20 6e 6f 77 20 74 a server, now t
1440: 72 79 20 63 6f 6e 6e 65 63 74 69 6e 67 20 74 6f ry connecting to
1450: 20 69 74 0a 09 28 6c 65 74 2a 20 28 28 73 72 76 it..(let* ((srv
1460: 2d 61 64 64 72 20 28 73 65 72 76 65 72 2d 61 64 -addr (server-ad
1470: 64 72 65 73 73 20 74 68 65 2d 73 72 76 29 29 0a dress the-srv)).
1480: 09 20 20 20 20 20 20 20 28 69 70 61 64 64 72 20 . (ipaddr
1490: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 69 70 (alist-ref 'ip
14a0: 61 64 64 72 20 74 68 65 2d 73 72 76 29 29 0a 09 addr the-srv))..
14b0: 20 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 (port
14c0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 (alist-ref 'por
14d0: 74 20 20 20 74 68 65 2d 73 72 76 29 29 0a 09 20 t the-srv))..
14e0: 20 20 20 20 20 20 28 66 75 6c 6c 70 61 74 68 20 (fullpath
14f0: 28 64 62 3a 64 62 6e 61 6d 65 2d 3e 70 61 74 68 (db:dbname->path
1500: 20 61 70 61 74 68 20 64 62 6e 61 6d 65 29 29 0a apath dbname)).
1510: 09 20 20 20 20 20 20 20 28 73 72 76 72 65 61 64 . (srvread
1520: 79 20 28 73 65 72 76 65 72 2d 72 65 61 64 79 3f y (server-ready?
1530: 20 69 70 61 64 64 72 20 70 6f 72 74 20 66 75 6c ipaddr port ful
1540: 6c 70 61 74 68 29 29 29 0a 09 20 20 28 69 66 20 lpath))).. (if
1550: 73 72 76 72 65 61 64 79 0a 09 20 20 20 20 20 20 srvready..
1560: 28 62 65 67 69 6e 0a 09 09 28 68 61 73 68 2d 74 (begin...(hash-t
1570: 61 62 6c 65 2d 73 65 74 21 20 28 72 6d 74 3a 72 able-set! (rmt:r
1580: 65 6d 6f 74 65 2d 63 6f 6e 6e 73 20 72 65 6d 6f emote-conns remo
1590: 74 65 29 0a 09 09 09 09 20 64 62 6e 61 6d 65 20 te)..... dbname
15a0: 3b 3b 20 66 75 6c 6c 70 61 74 68 20 3b 3b 20 79 ;; fullpath ;; y
15b0: 65 73 2c 20 49 27 64 20 70 72 65 66 65 72 20 69 es, I'd prefer i
15c0: 74 20 74 6f 20 62 65 20 66 75 6c 6c 70 61 74 68 t to be fullpath
15d0: 20 2d 20 46 49 58 4d 45 20 6c 61 74 65 72 0a 09 - FIXME later..
15e0: 09 09 09 20 28 6d 61 6b 65 2d 72 6d 74 3a 63 6f ... (make-rmt:co
15f0: 6e 6e 0a 09 09 09 09 20 20 61 70 61 74 68 3a 20 nn..... apath:
1600: 20 20 61 70 61 74 68 0a 09 09 09 09 20 20 64 62 apath..... db
1610: 6e 61 6d 65 3a 20 20 64 62 6e 61 6d 65 0a 09 09 name: dbname...
1620: 09 09 20 20 66 75 6c 6c 6e 61 6d 65 3a 20 66 75 .. fullname: fu
1630: 6c 6c 70 61 74 68 0a 09 09 09 09 20 20 68 6f 73 llpath..... hos
1640: 74 70 6f 72 74 3a 20 73 72 76 2d 61 64 64 72 0a tport: srv-addr.
1650: 09 09 09 09 20 20 69 70 61 64 64 72 3a 20 69 70 .... ipaddr: ip
1660: 61 64 64 72 0a 09 09 09 09 20 20 70 6f 72 74 3a addr..... port:
1670: 20 70 6f 72 74 0a 09 09 09 09 20 20 73 72 76 70 port..... srvp
1680: 6b 74 3a 20 74 68 65 2d 73 72 76 0a 09 09 09 09 kt: the-srv.....
1690: 20 20 6c 61 73 74 6d 73 67 3a 20 28 63 75 72 72 lastmsg: (curr
16a0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 ent-seconds)....
16b0: 09 20 20 65 78 70 69 72 65 73 3a 20 28 2b 20 28 . expires: (+ (
16c0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
16d0: 20 36 30 29 20 3b 3b 20 74 68 69 73 20 6e 65 65 60) ;; this nee
16e0: 64 73 20 74 6f 20 62 65 20 67 61 74 68 65 72 65 ds to be gathere
16f0: 64 20 64 75 72 69 6e 67 20 74 68 65 20 70 69 6e d during the pin
1700: 67 0a 09 09 09 09 20 20 29 29 0a 09 09 23 74 29 g..... ))...#t)
1710: 0a 09 20 20 20 20 20 20 28 73 74 61 72 74 2d 6d .. (start-m
1720: 61 69 6e 2d 73 72 76 29 29 29 0a 09 28 73 74 61 ain-srv)))..(sta
1730: 72 74 2d 6d 61 69 6e 2d 73 72 76 29 29 29 29 0a rt-main-srv)))).
1740: 0a 3b 3b 20 4e 42 2f 2f 20 72 65 6d 6f 74 65 20 .;; NB// remote
1750: 69 73 20 61 20 72 6d 74 3a 72 65 6d 6f 74 65 20 is a rmt:remote
1760: 73 74 72 75 63 74 0a 3b 3b 0a 28 64 65 66 69 6e struct.;;.(defin
1770: 65 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 6f e (rmt:general-o
1780: 70 65 6e 2d 63 6f 6e 6e 65 63 74 69 6f 6e 20 72 pen-connection r
1790: 65 6d 6f 74 65 20 61 70 61 74 68 20 64 62 6e 61 emote apath dbna
17a0: 6d 65 20 23 21 6b 65 79 20 28 6e 75 6d 2d 74 72 me #!key (num-tr
17b0: 69 65 73 20 35 29 29 0a 20 20 28 6c 65 74 20 28 ies 5)). (let (
17c0: 28 6d 64 62 6e 61 6d 65 20 28 64 62 3a 72 75 6e (mdbname (db:run
17d0: 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 23 66 29 29 -id->dbname #f))
17e0: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
17f0: 20 28 28 6e 6f 74 20 28 72 6d 74 3a 67 65 74 2d ((not (rmt:get-
1800: 63 6f 6e 6e 20 72 65 6d 6f 74 65 20 61 70 61 74 conn remote apat
1810: 68 20 6d 64 62 6e 61 6d 65 29 29 20 3b 3b 20 6e h mdbname)) ;; n
1820: 6f 20 63 68 61 6e 6e 65 6c 20 6f 70 65 6e 20 74 o channel open t
1830: 6f 20 6d 61 69 6e 3f 20 0a 20 20 20 20 20 20 28 o main? . (
1840: 72 6d 74 3a 6f 70 65 6e 2d 6d 61 69 6e 2d 63 6f rmt:open-main-co
1850: 6e 6e 65 63 74 69 6f 6e 20 72 65 6d 6f 74 65 20 nnection remote
1860: 61 70 61 74 68 29 0a 20 20 20 20 20 20 28 74 68 apath). (th
1870: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 20 read-sleep! 2).
1880: 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 (rmt:genera
1890: 6c 2d 6f 70 65 6e 2d 63 6f 6e 6e 65 63 74 69 6f l-open-connectio
18a0: 6e 20 72 65 6d 6f 74 65 20 61 70 61 74 68 20 6d n remote apath m
18b0: 64 62 6e 61 6d 65 29 29 0a 20 20 20 20 20 28 28 dbname)). ((
18c0: 6e 6f 74 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e not (rmt:get-con
18d0: 6e 20 72 65 6d 6f 74 65 20 61 70 61 74 68 20 64 n remote apath d
18e0: 62 6e 61 6d 65 29 29 20 20 20 20 20 20 20 20 20 bname))
18f0: 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 68 ;; no ch
1900: 61 6e 6e 65 6c 20 6f 70 65 6e 20 74 6f 20 64 62 annel open to db
1910: 6e 61 6d 65 3f 20 20 20 20 20 0a 20 20 20 20 20 name? .
1920: 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 72 6d (let* ((res (rm
1930: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 72 t:send-receive-r
1940: 65 61 6c 20 72 65 6d 6f 74 65 20 61 70 61 74 68 eal remote apath
1950: 20 6d 64 62 6e 61 6d 65 20 27 67 65 74 2d 73 65 mdbname 'get-se
1960: 72 76 65 72 20 60 28 2c 61 70 61 74 68 20 2c 64 rver `(,apath ,d
1970: 62 6e 61 6d 65 29 29 29 29 0a 09 28 63 61 73 65 bname))))..(case
1980: 20 72 65 73 0a 09 20 20 28 28 73 65 72 76 65 72 res.. ((server
1990: 2d 73 74 61 72 74 65 64 29 0a 09 20 20 20 28 69 -started).. (i
19a0: 66 20 28 3e 20 6e 75 6d 2d 74 72 69 65 73 20 30 f (> num-tries 0
19b0: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
19c0: 0a 09 09 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ... (thread-slee
19d0: 70 21 20 32 29 0a 09 09 20 28 72 6d 74 3a 67 65 p! 2)... (rmt:ge
19e0: 6e 65 72 61 6c 2d 6f 70 65 6e 2d 63 6f 6e 6e 65 neral-open-conne
19f0: 63 74 69 6f 6e 20 72 65 6d 6f 74 65 20 61 70 61 ction remote apa
1a00: 74 68 20 64 62 6e 61 6d 65 20 6e 75 6d 2d 74 72 th dbname num-tr
1a10: 69 65 73 3a 20 28 2d 20 6e 75 6d 2d 74 72 69 65 ies: (- num-trie
1a20: 73 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 s 1))).. (
1a30: 62 65 67 69 6e 0a 09 09 20 28 64 65 62 75 67 3a begin... (debug:
1a40: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
1a50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1a60: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 74 61 72 "Failed to star
1a70: 74 20 73 65 72 76 65 72 73 20 6e 65 65 64 65 64 t servers needed
1a80: 20 6f 72 20 6f 70 65 6e 20 63 68 61 6e 6e 65 6c or open channel
1a90: 20 74 6f 20 22 61 70 61 74 68 22 2c 20 22 64 62 to "apath", "db
1aa0: 6e 61 6d 65 29 0a 09 09 20 28 65 78 69 74 20 31 name)... (exit 1
1ab0: 29 29 29 29 0a 09 20 20 28 65 6c 73 65 0a 09 20 )))).. (else..
1ac0: 20 20 28 69 66 20 28 6c 69 73 74 3f 20 72 65 73 (if (list? res
1ad0: 29 20 3b 3b 20 73 65 72 76 65 72 20 68 61 73 20 ) ;; server has
1ae0: 62 65 65 6e 20 72 65 67 69 73 74 65 72 65 64 20 been registered
1af0: 61 6e 64 20 74 68 65 20 69 6e 66 6f 20 77 61 73 and the info was
1b00: 20 72 65 74 75 72 6e 65 64 2e 20 70 61 73 73 20 returned. pass
1b10: 69 74 20 6f 6e 2e 0a 09 20 20 20 20 20 20 20 72 it on... r
1b20: 65 73 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 es.. (begi
1b30: 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e n... (debug:prin
1b40: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
1b50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 65 t-log-port* "Une
1b60: 78 70 65 63 74 65 64 20 72 65 73 75 6c 74 3a 20 xpected result:
1b70: 22 20 72 65 73 29 0a 09 09 20 72 65 73 29 29 29 " res)... res)))
1b80: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
1b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bd0: 0a 0a 0a 3b 3b 20 44 65 66 61 75 6c 74 73 20 74 ...;; Defaults t
1be0: 6f 20 63 75 72 72 65 6e 74 20 61 72 65 61 0a 3b o current area.;
1bf0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ;.(define (rmt:s
1c00: 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 end-receive cmd
1c10: 72 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 rid params #!key
1c20: 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 28 (attemptnum 1)(
1c30: 61 72 65 61 2d 64 61 74 20 23 66 29 29 0a 20 20 area-dat #f)).
1c40: 28 69 66 20 28 6e 6f 74 20 2a 72 6d 74 3a 72 65 (if (not *rmt:re
1c50: 6d 6f 74 65 2a 29 28 73 65 74 21 20 2a 72 6d 74 mote*)(set! *rmt
1c60: 3a 72 65 6d 6f 74 65 2a 20 28 6d 61 6b 65 2d 72 :remote* (make-r
1c70: 6d 74 3a 72 65 6d 6f 74 65 29 29 29 0a 20 20 28 mt:remote))). (
1c80: 6c 65 74 2a 20 28 28 61 70 61 74 68 20 2a 74 6f let* ((apath *to
1c90: 70 70 61 74 68 2a 29 0a 09 20 28 63 6f 6e 6e 73 ppath*).. (conns
1ca0: 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 29 0a 09 *rmt:remote*)..
1cb0: 20 28 64 62 6e 61 6d 65 20 28 64 62 3a 72 75 6e (dbname (db:run
1cc0: 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 72 69 64 29 -id->dbname rid)
1cd0: 29 29 0a 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 )). (rmt:gene
1ce0: 72 61 6c 2d 6f 70 65 6e 2d 63 6f 6e 6e 65 63 74 ral-open-connect
1cf0: 69 6f 6e 20 63 6f 6e 6e 73 20 61 70 61 74 68 20 ion conns apath
1d00: 64 62 6e 61 6d 65 29 0a 20 20 20 20 28 72 6d 74 dbname). (rmt
1d10: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 72 65 :send-receive-re
1d20: 61 6c 20 63 6f 6e 6e 73 20 61 70 61 74 68 20 64 al conns apath d
1d30: 62 6e 61 6d 65 20 63 6d 64 20 70 61 72 61 6d 73 bname cmd params
1d40: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
1d50: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 72 t:send-receive-r
1d60: 65 61 6c 20 68 6f 73 74 20 70 6f 72 74 20 64 61 eal host port da
1d70: 74 61 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 ta). (let-value
1d80: 73 20 28 28 69 20 6f 29 20 28 74 63 70 2d 63 6f s ((i o) (tcp-co
1d90: 6e 6e 65 63 74 20 68 6f 73 74 20 70 6f 72 74 29 nnect host port)
1da0: 29 0a 20 20 20 20 28 77 72 69 74 65 2d 6c 69 6e ). (write-lin
1db0: 65 20 64 61 74 61 20 6f 29 0a 20 20 20 20 28 70 e data o). (p
1dc0: 72 69 6e 74 20 28 72 65 61 64 2d 6c 69 6e 65 20 rint (read-line
1dd0: 69 29 29 29 29 0a 20 20 0a 3b 3b 20 64 62 20 69 i)))). .;; db i
1de0: 73 20 61 74 20 61 70 61 74 68 2f 2e 64 62 2f 64 s at apath/.db/d
1df0: 62 6e 61 6d 65 2c 20 72 69 64 20 69 73 20 61 6e bname, rid is an
1e00: 20 69 6e 74 65 72 6d 65 64 69 61 72 79 20 73 6f intermediary so
1e10: 6c 75 74 69 6f 6e 20 61 6e 64 20 77 69 6c 6c 20 lution and will
1e20: 62 65 20 72 65 6d 6f 76 65 64 0a 3b 3b 20 73 6f be removed.;; so
1e30: 6d 65 74 69 6d 65 20 69 6e 20 74 68 65 20 66 75 metime in the fu
1e40: 74 75 72 65 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e ture.;;.#;(defin
1e50: 65 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 e (rmt:send-rece
1e60: 69 76 65 2d 72 65 61 6c 20 72 65 6d 6f 74 65 20 ive-real remote
1e70: 61 70 61 74 68 20 64 62 6e 61 6d 65 20 63 6d 64 apath dbname cmd
1e80: 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a params). (let*
1e90: 20 28 28 63 6f 6e 6e 20 28 72 6d 74 3a 67 65 74 ((conn (rmt:get
1ea0: 2d 63 6f 6e 6e 20 72 65 6d 6f 74 65 20 61 70 61 -conn remote apa
1eb0: 74 68 20 64 62 6e 61 6d 65 29 29 29 0a 20 20 20 th dbname))).
1ec0: 20 28 61 73 73 65 72 74 20 63 6f 6e 6e 20 22 46 (assert conn "F
1ed0: 41 54 41 4c 3a 20 72 6d 74 3a 73 65 6e 64 2d 72 ATAL: rmt:send-r
1ee0: 65 63 65 69 76 65 2d 72 65 61 6c 20 63 61 6c 6c eceive-real call
1ef0: 65 64 20 77 69 74 68 6f 75 74 20 74 68 65 20 6e ed without the n
1f00: 65 65 64 65 64 20 63 68 61 6e 6e 65 6c 73 20 6f eeded channels o
1f10: 70 65 6e 65 64 22 29 0a 20 20 20 20 28 6c 65 74 pened"). (let
1f20: 2a 20 28 28 70 61 79 6c 6f 61 64 20 28 73 65 78 * ((payload (sex
1f30: 70 72 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d pr->string param
1f40: 73 29 29 0a 09 20 20 20 28 72 65 73 20 20 20 20 s)).. (res
1f50: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
1f60: 6f 6d 2d 72 65 71 75 65 73 74 0a 09 09 20 20 20 om-request...
1f70: 20 20 20 28 72 6d 74 3a 63 6f 6e 6e 2d 3e 75 72 (rmt:conn->ur
1f80: 69 20 63 6f 6e 6e 20 22 61 70 69 22 29 0a 09 09 i conn "api")...
1f90: 20 20 20 20 20 20 60 28 28 70 61 72 61 6d 73 20 `((params
1fa0: 2e 20 2c 70 61 79 6c 6f 61 64 29 0a 09 09 09 28 . ,payload)....(
1fb0: 63 6d 64 20 20 20 20 2e 20 2c 63 6d 64 29 0a 09 cmd . ,cmd)..
1fc0: 09 09 28 6b 65 79 20 20 20 20 2e 20 22 6e 6f 6b ..(key . "nok
1fd0: 65 79 22 29 29 0a 09 09 20 20 20 20 20 20 72 65 ey"))... re
1fe0: 61 64 2d 73 74 72 69 6e 67 29 29 29 0a 20 20 20 ad-string))).
1ff0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
2000: 72 65 73 29 0a 09 20 20 28 73 74 72 69 6e 67 2d res).. (string-
2010: 3e 73 65 78 70 72 20 72 65 73 29 0a 09 20 20 72 >sexpr res).. r
2020: 65 73 29 29 29 29 0a 0a 3b 3b 20 64 62 20 69 73 es))))..;; db is
2030: 20 61 74 20 61 70 61 74 68 2f 2e 64 62 2f 64 62 at apath/.db/db
2040: 6e 61 6d 65 2c 20 72 69 64 20 69 73 20 61 6e 20 name, rid is an
2050: 69 6e 74 65 72 6d 65 64 69 61 72 79 20 73 6f 6c intermediary sol
2060: 75 74 69 6f 6e 20 61 6e 64 20 77 69 6c 6c 20 62 ution and will b
2070: 65 20 72 65 6d 6f 76 65 64 0a 3b 3b 20 73 6f 6d e removed.;; som
2080: 65 74 69 6d 65 20 69 6e 20 74 68 65 20 66 75 74 etime in the fut
2090: 75 72 65 2e 0a 3b 3b 0a 3b 3b 20 50 75 72 70 6f ure..;;.;; Purpo
20a0: 73 65 20 2d 20 63 61 6c 6c 20 74 68 65 20 6d 61 se - call the ma
20b0: 69 6e 2e 64 62 20 73 65 72 76 65 72 20 61 6e 64 in.db server and
20c0: 20 72 65 71 75 65 73 74 20 61 20 73 65 72 76 65 request a serve
20d0: 72 20 62 65 20 73 74 61 72 74 65 64 0a 3b 3b 20 r be started.;;
20e0: 66 6f 72 20 74 68 65 20 67 69 76 65 6e 20 61 72 for the given ar
20f0: 65 61 20 70 61 74 68 20 61 6e 64 20 64 62 6e 61 ea path and dbna
2100: 6d 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 me.;;.(define (r
2110: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d mt:send-receive-
2120: 73 65 72 76 65 72 2d 73 74 61 72 74 20 72 65 6d server-start rem
2130: 6f 74 65 20 61 70 61 74 68 20 64 62 6e 61 6d 65 ote apath dbname
2140: 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e ). (let* ((conn
2150: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 20 72 (rmt:get-conn r
2160: 65 6d 6f 74 65 20 61 70 61 74 68 20 64 62 6e 61 emote apath dbna
2170: 6d 65 29 29 29 0a 20 20 20 20 28 61 73 73 65 72 me))). (asser
2180: 74 20 63 6f 6e 6e 20 22 46 41 54 41 4c 3a 20 55 t conn "FATAL: U
2190: 6e 61 62 6c 65 20 74 6f 20 63 6f 6e 6e 65 63 74 nable to connect
21a0: 20 74 6f 20 64 62 20 22 61 70 61 74 68 22 2f 22 to db "apath"/"
21b0: 64 62 6e 61 6d 65 29 0a 20 20 20 20 23 3b 28 6c dbname). #;(l
21c0: 65 74 2a 20 28 28 72 65 73 20 20 20 20 20 20 28 et* ((res (
21d0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
21e0: 72 65 71 75 65 73 74 0a 09 09 20 20 20 20 20 20 request...
21f0: 28 72 6d 74 3a 63 6f 6e 6e 2d 3e 75 72 69 20 63 (rmt:conn->uri c
2200: 6f 6e 6e 20 22 61 70 69 22 29 20 0a 09 09 20 20 onn "api") ...
2210: 20 20 20 20 60 28 28 70 61 72 61 6d 73 20 2e 20 `((params .
2220: 28 2c 61 70 61 74 68 20 2c 64 62 6e 61 6d 65 29 (,apath ,dbname)
2230: 29 29 0a 09 09 20 20 20 20 20 20 72 65 61 64 2d ))... read-
2240: 73 74 72 69 6e 67 29 29 29 0a 20 20 20 20 20 20 string))).
2250: 28 73 74 72 69 6e 67 2d 3e 73 65 78 70 72 20 72 (string->sexpr r
2260: 65 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 es))))..(define
2270: 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 (rmt:print-db-st
2280: 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 66 6d ats). (let ((fm
2290: 74 73 74 72 20 22 7e 34 30 61 7e 37 2d 64 7e 39 tstr "~40a~7-d~9
22a0: 2d 64 7e 32 30 2c 32 2d 66 22 29 29 20 3b 3b 20 -d~20,2-f")) ;;
22b0: 22 7e 32 30 2c 32 2d 66 22 0a 20 20 20 20 28 64 "~20,2-f". (d
22c0: 65 62 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 ebug:print 18 *d
22d0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
22e0: 20 22 44 42 20 53 74 61 74 73 5c 6e 3d 3d 3d 3d "DB Stats\n====
22f0: 3d 3d 3d 3d 22 29 0a 20 20 20 20 28 64 65 62 75 ===="). (debu
2300: 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 g:print 18 *defa
2310: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 ult-log-port* (f
2320: 6f 72 6d 61 74 20 23 66 20 22 7e 34 30 61 7e 38 ormat #f "~40a~8
2330: 61 7e 31 30 61 7e 31 30 61 22 20 22 43 6d 64 22 a~10a~10a" "Cmd"
2340: 20 22 43 6f 75 6e 74 22 20 22 54 6f 74 54 69 6d "Count" "TotTim
2350: 65 22 20 22 41 76 67 22 29 29 0a 20 20 20 20 28 e" "Avg")). (
2360: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
2370: 20 28 63 6d 64 29 0a 09 09 28 6c 65 74 20 28 28 (cmd)...(let ((
2380: 63 6d 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 cmd-dat (hash-ta
2390: 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 ble-ref *db-stat
23a0: 73 2a 20 63 6d 64 29 29 29 0a 09 09 20 20 28 64 s* cmd)))... (d
23b0: 65 62 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 ebug:print 18 *d
23c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
23d0: 20 28 66 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 (format #f fmts
23e0: 74 72 20 63 6d 64 20 28 76 65 63 74 6f 72 2d 72 tr cmd (vector-r
23f0: 65 66 20 63 6d 64 2d 64 61 74 20 30 29 20 28 76 ef cmd-dat 0) (v
2400: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
2410: 74 20 31 29 20 28 2f 20 28 76 65 63 74 6f 72 2d t 1) (/ (vector-
2420: 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 28 76 ref cmd-dat 1)(v
2430: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
2440: 74 20 30 29 29 29 29 29 29 0a 09 20 20 20 20 20 t 0))))))..
2450: 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
2460: 6c 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 le-keys *db-stat
2470: 73 2a 29 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 s*)... (lambd
2480: 61 20 28 61 20 62 29 0a 09 09 20 20 20 20 20 20 a (a b)...
2490: 28 3e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 (> (vector-ref (
24a0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a hash-table-ref *
24b0: 64 62 2d 73 74 61 74 73 2a 20 61 29 20 30 29 0a db-stats* a) 0).
24c0: 09 09 09 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ... (vector-ref
24d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
24e0: 2a 64 62 2d 73 74 61 74 73 2a 20 62 29 20 30 29 *db-stats* b) 0)
24f0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
2500: 28 72 6d 74 3a 67 65 74 2d 6d 61 78 2d 71 75 65 (rmt:get-max-que
2510: 72 79 2d 61 76 65 72 61 67 65 20 72 75 6e 2d 69 ry-average run-i
2520: 64 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b d). (mutex-lock
2530: 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 ! *db-stats-mute
2540: 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 x*). (let* ((ru
2550: 6e 6b 65 79 20 28 63 6f 6e 63 20 22 72 75 6e 2d nkey (conc "run-
2560: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 22 29 id=" run-id " ")
2570: 29 0a 09 20 28 63 6d 64 73 20 20 20 28 66 69 6c ).. (cmds (fil
2580: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
2590: 09 09 09 20 20 20 28 73 75 62 73 74 72 69 6e 67 ... (substring
25a0: 2d 69 6e 64 65 78 20 72 75 6e 6b 65 79 20 78 29 -index runkey x)
25b0: 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c ).... (hash-tabl
25c0: 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 73 e-keys *db-stats
25d0: 2a 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 *))).. (res (
25e0: 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a if (null? cmds).
25f0: 09 09 20 20 20 20 20 28 63 6f 6e 73 20 27 6e 6f .. (cons 'no
2600: 6e 65 20 30 29 0a 09 09 20 20 20 20 20 28 6c 65 ne 0)... (le
2610: 74 20 6c 6f 6f 70 20 28 28 63 6d 64 20 28 63 61 t loop ((cmd (ca
2620: 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 74 61 r cmds)).....(ta
2630: 6c 20 28 63 64 72 20 63 6d 64 73 29 29 0a 09 09 l (cdr cmds))...
2640: 09 09 28 6d 61 78 2d 63 6d 64 20 28 63 61 72 20 ..(max-cmd (car
2650: 63 6d 64 73 29 29 0a 09 09 09 09 28 72 65 73 20 cmds)).....(res
2660: 30 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 0))... (le
2670: 74 2a 20 28 28 63 6d 64 2d 64 61 74 20 28 68 61 t* ((cmd-dat (ha
2680: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 sh-table-ref *db
2690: 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 0a 09 09 -stats* cmd))...
26a0: 09 20 20 20 20 20 20 28 74 6f 74 20 20 20 20 20 . (tot
26b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d (vector-ref cmd-
26c0: 64 61 74 20 30 29 29 0a 09 09 09 20 20 20 20 20 dat 0))....
26d0: 20 28 63 75 72 72 61 76 67 20 28 2f 20 28 76 65 (curravg (/ (ve
26e0: 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 ctor-ref cmd-dat
26f0: 20 31 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 1) (vector-ref
2700: 63 6d 64 2d 64 61 74 20 30 29 29 29 20 3b 3b 20 cmd-dat 0))) ;;
2710: 63 6f 75 6e 74 20 69 73 20 6e 65 76 65 72 20 7a count is never z
2720: 65 72 6f 20 62 79 20 63 6f 6e 73 74 72 75 63 74 ero by construct
2730: 69 6f 6e 0a 09 09 09 20 20 20 20 20 20 28 63 75 ion.... (cu
2740: 72 72 6d 61 78 20 28 6d 61 78 20 72 65 73 20 63 rrmax (max res c
2750: 75 72 72 61 76 67 29 29 0a 09 09 09 20 20 20 20 urravg))....
2760: 20 20 28 6e 65 77 6d 61 78 2d 63 6d 64 20 28 69 (newmax-cmd (i
2770: 66 20 28 3e 20 63 75 72 72 61 76 67 20 72 65 73 f (> curravg res
2780: 29 20 63 6d 64 20 6d 61 78 2d 63 6d 64 29 29 29 ) cmd max-cmd)))
2790: 0a 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 .... (if (null?
27a0: 74 61 6c 29 0a 09 09 09 20 20 20 20 20 28 69 66 tal).... (if
27b0: 20 28 3e 20 74 6f 74 20 31 30 29 0a 09 09 09 09 (> tot 10).....
27c0: 20 28 63 6f 6e 73 20 6e 65 77 6d 61 78 2d 63 6d (cons newmax-cm
27d0: 64 20 63 75 72 72 6d 61 78 29 0a 09 09 09 09 20 d currmax).....
27e0: 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 29 0a (cons 'none 0)).
27f0: 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 ... (loop (c
2800: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
2810: 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 72 newmax-cmd curr
2820: 6d 61 78 29 29 29 29 29 29 29 0a 20 20 20 20 28 max))))))). (
2830: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
2840: 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a b-stats-mutex*).
2850: 20 20 20 20 72 65 73 29 29 0a 0a 0a 3b 3b 3d 3d res))...;;==
2860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28a0: 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 41 20 43 20 54 ====.;;.;; A C T
28b0: 20 55 20 41 20 4c 20 20 20 41 20 50 20 49 20 20 U A L A P I
28c0: 20 43 20 41 20 4c 20 4c 20 53 20 20 0a 3b 3b 0a C A L L S .;;.
28d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
28e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2910: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d ========..;;====
2920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2960: 3d 3d 0a 3b 3b 20 20 53 20 45 20 52 20 56 20 45 ==.;; S E R V E
2970: 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;;===========
2980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
29c0: 66 69 6e 65 20 28 72 6d 74 3a 6b 69 6c 6c 2d 73 fine (rmt:kill-s
29d0: 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a 20 20 erver run-id).
29e0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
29f0: 65 20 27 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 e 'kill-server r
2a00: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
2a10: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
2a20: 72 6d 74 3a 73 74 61 72 74 2d 73 65 72 76 65 72 rmt:start-server
2a30: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
2a40: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 74 send-receive 'st
2a50: 61 72 74 2d 73 65 72 76 65 72 20 30 20 28 6c 69 art-server 0 (li
2a60: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b st run-id)))..;;
2a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ab0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4d 20 49 20 53 ======.;; M I S
2ac0: 20 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d C.;;===========
2ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
2b10: 66 69 6e 65 20 28 72 6d 74 3a 6c 6f 67 69 6e 20 fine (rmt:login
2b20: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
2b30: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6c 6f 67 end-receive 'log
2b40: 69 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 in run-id (list
2b50: 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 74 65 *toppath* megate
2b60: 73 74 2d 76 65 72 73 69 6f 6e 20 2a 6d 79 2d 63 st-version *my-c
2b70: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
2b80: 29 29 29 0a 0a 3b 3b 20 72 6d 74 3a 6c 6f 67 69 )))..;; rmt:logi
2b90: 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 n-no-auto-client
2ba0: 2d 73 65 74 75 70 0a 3b 3b 20 72 6d 74 3a 73 65 -setup.;; rmt:se
2bb0: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
2bc0: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 0a to-client-setup.
2bd0: 0a 3b 3b 20 68 61 6e 64 20 6f 66 66 20 61 20 63 .;; hand off a c
2be0: 61 6c 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 74 68 all to one of th
2bf0: 65 20 64 62 3a 71 75 65 72 69 65 73 20 73 74 61 e db:queries sta
2c00: 74 65 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 65 64 tements.;; added
2c10: 20 72 75 6e 2d 69 64 20 74 6f 20 6d 61 6b 65 20 run-id to make
2c20: 6c 6f 6f 6b 69 6e 67 20 75 70 20 74 68 65 20 63 looking up the c
2c30: 6f 72 72 65 63 74 20 64 62 20 70 6f 73 73 69 62 orrect db possib
2c40: 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 le .;;.(define (
2c50: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
2c60: 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 stmtname run-id
2c70: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d . params). (rm
2c80: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
2c90: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 75 6e general-call run
2ca0: 2d 69 64 20 28 61 70 70 65 6e 64 20 28 6c 69 73 -id (append (lis
2cb0: 74 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 t stmtname run-i
2cc0: 64 29 20 70 61 72 61 6d 73 29 29 29 0a 0a 0a 3b d) params)))...;
2cd0: 3b 20 67 69 76 65 6e 20 61 20 68 6f 73 74 6e 61 ; given a hostna
2ce0: 6d 65 2c 20 72 65 74 75 72 6e 20 61 20 70 61 69 me, return a pai
2cf0: 72 20 6f 66 20 63 70 75 20 6c 6f 61 64 20 61 6e r of cpu load an
2d00: 64 20 75 70 64 61 74 65 20 74 69 6d 65 20 72 65 d update time re
2d10: 70 72 65 73 65 6e 74 69 6e 67 20 6c 61 74 65 73 presenting lates
2d20: 74 20 69 6e 74 65 6c 6c 69 67 65 6e 63 65 20 66 t intelligence f
2d30: 72 6f 6d 20 74 65 73 74 73 20 72 75 6e 6e 69 6e rom tests runnin
2d40: 67 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 28 g on that host.(
2d50: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
2d60: 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 latest-host-load
2d70: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d hostname). (rm
2d80: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
2d90: 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d get-latest-host-
2da0: 6c 6f 61 64 20 30 20 28 6c 69 73 74 20 68 6f 73 load 0 (list hos
2db0: 74 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e tname)))..(defin
2dc0: 65 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 71 e (rmt:sdb-qry q
2dd0: 72 79 20 76 61 6c 20 72 75 6e 2d 69 64 29 0a 20 ry val run-id).
2de0: 20 3b 3b 20 61 64 64 20 63 61 63 68 69 6e 67 20 ;; add caching
2df0: 69 66 20 71 72 79 20 69 73 20 27 67 65 74 69 64 if qry is 'getid
2e00: 20 6f 72 20 27 67 65 74 73 74 72 0a 20 20 28 72 or 'getstr. (r
2e10: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
2e20: 27 73 64 62 2d 71 72 79 20 72 75 6e 2d 69 64 20 'sdb-qry run-id
2e30: 28 6c 69 73 74 20 71 72 79 20 76 61 6c 29 29 29 (list qry val)))
2e40: 0a 0a 3b 3b 20 4e 4f 54 20 43 4f 4d 50 4c 45 54 ..;; NOT COMPLET
2e50: 45 44 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ED.(define (rmt:
2e60: 72 75 6e 74 65 73 74 73 20 75 73 65 72 20 72 75 runtests user ru
2e70: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 70 61 n-id testpatt pa
2e80: 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e rams). (rmt:sen
2e90: 64 2d 72 65 63 65 69 76 65 20 27 72 75 6e 74 65 d-receive 'runte
2ea0: 73 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 70 sts run-id testp
2eb0: 61 74 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 att))..(define (
2ec0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f rmt:get-run-reco
2ed0: 72 64 2d 69 64 73 20 20 74 61 72 67 65 74 20 72 rd-ids target r
2ee0: 75 6e 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 un keynames test
2ef0: 2d 70 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 -patt). (rmt:se
2f00: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
2f10: 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 20 23 run-record-ids #
2f20: 66 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 f (list target r
2f30: 75 6e 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 un keynames test
2f40: 2d 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e -patt)))..(defin
2f50: 65 20 28 72 6d 74 3a 67 65 74 2d 63 68 61 6e 67 e (rmt:get-chang
2f60: 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 20 73 69 ed-record-ids si
2f70: 6e 63 65 2d 74 69 6d 65 29 0a 20 20 28 72 6d 74 nce-time). (rmt
2f80: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
2f90: 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 et-changed-recor
2fa0: 64 2d 69 64 73 20 23 66 20 28 6c 69 73 74 20 73 d-ids #f (list s
2fb0: 69 6e 63 65 2d 74 69 6d 65 29 29 20 29 0a 0a 28 ince-time)) )..(
2fc0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 72 6f 70 define (rmt:drop
2fd0: 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 29 0a 20 -all-triggers).
2fe0: 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (rmt:send-re
2ff0: 63 65 69 76 65 20 27 64 72 6f 70 2d 61 6c 6c 2d ceive 'drop-all-
3000: 74 72 69 67 67 65 72 73 20 23 66 20 27 28 29 29 triggers #f '())
3010: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
3020: 63 72 65 61 74 65 2d 61 6c 6c 2d 74 72 69 67 67 create-all-trigg
3030: 65 72 73 29 0a 20 20 20 20 20 28 72 6d 74 3a 73 ers). (rmt:s
3040: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 63 72 65 end-receive 'cre
3050: 61 74 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 ate-all-triggers
3060: 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d #f '()))..;;===
3070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30b0: 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 ===.;; T E S T
30c0: 20 20 4d 20 45 20 54 20 41 20 0a 3b 3b 3d 3d 3d M E T A .;;===
30d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3110: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
3120: 74 3a 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 t:get-tests-tags
3130: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
3140: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 ceive 'get-tests
3150: 2d 74 61 67 73 20 23 66 20 27 28 29 29 29 0a 0a -tags #f '()))..
3160: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
3170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31a0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 ========.;; K E
31b0: 20 59 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d Y S .;;========
31c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
3200: 3b 3b 20 54 68 65 73 65 20 72 65 71 75 69 72 65 ;; These require
3210: 20 72 75 6e 2d 69 64 20 62 65 63 61 75 73 65 20 run-id because
3220: 74 68 65 20 76 61 6c 75 65 73 20 63 6f 6d 65 20 the values come
3230: 66 72 6f 6d 20 74 68 65 20 72 75 6e 21 0a 3b 3b from the run!.;;
3240: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
3250: 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 t-key-val-pairs
3260: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
3270: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
3280: 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 -key-val-pairs r
3290: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
32a0: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
32b0: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 0a 20 20 rmt:get-keys).
32c0: 28 69 66 20 2a 64 62 2d 6b 65 79 73 2a 20 2a 64 (if *db-keys* *d
32d0: 62 2d 6b 65 79 73 2a 20 0a 20 20 20 20 20 28 6c b-keys* . (l
32e0: 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 et ((res (rmt:se
32f0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
3300: 6b 65 79 73 20 23 66 20 27 28 29 29 29 29 0a 20 keys #f '()))).
3310: 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d (set! *db-
3320: 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 20 keys* res).
3330: 20 20 72 65 73 29 29 29 0a 0a 28 64 65 66 69 6e res)))..(defin
3340: 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 2d e (rmt:get-keys-
3350: 77 72 69 74 65 29 20 3b 3b 20 64 75 6d 6d 79 20 write) ;; dummy
3360: 71 75 65 72 79 20 74 6f 20 66 6f 72 63 65 20 73 query to force s
3370: 65 72 76 65 72 20 73 74 61 72 74 0a 20 20 28 6c erver start. (l
3380: 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 et ((res (rmt:se
3390: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
33a0: 6b 65 79 73 2d 77 72 69 74 65 20 23 66 20 27 28 keys-write #f '(
33b0: 29 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a )))). (set! *
33c0: 64 62 2d 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 db-keys* res).
33d0: 20 20 72 65 73 29 29 0a 0a 3b 3b 20 77 65 20 64 res))..;; we d
33e0: 6f 6e 27 74 20 72 65 75 73 65 20 72 75 6e 2d 69 on't reuse run-i
33f0: 64 27 73 20 28 65 78 63 65 70 74 20 70 6f 73 73 d's (except poss
3400: 69 62 6c 79 20 2a 61 66 74 65 72 2a 20 61 20 64 ibly *after* a d
3410: 62 20 63 6c 65 61 6e 75 70 29 20 73 6f 20 69 74 b cleanup) so it
3420: 20 69 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 63 is safe.;; to c
3430: 61 63 68 65 20 74 68 65 20 72 65 73 75 6c 73 20 ache the resuls
3440: 69 6e 20 61 20 68 61 73 68 0a 3b 3b 0a 28 64 65 in a hash.;;.(de
3450: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 fine (rmt:get-ke
3460: 79 2d 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a 20 y-vals run-id).
3470: 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
3480: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b 65 -ref/default *ke
3490: 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 66 yvals* run-id #f
34a0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 ). (let ((r
34b0: 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 es (rmt:send-rec
34c0: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 eive 'get-key-va
34d0: 6c 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d ls #f (list run-
34e0: 69 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 id)))). (
34f0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3500: 2a 6b 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 *keyvals* run-id
3510: 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 res). re
3520: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s)))..(define (r
3530: 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 73 29 0a mt:get-targets).
3540: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
3550: 69 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 73 ive 'get-targets
3560: 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 #f '()))..(defi
3570: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 ne (rmt:get-targ
3580: 65 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d et run-id). (rm
3590: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
35a0: 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 get-target run-i
35b0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 d (list run-id))
35c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
35d0: 67 65 74 2d 72 75 6e 2d 74 69 6d 65 73 20 72 75 get-run-times ru
35e0: 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 74 npatt targetpatt
35f0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
3600: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 74 ceive 'get-run-t
3610: 69 6d 65 73 20 23 66 20 28 6c 69 73 74 20 72 75 imes #f (list ru
3620: 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 74 npatt targetpatt
3630: 20 29 29 29 20 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))) ...;;======
3640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3680: 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b .;; T E S T S.;
3690: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
36a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36d0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4a 75 73 74 =======..;; Just
36e0: 20 73 6f 6d 65 20 73 79 6e 74 61 74 69 63 20 73 some syntatic s
36f0: 75 67 61 72 0a 28 64 65 66 69 6e 65 20 28 72 6d ugar.(define (rm
3700: 74 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 t:register-test
3710: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
3720: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 item-path). (r
3730: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
3740: 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 'register-test r
3750: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 un-id run-id tes
3760: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
3770: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
3780: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e :get-test-id run
3790: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
37a0: 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a 73 m-path). (rmt:s
37b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
37c0: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
37d0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
37e0: 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 tname item-path)
37f0: 29 29 0a 0a 3b 3b 20 72 75 6e 2d 69 64 20 69 73 ))..;; run-id is
3800: 20 4e 4f 54 20 75 73 65 64 0a 3b 3b 0a 28 64 65 NOT used.;;.(de
3810: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
3820: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
3830: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
3840: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 74 65 73 (if (number? tes
3850: 74 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 t-id). (rmt
3860: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
3870: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
3880: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
3890: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
38a0: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
38b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
38c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
38d0: 20 22 57 41 52 4e 49 4e 47 3a 20 42 61 64 20 64 "WARNING: Bad d
38e0: 61 74 61 20 68 61 6e 64 65 64 20 74 6f 20 72 6d ata handed to rm
38f0: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
3900: 62 79 2d 69 64 20 72 75 6e 2d 69 64 3d 22 20 72 by-id run-id=" r
3910: 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 64 un-id ", test-id
3920: 3d 22 20 74 65 73 74 2d 69 64 29 0a 09 28 70 72 =" test-id)..(pr
3930: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
3940: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
3950: 72 74 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 rt))..#f)))..(de
3960: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 fine (rmt:test-g
3970: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
3980: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 est-id run-id te
3990: 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 st-id). (rmt:se
39a0: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
39b0: 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d -get-rundir-from
39c0: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
39d0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
39e0: 74 2d 69 64 29 29 29 0a 0a 3b 3b 20 28 64 65 66 t-id)))..;; (def
39f0: 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 65 ine (rmt:open-te
3a00: 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 64 st-db-by-test-id
3a10: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
3a20: 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 #!key (work-area
3a30: 20 23 66 29 29 0a 3b 3b 20 20 20 28 6c 65 74 2a #f)).;; (let*
3a40: 20 28 28 74 65 73 74 2d 70 61 74 68 20 28 69 66 ((test-path (if
3a50: 20 28 73 74 72 69 6e 67 3f 20 77 6f 72 6b 2d 61 (string? work-a
3a60: 72 65 61 29 0a 3b 3b 20 09 09 09 77 6f 72 6b 2d rea).;; ...work-
3a70: 61 72 65 61 0a 3b 3b 20 09 09 09 28 72 6d 74 3a area.;; ...(rmt:
3a80: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
3a90: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e from-test-id run
3aa0: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 29 0a -id test-id)))).
3ab0: 3b 3b 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
3ac0: 69 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c int 3 *default-l
3ad0: 6f 67 2d 70 6f 72 74 2a 20 22 54 45 53 54 20 50 og-port* "TEST P
3ae0: 41 54 48 3a 20 22 20 74 65 73 74 2d 70 61 74 68 ATH: " test-path
3af0: 29 0a 3b 3b 20 20 20 20 20 28 6f 70 65 6e 2d 74 ).;; (open-t
3b00: 65 73 74 2d 64 62 20 74 65 73 74 2d 70 61 74 68 est-db test-path
3b10: 29 29 29 0a 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a )))..;; WARNING:
3b20: 20 54 68 69 73 20 63 75 72 72 65 6e 74 6c 79 20 This currently
3b30: 62 79 70 61 73 73 65 73 20 74 68 65 20 74 72 61 bypasses the tra
3b40: 6e 73 61 63 74 69 6f 6e 20 77 72 61 70 70 65 64 nsaction wrapped
3b50: 20 77 72 69 74 65 73 20 73 79 73 74 65 6d 0a 28 writes system.(
3b60: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
3b70: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
3b80: 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
3b90: 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 est-id newstate
3ba0: 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d newstatus newcom
3bb0: 6d 65 6e 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e ment). (rmt:sen
3bc0: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
3bd0: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
3be0: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c -by-id run-id (l
3bf0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
3c00: 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 id newstate news
3c10: 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 tatus newcomment
3c20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
3c30: 74 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 t:set-tests-stat
3c40: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
3c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c60: 20 20 20 20 20 74 65 73 74 6e 61 6d 65 73 20 63 testnames c
3c70: 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 urrstate currsta
3c80: 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 tus newstate new
3c90: 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 3a 73 status). (rmt:s
3ca0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 end-receive 'set
3cb0: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
3cc0: 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 tus run-id (list
3cd0: 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 run-id testname
3ce0: 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 s currstate curr
3cf0: 73 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 status newstate
3d00: 6e 65 77 73 74 61 74 75 73 29 29 29 0a 0a 28 64 newstatus)))..(d
3d10: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
3d20: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
3d30: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
3d40: 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 66 tes statuses off
3d50: 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e set limit not-in
3d60: 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 sort-by sort-or
3d70: 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 der qryvals last
3d80: 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 0a 20 20 -update mode).
3d90: 3b 3b 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 ;; (if (number?
3da0: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
3db0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
3dc0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 -tests-for-run r
3dd0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
3de0: 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 id testpatt stat
3df0: 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 66 73 es statuses offs
3e00: 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 et limit not-in
3e10: 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 sort-by sort-ord
3e20: 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d er qryvals last-
3e30: 75 70 64 61 74 65 20 6d 6f 64 65 29 29 29 0a 20 update mode))).
3e40: 20 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a 20 20 ;; (begin.
3e50: 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ;;.(debug:print-
3e60: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3e70: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
3e80: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
3e90: 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 20 62 61 n called with ba
3ea0: 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 d run-id=" run-i
3eb0: 64 29 0a 20 20 3b 3b 09 28 70 72 69 6e 74 2d 63 d). ;;.(print-c
3ec0: 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 all-chain (curre
3ed0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
3ee0: 20 20 3b 3b 09 27 28 29 29 29 29 0a 0a 28 64 65 ;;.'())))..(de
3ef0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
3f00: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 73 74 61 74 sts-for-run-stat
3f10: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
3f20: 74 65 73 74 70 61 74 74 20 6c 61 73 74 2d 75 70 testpatt last-up
3f30: 64 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e date). (rmt:sen
3f40: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
3f50: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 73 74 61 ests-for-run-sta
3f60: 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 te-status run-id
3f70: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
3f80: 73 74 70 61 74 74 20 6c 61 73 74 2d 75 70 64 61 stpatt last-upda
3f90: 74 65 29 29 29 0a 0a 3b 3b 20 67 65 74 20 73 74 te)))..;; get st
3fa0: 75 66 66 20 76 69 61 20 73 79 6e 63 68 61 73 68 uff via synchash
3fb0: 20 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 .(define (rmt:s
3fc0: 79 6e 63 68 61 73 68 2d 67 65 74 20 72 75 6e 2d ynchash-get run-
3fd0: 69 64 20 70 72 6f 63 20 73 79 6e 63 6b 65 79 20 id proc synckey
3fe0: 6b 65 79 6e 75 6d 20 70 61 72 61 6d 73 29 0a 20 keynum params).
3ff0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
4000: 76 65 20 27 73 79 6e 63 68 61 73 68 2d 67 65 74 ve 'synchash-get
4010: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
4020: 6e 2d 69 64 20 70 72 6f 63 20 73 79 6e 63 6b 65 n-id proc syncke
4030: 79 20 6b 65 79 6e 75 6d 20 70 61 72 61 6d 73 29 y keynum params)
4040: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
4050: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
4060: 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 un-mindata run-i
4070: 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 d testpatt state
4080: 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 s status not-in)
4090: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
40a0: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d eive 'get-tests-
40b0: 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 for-run-mindata
40c0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
40d0: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
40e0: 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 tes status not-i
40f0: 6e 29 29 29 0a 20 20 0a 3b 3b 20 49 44 45 41 3a n))). .;; IDEA:
4100: 20 54 68 72 65 61 64 69 66 79 20 74 68 65 73 65 Threadify these
4110: 20 2d 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 - they spend a
4120: 6c 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 lot of time wait
4130: 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 ing ....;;.(defi
4140: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
4150: 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 s-for-runs-minda
4160: 74 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 ta run-ids testp
4170: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
4180: 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 6c 65 74 s not-in). (let
4190: 20 28 28 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 ((multi-run-mut
41a0: 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 ex (make-mutex))
41b0: 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 73 74 20 28 ..(run-id-list (
41c0: 69 66 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 72 if run-ids.... r
41d0: 75 6e 2d 69 64 73 0a 09 09 09 20 28 72 6d 74 3a un-ids.... (rmt:
41e0: 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 get-all-run-ids)
41f0: 29 29 0a 09 28 72 65 73 75 6c 74 20 20 20 20 20 ))..(result
4200: 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 20 28 '())). (if (
4210: 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 2d 6c 69 73 null? run-id-lis
4220: 74 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f t)..'()..(let lo
4230: 6f 70 20 28 28 68 65 64 20 20 20 20 20 28 63 61 op ((hed (ca
4240: 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 0a r run-id-list)).
4250: 09 09 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 .. (tal (c
4260: 64 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 dr run-id-list))
4270: 0a 09 09 20 20 20 28 74 68 72 65 61 64 73 20 27 ... (threads '
4280: 28 29 29 29 0a 09 20 20 28 69 66 20 28 3e 20 28 ())).. (if (> (
4290: 6c 65 6e 67 74 68 20 74 68 72 65 61 64 73 29 20 length threads)
42a0: 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 5).. (loop
42b0: 68 65 64 20 74 61 6c 20 28 66 69 6c 74 65 72 20 hed tal (filter
42c0: 28 6c 61 6d 62 64 61 20 28 74 68 29 28 6e 6f 74 (lambda (th)(not
42d0: 20 28 6d 65 6d 62 65 72 20 28 74 68 72 65 61 64 (member (thread
42e0: 2d 73 74 61 74 65 20 74 68 29 20 27 28 74 65 72 -state th) '(ter
42f0: 6d 69 6e 61 74 65 64 20 64 65 61 64 29 29 29 29 minated dead))))
4300: 20 74 68 72 65 61 64 73 29 29 0a 09 20 20 20 20 threads))..
4310: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 74 68 72 (let* ((newthr
4320: 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 ead (make-thread
4330: 0a 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 ..... (lambda ()
4340: 0a 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 ..... (let ((r
4350: 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 es (rmt:send-rec
4360: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d eive 'get-tests-
4370: 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 for-run-mindata
4380: 68 65 64 20 28 6c 69 73 74 20 68 65 64 20 74 65 hed (list hed te
4390: 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 stpatt states st
43a0: 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 29 0a atus not-in)))).
43b0: 09 09 09 09 20 20 20 20 20 28 69 66 20 28 6c 69 .... (if (li
43c0: 73 74 3f 20 72 65 73 29 0a 09 09 09 09 09 20 28 st? res)...... (
43d0: 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 28 6d begin...... (m
43e0: 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 75 6c 74 69 utex-lock! multi
43f0: 2d 72 75 6e 2d 6d 75 74 65 78 29 0a 09 09 09 09 -run-mutex).....
4400: 09 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 . (set! result
4410: 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 (append result
4420: 72 65 73 29 29 0a 09 09 09 09 09 20 20 20 28 6d res))...... (m
4430: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 75 6c utex-unlock! mul
4440: 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 29 0a 09 ti-run-mutex))..
4450: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
4460: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
4470: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 65 lt-log-port* "ge
4480: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d t-tests-for-run-
4490: 6d 69 6e 64 61 74 61 20 66 61 69 6c 65 64 20 66 mindata failed f
44a0: 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 64 20 or run-id " hed
44b0: 22 2c 20 74 65 73 74 70 61 74 74 20 22 20 74 65 ", testpatt " te
44c0: 73 74 70 61 74 74 20 22 2c 20 73 74 61 74 65 73 stpatt ", states
44d0: 20 22 20 73 74 61 74 65 73 20 22 2c 20 73 74 61 " states ", sta
44e0: 74 75 73 20 22 20 73 74 61 74 75 73 20 22 2c 20 tus " status ",
44f0: 6e 6f 74 2d 69 6e 20 22 20 6e 6f 74 2d 69 6e 29 not-in " not-in)
4500: 29 29 29 0a 09 09 09 09 20 28 63 6f 6e 63 20 22 )))..... (conc "
4510: 6d 75 6c 74 69 2d 72 75 6e 2d 74 68 72 65 61 64 multi-run-thread
4520: 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 for run-id " he
4530: 64 29 29 29 0a 09 09 20 20 20 20 20 28 6e 65 77 d)))... (new
4540: 74 68 72 65 61 64 73 20 28 63 6f 6e 73 20 6e 65 threads (cons ne
4550: 77 74 68 72 65 61 64 20 74 68 72 65 61 64 73 29 wthread threads)
4560: 29 29 0a 09 09 28 74 68 72 65 61 64 2d 73 74 61 ))...(thread-sta
4570: 72 74 21 20 6e 65 77 74 68 72 65 61 64 29 0a 09 rt! newthread)..
4580: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
4590: 30 2e 30 35 34 29 20 3b 3b 20 67 69 76 65 20 74 0.054) ;; give t
45a0: 68 61 74 20 74 68 72 65 61 64 20 73 6f 6d 65 20 hat thread some
45b0: 74 69 6d 65 20 74 6f 20 73 74 61 72 74 0a 09 09 time to start...
45c0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
45d0: 09 09 20 20 20 20 6e 65 77 74 68 72 65 61 64 73 .. newthreads
45e0: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
45f0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
4600: 6e 65 77 74 68 72 65 61 64 73 29 29 29 29 29 29 newthreads))))))
4610: 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b . result))..;
4620: 3b 20 3b 3b 20 49 44 45 41 3a 20 54 68 72 65 61 ; ;; IDEA: Threa
4630: 64 69 66 79 20 74 68 65 73 65 20 2d 20 74 68 65 dify these - the
4640: 79 20 73 70 65 6e 64 20 61 20 6c 6f 74 20 6f 66 y spend a lot of
4650: 20 74 69 6d 65 20 77 61 69 74 69 6e 67 20 2e 2e time waiting ..
4660: 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 ..;; ;;.;; (defi
4670: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
4680: 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 s-for-runs-minda
4690: 74 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 ta run-ids testp
46a0: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
46b0: 73 20 6e 6f 74 2d 69 6e 29 0a 3b 3b 20 20 20 28 s not-in).;; (
46c0: 6c 65 74 20 28 28 72 75 6e 2d 69 64 2d 6c 69 73 let ((run-id-lis
46d0: 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 3b 3b t (if run-ids.;;
46e0: 20 09 09 09 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 ... run-ids.;;
46f0: 09 09 09 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c ... (rmt:get-all
4700: 2d 72 75 6e 2d 69 64 73 29 29 29 29 0a 3b 3b 20 -run-ids)))).;;
4710: 20 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e (apply appen
4720: 64 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 d (map (lambda (
4730: 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 20 28 run-id).;; ... (
4740: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4750: 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 'get-tests-for-
4760: 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d run-mindata run-
4770: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 73 id (list run-ids
4780: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
4790: 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 status not-in))
47a0: 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 72 75 ).;; .. ru
47b0: 6e 2d 69 64 2d 6c 69 73 74 29 29 29 29 0a 0a 28 n-id-list))))..(
47c0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 define (rmt:dele
47d0: 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 te-test-records
47e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
47f0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4800: 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 74 ive 'delete-test
4810: 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 -records run-id
4820: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
4830: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
4840: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (rmt:test-set-s
4850: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
4860: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 id test-id state
4870: 20 73 74 61 74 75 73 20 6d 73 67 29 0a 20 20 28 status msg). (
4880: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4890: 20 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 'test-set-state
48a0: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 -status run-id (
48b0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
48c0: 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 -id state status
48d0: 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg)))..(define
48e0: 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 (rmt:test-tople
48f0: 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 vel-num-items ru
4900: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
4910: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4920: 69 76 65 20 27 74 65 73 74 2d 74 6f 70 6c 65 76 ive 'test-toplev
4930: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
4940: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4950: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 3b test-name)))..;
4960: 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ; (define (rmt:g
4970: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
4980: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d -run-record run-
4990: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
49a0: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 72 6d m-path).;; (rm
49b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
49c0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
49d0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
49e0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
49f0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4a00: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
4a10: 20 28 72 6d 74 3a 67 65 74 2d 6d 61 74 63 68 69 (rmt:get-matchi
4a20: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
4a30: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e -run-records run
4a40: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4a50: 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a em-path). (rmt:
4a60: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
4a70: 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
4a80: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
4a90: 6f 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 ords run-id (lis
4aa0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
4ab0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
4ac0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
4ad0: 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 st-get-logfile-i
4ae0: 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nfo run-id test-
4af0: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
4b00: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
4b10: 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f get-logfile-info
4b20: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
4b30: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 n-id test-name))
4b40: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4b50: 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 test-get-records
4b60: 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 -for-index-file
4b70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4b80: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
4b90: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
4ba0: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
4bb0: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 28 6c x-file run-id (l
4bc0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
4bd0: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
4be0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e (rmt:get-testin
4bf0: 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 fo-state-status
4c00: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
4c10: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4c20: 69 76 65 20 27 67 65 74 2d 74 65 73 74 69 6e 66 ive 'get-testinf
4c30: 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 o-state-status r
4c40: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
4c50: 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 id test-id)))..(
4c60: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
4c70: 2d 73 65 74 2d 6c 6f 67 21 20 72 75 6e 2d 69 64 -set-log! run-id
4c80: 20 74 65 73 74 2d 69 64 20 6c 6f 67 66 29 0a 20 test-id logf).
4c90: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6c 6f (if (string? lo
4ca0: 67 66 29 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d gf)(rmt:general-
4cb0: 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 6c call 'test-set-l
4cc0: 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 74 og run-id logf t
4cd0: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
4ce0: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
4cf0: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
4d00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4d10: 70 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 pid). (rmt:send
4d20: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 -receive 'test-s
4d30: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
4d40: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
4d50: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 run-id test-id p
4d60: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
4d70: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 rmt:test-get-top
4d80: 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e -process-pid run
4d90: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 -id test-id). (
4da0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4db0: 20 27 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 'test-get-top-p
4dc0: 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 rocess-pid run-i
4dd0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
4de0: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
4df0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d ne (rmt:get-run-
4e00: 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 ids-matching-tar
4e10: 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 get keynames tar
4e20: 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 get res runname
4e30: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 testpatt statepa
4e40: 74 74 20 73 74 61 74 75 73 70 61 74 74 29 0a 20 tt statuspatt).
4e50: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
4e60: 76 65 20 27 67 65 74 2d 72 75 6e 2d 69 64 73 2d ve 'get-run-ids-
4e70: 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 matching-target
4e80: 23 66 20 28 6c 69 73 74 20 6b 65 79 6e 61 6d 65 #f (list keyname
4e90: 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e s target res run
4ea0: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 name testpatt st
4eb0: 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 atepatt statuspa
4ec0: 74 74 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 tt)))..;; NOTE:
4ed0: 54 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e 20 61 This will open a
4ee0: 6e 64 20 61 63 63 65 73 73 20 41 4c 4c 20 72 75 nd access ALL ru
4ef0: 6e 20 64 61 74 61 62 61 73 65 73 2e 20 0a 3b 3b n databases. .;;
4f00: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
4f10: 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
4f20: 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 ching-keynames-t
4f30: 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d arget-new keynam
4f40: 65 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 es target res te
4f50: 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 stpatt statepatt
4f60: 20 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e statuspatt runn
4f70: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 75 ame). (let ((ru
4f80: 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 72 n-ids (rmt:get-r
4f90: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d un-ids-matching-
4fa0: 74 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 target keynames
4fb0: 74 61 72 67 65 74 20 72 65 73 20 72 75 6e 6e 61 target res runna
4fc0: 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 61 74 me testpatt stat
4fd0: 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 epatt statuspatt
4fe0: 29 29 29 0a 20 20 20 20 28 61 70 70 6c 79 20 61 ))). (apply a
4ff0: 70 70 65 6e 64 20 0a 09 20 20 20 28 6d 61 70 20 ppend .. (map
5000: 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 (lambda (run-id)
5010: 0a 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 ... (rmt:send-r
5020: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
5030: 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d -paths-matching-
5040: 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d keynames-target-
5050: 6e 65 77 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 new run-id (list
5060: 20 72 75 6e 2d 69 64 20 6b 65 79 6e 61 6d 65 73 run-id keynames
5070: 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 74 target res test
5080: 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 patt statepatt s
5090: 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 6d tatuspatt runnam
50a0: 65 29 29 29 0a 09 20 20 20 72 75 6e 2d 69 64 73 e))).. run-ids
50b0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
50c0: 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e mt:get-prereqs-n
50d0: 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 ot-met run-id wa
50e0: 69 74 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e itons ref-test-n
50f0: 61 6d 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 ame ref-item-pat
5100: 68 20 23 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 h #!key (mode '(
5110: 6e 6f 72 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 normal))(itemmap
5120: 73 20 23 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 s #f)). (rmt:se
5130: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5140: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
5150: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
5160: 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d -id waitons ref-
5170: 74 65 73 74 2d 6e 61 6d 65 20 72 65 66 2d 69 74 test-name ref-it
5180: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 20 69 74 65 em-path mode ite
5190: 6d 6d 61 70 73 29 29 29 0a 0a 28 64 65 66 69 6e mmaps)))..(defin
51a0: 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 e (rmt:get-count
51b0: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
51c0: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
51d0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
51e0: 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 ceive 'get-count
51f0: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
5200: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
5210: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
5220: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
5230: 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 et-not-completed
5240: 2d 63 6e 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 -cnt run-id). (
5250: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5260: 20 27 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 'get-not-comple
5270: 74 65 64 2d 63 6e 74 20 72 75 6e 2d 69 64 20 28 ted-cnt run-id (
5280: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
5290: 0a 3b 3b 20 53 74 61 74 69 73 74 69 63 61 6c 20 .;; Statistical
52a0: 71 75 65 72 69 65 73 0a 0a 28 64 65 66 69 6e 65 queries..(define
52b0: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d (rmt:get-count-
52c0: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 tests-running ru
52d0: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
52e0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 d-receive 'get-c
52f0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
5300: 6e 67 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ng run-id (list
5310: 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 run-id)))..(defi
5320: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e ne (rmt:get-coun
5330: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
5340: 66 6f 72 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e for-testname run
5350: 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 -id testname).
5360: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5370: 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 e 'get-count-tes
5380: 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 ts-running-for-t
5390: 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 estname run-id (
53a0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
53b0: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
53c0: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d (rmt:get-count-
53d0: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e tests-running-in
53e0: 2d 6a 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 -jobgroup run-id
53f0: 20 6a 6f 62 67 72 6f 75 70 29 0a 20 20 28 72 6d jobgroup). (rm
5400: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5410: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5420: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
5430: 6f 75 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 oup run-id (list
5440: 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 run-id jobgroup
5450: 29 29 29 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e )))..;; state an
5460: 64 20 73 74 61 74 75 73 20 61 72 65 20 65 78 74 d status are ext
5470: 72 61 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 ra hints not usu
5480: 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 ally used in the
5490: 20 63 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a calculation.;;.
54a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 (define (rmt:set
54b0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
54c0: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 d-roll-up-items
54d0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
54e0: 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 item-path state
54f0: 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 status comment)
5500: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5510: 65 69 76 65 20 27 73 65 74 2d 73 74 61 74 65 2d eive 'set-state-
5520: 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d status-and-roll-
5530: 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 up-items run-id
5540: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
5550: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
5560: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 63 6f state status co
5570: 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e mment)))..(defin
5580: 65 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 e (rmt:set-state
5590: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
55a0: 2d 75 70 2d 72 75 6e 20 72 75 6e 2d 69 64 20 73 -up-run run-id s
55b0: 74 61 74 65 20 73 74 61 74 75 73 29 0a 20 20 28 tate status). (
55c0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
55d0: 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 'set-state-stat
55e0: 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 us-and-roll-up-r
55f0: 75 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 un run-id (list
5600: 72 75 6e 2d 69 64 20 73 74 61 74 65 20 73 74 61 run-id state sta
5610: 74 75 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 tus)))...(define
5620: 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 (rmt:update-pas
5630: 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 s-fail-counts ru
5640: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
5650: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
5660: 61 6c 6c 20 27 75 70 64 61 74 65 2d 70 61 73 73 all 'update-pass
5670: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
5680: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 -id test-name te
5690: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
56a0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d e))..(define (rm
56b0: 74 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 t:top-test-set-p
56c0: 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e er-pf-counts run
56d0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
56e0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
56f0: 76 65 20 27 74 6f 70 2d 74 65 73 74 2d 73 65 74 ve 'top-test-set
5700: 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 -per-pf-counts r
5710: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
5720: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a id test-name))).
5730: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
5740: 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 t-raw-run-stats
5750: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
5760: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
5770: 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 -raw-run-stats r
5780: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
5790: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
57a0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 74 69 6d rmt:get-test-tim
57b0: 65 73 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 es runname targe
57c0: 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 t). (rmt:send-r
57d0: 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 eceive 'get-test
57e0: 2d 74 69 6d 65 73 20 23 66 20 28 6c 69 73 74 20 -times #f (list
57f0: 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 20 29 runname target )
5800: 29 29 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )) ..;;=========
5810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5850: 20 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d R U N S.;;====
5860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58a0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ==..(define (rmt
58b0: 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 :get-run-info ru
58c0: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
58d0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 d-receive 'get-r
58e0: 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 un-info run-id (
58f0: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
5900: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
5910: 2d 6e 75 6d 2d 72 75 6e 73 20 72 75 6e 70 61 74 -num-runs runpat
5920: 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 t). (rmt:send-r
5930: 65 63 65 69 76 65 20 27 67 65 74 2d 6e 75 6d 2d eceive 'get-num-
5940: 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 75 runs #f (list ru
5950: 6e 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e npatt)))..(defin
5960: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d e (rmt:get-runs-
5970: 63 6e 74 2d 62 79 2d 70 61 74 74 20 72 75 6e 70 cnt-by-patt runp
5980: 61 74 74 20 74 61 72 67 65 74 70 61 74 74 20 6b att targetpatt k
5990: 65 79 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 eys). (rmt:send
59a0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
59b0: 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 23 ns-cnt-by-patt #
59c0: 66 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 20 f (list runpatt
59d0: 20 74 61 72 67 65 74 70 61 74 74 20 6b 65 79 73 targetpatt keys
59e0: 29 29 29 0a 0a 3b 3b 20 55 73 65 20 74 68 65 20 )))..;; Use the
59f0: 73 70 65 63 69 61 6c 20 72 75 6e 2d 69 64 20 3d special run-id =
5a00: 3d 20 23 66 20 73 63 65 6e 61 72 69 6f 20 68 65 = #f scenario he
5a10: 72 65 20 73 69 6e 63 65 20 74 68 65 72 65 20 69 re since there i
5a20: 73 20 6e 6f 20 72 75 6e 20 79 65 74 0a 28 64 65 s no run yet.(de
5a30: 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 69 73 74 fine (rmt:regist
5a40: 65 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 er-run keyvals r
5a50: 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 unname state sta
5a60: 74 75 73 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 tus user contour
5a70: 29 0a 20 20 3b 3b 20 66 69 72 73 74 20 72 65 67 ). ;; first reg
5a80: 69 73 74 65 72 20 69 6e 20 6d 61 69 6e 2e 64 62 ister in main.db
5a90: 20 28 74 68 75 73 20 74 68 65 20 23 66 29 0a 20 (thus the #f).
5aa0: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 (let* ((run-id
5ab0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5ac0: 65 20 27 72 65 67 69 73 74 65 72 2d 72 75 6e 20 e 'register-run
5ad0: 23 66 20 28 6c 69 73 74 20 6b 65 79 76 61 6c 73 #f (list keyvals
5ae0: 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 runname state s
5af0: 74 61 74 75 73 20 75 73 65 72 20 63 6f 6e 74 6f tatus user conto
5b00: 75 72 29 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f ur)))). ;; no
5b10: 77 20 72 65 67 69 73 74 65 72 20 69 6e 20 74 68 w register in th
5b20: 65 20 72 75 6e 20 64 62 20 69 74 73 65 6c 66 0a e run db itself.
5b30: 0a 20 20 20 20 3b 3b 20 4e 45 45 44 20 41 20 52 . ;; NEED A R
5b40: 45 43 4f 52 44 20 49 4e 53 45 52 54 20 49 4e 43 ECORD INSERT INC
5b50: 4c 55 44 49 4e 47 20 53 45 54 54 49 4e 47 20 69 LUDING SETTING i
5b60: 64 0a 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d d. (rmt:send-
5b70: 72 65 63 65 69 76 65 20 27 72 65 67 69 73 74 65 receive 'registe
5b80: 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 28 6c 69 r-run run-id (li
5b90: 73 74 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 st keyvals runna
5ba0: 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 me state status
5bb0: 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 29 0a 20 user contour)).
5bc0: 20 20 20 0a 20 20 20 20 72 75 6e 2d 69 64 29 29 . run-id))
5bd0: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 . .(define (rmt
5be0: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
5bf0: 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 om-id run-id).
5c00: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5c10: 65 20 27 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d e 'get-run-name-
5c20: 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 20 28 from-id run-id (
5c30: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
5c40: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c (define (rmt:del
5c50: 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 29 0a ete-run run-id).
5c60: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5c70: 69 76 65 20 27 64 65 6c 65 74 65 2d 72 75 6e 20 ive 'delete-run
5c80: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
5c90: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
5ca0: 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d (rmt:update-run-
5cb0: 73 74 61 74 73 20 72 75 6e 2d 69 64 20 73 74 61 stats run-id sta
5cc0: 74 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ts). (rmt:send-
5cd0: 72 65 63 65 69 76 65 20 27 75 70 64 61 74 65 2d receive 'update-
5ce0: 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 6c 69 run-stats #f (li
5cf0: 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 73 29 st run-id stats)
5d00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5d10: 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 :delete-old-dele
5d20: 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ted-test-records
5d30: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5d40: 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d 6f 6c ceive 'delete-ol
5d50: 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 d-deleted-test-r
5d60: 65 63 6f 72 64 73 20 23 66 20 27 28 29 29 29 0a ecords #f '())).
5d70: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
5d80: 74 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 20 63 t-runs runpatt c
5d90: 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b 65 79 70 ount offset keyp
5da0: 61 74 74 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e atts). (rmt:sen
5db0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 d-receive 'get-r
5dc0: 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e uns #f (list run
5dd0: 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 patt count offse
5de0: 74 20 6b 65 79 70 61 74 74 73 29 29 29 0a 0a 28 t keypatts)))..(
5df0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 69 6d 70 define (rmt:simp
5e00: 6c 65 2d 67 65 74 2d 72 75 6e 73 20 72 75 6e 70 le-get-runs runp
5e10: 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 att count offset
5e20: 20 74 61 72 67 65 74 20 6c 61 73 74 2d 75 70 64 target last-upd
5e30: 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ate). (rmt:send
5e40: 2d 72 65 63 65 69 76 65 20 27 73 69 6d 70 6c 65 -receive 'simple
5e50: 2d 67 65 74 2d 72 75 6e 73 20 23 66 20 28 6c 69 -get-runs #f (li
5e60: 73 74 20 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 st runpatt count
5e70: 20 6f 66 66 73 65 74 20 74 61 72 67 65 74 20 6c offset target l
5e80: 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a 0a 28 ast-update)))..(
5e90: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
5ea0: 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 0a 20 20 28 all-run-ids). (
5eb0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5ec0: 20 27 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 'get-all-run-id
5ed0: 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 s #f '()))..(def
5ee0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 ine (rmt:get-pre
5ef0: 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 v-run-ids run-id
5f00: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5f10: 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 76 2d ceive 'get-prev-
5f20: 72 75 6e 2d 69 64 73 20 23 66 20 28 6c 69 73 74 run-ids #f (list
5f30: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
5f40: 69 6e 65 20 28 72 6d 74 3a 6c 6f 63 6b 2f 75 6e ine (rmt:lock/un
5f50: 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d 69 64 20 lock-run run-id
5f60: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
5f70: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5f80: 63 65 69 76 65 20 27 6c 6f 63 6b 2f 75 6e 6c 6f ceive 'lock/unlo
5f90: 63 6b 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 20 ck-run #f (list
5fa0: 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
5fb0: 63 6b 20 75 73 65 72 29 29 29 0a 0a 3b 3b 20 73 ck user)))..;; s
5fc0: 65 74 2f 67 65 74 20 73 74 61 74 75 73 0a 28 64 et/get status.(d
5fd0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
5fe0: 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 un-status run-id
5ff0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6000: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 ceive 'get-run-s
6010: 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 tatus #f (list r
6020: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
6030: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 e (rmt:get-run-s
6040: 74 61 74 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 tate run-id). (
6050: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6060: 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 20 'get-run-state
6070: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
6080: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6090: 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 :set-run-status
60a0: 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 run-id run-statu
60b0: 73 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 s #!key (msg #f)
60c0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
60d0: 63 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 ceive 'set-run-s
60e0: 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 tatus #f (list r
60f0: 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 un-id run-status
6100: 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg)))..(define
6110: 20 28 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 74 (rmt:set-run-st
6120: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
6130: 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 29 d state status )
6140: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6150: 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 74 eive 'set-run-st
6160: 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 28 6c ate-status #f (l
6170: 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 65 ist run-id state
6180: 20 73 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 status)))..(def
6190: 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 74 65 2d ine (rmt:update-
61a0: 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 70 69 6c tesdata-on-repil
61b0: 63 61 74 65 2d 64 62 20 6f 6c 64 2d 6c 74 20 6e cate-db old-lt n
61c0: 65 77 2d 6c 74 29 0a 28 72 6d 74 3a 73 65 6e 64 ew-lt).(rmt:send
61d0: 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 74 65 -receive 'update
61e0: 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 70 69 -tesdata-on-repi
61f0: 6c 63 61 74 65 2d 64 62 20 23 66 20 28 6c 69 73 lcate-db #f (lis
6200: 74 20 6f 6c 64 2d 6c 74 20 6e 65 77 2d 6c 74 29 t old-lt new-lt)
6210: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6220: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e :update-run-even
6230: 74 5f 74 69 6d 65 20 72 75 6e 2d 69 64 29 0a 20 t_time run-id).
6240: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6250: 76 65 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 65 ve 'update-run-e
6260: 76 65 6e 74 5f 74 69 6d 65 20 23 66 20 28 6c 69 vent_time #f (li
6270: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
6280: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
6290: 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 uns-by-patt key
62a0: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 s runnamepatt ta
62b0: 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c 69 rgpatt offset li
62c0: 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 2d mit fields last-
62d0: 72 75 6e 73 2d 75 70 64 61 74 65 20 20 23 21 6b runs-update #!k
62e0: 65 79 20 20 28 73 6f 72 74 2d 6f 72 64 65 72 20 ey (sort-order
62f0: 22 61 73 63 22 29 29 20 3b 3b 20 66 69 65 6c 64 "asc")) ;; field
6300: 73 20 6f 66 20 23 66 20 75 73 65 73 20 64 65 66 s of #f uses def
6310: 61 75 6c 74 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ault. (rmt:send
6320: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
6330: 6e 73 2d 62 79 2d 70 61 74 74 20 23 66 20 28 6c ns-by-patt #f (l
6340: 69 73 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 ist keys runname
6350: 70 61 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 patt targpatt of
6360: 66 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 fset limit field
6370: 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 70 64 61 s last-runs-upda
6380: 74 65 20 73 6f 72 74 2d 6f 72 64 65 72 29 29 29 te sort-order)))
6390: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 66 ..(define (rmt:f
63a0: 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 ind-and-mark-inc
63b0: 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f omplete run-id o
63c0: 76 72 2d 64 65 61 64 74 69 6d 65 29 0a 20 20 3b vr-deadtime). ;
63d0: 3b 20 28 69 66 20 28 72 6d 74 3a 73 65 6e 64 2d ; (if (rmt:send-
63e0: 72 65 63 65 69 76 65 20 27 68 61 76 65 2d 69 6e receive 'have-in
63f0: 63 6f 6d 70 6c 65 74 65 73 3f 20 72 75 6e 2d 69 completes? run-i
6400: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f d (list run-id o
6410: 76 72 2d 64 65 61 64 74 69 6d 65 29 29 0a 20 20 vr-deadtime)).
6420: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6430: 65 20 27 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 e 'mark-incomple
6440: 74 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 te run-id (list
6450: 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 run-id ovr-deadt
6460: 69 6d 65 29 29 0a 20 20 29 20 3b 3b 20 29 0a 0a ime)). ) ;; )..
6470: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6480: 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 74 73 20 -main-run-stats
6490: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
64a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
64b0: 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 74 73 20 -main-run-stats
64c0: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
64d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
64e0: 3a 67 65 74 2d 76 61 72 20 76 61 72 6e 61 6d 65 :get-var varname
64f0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6500: 63 65 69 76 65 20 27 67 65 74 2d 76 61 72 20 23 ceive 'get-var #
6510: 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 f (list varname)
6520: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6530: 3a 64 65 6c 2d 76 61 72 20 76 61 72 6e 61 6d 65 :del-var varname
6540: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6550: 63 65 69 76 65 20 27 64 65 6c 2d 76 61 72 20 23 ceive 'del-var #
6560: 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 f (list varname)
6570: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6580: 3a 73 65 74 2d 76 61 72 20 76 61 72 6e 61 6d 65 :set-var varname
6590: 20 76 61 6c 75 65 29 0a 20 20 28 72 6d 74 3a 73 value). (rmt:s
65a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 end-receive 'set
65b0: 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 -var #f (list va
65c0: 72 6e 61 6d 65 20 76 61 6c 75 65 29 29 29 0a 0a rname value)))..
65d0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 69 6e 63 (define (rmt:inc
65e0: 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 20 -var varname).
65f0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6600: 65 20 27 69 6e 63 2d 76 61 72 20 23 66 20 28 6c e 'inc-var #f (l
6610: 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a 0a ist varname)))..
6620: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 63 (define (rmt:dec
6630: 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 20 -var varname).
6640: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6650: 65 20 27 64 65 63 2d 76 61 72 20 23 66 20 28 6c e 'dec-var #f (l
6660: 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a 0a ist varname)))..
6670: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 64 64 (define (rmt:add
6680: 2d 76 61 72 20 76 61 72 6e 61 6d 65 20 76 61 6c -var varname val
6690: 75 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ue). (rmt:send-
66a0: 72 65 63 65 69 76 65 20 27 61 64 64 2d 76 61 72 receive 'add-var
66b0: 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d #f (list varnam
66c0: 65 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 3d 3d e value)))..;;==
66d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6710: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4c 20 54 20 ====.;; M U L T
6720: 49 20 52 20 55 20 4e 20 20 20 51 20 55 20 45 20 I R U N Q U E
6730: 52 20 49 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d R I E S.;;======
6740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6780: 0a 0a 3b 3b 20 4e 65 65 64 20 74 6f 20 6d 6f 76 ..;; Need to mov
6790: 65 20 74 68 69 73 20 74 6f 20 6d 75 6c 74 69 2d e this to multi-
67a0: 72 75 6e 20 73 65 63 74 69 6f 6e 20 61 6e 64 20 run section and
67b0: 6d 61 6b 65 20 61 73 73 6f 63 69 61 74 65 64 20 make associated
67c0: 63 68 61 6e 67 65 73 0a 28 64 65 66 69 6e 65 20 changes.(define
67d0: 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 (rmt:find-and-ma
67e0: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 6c rk-incomplete-al
67f0: 6c 2d 72 75 6e 73 20 23 21 6b 65 79 20 28 6f 76 l-runs #!key (ov
6800: 72 2d 64 65 61 64 74 69 6d 65 20 23 66 29 29 0a r-deadtime #f)).
6810: 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 (let ((run-ids
6820: 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 (rmt:get-all-ru
6830: 6e 2d 69 64 73 29 29 29 0a 20 20 20 20 28 66 6f n-ids))). (fo
6840: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
6850: 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 20 20 run-id)..
6860: 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 (rmt:find-and-ma
6870: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 rk-incomplete ru
6880: 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 6d n-id ovr-deadtim
6890: 65 29 29 0a 09 20 20 20 20 20 72 75 6e 2d 69 64 e)).. run-id
68a0: 73 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 s)))..;; get the
68b0: 20 70 72 65 76 69 6f 75 73 20 72 65 63 6f 72 64 previous record
68c0: 20 66 6f 72 20 77 68 65 6e 20 74 68 69 73 20 74 for when this t
68d0: 65 73 74 20 77 61 73 20 72 75 6e 20 77 68 65 72 est was run wher
68e0: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
68f0: 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b 20 but runname.;;
6900: 72 65 74 75 72 6e 73 20 23 66 20 69 66 20 6e 6f returns #f if no
6910: 20 73 75 63 68 20 74 65 73 74 20 66 6f 75 6e 64 such test found
6920: 2c 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 , returns a sing
6930: 6c 65 20 74 65 73 74 20 72 65 63 6f 72 64 20 69 le test record i
6940: 66 20 66 6f 75 6e 64 0a 3b 3b 20 0a 3b 3b 20 52 f found.;; .;; R
6950: 75 6e 20 74 68 69 73 20 61 74 20 74 68 65 20 63 un this at the c
6960: 6c 69 65 6e 74 20 65 6e 64 20 73 69 6e 63 65 20 lient end since
6970: 77 65 20 68 61 76 65 20 74 6f 20 63 6f 6e 6e 65 we have to conne
6980: 63 74 20 74 6f 20 6d 75 6c 74 69 70 6c 65 20 72 ct to multiple r
6990: 75 6e 2d 69 64 20 64 62 73 0a 3b 3b 0a 28 64 65 un-id dbs.;;.(de
69a0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 fine (rmt:get-pr
69b0: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
69c0: 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 65 record run-id te
69d0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
69e0: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 h). (let* ((key
69f0: 76 61 6c 73 20 28 72 6d 74 3a 67 65 74 2d 6b 65 vals (rmt:get-ke
6a00: 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d y-val-pairs run-
6a10: 69 64 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 id)).. (keys
6a20: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
6a30: 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 69 . (selstr (stri
6a40: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 20 ng-intersperse
6a50: 6b 65 79 73 20 22 2c 22 29 29 0a 09 20 28 71 72 keys ",")).. (qr
6a60: 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e ystr (string-in
6a70: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
6a80: 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 20 lambda (x)(conc
6a90: 78 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 x "=?")) keys) "
6aa0: 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 69 AND "))). (i
6ab0: 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 29 0a f (not keyvals).
6ac0: 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 65 76 .#f..(let ((prev
6ad0: 2d 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 -run-ids (rmt:ge
6ae0: 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 72 t-prev-run-ids r
6af0: 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 66 un-id))).. ;; f
6b00: 6f 72 20 65 61 63 68 20 72 75 6e 20 73 74 61 72 or each run star
6b10: 74 69 6e 67 20 77 69 74 68 20 74 68 65 20 6d 6f ting with the mo
6b20: 73 74 20 72 65 63 65 6e 74 20 6c 6f 6f 6b 20 74 st recent look t
6b30: 6f 20 73 65 65 20 69 66 20 74 68 65 72 65 20 69 o see if there i
6b40: 73 20 61 20 6d 61 74 63 68 69 6e 67 20 74 65 73 s a matching tes
6b50: 74 0a 09 20 20 3b 3b 20 69 66 20 66 6f 75 6e 64 t.. ;; if found
6b60: 20 74 68 65 6e 20 72 65 74 75 72 6e 20 74 68 61 then return tha
6b70: 74 20 6d 61 74 63 68 69 6e 67 20 74 65 73 74 20 t matching test
6b80: 72 65 63 6f 72 64 0a 09 20 20 28 64 65 62 75 67 record.. (debug
6b90: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
6ba0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 6c t-log-port* "sel
6bb0: 73 74 72 3a 20 22 20 73 65 6c 73 74 72 20 22 2c str: " selstr ",
6bc0: 20 71 72 79 73 74 72 3a 20 22 20 71 72 79 73 74 qrystr: " qryst
6bd0: 72 20 22 2c 20 6b 65 79 76 61 6c 73 3a 20 22 20 r ", keyvals: "
6be0: 6b 65 79 76 61 6c 73 20 22 2c 20 70 72 65 76 69 keyvals ", previ
6bf0: 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f 75 6e ous run ids foun
6c00: 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d 69 64 d: " prev-run-id
6c10: 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f s).. (if (null?
6c20: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 23 prev-run-ids) #
6c30: 66 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f f.. (let lo
6c40: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 70 72 op ((hed (car pr
6c50: 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a 09 09 09 ev-run-ids))....
6c60: 20 28 74 61 6c 20 28 63 64 72 20 70 72 65 76 2d (tal (cdr prev-
6c70: 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 28 6c 65 run-ids)))...(le
6c80: 74 20 28 28 72 65 73 75 6c 74 73 20 28 72 6d 74 t ((results (rmt
6c90: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
6ca0: 75 6e 20 68 65 64 20 28 63 6f 6e 63 20 74 65 73 un hed (conc tes
6cb0: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
6cc0: 70 61 74 68 29 20 27 28 29 20 27 28 29 20 3b 3b path) '() '() ;;
6cd0: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
6ce0: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
6cf0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
6d00: 23 66 20 23 66 20 20 20 20 20 20 20 20 20 20 20 #f #f
6d10: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 20 6c 69 ;; offset li
6d20: 6d 69 74 20 6e 6f 74 2d 69 6e 20 68 69 64 65 2f mit not-in hide/
6d30: 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 09 09 20 not-hide.......
6d40: 20 20 20 20 20 23 66 20 23 66 20 23 66 20 23 66 #f #f #f #f
6d50: 20 27 6e 6f 72 6d 61 6c 29 29 29 20 3b 3b 20 73 'normal))) ;; s
6d60: 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 ort-by sort-orde
6d70: 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 r qryvals last-u
6d80: 70 64 61 74 65 20 6d 6f 64 65 0a 09 09 20 20 28 pdate mode... (
6d90: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
6da0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6db0: 20 22 47 6f 74 20 74 65 73 74 73 20 66 6f 72 20 "Got tests for
6dc0: 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 run-id " run-id
6dd0: 22 2c 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 74 ", test-name " t
6de0: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
6df0: 2d 70 61 74 68 20 22 20 69 74 65 6d 2d 70 61 74 -path " item-pat
6e00: 68 20 22 3a 20 22 20 72 65 73 75 6c 74 73 29 0a h ": " results).
6e10: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 .. (if (and (nu
6e20: 6c 6c 3f 20 72 65 73 75 6c 74 73 29 0a 09 09 09 ll? results)....
6e30: 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 (not (null? t
6e40: 61 6c 29 29 29 0a 09 09 20 20 20 20 20 20 28 6c al)))... (l
6e50: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
6e60: 72 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 20 r tal))...
6e70: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 75 6c (if (null? resul
6e80: 74 73 29 20 23 66 0a 09 09 09 20 20 28 63 61 72 ts) #f.... (car
6e90: 20 72 65 73 75 6c 74 73 29 29 29 29 29 29 29 29 results))))))))
6ea0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6eb0: 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 29 0a :get-run-stats).
6ec0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6ed0: 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 ive 'get-run-sta
6ee0: 74 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d ts #f '()))..;;=
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 20 45 20 =====.;; S T E
6f40: 50 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d P S.;;==========
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
6f90: 20 47 65 74 74 69 6e 67 20 73 74 65 70 73 20 69 Getting steps i
6fa0: 73 20 6d 6f 72 65 20 63 6f 6d 70 6c 69 63 61 74 s more complicat
6fb0: 65 64 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 67 69 76 ed..;;.;; If giv
6fc0: 65 6e 20 77 6f 72 6b 20 61 72 65 61 20 0a 3b 3b en work area .;;
6fd0: 20 20 31 2e 20 46 69 6e 64 20 74 68 65 20 74 65 1. Find the te
6fe0: 73 74 64 61 74 2e 64 62 20 66 69 6c 65 0a 3b 3b stdat.db file.;;
6ff0: 20 20 32 2e 20 4f 70 65 6e 20 74 68 65 20 74 65 2. Open the te
7000: 73 74 64 61 74 2e 64 62 20 66 69 6c 65 20 61 6e stdat.db file an
7010: 64 20 64 6f 20 74 68 65 20 71 75 65 72 79 0a 3b d do the query.;
7020: 3b 20 49 66 20 6e 6f 74 20 67 69 76 65 6e 20 74 ; If not given t
7030: 68 65 20 77 6f 72 6b 20 61 72 65 61 0a 3b 3b 20 he work area.;;
7040: 20 31 2e 20 44 6f 20 61 20 72 65 6d 6f 74 65 20 1. Do a remote
7050: 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 68 65 20 call to get the
7060: 74 65 73 74 20 70 61 74 68 0a 3b 3b 20 20 32 2e test path.;; 2.
7070: 20 43 6f 6e 74 69 6e 75 65 20 61 73 20 61 62 6f Continue as abo
7080: 76 65 0a 3b 3b 20 0a 3b 3b 28 64 65 66 69 6e 65 ve.;; .;;(define
7090: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
70a0: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
70b0: 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 28 72 6d test-id).;; (rm
70c0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
70d0: 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 20 72 get-steps-data r
70e0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 74 un-id (list test
70f0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
7100: 28 72 6d 74 3a 74 65 73 74 73 74 65 70 2d 73 65 (rmt:teststep-se
7110: 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 t-status! run-id
7120: 20 74 65 73 74 2d 69 64 20 74 65 73 74 73 74 65 test-id testste
7130: 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e 20 p-name state-in
7140: 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e status-in commen
7150: 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 6c 65 t logfile). (le
7160: 74 2a 20 28 28 73 74 61 74 65 20 20 20 20 20 28 t* ((state (
7170: 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c 69 items:check-vali
7180: 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 22 20 d-items "state"
7190: 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 28 73 74 state-in)).. (st
71a0: 61 74 75 73 20 20 20 20 28 69 74 65 6d 73 3a 63 atus (items:c
71b0: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
71c0: 20 22 73 74 61 74 75 73 22 20 73 74 61 74 75 73 "status" status
71d0: 2d 69 6e 29 29 29 0a 20 20 20 20 28 69 66 20 28 -in))). (if (
71e0: 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 29 28 6e or (not state)(n
71f0: 6f 74 20 73 74 61 74 75 73 29 29 0a 09 28 64 65 ot status))..(de
7200: 62 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 bug:print 3 *def
7210: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7220: 57 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 64 WARNING: Invalid
7230: 20 22 20 28 69 66 20 73 74 61 74 75 73 20 22 73 " (if status "s
7240: 74 61 74 75 73 22 20 22 73 74 61 74 65 22 29 0a tatus" "state").
7250: 09 09 20 20 20 20 20 22 20 76 61 6c 75 65 20 5c .. " value \
7260: 22 22 20 28 69 66 20 73 74 61 74 75 73 20 73 74 "" (if status st
7270: 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e ate-in status-in
7280: 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 79 6f ) "\", update yo
7290: 75 72 20 76 61 6c 69 64 76 61 6c 75 65 73 20 73 ur validvalues s
72a0: 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 74 65 ection in megate
72b0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 20 st.config")).
72c0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
72d0: 76 65 20 27 74 65 73 74 73 74 65 70 2d 73 65 74 ve 'teststep-set
72e0: 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 -status! run-id
72f0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
7300: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
7310: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
7320: 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f us-in comment lo
7330: 67 66 69 6c 65 29 29 29 29 0a 0a 0a 28 64 65 66 gfile))))...(def
7340: 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d ine (rmt:delete-
7350: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 21 20 steps-for-test!
7360: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
7370: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7380: 69 76 65 20 27 64 65 6c 65 74 65 2d 73 74 65 70 ive 'delete-step
7390: 73 2d 66 6f 72 2d 74 65 73 74 21 20 72 75 6e 2d s-for-test! run-
73a0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
73b0: 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 test-id)))..(def
73c0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 ine (rmt:get-ste
73d0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
73e0: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 id test-id). (r
73f0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7400: 27 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 'get-steps-for-t
7410: 65 73 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 est run-id (list
7420: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
7430: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7440: 3a 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d :get-steps-info-
7450: 62 79 2d 69 64 20 74 65 73 74 2d 73 74 65 70 2d by-id test-step-
7460: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
7470: 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 receive 'get-ste
7480: 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 66 ps-info-by-id #f
7490: 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 65 70 (list test-step
74a0: 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d -id)))..;;======
74b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74f0: 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 20 20 44 .;; T E S T D
7500: 20 41 20 54 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d 3d A T A .;;======
7510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7550: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 ..(define (rmt:r
7560: 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 72 75 ead-test-data ru
7570: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 n-id test-id cat
7580: 65 67 6f 72 79 70 61 74 74 20 23 21 6b 65 79 20 egorypatt #!key
7590: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 20 (work-area #f))
75a0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
75b0: 65 69 76 65 20 27 72 65 61 64 2d 74 65 73 74 2d eive 'read-test-
75c0: 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 data run-id (lis
75d0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
75e0: 20 63 61 74 65 67 6f 72 79 70 61 74 74 29 29 29 categorypatt)))
75f0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 ..(define (rmt:r
7600: 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 ead-test-data-va
7610: 72 70 61 74 74 20 72 75 6e 2d 69 64 20 74 65 73 rpatt run-id tes
7620: 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 t-id categorypat
7630: 74 20 76 61 72 70 61 74 74 20 23 21 6b 65 79 20 t varpatt #!key
7640: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 20 (work-area #f))
7650: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
7660: 65 69 76 65 20 27 72 65 61 64 2d 74 65 73 74 2d eive 'read-test-
7670: 64 61 74 61 2d 76 61 72 70 61 74 74 20 72 75 6e data-varpatt run
7680: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7690: 20 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 test-id categor
76a0: 79 70 61 74 74 20 76 61 72 70 61 74 74 29 29 29 ypatt varpatt)))
76b0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
76c0: 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 62 79 2d et-data-info-by-
76d0: 69 64 20 74 65 73 74 2d 64 61 74 61 2d 69 64 29 id test-data-id)
76e0: 0a 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 . (rmt:send-re
76f0: 63 65 69 76 65 20 27 67 65 74 2d 64 61 74 61 2d ceive 'get-data-
7700: 69 6e 66 6f 2d 62 79 2d 69 64 20 23 66 20 28 6c info-by-id #f (l
7710: 69 73 74 20 74 65 73 74 2d 64 61 74 61 2d 69 64 ist test-data-id
7720: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
7730: 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 t:testmeta-add-r
7740: 65 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 29 0a ecord testname).
7750: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7760: 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d 61 64 ive 'testmeta-ad
7770: 64 2d 72 65 63 6f 72 64 20 23 66 20 28 6c 69 73 d-record #f (lis
7780: 74 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 0a 28 t testname)))..(
7790: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
77a0: 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 meta-get-record
77b0: 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 testname). (rmt
77c0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
77d0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
77e0: 72 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 rd #f (list test
77f0: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
7800: 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 75 (rmt:testmeta-u
7810: 70 64 61 74 65 2d 66 69 65 6c 64 20 74 65 73 74 pdate-field test
7820: 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 0a 20 -name fld val).
7830: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7840: 76 65 20 27 74 65 73 74 6d 65 74 61 2d 75 70 64 ve 'testmeta-upd
7850: 61 74 65 2d 66 69 65 6c 64 20 23 66 20 28 6c 69 ate-field #f (li
7860: 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 st test-name fld
7870: 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 val)))..(define
7880: 20 28 72 6d 74 3a 74 65 73 74 2d 64 61 74 61 2d (rmt:test-data-
7890: 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 74 65 rollup run-id te
78a0: 73 74 2d 69 64 20 73 74 61 74 75 73 29 0a 20 20 st-id status).
78b0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
78c0: 65 20 27 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c e 'test-data-rol
78d0: 6c 75 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 lup run-id (list
78e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
78f0: 73 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 status)))..(defi
7900: 6e 65 20 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 ne (rmt:csv->tes
7910: 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 t-data run-id te
7920: 73 74 2d 69 64 20 63 73 76 64 61 74 61 29 0a 20 st-id csvdata).
7930: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7940: 76 65 20 27 63 73 76 2d 3e 74 65 73 74 2d 64 61 ve 'csv->test-da
7950: 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ta run-id (list
7960: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 run-id test-id c
7970: 73 76 64 61 74 61 29 29 29 0a 0a 3b 3b 3d 3d 3d svdata)))..;;===
7980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79c0: 3d 3d 3d 0a 3b 3b 20 20 54 20 41 20 53 20 4b 20 ===.;; T A S K
79d0: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
79e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
7a20: 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 66 ine (rmt:tasks-f
7a30: 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 ind-task-queue-r
7a40: 65 63 6f 72 64 73 20 74 61 72 67 65 74 20 72 75 ecords target ru
7a50: 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 n-name test-patt
7a60: 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 state-patt acti
7a70: 6f 6e 2d 70 61 74 74 29 0a 20 20 28 72 6d 74 3a on-patt). (rmt:
7a80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 66 69 send-receive 'fi
7a90: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
7aa0: 63 6f 72 64 73 20 23 66 20 28 6c 69 73 74 20 74 cords #f (list t
7ab0: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 arget run-name t
7ac0: 65 73 74 2d 70 61 74 74 20 73 74 61 74 65 2d 70 est-patt state-p
7ad0: 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 att action-patt)
7ae0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7af0: 3a 74 61 73 6b 73 2d 61 64 64 20 61 63 74 69 6f :tasks-add actio
7b00: 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 72 n owner target r
7b10: 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 unname testpatt
7b20: 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 params). (rmt:s
7b30: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 end-receive 'tas
7b40: 6b 73 2d 61 64 64 20 23 66 20 28 6c 69 73 74 20 ks-add #f (list
7b50: 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 action owner tar
7b60: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
7b70: 70 61 74 74 20 70 61 72 61 6d 73 29 29 29 0a 0a patt params)))..
7b80: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 (define (rmt:tas
7b90: 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 ks-set-state-giv
7ba0: 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 70 61 72 en-param-key par
7bb0: 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 am-key new-state
7bc0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7bd0: 63 65 69 76 65 20 27 74 61 73 6b 73 2d 73 65 74 ceive 'tasks-set
7be0: 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 -state-given-par
7bf0: 61 6d 2d 6b 65 79 20 23 66 20 28 6c 69 73 74 20 am-key #f (list
7c00: 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 param-key new-s
7c10: 74 61 74 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 tate)))..(define
7c20: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 67 65 74 2d (rmt:tasks-get-
7c30: 6c 61 73 74 20 74 61 72 67 65 74 20 72 75 6e 6e last target runn
7c40: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
7c50: 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b 73 2d -receive 'tasks-
7c60: 67 65 74 2d 6c 61 73 74 20 23 66 20 28 6c 69 73 get-last #f (lis
7c70: 74 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 t target runname
7c80: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
7c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
7cd0: 20 4e 20 4f 20 20 20 53 20 59 20 4e 20 43 20 20 N O S Y N C
7ce0: 20 44 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d D B .;;========
7cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
7d30: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6e 6f 2d (define (rmt:no-
7d40: 73 79 6e 63 2d 73 65 74 20 76 61 72 20 76 61 6c sync-set var val
7d50: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7d60: 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e 63 2d 73 ceive 'no-sync-s
7d70: 65 74 20 23 66 20 60 28 2c 76 61 72 20 2c 76 61 et #f `(,var ,va
7d80: 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 l)))..(define (r
7d90: 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 mt:no-sync-get/d
7da0: 65 66 61 75 6c 74 20 76 61 72 20 64 65 66 61 75 efault var defau
7db0: 6c 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d lt). (rmt:send-
7dc0: 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e 63 receive 'no-sync
7dd0: 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 23 66 20 -get/default #f
7de0: 60 28 2c 76 61 72 20 2c 64 65 66 61 75 6c 74 29 `(,var ,default)
7df0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7e00: 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 76 61 :no-sync-del! va
7e10: 72 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 r). (rmt:send-r
7e20: 65 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e 63 2d eceive 'no-sync-
7e30: 64 65 6c 21 20 23 66 20 60 28 2c 76 61 72 29 29 del! #f `(,var))
7e40: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
7e50: 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
7e60: 20 6b 65 79 6e 61 6d 65 29 0a 20 20 28 72 6d 74 keyname). (rmt
7e70: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e :send-receive 'n
7e80: 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 o-sync-get-lock
7e90: 23 66 20 60 28 2c 6b 65 79 6e 61 6d 65 29 29 29 #f `(,keyname)))
7ea0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
7eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 ==========.;; A
7ef0: 52 20 43 20 48 20 49 20 56 20 45 20 53 0a 3b 3b R C H I V E S.;;
7f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f40: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
7f50: 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 67 65 74 (rmt:archive-get
7f60: 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 20 74 65 -allocations te
7f70: 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 20 stname itempath
7f80: 64 6e 65 65 64 65 64 29 0a 20 20 28 72 6d 74 3a dneeded). (rmt:
7f90: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 send-receive 'ar
7fa0: 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 chive-get-alloca
7fb0: 74 69 6f 6e 73 20 23 66 20 28 6c 69 73 74 20 74 tions #f (list t
7fc0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
7fd0: 20 64 6e 65 65 64 65 64 29 29 29 0a 0a 28 64 65 dneeded)))..(de
7fe0: 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 fine (rmt:archiv
7ff0: 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b e-register-block
8000: 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 69 64 20 61 -name bdisk-id a
8010: 72 63 68 69 76 65 2d 70 61 74 68 29 0a 20 20 28 rchive-path). (
8020: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8030: 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 'archive-regist
8040: 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 23 66 er-block-name #f
8050: 20 28 6c 69 73 74 20 62 64 69 73 6b 2d 69 64 20 (list bdisk-id
8060: 61 72 63 68 69 76 65 2d 70 61 74 68 29 29 29 0a archive-path))).
8070: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 .(define (rmt:ar
8080: 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 2d 74 chive-allocate-t
8090: 65 73 74 73 75 69 74 65 2f 61 72 65 61 2d 74 6f estsuite/area-to
80a0: 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 2d 69 64 20 -block block-id
80b0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 61 testsuite-name a
80c0: 72 65 61 6b 65 79 29 0a 20 20 28 72 6d 74 3a 73 reakey). (rmt:s
80d0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 63 end-receive 'arc
80e0: 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 2d 74 65 hive-allocate-te
80f0: 73 74 2d 74 6f 2d 62 6c 6f 63 6b 20 23 66 20 28 st-to-block #f (
8100: 6c 69 73 74 20 20 62 6c 6f 63 6b 2d 69 64 20 74 list block-id t
8110: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 61 72 estsuite-name ar
8120: 65 61 6b 65 79 29 29 29 0a 0a 28 64 65 66 69 6e eakey)))..(defin
8130: 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 72 e (rmt:archive-r
8140: 65 67 69 73 74 65 72 2d 64 69 73 6b 20 62 64 69 egister-disk bdi
8150: 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 61 sk-name bdisk-pa
8160: 74 68 20 64 66 29 0a 20 20 28 72 6d 74 3a 73 65 th df). (rmt:se
8170: 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 63 68 nd-receive 'arch
8180: 69 76 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 ive-register-dis
8190: 6b 20 23 66 20 28 6c 69 73 74 20 62 64 69 73 6b k #f (list bdisk
81a0: 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 61 74 68 -name bdisk-path
81b0: 20 64 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 df)))..(define
81c0: 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 61 72 (rmt:test-set-ar
81d0: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 72 chive-block-id r
81e0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 61 72 un-id test-id ar
81f0: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 0a chive-block-id).
8200: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8210: 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d 61 72 ive 'test-set-ar
8220: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 72 chive-block-id r
8230: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
8240: 69 64 20 74 65 73 74 2d 69 64 20 61 72 63 68 69 id test-id archi
8250: 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 29 0a 0a ve-block-id)))..
8260: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
8270: 74 2d 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-get-archive-bl
8280: 6f 63 6b 2d 69 6e 66 6f 20 61 72 63 68 69 76 65 ock-info archive
8290: 2d 62 6c 6f 63 6b 2d 69 64 29 0a 20 20 28 72 6d -block-id). (rm
82a0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
82b0: 74 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 test-get-archive
82c0: 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 23 66 20 28 -block-info #f (
82d0: 6c 69 73 74 20 61 72 63 68 69 76 65 2d 62 6c 6f list archive-blo
82e0: 63 6b 2d 69 64 29 29 29 0a 0a 3b 3b 20 67 65 74 ck-id)))..;; get
82f0: 73 20 6d 74 70 67 2d 72 75 6e 2d 69 64 20 61 6e s mtpg-run-id an
8300: 64 20 73 79 6e 63 73 20 74 68 65 20 72 65 63 6f d syncs the reco
8310: 72 64 20 69 66 20 64 69 66 66 65 72 65 6e 74 0a rd if different.
8320: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b ;;.(define (task
8330: 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 s:run-id->mtpg-r
8340: 75 6e 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 un-id dbh cached
8350: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 -info run-id are
8360: 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d a-info smallest-
8370: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
8380: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 73 ). (let* ((runs
8390: 2d 68 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d -ht (hash-table-
83a0: 72 65 66 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 ref cached-info
83b0: 27 72 75 6e 73 29 29 0a 09 20 28 72 75 6e 69 6e 'runs)).. (runin
83c0: 66 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 f (hash-table-r
83d0: 65 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 73 2d ef/default runs-
83e0: 68 74 20 72 75 6e 2d 69 64 20 23 66 29 29 0a 20 ht run-id #f)).
83f0: 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 69 64 (area-id
8400: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 (vector-ref are
8410: 61 2d 69 6e 66 6f 20 30 29 29 29 0a 20 20 20 20 a-info 0))).
8420: 20 20 20 28 69 66 20 72 75 6e 69 6e 66 0a 09 72 (if runinf..r
8430: 75 6e 69 6e 66 20 3b 3b 20 61 6c 72 65 61 64 79 uninf ;; already
8440: 20 63 61 63 68 65 64 0a 09 28 6c 65 74 2a 20 28 cached..(let* (
8450: 28 72 75 6e 2d 64 61 74 20 20 20 20 28 72 6d 74 (run-dat (rmt
8460: 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 :get-run-info ru
8470: 6e 2d 69 64 29 29 20 20 20 20 20 20 20 20 20 20 n-id))
8480: 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 67 65 ;; NOTE: ge
8490: 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 65 74 75 72 t-run-info retur
84a0: 6e 73 20 61 20 76 65 63 74 6f 72 20 3c 20 72 6f ns a vector < ro
84b0: 77 20 68 65 61 64 65 72 20 3e 0a 09 20 20 20 20 w header >..
84c0: 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 20 28 (run-name (
84d0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 rmt:get-run-name
84e0: 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 29 -from-id run-id)
84f0: 29 0a 09 20 20 20 20 20 20 20 28 72 6f 77 20 20 ).. (row
8500: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 72 6f (db:get-ro
8510: 77 73 20 72 75 6e 2d 64 61 74 29 29 20 20 20 20 ws run-dat))
8520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
8530: 3b 20 79 65 73 2c 20 74 68 69 73 20 72 65 74 75 ; yes, this retu
8540: 72 6e 73 20 61 20 73 69 6e 67 6c 65 20 72 6f 77 rns a single row
8550: 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 .. (header
8560: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 68 65 61 (db:get-hea
8570: 64 65 72 20 72 75 6e 2d 64 61 74 29 29 0a 09 20 der run-dat))..
8580: 20 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 (state
8590: 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d (db:get-value-
85a0: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
85b0: 61 64 65 72 20 22 73 74 61 74 65 22 29 29 0a 09 ader "state"))..
85c0: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 20 (status
85d0: 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 (db:get-value
85e0: 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 -by-header row h
85f0: 65 61 64 65 72 20 22 73 74 61 74 75 73 22 29 29 eader "status"))
8600: 0a 09 20 20 20 20 20 20 20 28 6f 77 6e 65 72 20 .. (owner
8610: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c (db:get-val
8620: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
8630: 20 68 65 61 64 65 72 20 22 6f 77 6e 65 72 22 29 header "owner")
8640: 29 0a 09 20 20 20 20 20 20 20 28 65 76 65 6e 74 ).. (event
8650: 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 -time (db:get-va
8660: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f lue-by-header ro
8670: 77 20 68 65 61 64 65 72 20 22 65 76 65 6e 74 5f w header "event_
8680: 74 69 6d 65 22 29 29 0a 09 20 20 20 20 20 20 20 time"))..
8690: 28 63 6f 6d 6d 65 6e 74 20 20 20 20 28 64 62 3a (comment (db:
86a0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
86b0: 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 22 der row header "
86c0: 63 6f 6d 6d 65 6e 74 22 29 29 0a 09 20 20 20 20 comment"))..
86d0: 20 20 20 28 66 61 69 6c 2d 63 6f 75 6e 74 20 28 (fail-count (
86e0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
86f0: 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 65 header row heade
8700: 72 20 22 66 61 69 6c 5f 63 6f 75 6e 74 22 29 29 r "fail_count"))
8710: 0a 09 20 20 20 20 20 20 20 28 70 61 73 73 2d 63 .. (pass-c
8720: 6f 75 6e 74 20 28 64 62 3a 67 65 74 2d 76 61 6c ount (db:get-val
8730: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
8740: 20 68 65 61 64 65 72 20 22 70 61 73 73 5f 63 6f header "pass_co
8750: 75 6e 74 22 29 29 0a 20 20 20 20 20 20 20 20 20 unt")).
8760: 20 20 20 20 20 20 28 64 62 2d 63 6f 6e 74 6f 75 (db-contou
8770: 72 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d r (db:get-value-
8780: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
8790: 61 64 65 72 20 22 63 6f 6e 74 6f 75 72 22 29 29 ader "contour"))
87a0: 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 .. (contou
87b0: 72 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 r (if (args:g
87c0: 65 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 et-arg "-prepend
87d0: 2d 63 6f 6e 74 6f 75 72 22 29 20 0a 20 20 20 20 -contour") .
87e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
87f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
8800: 20 28 61 6e 64 20 64 62 2d 63 6f 6e 74 6f 75 72 (and db-contour
8810: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 (not (equal? db
8820: 2d 63 6f 6e 74 6f 75 72 20 22 22 29 29 20 20 28 -contour "")) (
8830: 73 74 72 69 6e 67 3f 20 64 62 2d 63 6f 6e 74 6f string? db-conto
8840: 75 72 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 ur )) .
8850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8870: 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
8880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88a0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
88b0: 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 61 nt-info 10 *defa
88c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
88d0: 64 62 2d 63 6f 6e 74 6f 75 72 22 20 64 62 2d 63 db-contour" db-c
88e0: 6f 6e 74 6f 75 72 29 20 0a 20 09 09 09 09 09 09 ontour) . ......
88f0: 64 62 2d 63 6f 6e 74 6f 75 72 29 0a 09 09 09 09 db-contour).....
8900: 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 . (args:get-a
8910: 72 67 20 22 2d 63 6f 6e 74 6f 75 72 22 29 29 29 rg "-contour")))
8920: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8930: 20 28 72 75 6e 2d 74 61 67 20 28 69 66 20 28 61 (run-tag (if (a
8940: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
8950: 6e 2d 74 61 67 22 29 0a 20 20 20 20 20 20 20 20 n-tag").
8960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8970: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
8980: 67 20 22 2d 72 75 6e 2d 74 61 67 22 29 0a 09 09 g "-run-tag")...
8990: 09 09 09 09 09 09 09 22 22 29 29 0a 20 20 20 20 ......."")).
89a0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 73 74 (last
89b0: 2d 75 70 64 61 74 65 20 28 64 62 3a 67 65 74 2d -update (db:get-
89c0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
89d0: 72 6f 77 20 68 65 61 64 65 72 20 22 6c 61 73 74 row header "last
89e0: 5f 75 70 64 61 74 65 22 29 29 0a 09 20 20 20 20 _update"))..
89f0: 20 20 20 28 6b 65 79 74 61 72 67 20 20 20 20 28 (keytarg (
8a00: 69 66 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 if (or (args:get
8a10: 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 2d 63 -arg "-prepend-c
8a20: 6f 6e 74 6f 75 72 22 29 20 28 61 72 67 73 3a 67 ontour") (args:g
8a30: 65 74 2d 61 72 67 20 22 2d 70 72 65 66 69 78 2d et-arg "-prefix-
8a40: 74 61 72 67 65 74 22 29 29 0a 09 20 20 20 20 20 target"))..
8a50: 20 20 09 09 09 28 63 6f 6e 63 20 22 4d 54 5f 43 ...(conc "MT_C
8a60: 4f 4e 54 4f 55 52 2f 4d 54 5f 41 52 45 41 2f 22 ONTOUR/MT_AREA/"
8a70: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
8a80: 65 72 73 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 erse (rmt:get-ke
8a90: 79 73 29 20 22 2f 22 29 29 20 28 73 74 72 69 6e ys) "/")) (strin
8aa0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 72 g-intersperse (r
8ab0: 6d 74 3a 67 65 74 2d 6b 65 79 73 29 20 22 2f 22 mt:get-keys) "/"
8ac0: 29 29 29 20 3b 3b 20 65 2e 67 2e 20 76 65 72 73 ))) ;; e.g. vers
8ad0: 69 6f 6e 2f 69 74 65 72 61 74 69 6f 6e 2f 70 6c ion/iteration/pl
8ae0: 61 74 66 6f 72 6d 0a 20 20 20 20 20 20 20 20 20 atform.
8af0: 20 20 20 20 20 20 28 62 61 73 65 2d 74 61 72 67 (base-targ
8b00: 65 74 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 et (rmt:get
8b10: 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 64 29 29 -target run-id))
8b20: 0a 09 20 20 20 20 20 20 20 28 74 61 72 67 65 74 .. (target
8b30: 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 (if (or (ar
8b40: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
8b50: 70 65 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 pend-contour") (
8b60: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 args:get-arg "-p
8b70: 72 65 66 69 78 2d 74 61 72 67 65 74 22 29 29 20 refix-target"))
8b80: 0a 09 20 20 20 20 20 20 20 09 09 09 28 63 6f 6e .. ...(con
8b90: 63 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d c (or (args:get-
8ba0: 61 72 67 20 22 2d 70 72 65 66 69 78 2d 74 61 72 arg "-prefix-tar
8bb0: 67 65 74 22 29 20 28 63 6f 6e 63 20 63 6f 6e 74 get") (conc cont
8bc0: 6f 75 72 20 22 2f 22 20 28 63 6f 6d 6d 6f 6e 3a our "/" (common:
8bd0: 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 29 20 22 get-area-name) "
8be0: 2f 22 29 29 20 62 61 73 65 2d 74 61 72 67 65 74 /")) base-target
8bf0: 29 20 62 61 73 65 2d 74 61 72 67 65 74 29 29 20 ) base-target))
8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c10: 3b 3b 20 65 2e 67 2e 20 76 31 2e 36 33 2f 61 33 ;; e.g. v1.63/a3
8c20: 65 31 2f 75 62 75 6e 74 75 0a 09 20 20 20 20 20 e1/ubuntu..
8c30: 20 20 28 73 70 65 63 2d 69 64 20 20 20 20 28 70 (spec-id (p
8c40: 67 64 62 3a 67 65 74 2d 74 74 79 70 65 20 64 62 gdb:get-ttype db
8c50: 68 20 6b 65 79 74 61 72 67 29 29 0a 09 20 20 20 h keytarg))..
8c60: 20 20 20 20 28 70 75 62 6c 69 73 68 2d 74 69 6d (publish-tim
8c70: 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d e (if (args:get-
8c80: 61 72 67 20 22 2d 63 70 2d 65 76 65 6e 74 74 69 arg "-cp-eventti
8c90: 6d 65 2d 74 6f 2d 70 75 62 6c 69 73 68 74 69 6d me-to-publishtim
8ca0: 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e").
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cc0: 65 76 65 6e 74 2d 74 69 6d 65 0a 20 20 20 20 20 event-time.
8cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ce0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
8cf0: 65 63 6f 6e 64 73 29 29 29 20 0a 09 20 20 20 20 econds))) ..
8d00: 20 20 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 28 (new-run-id (
8d10: 69 66 20 28 61 6e 64 20 72 75 6e 2d 6e 61 6d 65 if (and run-name
8d20: 20 62 61 73 65 2d 74 61 72 67 65 74 29 20 28 70 base-target) (p
8d30: 67 64 62 3a 67 65 74 2d 72 75 6e 2d 69 64 20 64 gdb:get-run-id d
8d40: 62 68 20 73 70 65 63 2d 69 64 20 74 61 72 67 65 bh spec-id targe
8d50: 74 20 72 75 6e 2d 6e 61 6d 65 20 61 72 65 61 2d t run-name area-
8d60: 69 64 29 20 23 66 29 29 29 0a 20 20 20 20 20 20 id) #f))).
8d70: 20 20 20 28 69 66 20 6e 65 77 2d 72 75 6e 2d 69 (if new-run-i
8d80: 64 0a 09 20 20 20 20 20 20 20 20 20 28 62 65 67 d.. (beg
8d90: 69 6e 20 3b 3b 20 6c 65 74 20 28 28 72 75 6e 2d in ;; let ((run-
8da0: 72 65 63 6f 72 64 20 28 70 67 64 62 3a 67 65 74 record (pgdb:get
8db0: 2d 72 75 6e 2d 69 6e 66 6f 20 64 62 68 20 6e 65 -run-info dbh ne
8dc0: 77 2d 72 75 6e 2d 69 64 29 29 0a 09 09 20 20 20 w-run-id))...
8dd0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
8de0: 2d 73 65 74 21 20 72 75 6e 73 2d 68 74 20 72 75 -set! runs-ht ru
8df0: 6e 2d 69 64 20 6e 65 77 2d 72 75 6e 2d 69 64 29 n-id new-run-id)
8e00: 0a 09 09 3b 3b 20 65 6e 73 75 72 65 20 6b 65 79 ...;; ensure key
8e10: 20 66 69 65 6c 64 73 20 61 72 65 20 75 70 20 74 fields are up t
8e20: 6f 20 64 61 74 65 0a 20 20 20 20 20 3b 3b 20 69 o date. ;; i
8e30: 66 20 6c 61 73 74 5f 75 70 64 61 74 65 20 3d 3d f last_update ==
8e40: 20 70 67 64 62 5f 6c 61 73 74 5f 75 70 64 61 74 pgdb_last_updat
8e50: 65 20 64 6f 20 6e 6f 74 20 75 70 64 61 74 65 20 e do not update
8e60: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
8e70: 64 61 74 65 2d 74 69 6d 65 20 20 0a 20 20 20 20 date-time .
8e80: 28 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 (let* ((pgdb-las
8e90: 74 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 t-update (pgdb:g
8ea0: 65 74 2d 72 75 6e 2d 6c 61 73 74 2d 75 70 64 61 et-run-last-upda
8eb0: 74 65 20 64 62 68 20 6e 65 77 2d 72 75 6e 2d 69 te dbh new-run-i
8ec0: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 d)). (
8ed0: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 smallest-time (h
8ee0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8ef0: 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c fault smallest-l
8f00: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
8f10: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
8f20: 23 66 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 #f))). (if (
8f30: 61 6e 64 20 20 28 3e 20 6c 61 73 74 2d 75 70 64 and (> last-upd
8f40: 61 74 65 20 70 67 64 62 2d 6c 61 73 74 2d 75 70 ate pgdb-last-up
8f50: 64 61 74 65 29 20 28 6f 72 20 28 6e 6f 74 20 73 date) (or (not s
8f60: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c mallest-time) (<
8f70: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 last-update sma
8f80: 6c 6c 65 73 74 2d 74 69 6d 65 29 29 29 0a 20 20 llest-time))).
8f90: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
8fa0: 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d e-set! smallest-
8fb0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
8fc0: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
8fd0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a last-update))).
8fe0: 09 09 28 70 67 64 62 3a 72 65 66 72 65 73 68 2d ..(pgdb:refresh-
8ff0: 72 75 6e 2d 69 6e 66 6f 0a 09 09 20 64 62 68 0a run-info... dbh.
9000: 09 09 20 6e 65 77 2d 72 75 6e 2d 69 64 0a 09 09 .. new-run-id...
9010: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 6f 77 state status ow
9020: 6e 65 72 20 65 76 65 6e 74 2d 74 69 6d 65 20 63 ner event-time c
9030: 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d 63 6f 75 6e omment fail-coun
9040: 74 20 70 61 73 73 2d 63 6f 75 6e 74 20 61 72 65 t pass-count are
9050: 61 2d 69 64 20 6c 61 73 74 2d 75 70 64 61 74 65 a-id last-update
9060: 20 70 75 62 6c 69 73 68 2d 74 69 6d 65 29 0a 20 publish-time).
9070: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9080: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
9090: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 6f 72 6b -log-port* "Work
90a0: 69 6e 67 20 6f 6e 20 72 75 6e 2d 69 64 20 22 20 ing on run-id "
90b0: 72 75 6e 2d 69 64 20 22 20 70 67 64 62 2d 69 64 run-id " pgdb-id
90c0: 20 22 20 20 6e 65 77 2d 72 75 6e 2d 69 64 20 29 " new-run-id )
90d0: 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 . (if (not (
90e0: 65 71 75 61 6c 3f 20 72 75 6e 2d 74 61 67 20 22 equal? run-tag "
90f0: 22 29 29 0a 20 20 20 20 20 20 28 74 61 73 6b 3a ")). (task:
9100: 61 64 64 2d 72 75 6e 2d 74 61 67 20 64 62 68 20 add-run-tag dbh
9110: 6e 65 77 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 74 new-run-id run-t
9120: 61 67 29 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 ag))...new-run-i
9130: 64 29 20 0a 20 20 20 20 20 20 0a 09 20 20 20 20 d) . ..
9140: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 (if (or (not s
9150: 74 61 74 65 29 20 28 65 71 75 61 6c 3f 20 73 74 tate) (equal? st
9160: 61 74 65 20 22 64 65 6c 65 74 65 64 22 29 29 0a ate "deleted")).
9170: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9180: 20 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 . (deb
9190: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
91a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
91b0: 74 2a 20 20 22 57 61 72 6e 69 6e 67 3a 20 52 75 t* "Warning: Ru
91c0: 6e 20 77 69 74 68 20 69 64 20 22 20 72 75 6e 2d n with id " run-
91d0: 69 64 20 22 20 77 61 73 20 63 72 65 61 74 65 64 id " was created
91e0: 20 61 66 74 65 72 20 70 72 65 76 69 6f 75 73 20 after previous
91f0: 73 79 6e 63 20 61 6e 64 20 64 65 6c 65 74 65 64 sync and deleted
9200: 20 62 65 66 6f 72 65 20 74 68 65 20 73 79 6e 63 before the sync
9210: 22 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 ") #f).
9220: 20 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 78 63 (if (handle-exc
9230: 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 eptions...
9240: 20 20 65 78 6e 0a 09 09 20 20 20 20 20 20 20 20 exn...
9250: 28 62 65 67 69 6e 20 28 70 72 69 6e 74 2d 63 61 (begin (print-ca
9260: 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 20 20 ll-chain).
9270: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 (print (
9280: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
9290: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
92a0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
92b0: 29 20 20 20 20 20 0a 09 09 09 20 20 20 20 20 20 ) ....
92c0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
92d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 . (pg
92e0: 64 62 3a 69 6e 73 65 72 74 2d 72 75 6e 0a 09 09 db:insert-run...
92f0: 20 20 20 20 20 64 62 68 0a 09 09 20 20 20 20 20 dbh...
9300: 73 70 65 63 2d 69 64 20 74 61 72 67 65 74 20 72 spec-id target r
9310: 75 6e 2d 6e 61 6d 65 20 73 74 61 74 65 20 73 74 un-name state st
9320: 61 74 75 73 20 6f 77 6e 65 72 20 65 76 65 6e 74 atus owner event
9330: 2d 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 66 61 -time comment fa
9340: 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d 63 6f il-count pass-co
9350: 75 6e 74 20 20 61 72 65 61 2d 69 64 20 6c 61 73 unt area-id las
9360: 74 2d 75 70 64 61 74 65 20 70 75 62 6c 69 73 68 t-update publish
9370: 2d 74 69 6d 65 29 29 0a 09 09 20 20 20 20 20 20 -time))...
9380: 20 28 6c 65 74 2a 20 28 28 73 6d 61 6c 6c 65 73 (let* ((smalles
9390: 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 t-time (hash-tab
93a0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
93b0: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
93c0: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
93d0: 73 74 2d 74 69 6d 65 22 20 23 66 29 29 29 0a 20 st-time" #f))).
93e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
93f0: 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 (or (not smalles
9400: 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d t-time) (< last-
9410: 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d update smallest-
9420: 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 09 time)). .
9430: 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
9440: 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 et! smallest-las
9450: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 t-update-time "s
9460: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 mallest-time" la
9470: 73 74 2d 75 70 64 61 74 65 29 29 0a 20 20 20 20 st-update)).
9480: 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a (tasks:
9490: 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e run-id->mtpg-run
94a0: 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 -id dbh cached-i
94b0: 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d nfo run-id area-
94c0: 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 info smallest-la
94d0: 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 29 st-update-time))
94e0: 0a 09 09 20 20 23 66 29 29 29 29 29 29 29 0a 28 ... #f))))))).(
94f0: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 define (tasks:sy
9500: 6e 63 2d 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 nc-test-gen-data
9510: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
9520: 20 74 65 73 74 2d 64 61 74 61 2d 69 64 73 20 73 test-data-ids s
9530: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
9540: 61 74 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 ate-time). (let
9550: 20 28 28 74 65 73 74 2d 68 74 20 28 68 61 73 68 ((test-ht (hash
9560: 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 -table-ref cache
9570: 64 2d 69 6e 66 6f 20 27 74 65 73 74 73 29 29 0a d-info 'tests)).
9580: 20 20 20 20 20 20 20 20 28 64 61 74 61 2d 68 74 (data-ht
9590: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
95a0: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 64 61 cached-info 'da
95b0: 74 61 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ta))). (for-e
95c0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
95d0: 20 28 74 65 73 74 2d 64 61 74 61 2d 69 64 29 0a (test-data-id).
95e0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
95f0: 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 20 20 test-data-info
9600: 28 72 6d 74 3a 67 65 74 2d 64 61 74 61 2d 69 6e (rmt:get-data-in
9610: 66 6f 2d 62 79 2d 69 64 20 74 65 73 74 2d 64 61 fo-by-id test-da
9620: 74 61 2d 69 64 29 29 0a 20 20 20 20 20 20 20 20 ta-id)).
9630: 20 20 20 20 20 20 20 28 64 61 74 61 2d 69 64 20 (data-id
9640: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9650: 74 2d 69 64 20 20 74 65 73 74 2d 64 61 74 61 2d t-id test-data-
9660: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
9670: 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 (test-id
9680: 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 (db:test-data-ge
9690: 74 2d 74 65 73 74 5f 69 64 20 20 20 74 65 73 74 t-test_id test
96a0: 2d 64 61 74 61 2d 69 6e 66 6f 29 29 20 20 20 0a -data-info)) .
96b0: 09 20 20 20 20 20 20 20 28 63 61 74 65 67 6f 72 . (categor
96c0: 79 20 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 y (db:test-data
96d0: 2d 67 65 74 2d 63 61 74 65 67 6f 72 79 20 20 74 -get-category t
96e0: 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a est-data-info)).
96f0: 09 20 20 20 20 20 20 20 28 76 61 72 69 61 62 6c . (variabl
9700: 65 20 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 e (db:test-data
9710: 2d 67 65 74 2d 76 61 72 69 61 62 6c 65 20 74 65 -get-variable te
9720: 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a st-data-info))..
9730: 09 20 20 20 20 20 20 20 28 76 61 6c 75 65 20 28 . (value (
9740: 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 db:test-data-get
9750: 2d 76 61 6c 75 65 20 20 74 65 73 74 2d 64 61 74 -value test-dat
9760: 61 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 a-info))..
9770: 20 20 20 20 20 20 20 20 20 28 65 78 70 65 63 74 (expect
9780: 65 64 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 ed (db:test-data
9790: 2d 67 65 74 2d 65 78 70 65 63 74 65 64 20 20 74 -get-expected t
97a0: 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 0a est-data-info)).
97b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
97c0: 74 6f 6c 20 28 64 62 3a 74 65 73 74 2d 64 61 74 tol (db:test-dat
97d0: 61 2d 67 65 74 2d 74 6f 6c 20 20 74 65 73 74 2d a-get-tol test-
97e0: 64 61 74 61 2d 69 6e 66 6f 29 29 0a 20 20 20 20 data-info)).
97f0: 20 20 20 20 20 20 20 20 20 20 20 28 75 6e 69 74 (unit
9800: 73 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d s (db:test-data-
9810: 67 65 74 2d 75 6e 69 74 73 20 20 74 65 73 74 2d get-units test-
9820: 64 61 74 61 2d 69 6e 66 6f 29 29 20 20 20 20 20 data-info))
9830: 0a 09 20 20 20 20 20 20 20 28 63 6f 6d 6d 65 6e .. (commen
9840: 74 20 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 t (db:test-data
9850: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 74 65 73 -get-comment tes
9860: 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 0a 20 t-data-info))..
9870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
9880: 74 61 74 75 73 20 28 64 62 3a 74 65 73 74 2d 64 tatus (db:test-d
9890: 61 74 61 2d 67 65 74 2d 73 74 61 74 75 73 20 74 ata-get-status t
98a0: 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 29 09 est-data-info)).
98b0: 0a 09 20 20 20 20 20 20 20 28 74 79 70 65 20 28 .. (type (
98c0: 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 db:test-data-get
98d0: 2d 74 79 70 65 20 74 65 73 74 2d 64 61 74 61 2d -type test-data-
98e0: 69 6e 66 6f 29 29 0a 09 09 09 09 20 28 6c 61 73 info))..... (las
98f0: 74 2d 75 70 64 61 74 65 20 28 64 62 3a 74 65 73 t-update (db:tes
9900: 74 2d 64 61 74 61 2d 67 65 74 2d 6c 61 73 74 5f t-data-get-last_
9910: 75 70 64 61 74 65 20 74 65 73 74 2d 64 61 74 61 update test-data
9920: 2d 69 6e 66 6f 29 29 0a 09 09 09 09 20 28 73 6d -info))..... (sm
9930: 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 73 allest-time (has
9940: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
9950: 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 ult smallest-las
9960: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 t-update-time "s
9970: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 mallest-time" #f
9980: 29 29 0a 20 20 20 09 0a 09 20 20 20 20 20 20 20 )). ...
9990: 28 70 67 64 62 2d 74 65 73 74 2d 69 64 20 20 28 (pgdb-test-id (
99a0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
99b0: 65 66 61 75 6c 74 20 74 65 73 74 2d 68 74 20 74 efault test-ht t
99c0: 65 73 74 2d 69 64 20 23 66 29 29 0a 20 20 20 20 est-id #f)).
99d0: 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 (pgdb
99e0: 2d 64 61 74 61 2d 69 64 20 28 69 66 20 70 67 64 -data-id (if pgd
99f0: 62 2d 74 65 73 74 2d 69 64 20 0a 20 20 20 20 20 b-test-id .
9a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a10: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
9a20: 62 3a 67 65 74 2d 74 65 73 74 2d 64 61 74 61 2d b:get-test-data-
9a30: 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 id dbh pgdb-test
9a40: 2d 69 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 -id category var
9a50: 69 61 62 6c 65 29 0a 20 20 20 20 20 20 20 20 20 iable).
9a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a70: 20 20 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 #f))).
9a80: 20 20 20 28 69 66 20 64 61 74 61 2d 69 64 0a 20 (if data-id.
9a90: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
9aa0: 20 20 20 20 28 69 66 20 70 67 64 62 2d 74 65 73 (if pgdb-tes
9ab0: 74 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 t-id.
9ac0: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
9ad0: 20 20 20 20 20 20 20 20 28 69 66 20 20 70 67 64 (if pgd
9ae0: 62 2d 64 61 74 61 2d 69 64 0a 20 20 20 20 20 20 b-data-id.
9af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
9b00: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
9b10: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
9b20: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
9b30: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
9b40: 22 55 70 64 61 74 69 6e 67 20 65 78 69 73 74 69 "Updating existi
9b50: 6e 67 20 74 65 73 74 2d 64 61 74 61 20 77 69 74 ng test-data wit
9b60: 68 20 74 65 73 74 2d 69 64 3a 20 22 20 74 65 73 h test-id: " tes
9b70: 74 2d 69 64 20 22 20 61 6e 64 20 20 64 61 74 61 t-id " and data
9b80: 2d 69 64 20 22 20 64 61 74 61 2d 69 64 20 22 20 -id " data-id "
9b90: 70 67 64 62 20 74 65 73 74 20 69 64 3a 20 22 20 pgdb test id: "
9ba0: 70 67 64 62 2d 74 65 73 74 2d 69 64 20 22 20 70 pgdb-test-id " p
9bb0: 67 64 62 20 64 61 74 61 20 69 64 20 22 20 70 67 gdb data id " pg
9bc0: 64 62 2d 64 61 74 61 2d 69 64 29 0a 20 20 20 20 db-data-id).
9bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9be0: 28 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 (let* ((pgdb-las
9bf0: 74 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 t-update (pgdb:g
9c00: 65 74 2d 74 65 73 74 2d 64 61 74 61 2d 6c 61 73 et-test-data-las
9c10: 74 2d 75 70 64 61 74 65 20 64 62 68 20 70 67 64 t-update dbh pgd
9c20: 62 2d 64 61 74 61 2d 69 64 29 29 29 0a 20 20 20 b-data-id))).
9c30: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 20 (if (and
9c40: 28 3e 20 20 6c 61 73 74 2d 75 70 64 61 74 65 20 (> last-update
9c50: 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 pgdb-last-update
9c60: 29 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c ) (or (not small
9c70: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
9c80: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
9c90: 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 t-time))).
9ca0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9cb0: 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 t! smallest-last
9cc0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d -update-time "sm
9cd0: 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 allest-time" las
9ce0: 74 2d 75 70 64 61 74 65 29 29 29 20 0a 20 20 20 t-update))) .
9cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d00: 20 28 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 (pgdb:update-te
9d10: 73 74 2d 64 61 74 61 20 64 62 68 20 70 67 64 62 st-data dbh pgdb
9d20: 2d 64 61 74 61 2d 69 64 20 70 67 64 62 2d 74 65 -data-id pgdb-te
9d30: 73 74 2d 69 64 20 20 63 61 74 65 67 6f 72 79 20 st-id category
9d40: 76 61 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 variable value e
9d50: 78 70 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 xpected tol unit
9d60: 73 20 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 s comment status
9d70: 20 74 79 70 65 20 6c 61 73 74 2d 75 70 64 61 74 type last-updat
9d80: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
9d90: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
9da0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
9db0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
9dc0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
9dd0: 22 49 6e 73 65 72 74 69 6e 67 20 74 65 73 74 2d "Inserting test-
9de0: 64 61 74 61 20 77 69 74 68 20 74 65 73 74 2d 69 data with test-i
9df0: 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 d: " test-id " a
9e00: 6e 64 20 64 61 74 61 2d 69 64 20 22 20 64 61 74 nd data-id " dat
9e10: 61 2d 69 64 20 22 20 70 67 64 62 20 74 65 73 74 a-id " pgdb test
9e20: 20 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 id: " pgdb-test
9e30: 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 -id).
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
9e50: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
9e60: 6e 73 0a 09 09 20 20 20 20 20 20 65 78 6e 0a 09 ns... exn..
9e70: 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 70 . (begin (p
9e80: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 rint-call-chain)
9e90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9eb0: 70 72 69 6e 74 20 28 28 63 6f 6e 64 69 74 69 6f print ((conditio
9ec0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
9ed0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
9ee0: 65 29 20 65 78 6e 29 29 20 20 20 20 20 0a 09 09 e) exn)) ...
9ef0: 09 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 .#f).
9f00: 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 .
9f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9f20: 70 67 64 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 pgdb:insert-test
9f30: 2d 64 61 74 61 20 64 62 68 20 70 67 64 62 2d 74 -data dbh pgdb-t
9f40: 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 20 est-id category
9f50: 76 61 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 variable value e
9f60: 78 70 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 xpected tol unit
9f70: 73 20 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 s comment status
9f80: 20 74 79 70 65 20 6c 61 73 74 2d 75 70 64 61 74 type last-updat
9f90: 65 29 29 0a 09 09 20 20 20 20 20 20 20 3b 28 74 e))... ;(t
9fa0: 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 asks:run-id->mtp
9fb0: 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 63 g-run-id dbh cac
9fc0: 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 hed-info run-id
9fd0: 61 72 65 61 2d 69 6e 66 6f 29 0a 20 20 20 20 20 area-info).
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ff0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
a000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 ;(
a010: 70 67 64 62 3a 69 6e 73 65 72 74 2d 74 65 73 74 pgdb:insert-test
a020: 2d 64 61 74 61 20 64 62 68 20 70 67 64 62 2d 74 -data dbh pgdb-t
a030: 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 20 est-id category
a040: 76 61 72 69 61 62 6c 65 20 76 61 6c 75 65 20 65 variable value e
a050: 78 70 65 63 74 65 64 20 74 6f 6c 20 75 6e 69 74 xpected tol unit
a060: 73 20 63 6f 6d 6d 65 6e 74 20 73 74 61 74 75 73 s comment status
a070: 20 74 79 70 65 20 29 0a 09 09 09 09 09 09 09 09 type ).........
a080: 09 09 09 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 ...(if (or (not
a090: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 smallest-time) (
a0a0: 3c 20 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d < last-update sm
a0b0: 61 6c 6c 65 73 74 2d 74 69 6d 65 29 29 0a 20 20 allest-time)).
a0c0: 20 20 20 20 20 20 09 09 09 09 09 09 09 09 28 68 ........(h
a0d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
a0e0: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
a0f0: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
a100: 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 st-time" last-up
a110: 64 61 74 65 29 29 0a 20 20 20 20 20 20 20 20 20 date)).
a120: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
a130: 74 21 20 70 67 64 62 2d 64 61 74 61 2d 69 64 20 t! pgdb-data-id
a140: 20 28 70 67 64 62 3a 67 65 74 2d 74 65 73 74 2d (pgdb:get-test-
a150: 64 61 74 61 2d 69 64 20 64 62 68 20 70 67 64 62 data-id dbh pgdb
a160: 2d 74 65 73 74 2d 69 64 20 20 63 61 74 65 67 6f -test-id catego
a170: 72 79 20 76 61 72 69 61 62 6c 65 29 29 29 0a 09 ry variable)))..
a180: 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 . #f))).
a190: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
a1a0: 74 61 62 6c 65 2d 73 65 74 21 20 64 61 74 61 2d table-set! data-
a1b0: 68 74 20 64 61 74 61 2d 69 64 20 70 67 64 62 2d ht data-id pgdb-
a1c0: 64 61 74 61 2d 69 64 20 29 29 0a 20 20 20 20 20 data-id )).
a1d0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
a1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
a200: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
a210: 2d 70 6f 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 -port* "Error:
a220: 54 65 73 74 20 6e 6f 74 20 69 6e 20 70 67 64 62 Test not in pgdb
a230: 22 29 29 29 29 0a 0a 20 20 20 20 20 20 28 64 65 ")))).. (de
a240: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
a250: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
a260: 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 43 6f 75 rt* "Error: Cou
a270: 6c 64 20 6e 6f 74 20 67 65 74 20 74 65 73 74 20 ld not get test
a280: 64 61 74 61 20 69 6e 66 6f 20 66 6f 72 20 64 61 data info for da
a290: 74 61 20 69 64 20 22 20 74 65 73 74 2d 64 61 74 ta id " test-dat
a2a0: 61 2d 69 64 20 29 29 29 29 09 3b 3b 20 74 68 69 a-id )))).;; thi
a2b0: 73 20 69 73 20 61 20 77 69 65 72 64 20 73 65 6e s is a wierd sen
a2c0: 61 72 69 6f 20 6e 65 65 64 20 74 6f 20 64 65 62 ario need to deb
a2d0: 75 67 20 20 20 20 20 20 09 0a 20 20 20 74 65 73 ug .. tes
a2e0: 74 2d 64 61 74 61 2d 69 64 73 29 29 29 0a 0a 0a t-data-ids)))...
a2f0: 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 (define (task:g
a300: 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 et-test-times).
a310: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 6e 61 6d (let* ((runnam
a320: 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d e (if (args:get-
a330: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
a340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a350: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
a360: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
a370: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a380: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 #f)).
a390: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
a3a0: 74 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d t (if (args:get-
a3b0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 arg "-target").
a3c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3d0: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
a3e0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
a3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a400: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 0a 20 #f)). .
a410: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
a420: 74 69 6d 65 73 20 20 28 72 6d 74 3a 67 65 74 2d times (rmt:get-
a430: 74 65 73 74 2d 74 69 6d 65 73 20 20 72 75 6e 6e test-times runn
a440: 61 6d 65 20 74 61 72 67 65 74 20 29 29 29 0a 20 ame target ))).
a450: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 6e 61 (if (not runna
a460: 6d 65 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e me). (begin
a470: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 . (print "E
a480: 72 72 6f 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 rror: Missing ar
a490: 67 75 6d 65 6e 74 20 2d 72 75 6e 6e 61 6d 65 22 gument -runname"
a4a0: 29 0a 20 20 20 20 20 20 28 65 78 69 74 29 29 29 ). (exit)))
a4b0: 20 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 6e . (if (strin
a4c0: 67 2d 63 6f 6e 74 61 69 6e 73 20 72 75 6e 6e 61 g-contains runna
a4d0: 6d 65 20 22 25 22 29 0a 20 20 20 20 20 20 28 62 me "%"). (b
a4e0: 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 6e egin. (prin
a4f0: 74 20 22 45 72 72 6f 72 3a 20 49 6e 76 61 6c 69 t "Error: Invali
a500: 64 20 72 75 6e 6e 61 6d 65 2c 20 27 25 27 20 6e d runname, '%' n
a510: 6f 74 20 61 6c 6c 6f 77 65 64 20 20 28 22 20 72 ot allowed (" r
a520: 75 6e 6e 61 6d 65 20 22 29 20 22 29 0a 20 20 20 unname ") ").
a530: 20 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 (exit))).
a540: 28 69 66 20 28 6e 6f 74 20 74 61 72 67 65 74 29 (if (not target)
a550: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 . (begin.
a560: 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f (print "Erro
a570: 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d r: Missing argum
a580: 65 6e 74 20 2d 74 61 72 67 65 74 22 29 0a 20 20 ent -target").
a590: 20 20 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 (exit))).
a5a0: 20 20 28 69 66 20 20 28 73 74 72 69 6e 67 2d 63 (if (string-c
a5b0: 6f 6e 74 61 69 6e 73 20 74 61 72 67 65 74 20 22 ontains target "
a5c0: 25 22 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e %"). (begin
a5d0: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 . (print "E
a5e0: 72 72 6f 72 3a 20 49 6e 76 61 6c 69 64 20 74 61 rror: Invalid ta
a5f0: 72 67 65 74 2c 20 27 25 27 20 6e 6f 74 20 61 6c rget, '%' not al
a600: 6c 6f 77 65 64 20 20 28 22 20 74 61 72 67 65 74 lowed (" target
a610: 20 22 29 20 22 29 0a 20 20 20 20 20 20 28 65 78 ") "). (ex
a620: 69 74 29 29 29 0a 20 0a 20 20 20 28 69 66 20 28 it))). . (if (
a630: 65 71 3f 20 28 6c 65 6e 67 74 68 20 74 65 73 74 eq? (length test
a640: 2d 74 69 6d 65 73 29 20 30 29 0a 20 20 20 20 20 -times) 0).
a650: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 (begin. (p
a660: 72 69 6e 74 20 22 44 61 74 61 20 6e 6f 74 20 66 rint "Data not f
a670: 6f 75 6e 64 21 21 22 29 0a 20 20 20 20 20 20 20 ound!!").
a680: 28 65 78 69 74 29 29 29 0a 20 20 20 28 69 66 20 (exit))). (if
a690: 28 65 71 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 (equal? (args:ge
a6a0: 74 2d 61 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 t-arg "-dumpmode
a6b0: 22 29 20 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 ") "json").
a6c0: 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 (task:print-te
a6d0: 73 74 74 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 sttime-as-json t
a6e0: 65 73 74 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 est-times).
a6f0: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
a700: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a710: 64 75 6d 70 6d 6f 64 65 22 29 20 22 63 73 76 22 dumpmode") "csv"
a720: 29 0a 09 20 20 20 20 20 28 74 61 73 6b 3a 70 72 ).. (task:pr
a730: 69 6e 74 2d 74 65 73 74 74 69 6d 65 20 74 65 73 int-testtime tes
a740: 74 2d 74 69 6d 65 73 20 22 2c 22 29 0a 09 20 20 t-times ",")..
a750: 20 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 (task:print-t
a760: 65 73 74 74 69 6d 65 20 74 65 73 74 2d 74 69 6d esttime test-tim
a770: 65 73 20 22 20 20 22 29 29 29 29 29 0a 0a 0a 0a es " ")))))....
a780: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 (define (tasks:s
a790: 79 6e 63 2d 74 65 73 74 2d 73 74 65 70 73 20 64 ync-test-steps d
a7a0: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 bh cached-info t
a7b0: 65 73 74 2d 73 74 65 70 2d 69 64 73 20 73 6d 61 est-step-ids sma
a7c0: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
a7d0: 65 2d 74 69 6d 65 29 0a 20 3b 20 28 70 72 69 6e e-time). ; (prin
a7e0: 74 20 22 53 79 6e 63 20 53 74 65 70 73 20 22 20 t "Sync Steps "
a7f0: 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 29 0a test-step-ids ).
a800: 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 68 74 (let ((test-ht
a810: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
a820: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 74 65 cached-info 'te
a830: 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 28 73 sts)). (s
a840: 74 65 70 2d 68 74 20 28 68 61 73 68 2d 74 61 62 tep-ht (hash-tab
a850: 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e le-ref cached-in
a860: 66 6f 20 27 73 74 65 70 73 29 29 29 0a 20 20 20 fo 'steps))).
a870: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
a880: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 73 74 (lambda (test-st
a890: 65 70 2d 69 64 29 0a 20 20 20 20 20 20 20 20 28 ep-id). (
a8a0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 74 65 70 let* ((test-step
a8b0: 2d 69 6e 66 6f 20 20 28 72 6d 74 3a 67 65 74 2d -info (rmt:get-
a8c0: 73 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 steps-info-by-id
a8d0: 20 74 65 73 74 2d 73 74 65 70 2d 69 64 29 29 0a test-step-id)).
a8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a8f0: 73 74 65 70 2d 69 64 20 28 74 64 62 3a 73 74 65 step-id (tdb:ste
a900: 70 2d 67 65 74 2d 69 64 20 74 65 73 74 2d 73 74 p-get-id test-st
a910: 65 70 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 ep-info)).
a920: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 (test-i
a930: 64 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 d (tdb:step-get
a940: 2d 74 65 73 74 5f 69 64 20 20 20 20 74 65 73 74 -test_id test
a950: 2d 73 74 65 70 2d 69 6e 66 6f 29 29 20 20 20 0a -step-info)) .
a960: 09 20 20 20 20 20 20 20 28 73 74 65 70 6e 61 6d . (stepnam
a970: 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d e (tdb:step-get-
a980: 73 74 65 70 6e 61 6d 65 20 20 74 65 73 74 2d 73 stepname test-s
a990: 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 tep-info))..
a9a0: 20 20 20 28 73 74 61 74 65 20 28 74 64 62 3a 73 (state (tdb:s
a9b0: 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 74 65 tep-get-state te
a9c0: 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 09 0a st-step-info))..
a9d0: 09 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 . (status
a9e0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
a9f0: 61 74 75 73 20 74 65 73 74 2d 73 74 65 70 2d 69 atus test-step-i
aa00: 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 nfo))... (
aa10: 65 76 65 6e 74 5f 74 69 6d 65 20 28 74 64 62 3a event_time (tdb:
aa20: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
aa30: 69 6d 65 20 20 74 65 73 74 2d 73 74 65 70 2d 69 ime test-step-i
aa40: 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 20 28 nfo))... (
aa50: 63 6f 6d 6d 65 6e 74 20 20 28 74 64 62 3a 73 74 comment (tdb:st
aa60: 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 74 ep-get-comment t
aa70: 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 09 est-step-info)).
aa80: 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 66 69 6c .. (logfil
aa90: 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d e (tdb:step-get-
aaa0: 6c 6f 67 66 69 6c 65 20 74 65 73 74 2d 73 74 65 logfile test-ste
aab0: 70 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 p-info))..
aac0: 20 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 (last-update
aad0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 61 (tdb:step-get-la
aae0: 73 74 5f 75 70 64 61 74 65 20 74 65 73 74 2d 73 st_update test-s
aaf0: 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 tep-info))..
ab00: 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d 69 64 (pgdb-test-id
ab10: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
ab20: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 68 f/default test-h
ab30: 74 20 74 65 73 74 2d 69 64 20 23 66 29 29 0a 09 t test-id #f))..
ab40: 09 09 09 20 28 73 6d 61 6c 6c 65 73 74 2d 74 69 ... (smallest-ti
ab50: 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 me (hash-table-r
ab60: 65 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c ef/default small
ab70: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
ab80: 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 time "smallest-t
ab90: 69 6d 65 22 20 23 66 29 29 0a 20 20 20 20 20 20 ime" #f)).
aba0: 20 20 20 28 70 67 64 62 2d 73 74 65 70 2d 69 64 (pgdb-step-id
abb0: 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 (if pgdb-test-i
abc0: 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d .
abd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
abe0: 62 3a 67 65 74 2d 74 65 73 74 2d 73 74 65 70 2d b:get-test-step-
abf0: 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 id dbh pgdb-test
ac00: 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 -id stepname sta
ac10: 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 te).
ac20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
ac30: 29 29 29 0a 20 20 20 20 28 69 66 20 73 74 65 70 ))). (if step
ac40: 2d 69 64 0a 20 20 20 20 20 20 28 62 65 67 69 6e -id. (begin
ac50: 20 20 0a 20 20 20 20 20 20 20 20 28 69 66 20 70 . (if p
ac60: 67 64 62 2d 74 65 73 74 2d 69 64 0a 20 20 20 20 gdb-test-id.
ac70: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 (begin .
ac80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ac90: 69 66 20 20 70 67 64 62 2d 73 74 65 70 2d 69 64 if pgdb-step-id
aca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
acb0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
acc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
acd0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
ace0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
acf0: 70 6f 72 74 2a 20 20 22 55 70 64 61 74 69 6e 67 port* "Updating
ad00: 20 65 78 69 73 74 69 6e 67 20 74 65 73 74 2d 73 existing test-s
ad10: 74 65 70 20 77 69 74 68 20 74 65 73 74 2d 69 64 tep with test-id
ad20: 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e : " test-id " an
ad30: 64 20 73 74 65 70 2d 69 64 20 22 20 73 74 65 70 d step-id " step
ad40: 2d 69 64 20 22 20 70 67 64 62 20 74 65 73 74 20 -id " pgdb test
ad50: 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d id: " pgdb-test-
ad60: 69 64 20 22 20 70 67 64 62 20 73 74 65 70 20 69 id " pgdb step i
ad70: 64 20 22 20 70 67 64 62 2d 73 74 65 70 2d 69 64 d " pgdb-step-id
ad80: 20 29 0a 09 09 09 09 09 09 09 09 09 09 28 6c 65 )...........(le
ad90: 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 t* ((pgdb-last-u
ada0: 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d pdate (pgdb:get-
adb0: 74 65 73 74 2d 73 74 65 70 2d 6c 61 73 74 2d 75 test-step-last-u
adc0: 70 64 61 74 65 20 64 62 68 20 70 67 64 62 2d 73 pdate dbh pgdb-s
add0: 74 65 70 2d 69 64 29 29 29 0a 20 20 20 20 20 20 tep-id))).
ade0: 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 3e 20 (if (and (>
adf0: 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 64 62 last-update pgdb
ae00: 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 28 6f -last-update) (o
ae10: 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d r (not smallest-
ae20: 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 time) (< last-up
ae30: 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 date smallest-ti
ae40: 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 me))). (h
ae50: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 ash-table-set! s
ae60: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
ae70: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
ae80: 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 st-time" last-up
ae90: 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 20 20 date))) .
aea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 (pg
aeb0: 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 2d 73 db:update-test-s
aec0: 74 65 70 20 64 62 68 20 70 67 64 62 2d 73 74 65 tep dbh pgdb-ste
aed0: 70 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d 69 p-id pgdb-test-i
aee0: 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 74 65 d stepname state
aef0: 20 73 74 61 74 75 73 20 65 76 65 6e 74 5f 74 69 status event_ti
af00: 6d 65 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 me comment logfi
af10: 6c 65 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 le last-update))
af20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
af30: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 09 20 (begin. ..
af40: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
af50: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
af60: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e t-log-port* "In
af70: 73 65 72 74 69 6e 67 20 74 65 73 74 2d 73 74 65 serting test-ste
af80: 70 20 77 69 74 68 20 74 65 73 74 2d 69 64 3a 20 p with test-id:
af90: 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e 64 20 " test-id " and
afa0: 73 74 65 70 2d 69 64 20 22 20 73 74 65 70 2d 69 step-id " step-i
afb0: 64 20 20 22 20 70 67 64 62 20 74 65 73 74 20 69 d " pgdb test i
afc0: 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 2d 69 d: " pgdb-test-i
afd0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d).
afe0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 (if (or
aff0: 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 (not smallest-ti
b000: 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 me) (< last-upda
b010: 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 te smallest-time
b020: 29 29 0a 20 20 20 20 20 20 20 20 09 09 09 09 20 )). ....
b030: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
b040: 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c -set! smallest-l
b050: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
b060: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
b070: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 20 20 last-update)).
b080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b090: 20 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 (pgdb:insert
b0a0: 2d 74 65 73 74 2d 73 74 65 70 20 64 62 68 20 70 -test-step dbh p
b0b0: 67 64 62 2d 74 65 73 74 2d 69 64 20 73 74 65 70 gdb-test-id step
b0c0: 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 name state statu
b0d0: 73 20 65 76 65 6e 74 5f 74 69 6d 65 20 63 6f 6d s event_time com
b0e0: 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 20 6c 61 73 ment logfile las
b0f0: 74 2d 75 70 64 61 74 65 20 29 0a 20 20 20 20 20 t-update ).
b100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b110: 20 28 73 65 74 21 20 70 67 64 62 2d 73 74 65 70 (set! pgdb-step
b120: 2d 69 64 20 20 28 70 67 64 62 3a 67 65 74 2d 74 -id (pgdb:get-t
b130: 65 73 74 2d 73 74 65 70 2d 69 64 20 64 62 68 20 est-step-id dbh
b140: 70 67 64 62 2d 74 65 73 74 2d 69 64 20 73 74 65 pgdb-test-id ste
b150: 70 6e 61 6d 65 20 73 74 61 74 65 29 29 29 29 0a pname state)))).
b160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b170: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
b180: 20 73 74 65 70 2d 68 74 20 73 74 65 70 2d 69 64 step-ht step-id
b190: 20 70 67 64 62 2d 73 74 65 70 2d 69 64 20 29 29 pgdb-step-id ))
b1a0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 . (deb
b1b0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
b1c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
b1d0: 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 73 74 t* "Error: Test
b1e0: 20 6e 6f 74 20 63 61 73 68 65 64 22 29 29 29 0a not cashed"))).
b1f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
b200: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
b210: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 45 lt-log-port* "E
b220: 72 72 6f 72 3a 20 43 6f 75 6c 64 20 6e 6f 74 20 rror: Could not
b230: 67 65 74 20 74 65 73 74 20 73 74 65 70 20 69 6e get test step in
b240: 66 6f 20 66 6f 72 20 73 74 65 70 20 69 64 20 22 fo for step id "
b250: 20 74 65 73 74 2d 73 74 65 70 2d 69 64 20 29 29 test-step-id ))
b260: 29 29 09 3b 3b 20 74 68 69 73 20 69 73 20 61 20 )).;; this is a
b270: 77 69 65 72 64 20 73 65 6e 61 72 69 6f 20 6e 65 wierd senario ne
b280: 65 64 20 74 6f 20 64 65 62 75 67 20 20 20 20 20 ed to debug
b290: 20 09 0a 20 20 20 74 65 73 74 2d 73 74 65 70 2d .. test-step-
b2a0: 69 64 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ids)))...(define
b2b0: 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 (tasks:sync-tes
b2c0: 74 73 2d 64 61 74 61 20 64 62 68 20 63 61 63 68 ts-data dbh cach
b2d0: 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 73 ed-info test-ids
b2e0: 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c area-info small
b2f0: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
b300: 74 69 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 74 time). (let ((t
b310: 65 73 74 2d 68 74 20 28 68 61 73 68 2d 74 61 62 est-ht (hash-tab
b320: 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e le-ref cached-in
b330: 66 6f 20 27 74 65 73 74 73 29 29 29 0a 20 20 20 fo 'tests))).
b340: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
b350: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 69 64 (lambda (test-id
b360: 29 0a 20 20 20 20 20 20 3b 20 28 70 72 69 6e 74 ). ; (print
b370: 20 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 test-id).
b380: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 69 6e (let* ((test-in
b390: 66 6f 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 fo (rmt:get-t
b3a0: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 est-info-by-id #
b3b0: 66 20 74 65 73 74 2d 69 64 29 29 0a 09 20 20 20 f test-id))..
b3c0: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 (run-id
b3d0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
b3e0: 6e 5f 69 64 20 20 20 20 74 65 73 74 2d 69 6e 66 n_id test-inf
b3f0: 6f 29 29 20 3b 3b 20 6c 6f 6f 6b 20 74 68 65 73 o)) ;; look thes
b400: 65 20 75 70 20 69 6e 20 64 62 5f 72 65 63 6f 72 e up in db_recor
b410: 64 73 2e 73 63 6d 0a 09 20 20 20 20 20 20 28 74 ds.scm.. (t
b420: 65 73 74 2d 69 64 20 20 20 20 20 20 28 64 62 3a est-id (db:
b430: 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 20 test-get-id
b440: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
b450: 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 (test-name
b460: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
b470: 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 2d -testname test-
b480: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 69 info)).. (i
b490: 74 65 6d 2d 70 61 74 68 20 20 20 20 28 64 62 3a tem-path (db:
b4a0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
b4b0: 74 68 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 th test-info))..
b4c0: 20 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 (state
b4d0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
b4e0: 2d 73 74 61 74 65 20 20 20 20 20 74 65 73 74 2d -state test-
b4f0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 73 info)).. (s
b500: 74 61 74 75 73 20 20 20 20 20 20 20 28 64 62 3a tatus (db:
b510: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
b520: 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 test-info))..
b530: 20 20 20 20 20 20 28 68 6f 73 74 20 20 20 20 20 (host
b540: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
b550: 2d 68 6f 73 74 20 20 20 20 20 20 74 65 73 74 2d -host test-
b560: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 28 info)). (
b570: 70 69 64 20 20 20 20 20 20 20 20 20 20 28 64 62 pid (db
b580: 3a 74 65 73 74 2d 67 65 74 2d 70 72 6f 63 65 73 :test-get-proces
b590: 73 5f 69 64 20 74 65 73 74 2d 69 6e 66 6f 29 29 s_id test-info))
b5a0: 20 0a 09 20 20 20 20 20 20 28 63 70 75 6c 6f 61 .. (cpuloa
b5b0: 64 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d d (db:test-
b5c0: 67 65 74 2d 63 70 75 6c 6f 61 64 20 20 20 74 65 get-cpuload te
b5d0: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
b5e0: 20 28 64 69 73 6b 66 72 65 65 20 20 20 20 20 28 (diskfree (
b5f0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 64 69 73 6b db:test-get-disk
b600: 66 72 65 65 20 20 74 65 73 74 2d 69 6e 66 6f 29 free test-info)
b610: 29 0a 09 20 20 20 20 20 20 28 75 6e 61 6d 65 20 ).. (uname
b620: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
b630: 67 65 74 2d 75 6e 61 6d 65 20 20 20 20 20 74 65 get-uname te
b640: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
b650: 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 28 (run-dir (
b660: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
b670: 69 72 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 ir test-info)
b680: 29 0a 09 20 20 20 20 20 20 28 6c 6f 67 2d 66 69 ).. (log-fi
b690: 6c 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d le (db:test-
b6a0: 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 get-final_logf t
b6b0: 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 est-info))..
b6c0: 20 20 28 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 (run-duration
b6d0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
b6e0: 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d 69 _duration test-i
b6f0: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 63 6f nfo)).. (co
b700: 6d 6d 65 6e 74 20 20 20 20 20 20 28 64 62 3a 74 mment (db:t
b710: 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 est-get-comment
b720: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 test-info))..
b730: 20 20 20 20 20 28 65 76 65 6e 74 2d 74 69 6d 65 (event-time
b740: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
b750: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 2d event_time test-
b760: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 28 61 info)).. (a
b770: 72 63 68 69 76 65 64 20 20 20 20 20 28 64 62 3a rchived (db:
b780: 74 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 test-get-archive
b790: 64 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 20 d test-info)).
b7a0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 75 70 64 (last-upd
b7b0: 61 74 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ate (db:test-ge
b7c0: 74 2d 6c 61 73 74 5f 75 70 64 61 74 65 20 20 74 t-last_update t
b7d0: 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 est-info))..
b7e0: 20 20 28 70 67 64 62 2d 72 75 6e 2d 69 64 20 20 (pgdb-run-id
b7f0: 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d (tasks:run-id->m
b800: 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 tpg-run-id dbh c
b810: 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 ached-info run-i
b820: 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c d area-info smal
b830: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
b840: 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -time)).
b850: 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 (smallest-time (
b860: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
b870: 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d efault smallest-
b880: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
b890: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
b8a0: 20 23 66 29 29 20 20 20 20 20 20 20 0a 09 20 20 #f)) ..
b8b0: 20 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d 69 (pgdb-test-i
b8c0: 64 20 28 69 66 20 70 67 64 62 2d 72 75 6e 2d 69 d (if pgdb-run-i
b8d0: 64 20 0a 09 09 09 09 28 62 65 67 69 6e 0a 20 20 d .....(begin.
b8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b900: 3b 28 70 72 69 6e 74 20 70 67 64 62 2d 72 75 6e ;(print pgdb-run
b910: 2d 69 64 29 20 20 20 20 0a 20 20 20 20 20 20 20 -id) .
b920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b930: 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a (pgdb:
b940: 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 68 20 get-test-id dbh
b950: 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 pgdb-run-id test
b960: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
b970: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b990: 20 20 20 23 66 29 29 29 0a 09 20 3b 3b 20 22 69 #f))).. ;; "i
b9a0: 64 22 20 20 20 20 20 20 20 20 20 20 20 22 72 75 d" "ru
b9b0: 6e 5f 69 64 22 20 20 20 20 20 20 20 20 22 74 65 n_id" "te
b9c0: 73 74 6e 61 6d 65 22 20 20 22 73 74 61 74 65 22 stname" "state"
b9d0: 20 20 20 20 20 20 22 73 74 61 74 75 73 22 20 20 "status"
b9e0: 20 20 20 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 "event_time"
b9f0: 0a 09 20 3b 3b 20 22 68 6f 73 74 22 20 20 20 20 .. ;; "host"
ba00: 20 20 20 20 20 22 63 70 75 6c 6f 61 64 22 20 20 "cpuload"
ba10: 20 20 20 20 20 22 64 69 73 6b 66 72 65 65 22 20 "diskfree"
ba20: 20 22 75 6e 61 6d 65 22 20 20 20 20 20 20 22 72 "uname" "r
ba30: 75 6e 64 69 72 22 20 20 20 20 20 20 22 69 74 65 undir" "ite
ba40: 6d 5f 70 61 74 68 22 0a 09 20 3b 3b 20 22 72 75 m_path".. ;; "ru
ba50: 6e 5f 64 75 72 61 74 69 6f 6e 22 20 22 66 69 6e n_duration" "fin
ba60: 61 6c 5f 6c 6f 67 66 22 20 20 20 20 22 63 6f 6d al_logf" "com
ba70: 6d 65 6e 74 22 20 20 20 22 73 68 6f 72 74 64 69 ment" "shortdi
ba80: 72 22 20 20 20 22 61 74 74 65 6d 70 74 6e 75 6d r" "attemptnum
ba90: 22 20 20 22 61 72 63 68 69 76 65 64 22 0a 20 20 " "archived".
baa0: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
bab0: 6e 6f 74 20 69 74 65 6d 2d 70 61 74 68 29 20 28 not item-path) (
bac0: 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 string-null? ite
bad0: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 m-path)).
bae0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
baf0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
bb00: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 6f lt-log-port* "Wo
bb10: 72 6b 69 6e 67 20 6f 6e 20 52 75 6e 20 69 64 20 rking on Run id
bb20: 3a 20 22 20 72 75 6e 2d 69 64 20 22 61 6e 64 20 : " run-id "and
bb30: 74 65 73 74 20 6e 61 6d 65 20 3a 20 22 20 74 65 test name : " te
bb40: 73 74 2d 6e 61 6d 65 29 29 20 0a 20 20 20 20 20 st-name)) .
bb50: 20 20 20 20 28 69 66 20 70 67 64 62 2d 72 75 6e (if pgdb-run
bb60: 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 -id. (
bb70: 62 65 67 69 6e 0a 09 20 20 20 28 69 66 20 70 67 begin.. (if pg
bb80: 64 62 2d 74 65 73 74 2d 69 64 20 3b 3b 20 68 61 db-test-id ;; ha
bb90: 76 65 20 61 20 72 65 63 6f 72 64 0a 09 20 20 20 ve a record..
bba0: 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 (begin ;; let
bbb0: 28 28 6b 65 79 2d 6e 61 6d 65 20 28 63 6f 6e 63 ((key-name (conc
bbc0: 20 72 75 6e 2d 69 64 20 22 2f 22 20 74 65 73 74 run-id "/" test
bbd0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
bbe0: 61 74 68 29 29 29 0a 09 20 20 20 20 20 20 20 28 ath))).. (
bbf0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
bc00: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
bc10: 70 6f 72 74 2a 20 20 22 55 70 64 61 74 69 6e 67 port* "Updating
bc20: 20 65 78 69 73 74 69 6e 67 20 74 65 73 74 20 77 existing test w
bc30: 69 74 68 20 72 75 6e 2d 69 64 3a 20 22 20 72 75 ith run-id: " ru
bc40: 6e 2d 69 64 20 22 20 61 6e 64 20 74 65 73 74 2d n-id " and test-
bc50: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 id: " test-id "
bc60: 70 67 64 62 20 72 75 6e 20 69 64 3a 20 22 20 70 pgdb run id: " p
bc70: 67 64 62 2d 72 75 6e 2d 69 64 20 22 20 20 70 67 gdb-run-id " pg
bc80: 64 62 2d 74 65 73 74 2d 69 64 20 22 20 20 70 67 db-test-id " pg
bc90: 64 62 2d 74 65 73 74 2d 69 64 29 0a 20 20 20 20 db-test-id).
bca0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 67 64 (let* ((pgd
bcb0: 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 28 70 b-last-update (p
bcc0: 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 6c 61 73 gdb:get-test-las
bcd0: 74 2d 75 70 64 61 74 65 20 64 62 68 20 70 67 64 t-update dbh pgd
bce0: 62 2d 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 b-test-id))).
bcf0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 20 (if (and
bd00: 28 3e 20 20 6c 61 73 74 2d 75 70 64 61 74 65 20 (> last-update
bd10: 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 pgdb-last-update
bd20: 29 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c ) (or (not small
bd30: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
bd40: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
bd50: 74 2d 74 69 6d 65 29 29 29 20 3b 3b 69 66 20 6c t-time))) ;;if l
bd60: 61 73 74 2d 75 70 64 61 74 65 20 69 73 20 73 61 ast-update is sa
bd70: 6d 65 20 61 73 20 70 67 64 62 2d 6c 61 73 74 2d me as pgdb-last-
bd80: 75 70 64 61 74 65 20 74 68 65 6e 20 69 74 20 69 update then it i
bd90: 73 20 73 61 66 65 20 74 6f 20 61 73 73 75 6d 65 s safe to assume
bda0: 20 74 68 65 20 72 65 63 6f 72 64 73 20 61 72 65 the records are
bdb0: 20 69 64 65 6e 74 69 63 61 6c 20 61 6e 64 20 77 identical and w
bdc0: 65 20 63 61 6e 20 75 73 65 20 61 20 6c 61 72 67 e can use a larg
bdd0: 65 72 20 6c 61 73 74 20 75 70 64 61 74 65 20 74 er last update t
bde0: 69 6d 65 2e 0a 20 20 20 20 20 20 20 20 28 68 61 ime.. (ha
bdf0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d sh-table-set! sm
be00: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
be10: 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 te-time "smalles
be20: 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 t-time" last-upd
be30: 61 74 65 29 29 29 20 0a 09 20 20 20 20 20 20 20 ate))) ..
be40: 28 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 (pgdb:update-tes
be50: 74 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d t dbh pgdb-test-
be60: 69 64 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 id pgdb-run-id t
be70: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
be80: 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 20 th state status
be90: 68 6f 73 74 20 63 70 75 6c 6f 61 64 20 64 69 73 host cpuload dis
bea0: 6b 66 72 65 65 20 75 6e 61 6d 65 20 72 75 6e 2d kfree uname run-
beb0: 64 69 72 20 6c 6f 67 2d 66 69 6c 65 20 72 75 6e dir log-file run
bec0: 2d 64 75 72 61 74 69 6f 6e 20 63 6f 6d 6d 65 6e -duration commen
bed0: 74 20 65 76 65 6e 74 2d 74 69 6d 65 20 61 72 63 t event-time arc
bee0: 68 69 76 65 64 20 6c 61 73 74 2d 75 70 64 61 74 hived last-updat
bef0: 65 20 70 69 64 29 29 0a 09 20 20 20 20 20 28 62 e pid)).. (b
bf00: 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 20 egin .
bf10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
bf20: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
bf30: 67 2d 70 6f 72 74 2a 20 20 22 49 6e 73 65 72 74 g-port* "Insert
bf40: 69 6e 67 20 74 65 73 74 20 77 69 74 68 20 72 75 ing test with ru
bf50: 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 n-id: " run-id "
bf60: 20 61 6e 64 20 74 65 73 74 2d 69 64 3a 20 22 20 and test-id: "
bf70: 74 65 73 74 2d 69 64 20 20 22 20 70 67 64 62 20 test-id " pgdb
bf80: 72 75 6e 20 69 64 3a 20 22 20 70 67 64 62 2d 72 run id: " pgdb-r
bf90: 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 un-id).
bfa0: 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d 74 (pgdb:insert-t
bfb0: 65 73 74 20 64 62 68 20 70 67 64 62 2d 72 75 6e est dbh pgdb-run
bfc0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
bfd0: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 em-path state st
bfe0: 61 74 75 73 20 68 6f 73 74 20 63 70 75 6c 6f 61 atus host cpuloa
bff0: 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 6d 65 d diskfree uname
c000: 20 72 75 6e 2d 64 69 72 20 6c 6f 67 2d 66 69 6c run-dir log-fil
c010: 65 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 63 e run-duration c
c020: 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 2d 74 69 6d omment event-tim
c030: 65 20 61 72 63 68 69 76 65 64 20 6c 61 73 74 2d e archived last-
c040: 75 70 64 61 74 65 20 70 69 64 29 0a 20 20 20 20 update pid).
c050: 20 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 (if (or
c060: 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 69 (not smallest-ti
c070: 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 61 me) (< last-upda
c080: 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 te smallest-time
c090: 29 29 0a 20 20 20 20 20 20 20 20 09 09 09 09 28 )). ....(
c0a0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
c0b0: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
c0c0: 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c date-time "small
c0d0: 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 est-time" last-u
c0e0: 70 64 61 74 65 29 29 0a 20 20 20 20 20 20 20 20 pdate)).
c0f0: 20 20 20 28 73 65 74 21 20 70 67 64 62 2d 74 65 (set! pgdb-te
c100: 73 74 2d 69 64 20 28 70 67 64 62 3a 67 65 74 2d st-id (pgdb:get-
c110: 74 65 73 74 2d 69 64 20 64 62 68 20 70 67 64 62 test-id dbh pgdb
c120: 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d -run-id test-nam
c130: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a e item-path)))).
c140: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
c150: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 -table-set! test
c160: 2d 68 74 20 74 65 73 74 2d 69 64 20 70 67 64 62 -ht test-id pgdb
c170: 2d 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 -test-id)).
c180: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
c190: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
c1a0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 57 lt-log-port* "W
c1b0: 41 52 4e 49 4e 47 3a 20 53 6b 69 70 70 69 6e 67 ARNING: Skipping
c1c0: 20 72 75 6e 20 77 69 74 68 20 72 75 6e 2d 69 64 run with run-id
c1d0: 3a 22 20 72 75 6e 2d 69 64 20 22 2e 20 54 68 69 :" run-id ". Thi
c1e0: 73 20 72 75 6e 20 77 61 73 20 63 72 65 61 74 65 s run was create
c1f0: 64 20 61 66 74 65 72 20 70 72 69 76 69 6f 75 73 d after privious
c200: 20 73 79 6e 63 20 61 6e 64 20 72 65 6d 6f 76 65 sync and remove
c210: 64 20 62 65 66 6f 72 65 20 74 68 69 73 20 73 79 d before this sy
c220: 6e 63 2e 22 29 29 29 29 0a 20 20 20 20 20 74 65 nc.")))). te
c230: 73 74 2d 69 64 73 29 29 29 0a 0a 0a 3b 3b 20 67 st-ids)))...;; g
c240: 65 74 20 72 75 6e 73 20 63 68 61 6e 67 65 64 20 et runs changed
c250: 73 69 6e 63 65 20 6c 61 73 74 20 73 79 6e 63 0a since last sync.
c260: 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 61 73 6b ;; (define (task
c270: 73 3a 73 79 6e 63 2d 74 65 73 74 2d 64 61 74 61 s:sync-test-data
c280: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
c290: 20 61 72 65 61 2d 69 6e 66 6f 29 0a 3b 3b 20 20 area-info).;;
c2a0: 20 28 6c 65 74 2a 20 28 28 0a 0a 28 64 65 66 69 (let* ((..(defi
c2b0: 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 ne (tasks:sync-t
c2c0: 6f 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 o-postgres confi
c2d0: 67 64 61 74 20 64 65 73 74 29 0a 20 20 28 70 72 gdat dest). (pr
c2e0: 69 6e 74 20 22 49 6e 20 73 79 6e 63 22 29 0a 20 int "In sync").
c2f0: 20 28 6c 65 74 2a 20 28 28 64 62 68 20 20 20 20 (let* ((dbh
c300: 20 20 20 20 20 28 70 67 64 62 3a 6f 70 65 6e 20 (pgdb:open
c310: 63 6f 6e 66 69 67 64 61 74 20 64 62 6e 61 6d 65 configdat dbname
c320: 3a 20 64 65 73 74 29 29 0a 09 20 28 61 72 65 61 : dest)).. (area
c330: 2d 69 6e 66 6f 20 20 20 28 70 67 64 62 3a 67 65 -info (pgdb:ge
c340: 74 2d 61 72 65 61 2d 62 79 2d 70 61 74 68 20 64 t-area-by-path d
c350: 62 68 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 bh *toppath*))..
c360: 20 28 63 61 63 68 65 64 2d 69 6e 66 6f 20 28 6d (cached-info (m
c370: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
c380: 0a 09 20 28 73 74 61 72 74 20 20 20 20 20 20 20 .. (start
c390: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
c3a0: 29 29 0a 20 20 20 28 74 65 73 74 2d 70 61 74 74 )). (test-patt
c3b0: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
c3c0: 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
c3d0: 29 0a 09 09 09 09 09 09 09 09 09 09 09 28 61 72 )............(ar
c3e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
c3f0: 74 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 tpatt").
c400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
c410: 22 29 29 0a 20 20 20 28 74 61 72 67 65 74 20 20 ")). (target
c420: 20 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 (if (args
c430: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
c440: 74 22 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 t").............
c450: 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 .. (args:get-arg
c460: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 09 09 "-target").....
c470: 09 09 09 09 09 09 09 09 09 23 66 29 29 0a 20 20 .........#f)).
c480: 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 20 20 20 (run-name
c490: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
c4a0: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
c4b0: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 )...............
c4c0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
c4d0: 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 09 09 09 -runname")......
c4e0: 09 09 09 09 09 09 09 09 23 66 29 29 29 0a 20 20 ........#f))).
c4f0: 20 20 20 28 69 66 20 28 61 6e 64 20 74 61 72 67 (if (and targ
c500: 65 74 20 20 28 6e 6f 74 20 72 75 6e 2d 6e 61 6d et (not run-nam
c510: 65 29 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 e)). (begi
c520: 6e 0a 09 09 09 09 09 28 70 72 69 6e 74 20 22 45 n......(print "E
c530: 72 72 6f 72 3a 20 50 72 6f 76 69 64 65 20 72 75 rror: Provide ru
c540: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 20 nname").
c550: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
c560: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
c570: 74 61 72 67 65 74 29 20 20 72 75 6e 2d 6e 61 6d target) run-nam
c580: 65 29 0a 20 20 20 20 20 20 20 28 62 65 67 69 6e e). (begin
c590: 0a 09 09 09 09 09 28 70 72 69 6e 74 20 22 45 72 ......(print "Er
c5a0: 72 6f 72 3a 20 50 72 6f 76 69 64 65 20 74 61 72 ror: Provide tar
c5b0: 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 get").
c5c0: 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 20 3b (exit 1))). ;
c5d0: 28 70 72 69 6e 74 20 22 31 32 33 22 29 0a 20 20 (print "123").
c5e0: 20 20 3b 28 65 78 69 74 20 31 29 20 0a 20 20 20 ;(exit 1) .
c5f0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
c600: 64 61 20 28 64 74 79 70 65 29 0a 09 09 28 68 61 da (dtype)...(ha
c610: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 sh-table-set! ca
c620: 63 68 65 64 2d 69 6e 66 6f 20 64 74 79 70 65 20 ched-info dtype
c630: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
c640: 29 29 29 0a 09 20 20 20 20 20 20 27 28 72 75 6e ))).. '(run
c650: 73 20 74 61 72 67 65 74 73 20 74 65 73 74 73 20 s targets tests
c660: 73 74 65 70 73 20 64 61 74 61 29 29 0a 20 20 20 steps data)).
c670: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
c680: 21 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 73 ! cached-info 's
c690: 74 61 72 74 20 73 74 61 72 74 29 20 3b 3b 20 77 tart start) ;; w
c6a0: 68 65 6e 20 64 6f 6e 65 20 77 65 27 6c 6c 20 73 hen done we'll s
c6b0: 65 74 20 73 79 6e 63 20 74 69 6d 65 73 20 74 6f et sync times to
c6c0: 20 74 68 69 73 0a 20 20 20 20 28 69 66 20 61 72 this. (if ar
c6d0: 65 61 2d 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 ea-info..(let* (
c6e0: 28 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 (last-sync-time
c6f0: 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 61 (vector-ref area
c700: 2d 69 6e 66 6f 20 33 29 29 0a 09 20 20 20 20 20 -info 3))..
c710: 20 20 28 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 (smallest-last
c720: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 20 28 6d -update-time (m
c730: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
c740: 0a 20 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 . (chang
c750: 65 64 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 ed (if (and
c760: 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 target run-name
c770: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
c790: 6d 74 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 mt:get-run-recor
c7a0: 64 2d 69 64 73 20 74 61 72 67 65 74 20 72 75 6e d-ids target run
c7b0: 2d 6e 61 6d 65 20 28 72 6d 74 3a 67 65 74 2d 6b -name (rmt:get-k
c7c0: 65 79 73 29 20 74 65 73 74 2d 70 61 74 74 29 0a eys) test-patt).
c7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 (rmt
c7f0: 3a 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 :get-changed-rec
c800: 6f 72 64 2d 69 64 73 20 6c 61 73 74 2d 73 79 6e ord-ids last-syn
c810: 63 2d 74 69 6d 65 29 29 29 0a 09 20 20 20 20 20 c-time)))..
c820: 20 20 28 72 75 6e 2d 69 64 73 20 20 20 20 20 20 (run-ids
c830: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 (alist-ref 'ru
c840: 6e 73 20 20 20 20 20 20 20 63 68 61 6e 67 65 64 ns changed
c850: 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 )).. (test
c860: 2d 69 64 73 20 20 20 20 20 20 20 28 61 6c 69 73 -ids (alis
c870: 74 2d 72 65 66 20 27 74 65 73 74 73 20 20 20 20 t-ref 'tests
c880: 20 20 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 changed))..
c890: 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 2d 69 (test-step-i
c8a0: 64 73 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 ds (alist-ref '
c8b0: 74 65 73 74 5f 73 74 65 70 73 20 63 68 61 6e 67 test_steps chang
c8c0: 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 ed)).. (te
c8d0: 73 74 2d 64 61 74 61 2d 69 64 73 20 20 28 61 6c st-data-ids (al
c8e0: 69 73 74 2d 72 65 66 20 27 74 65 73 74 5f 64 61 ist-ref 'test_da
c8f0: 74 61 20 20 63 68 61 6e 67 65 64 29 29 0a 09 20 ta changed))..
c900: 20 20 20 20 20 20 28 72 75 6e 2d 73 74 61 74 2d (run-stat-
c910: 69 64 73 20 20 20 28 61 6c 69 73 74 2d 72 65 66 ids (alist-ref
c920: 20 27 72 75 6e 5f 73 74 61 74 73 20 20 63 68 61 'run_stats cha
c930: 6e 67 65 64 29 29 0a 20 20 20 20 20 20 20 20 20 nged)).
c940: 28 61 72 65 61 2d 74 61 67 20 20 20 20 28 69 66 (area-tag (if
c950: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
c960: 2d 61 72 65 61 2d 74 61 67 22 29 20 0a 20 20 20 -area-tag") .
c970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
c990: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 rgs:get-arg "-ar
c9a0: 65 61 2d 74 61 67 22 29 0a 20 20 20 20 20 20 20 ea-tag").
c9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
c9d0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 rgs:get-arg "-ar
c9e0: 65 61 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 ea") .
c9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca00: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
ca10: 65 74 2d 61 72 67 20 22 2d 61 72 65 61 22 29 20 et-arg "-area")
ca20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ca30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca40: 20 20 20 20 22 22 29 29 29 29 0a 20 20 20 20 20 "")))).
ca50: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
ca60: 65 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 67 20 equal? area-tag
ca70: 22 22 29 20 28 6e 6f 74 20 28 70 67 64 62 3a 69 "") (not (pgdb:i
ca80: 73 2d 61 72 65 61 2d 74 61 67 65 64 20 64 62 68 s-area-taged dbh
ca90: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 72 65 (vector-ref are
caa0: 61 2d 69 6e 66 6f 20 30 29 29 29 29 0a 20 20 20 a-info 0)))).
cab0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 61 (set! a
cac0: 72 65 61 2d 74 61 67 20 2a 64 65 66 61 75 6c 74 rea-tag *default
cad0: 2d 61 72 65 61 2d 74 61 67 2a 29 29 20 0a 20 20 -area-tag*)) .
cae0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
caf0: 74 20 28 65 71 75 61 6c 3f 20 61 72 65 61 2d 74 t (equal? area-t
cb00: 61 67 20 22 22 29 29 20 0a 20 20 20 20 20 20 20 ag "")) .
cb10: 20 20 20 20 20 20 28 74 61 73 6b 3a 61 64 64 2d (task:add-
cb20: 61 72 65 61 2d 74 61 67 20 64 62 68 20 61 72 65 area-tag dbh are
cb30: 61 2d 69 6e 66 6f 20 61 72 65 61 2d 74 61 67 29 a-info area-tag)
cb40: 29 20 0a 09 20 20 28 69 66 20 28 6f 72 20 28 6e ) .. (if (or (n
cb50: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 69 ot (null? test-i
cb60: 64 73 29 29 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f ds)) (not (null?
cb70: 20 72 75 6e 2d 69 64 73 29 29 29 0a 09 20 20 20 run-ids)))..
cb80: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
cb90: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
cba0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
cbb0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
cbc0: 20 20 22 73 79 6e 63 69 6e 67 20 72 75 6e 73 22 "syncing runs"
cbd0: 29 20 20 20 0a 09 20 20 20 20 20 20 20 20 20 20 ) ..
cbe0: 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d (tasks:sync-
cbf0: 72 75 6e 2d 64 61 74 61 20 64 62 68 20 63 61 63 run-data dbh cac
cc00: 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 73 hed-info run-ids
cc10: 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c area-info small
cc20: 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d est-last-update-
cc30: 74 69 6d 65 29 20 0a 20 20 20 20 20 20 20 20 20 time) .
cc40: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
cc50: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
cc60: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
cc70: 73 79 6e 63 69 6e 67 20 74 65 73 74 73 22 29 0a syncing tests").
cc80: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 28 74 .. (t
cc90: 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 73 2d asks:sync-tests-
cca0: 64 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d data dbh cached-
ccb0: 69 6e 66 6f 20 74 65 73 74 2d 69 64 73 20 61 72 info test-ids ar
ccc0: 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 ea-info smallest
ccd0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
cce0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
ccf0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
cd00: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
cd10: 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 79 6e 63 log-port* "sync
cd20: 69 6e 67 20 74 65 73 74 20 73 74 65 70 73 22 29 ing test steps")
cd30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cd40: 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 73 (tasks:sync-tes
cd50: 74 2d 73 74 65 70 73 20 64 62 68 20 63 61 63 68 t-steps dbh cach
cd60: 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d 73 74 65 ed-info test-ste
cd70: 70 2d 69 64 73 20 73 6d 61 6c 6c 65 73 74 2d 6c p-ids smallest-l
cd80: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 ast-update-time)
cd90: 0a 09 09 09 09 09 09 09 09 28 64 65 62 75 67 3a .........(debug:
cda0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
cdb0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
cdc0: 20 22 73 79 6e 63 69 6e 67 20 74 65 73 74 20 64 "syncing test d
cdd0: 61 74 61 22 29 0a 20 20 20 20 20 20 20 20 20 20 ata").
cde0: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 79 6e (tasks:syn
cdf0: 63 2d 74 65 73 74 2d 67 65 6e 2d 64 61 74 61 20 c-test-gen-data
ce00: 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 dbh cached-info
ce10: 74 65 73 74 2d 64 61 74 61 2d 69 64 73 20 73 6d test-data-ids sm
ce20: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
ce30: 74 65 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 te-time).
ce40: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
ce50: 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 64 6f 6e 65 2d "----------done-
ce60: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 22 29 --------------")
ce70: 29 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 20 28 )). (let* (
ce80: 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 (smallest-time (
ce90: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
cea0: 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d efault smallest-
ceb0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
cec0: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
ced0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
cee0: 73 29 29 29 29 0a 20 20 20 20 20 28 64 65 62 75 s)))). (debu
cef0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
cf00: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 3a 22 smallest-time :"
cf10: 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 20 smallest-time
cf20: 22 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 " last-sync-time
cf30: 20 22 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d " last-sync-tim
cf40: 65 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 e). (if (not
cf50: 28 61 6e 64 20 74 61 72 67 65 74 20 72 75 6e 2d (and target run-
cf60: 6e 61 6d 65 29 29 20 0a 09 20 20 28 69 66 20 28 name)) .. (if (
cf70: 6f 72 20 28 61 6e 64 20 73 6d 61 6c 6c 65 73 74 or (and smallest
cf80: 2d 74 69 6d 65 20 28 3e 20 73 6d 61 6c 6c 65 73 -time (> smalles
cf90: 74 2d 74 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 t-time last-sync
cfa0: 2d 74 69 6d 65 29 29 20 28 61 6e 64 20 73 6d 61 -time)) (and sma
cfb0: 6c 6c 65 73 74 2d 74 69 6d 65 20 28 65 71 3f 20 llest-time (eq?
cfc0: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 last-sync-time 0
cfd0: 29 29 29 0a 09 09 09 09 28 70 67 64 62 3a 77 72 ))).....(pgdb:wr
cfe0: 69 74 65 2d 73 79 6e 63 2d 74 69 6d 65 20 64 62 ite-sync-time db
cff0: 68 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c h area-info smal
d000: 6c 65 73 74 2d 74 69 6d 65 29 29 29 29 29 20 3b lest-time))))) ;
d010: 3b 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 ;this needs to b
d020: 65 20 63 68 61 6e 67 65 64 0a 09 28 69 66 20 28 e changed..(if (
d030: 74 61 73 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 tasks:set-area d
d040: 62 68 20 63 6f 6e 66 69 67 64 61 74 29 0a 09 20 bh configdat)..
d050: 20 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 (tasks:sync-t
d060: 6f 2d 70 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 o-postgres confi
d070: 67 64 61 74 20 64 65 73 74 29 0a 09 20 20 20 20 gdat dest)..
d080: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
d090: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
d0a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
d0b0: 22 45 52 52 4f 52 3a 20 75 6e 61 62 6c 65 20 74 "ERROR: unable t
d0c0: 6f 20 63 72 65 61 74 65 20 61 6e 20 61 72 65 61 o create an area
d0d0: 20 72 65 63 6f 72 64 22 29 0a 09 20 20 20 20 20 record")..
d0e0: 20 23 66 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 #f)))))...(defi
d0f0: 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 72 ne (tasks:sync-r
d100: 75 6e 2d 64 61 74 61 20 64 62 68 20 63 61 63 68 un-data dbh cach
d110: 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 73 20 ed-info run-ids
d120: 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 area-info smalle
d130: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
d140: 69 6d 65 29 20 0a 20 20 28 66 6f 72 2d 65 61 63 ime) . (for-eac
d150: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
d160: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 64 run-id). (d
d170: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
d180: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
d190: 6f 72 74 2a 20 20 20 22 43 68 65 63 6b 20 69 66 ort* "Check if
d1a0: 20 72 75 6e 20 77 69 74 68 20 22 20 72 75 6e 2d run with " run-
d1b0: 69 64 20 22 20 6e 65 65 64 73 20 74 6f 20 62 65 id " needs to be
d1c0: 20 73 79 6e 63 65 64 22 20 29 0a 20 20 20 20 20 synced" ).
d1d0: 20 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 2d (tasks:run-id-
d1e0: 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 68 >mtpg-run-id dbh
d1f0: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e cached-info run
d200: 2d 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d -id area-info sm
d210: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
d220: 74 65 2d 74 69 6d 65 29 29 0a 72 75 6e 2d 69 64 te-time)).run-id
d230: 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d s))..;;=========
d240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
d280: 20 73 69 6d 70 6c 65 20 6c 6f 63 6b 2e 20 69 6d simple lock. im
d290: 70 72 6f 76 65 20 61 6e 64 20 63 6f 6e 76 65 72 prove and conver
d2a0: 67 65 20 6f 6e 20 74 68 69 73 20 6f 6e 65 2e 0a ge on this one..
d2b0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
d2c0: 6f 6e 3a 73 69 6d 70 6c 65 2d 6c 6f 63 6b 20 6b on:simple-lock k
d2d0: 65 79 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 6e eyname). (rmt:n
d2e0: 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 o-sync-get-lock
d2f0: 6b 65 79 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 keyname))..(defi
d300: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
d310: 65 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 e-unlock keyname
d320: 20 23 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 #!key (force #f
d330: 29 29 0a 20 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e )). (rmt:no-syn
d340: 63 2d 64 65 6c 21 20 6b 65 79 6e 61 6d 65 29 29 c-del! keyname))
d350: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
d360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 ==========.;; S
d3a0: 20 54 20 41 20 54 20 45 20 20 20 41 20 4e 20 44 T A T E A N D
d3b0: 20 20 20 53 20 54 20 41 20 54 20 55 20 53 20 20 S T A T U S
d3c0: 20 46 20 4f 20 52 20 20 20 54 20 45 20 53 20 54 F O R T E S T
d3d0: 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;==========
d3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
d420: 20 73 70 65 65 64 20 75 70 20 66 6f 72 20 63 6f speed up for co
d430: 6d 6d 6f 6e 20 63 61 73 65 73 20 77 69 74 68 20 mmon cases with
d440: 61 20 6c 69 74 74 6c 65 20 6c 6f 67 69 63 0a 28 a little logic.(
d450: 64 65 66 69 6e 65 20 28 6d 74 3a 74 65 73 74 2d define (mt:test-
d460: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
d470: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
d480: 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e st-id newstate n
d490: 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d ewstatus newcomm
d4a0: 65 6e 74 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 ent). (if (not
d4b0: 28 61 6e 64 20 72 75 6e 2d 69 64 20 74 65 73 74 (and run-id test
d4c0: 2d 69 64 29 29 0a 20 20 20 20 20 20 28 62 65 67 -id)). (beg
d4d0: 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 in..(debug:print
d4e0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
d4f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 t-log-port* "bad
d500: 20 64 61 74 61 20 68 61 6e 64 65 64 20 74 6f 20 data handed to
d510: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
d520: 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 2c 20 e-status-by-id,
d530: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
d540: 22 2c 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 ", test-id=" tes
d550: 74 2d 69 64 20 22 2c 20 6e 65 77 73 74 61 74 65 t-id ", newstate
d560: 3d 22 20 6e 65 77 73 74 61 74 65 29 0a 09 28 70 =" newstate)..(p
d570: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
d580: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
d590: 6f 72 74 29 29 0a 09 23 66 29 0a 20 20 20 20 20 ort))..#f).
d5a0: 20 28 62 65 67 69 6e 0a 09 3b 3b 20 63 6f 6e 64 (begin..;; cond
d5b0: 0a 09 3b 3b 20 28 28 61 6e 64 20 6e 65 77 73 74 ..;; ((and newst
d5c0: 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 ate newstatus ne
d5d0: 77 63 6f 6d 6d 65 6e 74 29 0a 09 3b 3b 20 20 28 wcomment)..;; (
d5e0: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
d5f0: 20 27 73 74 61 74 65 2d 73 74 61 74 75 73 2d 6d 'state-status-m
d600: 73 67 20 72 75 6e 2d 69 64 20 6e 65 77 73 74 61 sg run-id newsta
d610: 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 te newstatus new
d620: 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 69 64 29 comment test-id)
d630: 29 0a 09 3b 3b 20 28 28 61 6e 64 20 6e 65 77 73 )..;; ((and news
d640: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 29 0a tate newstatus).
d650: 09 3b 3b 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 .;; (rmt:genera
d660: 6c 2d 63 61 6c 6c 20 27 73 74 61 74 65 2d 73 74 l-call 'state-st
d670: 61 74 75 73 20 72 75 6e 2d 69 64 20 6e 65 77 73 atus run-id news
d680: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 74 tate newstatus t
d690: 65 73 74 2d 69 64 29 29 0a 09 3b 3b 20 28 65 6c est-id))..;; (el
d6a0: 73 65 0a 09 3b 3b 20 20 28 69 66 20 6e 65 77 73 se..;; (if news
d6b0: 74 61 74 65 20 20 20 28 72 6d 74 3a 67 65 6e 65 tate (rmt:gene
d6c0: 72 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 ral-call 'set-te
d6d0: 73 74 2d 73 74 61 74 65 20 20 20 72 75 6e 2d 69 st-state run-i
d6e0: 64 20 6e 65 77 73 74 61 74 65 20 20 20 74 65 73 d newstate tes
d6f0: 74 2d 69 64 29 29 0a 09 3b 3b 20 20 28 69 66 20 t-id))..;; (if
d700: 6e 65 77 73 74 61 74 75 73 20 20 28 72 6d 74 3a newstatus (rmt:
d710: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
d720: 74 2d 74 65 73 74 2d 73 74 61 74 75 73 20 20 72 t-test-status r
d730: 75 6e 2d 69 64 20 6e 65 77 73 74 61 74 75 73 20 un-id newstatus
d740: 20 74 65 73 74 2d 69 64 29 29 0a 09 3b 3b 20 20 test-id))..;;
d750: 28 69 66 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 28 (if newcomment (
d760: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
d770: 20 27 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 'set-test-comme
d780: 6e 74 20 72 75 6e 2d 69 64 20 6e 65 77 63 6f 6d nt run-id newcom
d790: 6d 65 6e 74 20 74 65 73 74 2d 69 64 29 29 29 29 ment test-id))))
d7a0: 0a 09 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 ..(rmt:set-state
d7b0: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
d7c0: 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 -up-items run-id
d7d0: 20 74 65 73 74 2d 69 64 20 23 66 20 6e 65 77 73 test-id #f news
d7e0: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e tate newstatus n
d7f0: 65 77 63 6f 6d 6d 65 6e 74 29 0a 09 3b 3b 20 28 ewcomment)..;; (
d800: 6d 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 mt:process-trigg
d810: 65 72 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ers run-id test-
d820: 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 id newstate news
d830: 74 61 74 75 73 29 0a 09 23 74 29 29 29 0a 0a 0a tatus)..#t)))...
d840: 28 64 65 66 69 6e 65 20 28 6d 74 3a 74 65 73 74 (define (mt:test
d850: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
d860: 73 2d 62 79 2d 69 64 2d 75 6e 6c 65 73 73 2d 63 s-by-id-unless-c
d870: 6f 6d 70 6c 65 74 65 64 20 72 75 6e 2d 69 64 20 ompleted run-id
d880: 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 test-id newstate
d890: 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f newstatus newco
d8a0: 6d 6d 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 mment). (let* (
d8b0: 28 74 65 73 74 2d 76 65 63 20 20 20 28 72 6d 74 (test-vec (rmt
d8c0: 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
d8d0: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
d8e0: 64 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 d test-id)).
d8f0: 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 20 (state
d900: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
d910: 2d 76 65 63 20 33 29 29 29 0a 20 20 20 20 28 69 -vec 3))). (i
d920: 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 65 20 f (equal? state
d930: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 20 20 20 "COMPLETED").
d940: 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 #t.
d950: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
d960: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
d970: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
d980: 65 73 74 2d 69 64 20 23 66 20 6e 65 77 73 74 61 est-id #f newsta
d990: 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 te newstatus new
d9a0: 63 6f 6d 6d 65 6e 74 29 29 29 29 0a 0a 20 20 0a comment)))).. .
d9b0: 28 64 65 66 69 6e 65 20 28 6d 74 3a 74 65 73 74 (define (mt:test
d9c0: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
d9d0: 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 20 72 75 s-by-testname ru
d9e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
d9f0: 74 65 6d 2d 70 61 74 68 20 6e 65 77 2d 73 74 61 tem-path new-sta
da00: 74 65 20 6e 65 77 2d 73 74 61 74 75 73 20 6e 65 te new-status ne
da10: 77 2d 63 6f 6d 6d 65 6e 74 29 0a 20 20 3b 28 6c w-comment). ;(l
da20: 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 6d et ((test-id (rm
da30: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
da40: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
da50: 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 28 72 tem-path))). (r
da60: 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 mt:set-state-sta
da70: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
da80: 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
da90: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
daa0: 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 new-state new-s
dab0: 74 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e tatus new-commen
dac0: 74 29 0a 20 20 3b 3b 20 28 6d 74 3a 70 72 6f 63 t). ;; (mt:proc
dad0: 65 73 73 2d 74 72 69 67 67 65 72 73 20 72 75 6e ess-triggers run
dae0: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 2d -id test-id new-
daf0: 73 74 61 74 65 20 6e 65 77 2d 73 74 61 74 75 73 state new-status
db00: 29 0a 20 20 23 74 29 3b 29 0a 09 3b 3b 28 6d 74 ). #t);)..;;(mt
db10: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
db20: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
db30: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 2d -id test-id new-
db40: 73 74 61 74 65 20 6e 65 77 2d 73 74 61 74 75 73 state new-status
db50: 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 29 29 29 0a new-comment))).
db60: 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 74 65 73 .(define (mt:tes
db70: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
db80: 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d 65 2d 75 us-by-testname-u
db90: 6e 6c 65 73 73 2d 63 6f 6d 70 6c 65 74 65 64 20 nless-completed
dba0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
dbb0: 20 69 74 65 6d 2d 70 61 74 68 20 6e 65 77 2d 73 item-path new-s
dbc0: 74 61 74 65 20 6e 65 77 2d 73 74 61 74 75 73 20 tate new-status
dbd0: 6e 65 77 2d 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 new-comment). (
dbe0: 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 72 let ((test-id (r
dbf0: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 mt:get-test-id r
dc00: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
dc10: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 item-path))).
dc20: 20 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (mt:test-set-st
dc30: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
dc40: 2d 75 6e 6c 65 73 73 2d 63 6f 6d 70 6c 65 74 65 -unless-complete
dc50: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
dc60: 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 new-state new-s
dc70: 74 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e tatus new-commen
dc80: 74 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d t)))..;;========
dc90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dcb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dcc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
dcd0: 3b 20 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d ; R U N S.;;===
dce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dcf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd20: 3d 3d 3d 0a 0a 3b 3b 20 72 75 6e 73 3a 67 65 74 ===..;; runs:get
dd30: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 3b 3b -runs-by-patt.;;
dd40: 20 67 65 74 20 72 75 6e 73 20 62 79 20 6c 69 73 get runs by lis
dd50: 74 20 6f 66 20 63 72 69 74 65 72 69 61 0a 3b 3b t of criteria.;;
dd60: 20 72 65 67 69 73 74 65 72 20 61 20 74 65 73 74 register a test
dd70: 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 run with the db
dd80: 0a 3b 3b 0a 3b 3b 20 55 73 65 3a 20 28 64 62 2d .;;.;; Use: (db-
dd90: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
dda0: 64 65 72 20 28 64 62 3a 67 65 74 2d 68 65 61 64 der (db:get-head
ddb0: 65 72 20 72 75 6e 69 6e 66 6f 29 28 64 62 3a 67 er runinfo)(db:g
ddc0: 65 74 2d 72 6f 77 73 20 72 75 6e 69 6e 66 6f 29 et-rows runinfo)
ddd0: 29 0a 3b 3b 20 20 74 6f 20 65 78 74 72 61 63 74 ).;; to extract
dde0: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 73 info from the s
ddf0: 74 72 75 63 74 75 72 65 20 72 65 74 75 72 6e 65 tructure returne
de00: 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 74 d.;;.(define (mt
de10: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
de20: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 t keys runnamepa
de30: 74 74 20 74 61 72 67 70 61 74 74 29 0a 20 20 28 tt targpatt). (
de40: 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 73 64 let loop ((runsd
de50: 61 74 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e at (rmt:get-run
de60: 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 20 72 s-by-patt keys r
de70: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
de80: 61 74 74 20 30 20 35 30 30 20 23 66 20 30 29 29 att 0 500 #f 0))
de90: 0a 09 20 20 20 20 20 28 72 65 73 20 20 20 20 20 .. (res
dea0: 20 27 28 29 29 0a 09 20 20 20 20 20 28 6f 66 66 '()).. (off
deb0: 73 65 74 20 20 20 30 29 0a 09 20 20 20 20 20 28 set 0).. (
dec0: 6c 69 6d 69 74 20 20 20 20 35 30 30 29 29 0a 20 limit 500)).
ded0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 ;; (print "ru
dee0: 6e 73 64 61 74 3a 20 22 20 72 75 6e 73 64 61 74 nsdat: " runsdat
def0: 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 68 65 ). (let* ((he
df00: 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d ader (vector-
df10: 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a ref runsdat 0)).
df20: 09 20 20 20 28 72 75 6e 73 6c 73 74 20 20 20 28 . (runslst (
df30: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 vector-ref runsd
df40: 61 74 20 31 29 29 0a 09 20 20 20 28 66 75 6c 6c at 1)).. (full
df50: 2d 6c 69 73 74 20 28 61 70 70 65 6e 64 20 72 65 -list (append re
df60: 73 20 72 75 6e 73 6c 73 74 29 29 0a 09 20 20 20 s runslst))..
df70: 28 68 61 76 65 2d 6d 6f 72 65 20 28 65 71 3f 20 (have-more (eq?
df80: 28 6c 65 6e 67 74 68 20 72 75 6e 73 6c 73 74 29 (length runslst)
df90: 20 6c 69 6d 69 74 29 29 29 0a 20 20 20 20 20 20 limit))).
dfa0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
dfb0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
dfc0: 6f 72 74 2a 20 22 68 65 61 64 65 72 3a 20 22 20 ort* "header: "
dfd0: 68 65 61 64 65 72 20 22 20 72 75 6e 73 6c 73 74 header " runslst
dfe0: 3a 20 22 20 72 75 6e 73 6c 73 74 20 22 20 68 61 : " runslst " ha
dff0: 76 65 2d 6d 6f 72 65 3a 20 22 20 68 61 76 65 2d ve-more: " have-
e000: 6d 6f 72 65 29 0a 20 20 20 20 20 20 28 69 66 20 more). (if
e010: 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 20 28 6c have-more .. (l
e020: 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 65 74 20 et ((new-offset
e030: 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 29 (+ offset limit)
e040: 29 0a 09 09 28 6e 65 78 74 2d 62 61 74 63 68 20 )...(next-batch
e050: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
e060: 2d 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 -patt keys runna
e070: 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 mepatt targpatt
e080: 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 23 66 20 offset limit #f
e090: 30 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 0))).. (debug
e0a0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
e0b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e0c0: 20 22 4d 6f 72 65 20 74 68 61 6e 20 22 20 6c 69 "More than " li
e0d0: 6d 69 74 20 22 20 72 75 6e 73 2c 20 68 61 76 65 mit " runs, have
e0e0: 20 22 20 28 6c 65 6e 67 74 68 20 66 75 6c 6c 2d " (length full-
e0f0: 6c 69 73 74 29 20 22 20 72 75 6e 73 20 73 6f 20 list) " runs so
e100: 66 61 72 2e 22 29 0a 09 20 20 20 20 28 64 65 62 far.").. (deb
e110: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
e120: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e130: 74 2a 20 22 6e 65 78 74 2d 62 61 74 63 68 3a 20 t* "next-batch:
e140: 22 20 6e 65 78 74 2d 62 61 74 63 68 29 0a 09 20 " next-batch)..
e150: 20 20 20 28 6c 6f 6f 70 20 6e 65 78 74 2d 62 61 (loop next-ba
e160: 74 63 68 0a 09 09 20 20 66 75 6c 6c 2d 6c 69 73 tch... full-lis
e170: 74 0a 09 09 20 20 6e 65 77 2d 6f 66 66 73 65 74 t... new-offset
e180: 0a 09 09 20 20 6c 69 6d 69 74 29 29 0a 09 20 28 ... limit)).. (
e190: 76 65 63 74 6f 72 20 68 65 61 64 65 72 20 66 75 vector header fu
e1a0: 6c 6c 2d 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b ll-list)))))..;;
e1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1f0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 ======.;; T E S
e200: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
e210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
e250: 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d 74 define (mt:get-t
e260: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
e270: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
e280: 74 65 73 20 73 74 61 74 75 73 20 23 21 6b 65 79 tes status #!key
e290: 20 28 6e 6f 74 2d 69 6e 20 23 74 29 20 28 73 6f (not-in #t) (so
e2a0: 72 74 2d 62 79 20 27 65 76 65 6e 74 5f 74 69 6d rt-by 'event_tim
e2b0: 65 29 20 28 73 6f 72 74 2d 6f 72 64 65 72 20 22 e) (sort-order "
e2c0: 41 53 43 22 29 20 28 71 72 79 76 61 6c 73 20 23 ASC") (qryvals #
e2d0: 66 29 28 6c 61 73 74 2d 75 70 64 61 74 65 20 23 f)(last-update #
e2e0: 66 29 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 f)). (let loop
e2f0: 28 28 74 65 73 74 73 64 61 74 20 28 72 6d 74 3a ((testsdat (rmt:
e300: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
e310: 6e 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 n run-id testpat
e320: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 t states status
e330: 30 20 35 30 30 20 6e 6f 74 2d 69 6e 20 73 6f 72 0 500 not-in sor
e340: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
e350: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
e360: 61 74 65 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 20 ate 'normal))..
e370: 20 20 20 20 28 72 65 73 20 20 20 20 20 20 27 28 (res '(
e380: 29 29 0a 09 20 20 20 20 20 28 6f 66 66 73 65 74 )).. (offset
e390: 20 20 20 30 29 0a 09 20 20 20 20 20 28 6c 69 6d 0).. (lim
e3a0: 69 74 20 20 20 20 35 30 30 29 29 0a 20 20 20 20 it 500)).
e3b0: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 2d 6c 69 73 (let* ((full-lis
e3c0: 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 65 t (append res te
e3d0: 73 74 73 64 61 74 29 29 0a 09 20 20 20 28 68 61 stsdat)).. (ha
e3e0: 76 65 2d 6d 6f 72 65 20 28 65 71 3f 20 28 6c 65 ve-more (eq? (le
e3f0: 6e 67 74 68 20 74 65 73 74 73 64 61 74 29 20 6c ngth testsdat) l
e400: 69 6d 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 imit))). (i
e410: 66 20 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 20 f have-more ..
e420: 28 6c 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 65 (let ((new-offse
e430: 74 20 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d 69 t (+ offset limi
e440: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
e450: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
e460: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e470: 20 22 4d 6f 72 65 20 74 68 61 6e 20 22 20 6c 69 "More than " li
e480: 6d 69 74 20 22 20 74 65 73 74 73 2c 20 68 61 76 mit " tests, hav
e490: 65 20 22 20 28 6c 65 6e 67 74 68 20 66 75 6c 6c e " (length full
e4a0: 2d 6c 69 73 74 29 20 22 20 74 65 73 74 73 20 73 -list) " tests s
e4b0: 6f 20 66 61 72 2e 22 29 0a 09 20 20 20 20 28 6c o far.").. (l
e4c0: 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 oop (rmt:get-tes
e4d0: 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 ts-for-run run-i
e4e0: 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 d testpatt state
e4f0: 73 20 73 74 61 74 75 73 20 6e 65 77 2d 6f 66 66 s status new-off
e500: 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e set limit not-in
e510: 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 sort-by sort-or
e520: 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 der qryvals last
e530: 2d 75 70 64 61 74 65 20 27 6e 6f 72 6d 61 6c 29 -update 'normal)
e540: 0a 09 09 20 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 ... full-list..
e550: 09 20 20 6e 65 77 2d 6f 66 66 73 65 74 0a 09 09 . new-offset...
e560: 20 20 6c 69 6d 69 74 29 29 0a 09 20 20 66 75 6c limit)).. ful
e570: 6c 2d 6c 69 73 74 29 29 29 29 0a 0a 28 64 65 66 l-list))))..(def
e580: 69 6e 65 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 ine (mt:lazy-get
e590: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
e5a0: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
e5b0: 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 ref-item-path #!
e5c0: 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d key (mode '(norm
e5d0: 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 23 66 al))(itemmaps #f
e5e0: 29 20 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 ) ). (let* ((ke
e5f0: 79 20 20 20 20 28 6c 69 73 74 20 72 75 6e 2d 69 y (list run-i
e600: 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 69 74 d waitons ref-it
e610: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 29 29 0a 09 em-path mode))..
e620: 20 28 72 65 73 20 20 20 20 28 68 61 73 68 2d 74 (res (hash-t
e630: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e640: 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 *pre-reqs-met-c
e650: 61 63 68 65 2a 20 6b 65 79 20 23 66 29 29 0a 09 ache* key #f))..
e660: 20 28 75 73 65 72 65 73 20 28 6c 65 74 20 28 28 (useres (let ((
e670: 6c 61 73 74 2d 74 69 6d 65 20 28 69 66 20 28 76 last-time (if (v
e680: 65 63 74 6f 72 3f 20 72 65 73 29 20 28 76 65 63 ector? res) (vec
e690: 74 6f 72 2d 72 65 66 20 72 65 73 20 30 29 20 23 tor-ref res 0) #
e6a0: 66 29 29 29 0a 09 09 20 20 20 28 69 66 20 6c 61 f)))... (if la
e6b0: 73 74 2d 74 69 6d 65 0a 09 09 20 20 20 20 20 20 st-time...
e6c0: 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (< (current-sec
e6d0: 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d onds)(+ last-tim
e6e0: 65 20 35 29 29 0a 09 09 20 20 20 20 20 20 20 23 e 5))... #
e6f0: 66 29 29 29 29 0a 20 20 20 20 28 69 66 20 75 73 f)))). (if us
e700: 65 72 65 73 0a 09 28 6c 65 74 20 28 28 72 65 73 eres..(let ((res
e710: 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ult (vector-ref
e720: 72 65 73 20 31 29 29 29 0a 09 20 20 28 64 65 62 res 1))).. (deb
e730: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
e740: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 ult-log-port* "U
e750: 73 69 6e 67 20 6c 61 7a 79 20 76 61 6c 75 65 20 sing lazy value
e760: 72 65 73 3a 20 22 20 72 65 73 75 6c 74 29 0a 09 res: " result)..
e770: 20 20 72 65 73 75 6c 74 29 0a 09 28 6c 65 74 20 result)..(let
e780: 28 28 6e 65 77 72 65 73 20 28 72 6d 74 3a 67 65 ((newres (rmt:ge
e790: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
e7a0: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
e7b0: 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 6d ref-item-path m
e7c0: 6f 64 65 3a 20 6d 6f 64 65 20 69 74 65 6d 6d 61 ode: mode itemma
e7d0: 70 73 3a 20 69 74 65 6d 6d 61 70 73 29 29 29 0a ps: itemmaps))).
e7e0: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
e7f0: 65 74 21 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 et! *pre-reqs-me
e800: 74 2d 63 61 63 68 65 2a 20 6b 65 79 20 28 76 65 t-cache* key (ve
e810: 63 74 6f 72 20 28 63 75 72 72 65 6e 74 2d 73 65 ctor (current-se
e820: 63 6f 6e 64 73 29 20 6e 65 77 72 65 73 29 29 0a conds) newres)).
e830: 09 20 20 6e 65 77 72 65 73 29 29 29 29 0a 0a 3b . newres))))..;
e840: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
e850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e880: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 66 72 6f 6d 20 =======.;; from
e890: 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 4d metadat lookup M
e8a0: 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 0a EGATEST_VERSION.
e8b0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
e8c0: 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:get-last-run-
e8d0: 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 54 version) ;; RADT
e8e0: 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 69 => How does thi
e8f0: 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d 72 s work in send-r
e900: 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f 6e 3f eceive function?
e910: 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 ?; assume it is
e920: 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 64 20 the value saved
e930: 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 6d in some DB. (rm
e940: 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 t:get-var "MEGAT
e950: 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a 0a EST_VERSION"))..
e960: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
e970: 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 get-last-run-ver
e980: 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 28 sion-number). (
e990: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a string->number .
e9a0: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 (substring (c
e9b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
e9c0: 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 29 un-version) 0 6)
e9d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
e9e0: 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e mon:set-last-run
e9f0: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d 74 -version). (rmt
ea00: 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 :set-var "MEGATE
ea10: 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f 6d ST_VERSION" (com
ea20: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
ea30: 61 74 75 72 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ature)))..;;====
ea40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea80: 3d 3d 0a 3b 3b 20 66 61 75 78 2d 6c 6f 63 6b 20 ==.;; faux-lock
ea90: 69 73 20 64 65 70 72 65 63 61 74 65 64 2e 20 50 is deprecated. P
eaa0: 6c 65 61 73 65 20 75 73 65 20 73 69 6d 70 6c 65 lease use simple
eab0: 2d 6c 6f 63 6b 20 62 65 6c 6f 77 0a 3b 3b 0a 28 -lock below.;;.(
eac0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
ead0: 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 aux-lock keyname
eae0: 20 23 21 6b 65 79 20 28 77 61 69 74 2d 74 69 6d #!key (wait-tim
eaf0: 65 20 38 29 28 61 6c 6c 6f 77 2d 6c 6f 63 6b 2d e 8)(allow-lock-
eb00: 73 74 65 61 6c 20 23 74 29 29 0a 20 20 28 69 66 steal #t)). (if
eb10: 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
eb20: 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d t/default keynam
eb30: 65 20 23 66 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 e #f) ;; do not
eb40: 62 65 20 74 65 6d 70 74 65 64 20 74 6f 20 63 6f be tempted to co
eb50: 6d 70 61 72 65 20 74 6f 20 70 69 64 2e 20 6c 6f mpare to pid. lo
eb60: 63 6b 69 6e 67 20 69 73 20 61 20 6f 6e 65 2d 73 cking is a one-s
eb70: 68 6f 74 20 61 63 74 69 6f 6e 2c 20 69 66 20 61 hot action, if a
eb80: 6c 72 65 61 64 79 20 6c 6f 63 6b 65 64 20 66 6f lready locked fo
eb90: 72 20 74 68 69 73 20 70 69 64 20 69 74 20 64 6f r this pid it do
eba0: 65 73 6e 27 74 20 61 63 74 75 61 6c 6c 79 20 63 esn't actually c
ebb0: 6f 75 6e 74 0a 20 20 20 20 20 20 28 69 66 20 28 ount. (if (
ebc0: 3e 20 77 61 69 74 2d 74 69 6d 65 20 30 29 0a 09 > wait-time 0)..
ebd0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 74 (begin.. (t
ebe0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
ebf0: 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 77 61 . (if (eq? wa
ec00: 69 74 2d 74 69 6d 65 20 31 29 20 3b 3b 20 6f 6e it-time 1) ;; on
ec10: 6c 79 20 6f 6e 65 20 73 65 63 6f 6e 64 20 6c 65 ly one second le
ec20: 66 74 2c 20 73 74 65 61 6c 20 74 68 65 20 6c 6f ft, steal the lo
ec30: 63 6b 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 ck...(begin...
ec40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
ec50: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
ec60: 2d 70 6f 72 74 2a 20 22 73 74 65 61 6c 69 6e 67 -port* "stealing
ec70: 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6b 65 79 6e lock for " keyn
ec80: 61 6d 65 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e ame)... (common
ec90: 3a 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 :faux-unlock key
eca0: 6e 61 6d 65 20 66 6f 72 63 65 3a 20 23 74 29 29 name force: #t))
ecb0: 29 0a 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 ).. (common:f
ecc0: 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 aux-lock keyname
ecd0: 20 77 61 69 74 2d 74 69 6d 65 3a 20 28 2d 20 77 wait-time: (- w
ece0: 61 69 74 2d 74 69 6d 65 20 31 29 29 29 0a 09 20 ait-time 1)))..
ecf0: 20 23 66 29 0a 20 20 20 20 20 20 28 62 65 67 69 #f). (begi
ed00: 6e 0a 20 20 20 20 20 20 20 20 28 72 6d 74 3a 6e n. (rmt:n
ed10: 6f 2d 73 79 6e 63 2d 73 65 74 20 6b 65 79 6e 61 o-sync-set keyna
ed20: 6d 65 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e me (conc (curren
ed30: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a t-process-id))).
ed40: 20 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 (equal?
ed50: 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 (conc (current-p
ed60: 72 6f 63 65 73 73 2d 69 64 29 29 20 28 63 6f 6e rocess-id)) (con
ed70: 63 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 c (rmt:no-sync-g
ed80: 65 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 et/default keyna
ed90: 6d 65 20 23 66 29 29 29 29 29 29 0a 0a 28 64 65 me #f))))))..(de
eda0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 75 fine (common:fau
edb0: 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 x-unlock keyname
edc0: 20 23 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 #!key (force #f
edd0: 29 29 0a 20 20 28 69 66 20 28 6f 72 20 66 6f 72 )). (if (or for
ede0: 63 65 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 63 ce (equal? (conc
edf0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
ee00: 73 2d 69 64 29 29 20 28 63 6f 6e 63 20 28 72 6d s-id)) (conc (rm
ee10: 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 t:no-sync-get/de
ee20: 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 fault keyname #f
ee30: 29 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 )))). (begi
ee40: 6e 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 72 n. (if (r
ee50: 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 mt:no-sync-get/d
ee60: 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 efault keyname #
ee70: 66 29 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d f) (rmt:no-sync-
ee80: 64 65 6c 21 20 6b 65 79 6e 61 6d 65 29 29 0a 20 del! keyname)).
ee90: 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 #t).
eea0: 20 23 66 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #f))..;;=======
eeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
eef0: 3b 3b 20 70 6f 73 74 69 76 65 20 6e 75 6d 62 65 ;; postive numbe
ef00: 72 20 69 66 20 6d 65 67 61 74 65 73 74 20 76 65 r if megatest ve
ef10: 72 73 69 6f 6e 20 3e 20 64 62 20 76 65 72 73 69 rsion > db versi
ef20: 6f 6e 0a 3b 3b 20 6e 65 67 61 74 69 76 65 20 6e on.;; negative n
ef30: 75 6d 62 65 72 20 69 66 20 6d 65 67 61 74 65 73 umber if megates
ef40: 74 20 76 65 72 73 69 6f 6e 20 3c 20 64 62 20 76 t version < db v
ef50: 65 72 73 69 6f 6e 0a 28 64 65 66 69 6e 65 20 28 ersion.(define (
ef60: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 64 common:version-d
ef70: 62 2d 64 65 6c 74 61 29 0a 20 20 28 2d 20 6d 65 b-delta). (- me
ef80: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 28 gatest-version (
ef90: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d common:get-last-
efa0: 72 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 run-version-numb
efb0: 65 72 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 er)))..(define (
efc0: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 63 common:version-c
efd0: 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f 74 20 hanged?). (not
efe0: 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f 6e 3a (equal? (common:
eff0: 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 get-last-run-ver
f000: 73 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 20 sion).
f010: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 (common:ver
f020: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 sion-signature))
f030: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
f040: 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 64 3f mon:api-changed?
f050: 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f ). (not (equal?
f060: 20 28 73 75 62 73 74 72 69 6e 67 20 28 2d 3e 73 (substring (->s
f070: 74 72 69 6e 67 20 6d 65 67 61 74 65 73 74 2d 76 tring megatest-v
f080: 65 72 73 69 6f 6e 29 20 30 20 34 29 0a 20 20 20 ersion) 0 4).
f090: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 75 62 (sub
f0a0: 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 63 6f string (conc (co
f0b0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
f0c0: 6e 2d 76 65 72 73 69 6f 6e 29 29 20 30 20 34 29 n-version)) 0 4)
f0d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 )))..(define (st
f0e0: 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 d-exit-procedure
f0f0: 29 0a 20 20 3b 3b 28 63 6f 6d 6d 6f 6e 3a 74 65 ). ;;(common:te
f100: 6c 65 6d 65 74 72 79 2d 6c 6f 67 2d 63 6c 6f 73 lemetry-log-clos
f110: 65 29 0a 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c e). (on-exit (l
f120: 61 6d 62 64 61 20 28 29 20 30 29 29 0a 20 20 3b ambda () 0)). ;
f130: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e ;(debug:print-in
f140: 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c fo 13 *default-l
f150: 6f 67 2d 70 6f 72 74 2a 20 22 73 74 64 2d 65 78 og-port* "std-ex
f160: 69 74 2d 70 72 6f 63 65 64 75 72 65 20 63 61 6c it-procedure cal
f170: 6c 65 64 3b 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 led; *time-to-ex
f180: 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 it*="*time-to-ex
f190: 69 74 2a 29 0a 20 20 28 6c 65 74 20 28 28 6e 6f it*). (let ((no
f1a0: 2d 68 75 72 72 79 20 20 28 69 66 20 28 62 64 61 -hurry (if (bda
f1b0: 74 2d 74 69 6d 65 2d 74 6f 2d 65 78 69 74 20 2a t-time-to-exit *
f1c0: 62 64 61 74 2a 29 20 3b 3b 20 68 75 72 72 79 20 bdat*) ;; hurry
f1d0: 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 up... #f..
f1e0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
f1f0: 09 09 20 28 62 64 61 74 2d 74 69 6d 65 2d 74 6f .. (bdat-time-to
f200: 2d 65 78 69 74 2d 73 65 74 21 20 2a 62 64 61 74 -exit-set! *bdat
f210: 2a 20 23 74 29 0a 09 09 09 20 23 74 29 29 29 29 * #t).... #t))))
f220: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
f230: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
f240: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 t-log-port* "sta
f250: 72 74 69 6e 67 20 65 78 69 74 20 70 72 6f 63 65 rting exit proce
f260: 73 73 2c 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 ss, finalizing d
f270: 61 74 61 62 61 73 65 73 2e 22 29 0a 20 20 20 20 atabases.").
f280: 28 69 66 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 (if (and no-hurr
f290: 79 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d y (debug:debug-m
f2a0: 6f 64 65 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 ode 18))..(rmt:p
f2b0: 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 29 0a rint-db-stats)).
f2c0: 20 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 (let ((th1 (
f2d0: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
f2e0: 62 64 61 20 28 29 20 3b 3b 20 74 68 72 65 61 64 bda () ;; thread
f2f0: 20 66 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 for cleaning up
f300: 2c 20 67 69 76 65 20 69 74 20 66 69 76 65 20 73 , give it five s
f310: 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 20 20 20 econds.
f320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f330: 20 20 20 20 20 28 69 66 20 2a 73 65 72 76 65 72 (if *server
f340: 2d 69 6e 66 6f 2a 0a 09 09 09 09 20 20 28 6c 65 -info*..... (le
f350: 74 20 28 28 70 6b 74 2d 66 69 6c 65 20 28 63 6f t ((pkt-file (co
f360: 6e 63 20 28 67 65 74 2d 70 6b 74 73 2d 64 69 72 nc (get-pkts-dir
f370: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 *toppath*).....
f380: 09 09 09 22 2f 22 20 28 73 65 72 76 64 61 74 2d ..."/" (servdat-
f390: 75 75 69 64 20 2a 73 65 72 76 65 72 2d 69 6e 66 uuid *server-inf
f3a0: 6f 2a 29 0a 09 09 09 09 09 09 09 22 2e 70 6b 74 o*)........".pkt
f3b0: 22 29 29 0a 09 09 09 09 09 28 64 62 66 69 6c 65 "))......(dbfile
f3c0: 20 20 20 28 73 65 72 76 64 61 74 2d 64 62 66 69 (servdat-dbfi
f3d0: 6c 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a le *server-info*
f3e0: 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 )))..... (if
f3f0: 64 62 66 69 6c 65 0a 09 09 09 09 09 28 62 65 67 dbfile......(beg
f400: 69 6e 0a 0a 09 09 09 09 09 20 20 3b 3b 20 64 6f in....... ;; do
f410: 20 61 20 66 69 6e 61 6c 20 73 79 6e 63 20 68 65 a final sync he
f420: 72 65 0a 09 09 09 09 09 20 20 0a 09 09 09 09 09 re...... ......
f430: 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (if (string-matc
f440: 68 20 22 2e 2a 2f 6d 61 69 6e 2e 64 62 24 22 20 h ".*/main.db$"
f450: 64 62 66 69 6c 65 29 0a 09 09 09 09 09 20 20 20 dbfile)......
f460: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin......
f470: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
f480: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
f490: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f 76 log-port* "remov
f4a0: 69 6e 67 20 70 6b 74 20 22 70 6b 74 2d 66 69 6c ing pkt "pkt-fil
f4b0: 65 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 64 e)...... (d
f4c0: 65 6c 65 74 65 2d 66 69 6c 65 2a 20 70 6b 74 2d elete-file* pkt-
f4d0: 66 69 6c 65 29 0a 09 09 09 09 09 20 20 20 20 20 file)......
f4e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
f4f0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
f500: 67 2d 70 6f 72 74 2a 20 22 52 65 6c 65 61 73 69 g-port* "Releasi
f510: 6e 67 20 6c 6f 63 6b 20 66 6f 72 20 22 64 62 66 ng lock for "dbf
f520: 69 6c 65 29 0a 09 09 09 09 09 20 20 20 20 20 20 ile)......
f530: 28 64 62 3a 77 69 74 68 2d 6c 6f 63 6b 2d 64 62 (db:with-lock-db
f540: 20 28 73 65 72 76 64 61 74 2d 64 62 66 69 6c 65 (servdat-dbfile
f550: 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a *server-info*).
f560: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 6c ....... (l
f570: 61 6d 62 64 61 20 28 64 62 68 20 64 62 66 69 6c ambda (dbh dbfil
f580: 65 29 0a 09 09 09 09 09 09 09 09 20 28 64 62 3a e)......... (db:
f590: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 64 62 68 release-lock dbh
f5a0: 20 64 62 66 69 6c 65 29 29 29 29 0a 09 09 09 09 dbfile)))).....
f5b0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 73 64 61 . (let* ((sda
f5c0: 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 t *server-info*)
f5d0: 29 20 3b 3b 20 77 65 20 68 61 76 65 20 61 20 72 ) ;; we have a r
f5e0: 75 6e 2d 69 64 20 73 65 72 76 65 72 0a 09 09 09 un-id server....
f5f0: 09 09 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e .. (rmt:sen
f600: 64 2d 72 65 63 65 69 76 65 2d 72 65 61 6c 20 2a d-receive-real *
f610: 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 2a 74 6f 70 rmt:remote* *top
f620: 70 61 74 68 2a 0a 09 09 09 09 09 09 09 09 20 20 path*.........
f630: 20 20 20 28 64 62 3a 72 75 6e 2d 69 64 2d 3e 64 (db:run-id->d
f640: 62 6e 61 6d 65 20 23 66 29 0a 09 09 09 09 09 09 bname #f).......
f650: 09 09 20 20 20 20 20 27 64 65 72 65 67 69 73 74 .. 'deregist
f660: 65 72 2d 73 65 72 76 65 72 0a 09 09 09 09 09 09 er-server.......
f670: 09 09 20 20 20 20 20 60 28 2c 28 73 65 72 76 64 .. `(,(servd
f680: 61 74 2d 75 75 69 64 20 73 64 61 74 29 0a 09 09 at-uuid sdat)...
f690: 09 09 09 09 09 09 20 20 20 20 20 20 20 2c 28 63 ...... ,(c
f6a0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
f6b0: 64 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 d).........
f6c0: 20 20 2c 28 73 65 72 76 64 61 74 2d 68 6f 73 74 ,(servdat-host
f6d0: 20 73 64 61 74 29 20 20 20 3b 3b 20 69 66 61 63 sdat) ;; ifac
f6e0: 65 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 e.........
f6f0: 20 2c 28 73 65 72 76 64 61 74 2d 70 6f 72 74 20 ,(servdat-port
f700: 73 64 61 74 29 29 29 29 29 29 29 29 29 0a 09 09 sdat)))))))))...
f710: 09 20 20 20 20 20 20 28 69 66 20 2a 64 62 73 74 . (if *dbst
f720: 72 75 63 74 2d 64 62 2a 20 28 64 62 3a 63 6c 6f ruct-db* (db:clo
f730: 73 65 2d 61 6c 6c 20 2a 64 62 73 74 72 75 63 74 se-all *dbstruct
f740: 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e 65 20 73 65 -db*)) ;; one se
f750: 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 65 64 0a 09 cond allocated..
f760: 09 09 20 20 20 20 20 20 28 69 66 20 28 62 64 61 .. (if (bda
f770: 74 2d 74 61 73 6b 2d 64 62 20 2a 62 64 61 74 2a t-task-db *bdat*
f780: 29 20 20 20 20 3b 3b 20 54 4f 44 4f 3a 20 43 68 ) ;; TODO: Ch
f790: 65 63 6b 20 74 68 61 74 20 74 68 69 73 20 69 73 eck that this is
f7a0: 20 63 6f 72 72 65 63 74 20 66 6f 72 20 74 61 73 correct for tas
f7b0: 6b 20 64 62 0a 09 09 09 09 20 20 28 6c 65 74 20 k db..... (let
f7c0: 28 28 64 62 20 28 63 64 72 20 28 62 64 61 74 2d ((db (cdr (bdat-
f7d0: 74 61 73 6b 2d 64 62 20 2a 62 64 61 74 2a 29 29 task-db *bdat*))
f7e0: 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 ))..... (if (
f7f0: 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 sqlite3:database
f800: 3f 20 64 62 29 0a 09 09 09 09 09 28 62 65 67 69 ? db)......(begi
f810: 6e 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 n...... (sqlite
f820: 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 29 3:interrupt! db)
f830: 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 ...... (sqlite3
f840: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 :finalize! db #t
f850: 29 0a 09 09 09 09 09 20 20 28 62 64 61 74 2d 74 )...... (bdat-t
f860: 61 73 6b 2d 64 62 2d 73 65 74 21 20 2a 62 64 61 ask-db-set! *bda
f870: 74 2a 20 23 66 29 29 29 29 29 0a 20 20 20 20 20 t* #f))))).
f880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f890: 20 20 20 20 20 20 20 20 20 23 3b 28 68 74 74 70 #;(http
f8a0: 2d 63 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 69 64 -client#close-id
f8b0: 6c 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 le-connections!)
f8c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
f8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
f8e0: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 64 65 if (not (eq? *de
f8f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
f900: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
f910: 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ort))).
f920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f930: 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d (close-
f940: 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 65 66 output-port *def
f950: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 ault-log-port*))
f960: 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 .... (set!
f970: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f980: 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f t* (current-erro
f990: 72 2d 70 6f 72 74 29 29 29 20 22 43 6c 65 61 6e r-port))) "Clean
f9a0: 75 70 20 64 62 20 65 78 69 74 20 74 68 72 65 61 up db exit threa
f9b0: 64 22 29 29 0a 09 20 20 28 74 68 32 20 28 6d 61 d")).. (th2 (ma
f9c0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
f9d0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 64 a ().... (d
f9e0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 ebug:print 4 *de
f9f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
fa00: 22 41 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 "Attempting clea
fa10: 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 n exit. Please b
fa20: 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 e patient and wa
fa30: 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 it a few seconds
fa40: 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 20 20 28 ...").... (
fa50: 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 20 20 20 if no-hurry.
fa60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
fa70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
fa80: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
fa90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
faa0: 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 (thread
fab0: 2d 73 6c 65 65 70 21 20 35 29 29 20 3b 3b 20 67 -sleep! 5)) ;; g
fac0: 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 75 70 ive the clean up
fad0: 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 6f 20 few seconds to
fae0: 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a 20 20 do it's stuff.
faf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
fb00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
fb10: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 09 09 09 (begin. ...
fb20: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
fb30: 21 20 32 29 29 29 0a 20 20 20 20 20 20 09 09 09 ! 2))). ...
fb40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
fb50: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
fb60: 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 6f g-port* " ... do
fb70: 6e 65 22 29 0a 20 20 20 20 20 20 09 09 09 20 20 ne"). ...
fb80: 20 20 20 20 29 0a 09 09 09 20 20 20 20 22 63 6c ).... "cl
fb90: 65 61 6e 20 65 78 69 74 22 29 29 29 0a 20 20 20 ean exit"))).
fba0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
fbb0: 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 68 ! th1). (th
fbc0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
fbd0: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a . (thread-j
fbe0: 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 20 20 20 oin! th1).
fbf0: 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 0a 0a 0a ). ).. 0)...
fc00: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
fc10: 72 75 6e 2d 73 79 6e 63 3f 29 0a 20 20 20 20 3b run-sync?). ;
fc20: 3b 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f ; (and (common:o
fc30: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 28 n-homehost?). (
fc40: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
fc50: 65 72 76 65 72 22 29 29 0a 0a 3b 3b 20 63 61 6c erver"))..;; cal
fc60: 6c 65 64 20 69 6e 20 6d 65 67 61 74 65 73 74 2e led in megatest.
fc70: 73 63 6d 2c 20 68 6f 73 74 2d 70 6f 72 74 20 69 scm, host-port i
fc80: 73 20 73 74 72 69 6e 67 20 68 6f 73 74 6e 61 6d s string hostnam
fc90: 65 3a 70 6f 72 74 0a 3b 3b 0a 3b 3b 20 4e 4f 54 e:port.;;.;; NOT
fca0: 45 3a 20 54 68 69 73 20 69 73 20 4e 4f 54 20 63 E: This is NOT c
fcb0: 61 6c 6c 65 64 20 64 69 72 65 63 74 6c 79 20 66 alled directly f
fcc0: 72 6f 6d 20 63 6c 69 65 6e 74 73 20 61 73 20 6e rom clients as n
fcd0: 6f 74 20 61 6c 6c 20 74 72 61 6e 73 70 6f 72 74 ot all transport
fce0: 73 20 73 75 70 70 6f 72 74 20 61 20 63 6c 69 65 s support a clie
fcf0: 6e 74 20 72 75 6e 6e 69 6e 67 0a 3b 3b 20 20 20 nt running.;;
fd00: 20 20 20 20 69 6e 20 74 68 65 20 73 61 6d 65 20 in the same
fd10: 70 72 6f 63 65 73 73 20 61 73 20 74 68 65 20 73 process as the s
fd20: 65 72 76 65 72 2e 20 0a 3b 3b 0a 28 64 65 66 69 erver. .;;.(defi
fd30: 6e 65 20 28 73 65 72 76 65 72 3a 70 69 6e 67 20 ne (server:ping
fd40: 68 6f 73 74 20 70 6f 72 74 20 73 65 72 76 65 72 host port server
fd50: 2d 69 64 20 23 21 6b 65 79 20 28 64 6f 2d 65 78 -id #!key (do-ex
fd60: 69 74 20 23 66 29 29 0a 20 20 28 73 65 72 76 65 it #f)). (serve
fd70: 72 2d 72 65 61 64 79 3f 20 68 6f 73 74 20 70 6f r-ready? host po
fd80: 72 74 20 22 6e 6f 6b 65 79 20 79 65 74 22 29 29 rt "nokey yet"))
fd90: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
fda0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 74 ==========.;; ht
fde0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 6d 6f 64 2e tp-transportmod.
fdf0: 73 63 6d 20 63 6f 6e 74 65 6e 74 73 20 6d 6f 76 scm contents mov
fe00: 65 64 20 68 65 72 65 0a 3b 3b 3d 3d 3d 3d 3d 3d ed here.;;======
fe10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe50: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
fe60: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 transport:make-s
fe70: 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 74 70 6f erver-url hostpo
fe80: 72 74 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 68 rt). (if (not h
fe90: 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 20 20 23 ostport). #
fea0: 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 f. (conc "h
feb0: 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 68 6f 73 ttp://" (car hos
fec0: 74 70 6f 72 74 29 20 22 3a 22 20 28 63 61 64 72 tport) ":" (cadr
fed0: 20 68 6f 73 74 70 6f 72 74 29 29 29 29 0a 0a 3b hostport))))..;
fee0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
fef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff20: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 =======.;; S E R
ff30: 20 56 20 45 20 52 0a 3b 3b 20 3d 3d 3d 3d 3d 3d V E R.;; ======
ff40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff80: 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 68 74 74 70 2d ..;; NOTE: http-
ff90: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch
ffa0: 20 69 73 20 74 68 65 20 65 6e 74 72 79 20 70 6f is the entry po
ffb0: 69 6e 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 int.;;
ffc0: 2d 3e 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 -> http-transpor
ffd0: 74 3a 72 75 6e 0a 3b 3b 20 20 20 20 20 20 20 20 t:run.;;
ffe0: 20 20 20 20 20 2d 3e 20 68 74 74 70 2d 74 72 61 -> http-tra
fff0: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
10000 2d 73 65 72 76 65 72 20 2d 3e 20 68 74 74 70 2d -server -> http-
10010 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 transport:try-st
10020 61 72 74 2d 73 65 72 76 65 72 20 28 75 6e 74 69 art-server (unti
10030 6c 20 73 75 63 63 65 73 73 29 0a 0a 28 64 65 66 l success)..(def
10040 69 6e 65 20 28 68 74 74 70 2d 67 65 74 2d 66 75 ine (http-get-fu
10050 6e 63 74 69 6f 6e 20 66 6e 6b 65 79 29 0a 20 20 nction fnkey).
10060 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
10070 64 65 66 61 75 6c 74 20 2a 68 74 74 70 2d 66 75 default *http-fu
10080 6e 63 74 69 6f 6e 73 2a 20 66 6e 6b 65 79 20 28 nctions* fnkey (
10090 6c 61 6d 62 64 61 20 28 29 20 22 6e 6f 74 68 69 lambda () "nothi
100a0 6e 67 20 68 65 72 65 20 79 65 74 22 29 29 29 0a ng here yet"))).
100b0 0a 23 3b 28 64 65 66 69 6e 65 20 28 72 6d 74 3a .#;(define (rmt:
100c0 6c 61 75 6e 63 68 2d 73 65 72 76 65 72 20 68 6f launch-server ho
100d0 73 74 6e 20 70 6f 72 74 29 0a 20 20 20 28 69 66 stn port). (if
100e0 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 0a 09 *server-info*..
100f0 28 62 65 67 69 6e 0a 09 20 20 28 73 65 72 76 64 (begin.. (servd
10100 61 74 2d 68 6f 73 74 2d 73 65 74 21 20 2a 73 65 at-host-set! *se
10110 72 76 65 72 2d 69 6e 66 6f 2a 20 68 6f 73 74 6e rver-info* hostn
10120 29 0a 09 20 20 28 73 65 72 76 64 61 74 2d 70 6f ).. (servdat-po
10130 72 74 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d rt-set! *server-
10140 69 6e 66 6f 2a 20 70 6f 72 74 29 0a 09 20 20 28 info* port).. (
10150 73 65 72 76 64 61 74 2d 73 74 61 74 75 73 2d 73 servdat-status-s
10160 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f et! *server-info
10170 2a 20 27 74 72 79 69 6e 67 2d 70 6f 72 74 29 0a * 'trying-port).
10180 09 20 20 28 73 65 72 76 64 61 74 2d 74 72 79 6e . (servdat-tryn
10190 75 6d 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d um-set! *server-
101a0 69 6e 66 6f 2a 20 28 2b 20 28 73 65 72 76 64 61 info* (+ (servda
101b0 74 2d 74 72 79 6e 75 6d 20 2a 73 65 72 76 65 72 t-trynum *server
101c0 2d 69 6e 66 6f 2a 29 20 31 29 29 29 0a 09 28 73 -info*) 1)))..(s
101d0 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f et! *server-info
101e0 2a 20 28 6d 61 6b 65 2d 73 65 72 76 64 61 74 20 * (make-servdat
101f0 68 6f 73 74 3a 20 69 70 61 64 64 72 73 74 72 20 host: ipaddrstr
10200 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 29 29 port: portnum)))
10210 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c 20 20 20 . (let* ((l
10220 20 20 20 20 20 28 74 63 70 2d 6c 69 73 74 65 6e (tcp-listen
10230 20 70 6f 72 74 29 29 0a 09 20 28 64 62 73 74 72 port)).. (dbstr
10240 75 63 74 20 23 66 29 29 0a 20 20 20 20 28 6c 65 uct #f)). (le
10250 74 2d 76 61 6c 75 65 73 20 28 28 28 69 20 6f 29 t-values (((i o)
10260 20 28 74 63 70 2d 61 63 63 65 70 74 20 6c 29 29 (tcp-accept l))
10270 29 0a 20 20 20 20 20 20 3b 3b 20 28 77 72 69 74 ). ;; (writ
10280 65 2d 6c 69 6e 65 20 22 48 65 6c 6c 6f 21 22 20 e-line "Hello!"
10290 6f 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f o). (let lo
102a0 6f 70 20 28 28 69 6e 64 61 74 20 28 72 65 61 64 op ((indat (read
102b0 20 69 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 72 i)))..(let* ((r
102c0 65 73 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d es (api:process-
102d0 72 65 71 75 65 73 74 20 64 62 73 74 72 75 63 74 request dbstruct
102e0 20 69 6e 64 61 74 29 29 29 0a 09 20 20 28 63 61 indat))).. (ca
102f0 73 65 20 72 65 73 0a 09 20 20 20 20 28 28 71 75 se res.. ((qu
10300 69 74 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 it).. (close
10310 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 29 0a 09 -input-port i)..
10320 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
10330 75 74 2d 70 6f 72 74 20 6f 29 29 0a 09 20 20 20 ut-port o))..
10340 20 28 65 6c 73 65 0a 09 20 20 20 20 20 28 77 72 (else.. (wr
10350 69 74 65 20 72 65 73 20 6f 29 29 29 29 29 29 29 ite res o)))))))
10360 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
10370 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 3b 3b 20 run hostn). ;;
10380 20 3b 3b 20 43 6f 6e 66 69 67 75 72 61 74 69 6f ;; Configuratio
10390 6e 73 20 66 6f 72 20 73 65 72 76 65 72 0a 20 20 ns for server.
103a0 3b 3b 20 20 28 74 63 70 2d 62 75 66 66 65 72 2d ;; (tcp-buffer-
103b0 73 69 7a 65 20 32 30 34 38 29 0a 20 20 3b 3b 20 size 2048). ;;
103c0 20 28 6d 61 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e (max-connection
103d0 73 20 32 30 34 38 29 20 0a 20 20 28 64 65 62 75 s 2048) . (debu
103e0 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 g:print 2 *defau
103f0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 lt-log-port* "At
10400 74 65 6d 70 74 69 6e 67 20 74 6f 20 73 74 61 72 tempting to star
10410 74 20 74 68 65 20 73 65 72 76 65 72 20 2e 2e 2e t the server ...
10420 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 "). (let* ((db
10430 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
10440 20 3b 3b 20 20 20 20 20 20 20 20 28 6f 70 65 6e ;; (open
10450 2d 64 62 29 29 20 3b 3b 20 77 65 20 64 6f 6e 27 -db)) ;; we don'
10460 74 20 77 61 6e 74 20 74 68 65 20 73 65 72 76 65 t want the serve
10470 72 20 74 6f 20 62 65 20 6f 70 65 6e 69 6e 67 20 r to be opening
10480 61 6e 64 20 63 6c 6f 73 69 6e 67 20 74 68 65 20 and closing the
10490 64 62 20 75 6e 6e 65 63 65 73 61 72 69 6c 79 0a db unnecesarily.
104a0 09 20 28 68 6f 73 74 6e 61 6d 65 20 20 20 20 20 . (hostname
104b0 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d (get-host-nam
104c0 65 29 29 0a 09 20 28 69 70 61 64 64 72 73 74 72 e)).. (ipaddrstr
104d0 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 70 (let ((ip
104e0 73 74 72 20 28 69 66 20 28 73 74 72 69 6e 67 3d str (if (string=
104f0 3f 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 09 09 ? "-" hostn)....
10500 09 09 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d .. ;; (string-
10510 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
10520 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 number->string
10530 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 (u8vector->list
10540 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f (hostname->ip ho
10550 73 74 6e 61 6d 65 29 29 29 20 22 2e 22 29 0a 09 stname))) ".")..
10560 09 09 09 09 20 20 20 28 73 65 72 76 65 72 3a 67 .... (server:g
10570 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
10580 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a dress hostname).
10590 09 09 09 09 09 20 20 20 23 66 29 29 29 0a 09 09 ..... #f)))...
105a0 09 20 20 20 20 28 69 66 20 69 70 73 74 72 20 69 . (if ipstr i
105b0 70 73 74 72 20 68 6f 73 74 6e 29 29 29 20 3b 3b pstr hostn))) ;;
105c0 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 0a 09 20 hostname))) ..
105d0 28 70 6f 72 74 20 20 20 20 20 20 20 20 20 20 20 (port
105e0 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 (portlogger:ope
105f0 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 n-run-close port
10600 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 logger:find-port
10610 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 72 65 65 2d )).. (link-tree-
10620 70 61 74 68 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 path (common:ge
10630 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 20 28 t-linktree)).. (
10640 74 6d 70 2d 61 72 65 61 20 20 20 20 20 20 20 20 tmp-area
10650 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 (common:get-db-t
10660 6d 70 2d 61 72 65 61 29 29 0a 09 20 23 3b 28 73 mp-area)).. #;(s
10670 74 61 72 74 2d 66 69 6c 65 20 20 20 20 20 20 28 tart-file (
10680 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 2f conc tmp-area "/
10690 2e 73 65 72 76 65 72 2d 73 74 61 72 74 22 29 29 .server-start"))
106a0 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
106b0 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
106c0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6f lt-log-port* "po
106d0 72 74 6c 6f 67 67 65 72 20 72 65 63 6f 6d 6d 65 rtlogger recomme
106e0 6e 64 65 64 20 70 6f 72 74 3a 20 22 20 70 6f 72 nded port: " por
106f0 74 29 0a 20 20 20 20 28 69 66 20 2a 73 65 72 76 t). (if *serv
10700 65 72 2d 69 6e 66 6f 2a 0a 09 28 62 65 67 69 6e er-info*..(begin
10710 0a 09 20 20 28 73 65 72 76 64 61 74 2d 68 6f 73 .. (servdat-hos
10720 74 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 t-set! *server-i
10730 6e 66 6f 2a 20 69 70 61 64 64 72 73 74 72 29 0a nfo* ipaddrstr).
10740 09 20 20 28 73 65 72 76 64 61 74 2d 70 6f 72 74 . (servdat-port
10750 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e -set! *server-in
10760 66 6f 2a 20 70 6f 72 74 29 0a 09 20 20 28 73 65 fo* port).. (se
10770 72 76 64 61 74 2d 73 74 61 74 75 73 2d 73 65 74 rvdat-status-set
10780 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 ! *server-info*
10790 27 74 72 79 69 6e 67 2d 70 6f 72 74 29 0a 09 20 'trying-port)..
107a0 20 28 73 65 72 76 64 61 74 2d 74 72 79 6e 75 6d (servdat-trynum
107b0 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e -set! *server-in
107c0 66 6f 2a 20 28 2b 20 28 73 65 72 76 64 61 74 2d fo* (+ (servdat-
107d0 74 72 79 6e 75 6d 20 2a 73 65 72 76 65 72 2d 69 trynum *server-i
107e0 6e 66 6f 2a 29 20 31 29 29 29 0a 09 28 73 65 74 nfo*) 1)))..(set
107f0 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 ! *server-info*
10800 28 6d 61 6b 65 2d 73 65 72 76 64 61 74 20 68 6f (make-servdat ho
10810 73 74 3a 20 69 70 61 64 64 72 73 74 72 20 70 6f st: ipaddrstr po
10820 72 74 3a 20 70 6f 72 74 29 29 29 0a 20 20 20 20 rt: port))).
10830 28 6c 65 74 2a 20 28 28 6c 20 20 20 20 20 20 20 (let* ((l
10840 20 28 72 6d 74 3a 74 72 79 2d 73 74 61 72 74 2d (rmt:try-start-
10850 73 65 72 76 65 72 20 69 70 61 64 64 72 73 74 72 server ipaddrstr
10860 20 70 6f 72 74 29 29 0a 09 20 20 20 28 64 62 73 port)).. (dbs
10870 74 72 75 63 74 20 23 66 29 29 0a 20 20 20 20 20 truct #f)).
10880 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values (((
10890 69 20 6f 29 20 28 74 63 70 2d 61 63 63 65 70 74 i o) (tcp-accept
108a0 20 6c 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 l))). ;; (
108b0 77 72 69 74 65 2d 6c 69 6e 65 20 22 48 65 6c 6c write-line "Hell
108c0 6f 21 22 20 6f 29 0a 20 20 20 20 20 20 28 6c 65 o!" o). (le
108d0 74 20 6c 6f 6f 70 20 28 28 69 6e 64 61 74 20 28 t loop ((indat (
108e0 72 65 61 64 20 69 29 29 29 0a 09 28 6c 65 74 2a read i)))..(let*
108f0 20 28 28 72 65 73 20 28 61 70 69 3a 70 72 6f 63 ((res (api:proc
10900 65 73 73 2d 72 65 71 75 65 73 74 20 64 62 73 74 ess-request dbst
10910 72 75 63 74 20 69 6e 64 61 74 29 29 29 0a 09 20 ruct indat)))..
10920 20 28 63 61 73 65 20 72 65 73 0a 09 20 20 20 20 (case res..
10930 28 28 71 75 69 74 29 0a 09 20 20 20 20 20 28 63 ((quit).. (c
10940 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
10950 69 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 2d i).. (close-
10960 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 29 29 0a output-port o)).
10970 09 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 . (else..
10980 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d (set! *db-last-
10990 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 access* (current
109a0 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 20 -seconds))..
109b0 20 28 77 72 69 74 65 20 72 65 73 20 6f 29 29 29 (write res o)))
109c0 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 )). (let* (
109d0 28 70 6f 72 74 6e 75 6d 20 28 73 65 72 76 64 61 (portnum (servda
109e0 74 2d 70 6f 72 74 20 2a 73 65 72 76 65 72 2d 69 t-port *server-i
109f0 6e 66 6f 2a 29 29 29 0a 09 28 70 6f 72 74 6c 6f nfo*)))..(portlo
10a00 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c gger:open-run-cl
10a10 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 ose portlogger:s
10a20 65 74 2d 70 6f 72 74 20 70 6f 72 74 6e 75 6d 20 et-port portnum
10a30 22 72 65 6c 65 61 73 65 64 22 29 0a 09 28 64 65 "released")..(de
10a40 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 bug:print 1 *def
10a50 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10a60 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 68 61 73 INFO: server has
10a70 20 62 65 65 6e 20 73 74 6f 70 70 65 64 22 29 29 been stopped"))
10a80 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
10a90 6d 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 mt:try-start-ser
10aa0 76 65 72 20 69 70 61 64 64 72 73 74 72 20 70 6f ver ipaddrstr po
10ab0 72 74 6e 75 6d 29 0a 20 20 28 69 66 20 2a 73 65 rtnum). (if *se
10ac0 72 76 65 72 2d 69 6e 66 6f 2a 0a 20 20 20 20 20 rver-info*.
10ad0 20 28 62 65 67 69 6e 0a 09 28 73 65 72 76 64 61 (begin..(servda
10ae0 74 2d 68 6f 73 74 2d 73 65 74 21 20 2a 73 65 72 t-host-set! *ser
10af0 76 65 72 2d 69 6e 66 6f 2a 20 69 70 61 64 64 72 ver-info* ipaddr
10b00 73 74 72 29 0a 09 28 73 65 72 76 64 61 74 2d 70 str)..(servdat-p
10b10 6f 72 74 2d 73 65 74 21 20 2a 73 65 72 76 65 72 ort-set! *server
10b20 2d 69 6e 66 6f 2a 20 70 6f 72 74 6e 75 6d 29 0a -info* portnum).
10b30 09 28 73 65 72 76 64 61 74 2d 73 74 61 74 75 73 .(servdat-status
10b40 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e -set! *server-in
10b50 66 6f 2a 20 27 74 72 79 69 6e 67 2d 70 6f 72 74 fo* 'trying-port
10b60 29 0a 09 28 73 65 72 76 64 61 74 2d 74 72 79 6e )..(servdat-tryn
10b70 75 6d 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d um-set! *server-
10b80 69 6e 66 6f 2a 20 28 2b 20 28 73 65 72 76 64 61 info* (+ (servda
10b90 74 2d 74 72 79 6e 75 6d 20 2a 73 65 72 76 65 72 t-trynum *server
10ba0 2d 69 6e 66 6f 2a 29 20 31 29 29 29 0a 20 20 20 -info*) 1))).
10bb0 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 (set! *server
10bc0 2d 69 6e 66 6f 2a 20 28 6d 61 6b 65 2d 73 65 72 -info* (make-ser
10bd0 76 64 61 74 20 68 6f 73 74 3a 20 69 70 61 64 64 vdat host: ipadd
10be0 72 73 74 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e rstr port: portn
10bf0 75 6d 29 29 29 0a 20 20 28 64 65 62 75 67 3a 70 um))). (debug:p
10c00 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
10c10 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10c20 72 6d 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 rmt:try-start-se
10c30 72 76 65 72 20 74 69 6d 65 3d 22 0a 09 09 20 20 rver time="...
10c40 20 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 (seconds->time
10c50 2d 73 74 72 69 6e 67 20 28 63 75 72 72 65 6e 74 -string (current
10c60 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 -seconds))...
10c70 20 22 20 69 70 61 64 64 72 73 73 74 72 3d 22 20 " ipaddrsstr="
10c80 69 70 61 64 64 72 73 74 72 0a 09 09 20 20 20 20 ipaddrstr...
10c90 22 20 70 6f 72 74 6e 75 6d 3d 22 20 70 6f 72 74 " portnum=" port
10ca0 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 num). (handle-e
10cb0 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
10cc0 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 . (begin.
10cd0 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 (print-error-mes
10ce0 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 20 28 sage exn). (
10cf0 69 66 20 28 3c 20 70 6f 72 74 6e 75 6d 20 36 34 if (< portnum 64
10d00 30 30 30 29 0a 09 20 28 62 65 67 69 6e 20 0a 09 000).. (begin ..
10d10 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
10d20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
10d30 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 61 ort* "WARNING: a
10d40 74 74 65 6d 70 74 20 74 6f 20 73 74 61 72 74 20 ttempt to start
10d50 73 65 72 76 65 72 20 66 61 69 6c 65 64 2e 20 54 server failed. T
10d60 72 79 69 6e 67 20 61 67 61 69 6e 20 2e 2e 2e 22 rying again ..."
10d70 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
10d80 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
10d90 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 g-port* " messag
10da0 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
10db0 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
10dc0 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
10dd0 29 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 62 ) exn)).. (deb
10de0 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 61 ug:print 5 *defa
10df0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 ult-log-port* "e
10e00 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
10e10 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 >list exn))..
10e20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e (portlogger:open
10e30 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c -run-close portl
10e40 6f 67 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 64 ogger:set-failed
10e50 20 70 6f 72 74 6e 75 6d 29 0a 09 20 20 20 28 64 portnum).. (d
10e60 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
10e70 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
10e80 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 "WARNING: failed
10e90 20 74 6f 20 73 74 61 72 74 20 6f 6e 20 70 6f 72 to start on por
10ea0 74 6e 75 6d 3a 20 22 20 70 6f 72 74 6e 75 6d 20 tnum: " portnum
10eb0 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 20 70 ", trying next p
10ec0 6f 72 74 22 29 0a 09 20 20 20 3b 3b 20 28 74 68 ort").. ;; (th
10ed0 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 read-sleep! 0.1)
10ee0 0a 09 20 20 20 28 72 6d 74 3a 74 72 79 2d 73 74 .. (rmt:try-st
10ef0 61 72 74 2d 73 65 72 76 65 72 20 69 70 61 64 64 art-server ipadd
10f00 72 73 74 72 0a 09 09 09 09 20 28 70 6f 72 74 6c rstr..... (portl
10f10 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
10f20 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
10f30 66 69 6e 64 2d 70 6f 72 74 29 29 29 0a 09 20 28 find-port))).. (
10f40 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 6e 74 begin.. (print
10f50 20 22 45 52 52 4f 52 3a 20 54 72 69 65 64 20 61 "ERROR: Tried a
10f60 6e 64 20 74 72 69 65 64 20 62 75 74 20 63 6f 75 nd tried but cou
10f70 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 74 68 65 ld not start the
10f80 20 73 65 72 76 65 72 22 29 29 29 29 0a 20 20 20 server")))).
10f90 3b 3b 20 61 6e 79 20 65 72 72 6f 72 20 69 6e 20 ;; any error in
10fa0 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 65 70 73 20 following steps
10fb0 77 69 6c 6c 20 72 65 73 75 6c 74 20 69 6e 20 61 will result in a
10fc0 20 72 65 74 72 79 0a 20 20 20 28 69 66 20 2a 73 retry. (if *s
10fd0 65 72 76 65 72 2d 69 6e 66 6f 2a 0a 20 20 20 20 erver-info*.
10fe0 20 20 20 28 73 65 72 76 64 61 74 2d 73 74 61 74 (servdat-stat
10ff0 75 73 2d 73 65 74 21 20 2a 73 65 72 76 65 72 2d us-set! *server-
11000 69 6e 66 6f 2a 20 27 73 74 61 72 74 69 6e 67 29 info* 'starting)
11010 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 2a 73 . (set! *s
11020 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 6d 61 6b erver-info* (mak
11030 65 2d 73 65 72 76 64 61 74 20 68 6f 73 74 3a 20 e-servdat host:
11040 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 3a 20 ipaddrstr port:
11050 70 6f 72 74 6e 75 6d 29 29 29 0a 20 20 20 0a 20 portnum))). .
11060 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
11070 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
11080 72 74 2a 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e rt* "INFO: Tryin
11090 67 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 g to start serve
110a0 72 20 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 r on " ipaddrstr
110b0 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ":" portnum).
110c0 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 70 6f 72 (tcp-listen por
110d0 74 6e 75 6d 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d tnum)))..;;=====
110e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
110f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11100 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11120 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 =.;; S E R V E R
11130 20 20 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 U T I L I T I
11140 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d E S .;;========
11150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11170 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
11190 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
111a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
111d0 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 ========.;; C L
111e0 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d 3d I E N T S.;;====
111f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11230 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ==..(define (htt
11240 70 2d 74 72 61 6e 73 70 6f 72 74 3a 67 65 74 2d p-transport:get-
11250 74 69 6d 65 2d 74 6f 2d 63 6c 65 61 6e 75 70 29 time-to-cleanup)
11260 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
11270 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f )). (mutex-lo
11280 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
11290 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 73 20 ). (set! res
112a0 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (> (current-seco
112b0 6e 64 73 29 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 nds) *http-conne
112c0 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 ctions-next-clea
112d0 6e 75 70 2a 29 29 0a 20 20 20 20 28 6d 75 74 65 nup*)). (mute
112e0 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
112f0 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 73 29 mutex*). res)
11300 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
11310 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 -transport:inc-r
11320 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 equests-count).
11330 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
11340 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 ttp-mutex*). (s
11350 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 et! *http-reques
11360 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
11370 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 75 65 (+ 1 *http-reque
11380 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
11390 29 29 0a 20 20 3b 3b 20 55 73 65 20 74 68 69 73 )). ;; Use this
113a0 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 opportunity to
113b0 73 6c 6f 77 20 74 68 69 6e 67 73 20 64 6f 77 6e slow things down
113c0 20 69 66 66 20 74 68 65 72 65 20 61 72 65 20 74 iff there are t
113d0 6f 6f 20 6d 61 6e 79 20 72 65 71 75 65 73 74 73 oo many requests
113e0 20 69 6e 20 66 6c 69 67 68 74 0a 20 20 28 69 66 in flight. (if
113f0 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 73 (> *http-reques
11400 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
11410 35 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 5). (begin.
11420 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
11430 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
11440 67 2d 70 6f 72 74 2a 20 22 57 68 6f 61 20 74 68 g-port* "Whoa th
11450 65 72 65 20 62 75 64 64 79 2c 20 65 61 73 65 20 ere buddy, ease
11460 75 70 2e 2e 2e 22 29 0a 09 28 74 68 72 65 61 64 up...")..(thread
11470 2d 73 6c 65 65 70 21 20 31 29 29 29 0a 20 20 28 -sleep! 1))). (
11480 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
11490 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 ttp-mutex*))..(d
114a0 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
114b0 73 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 sport:dec-reques
114c0 74 73 2d 63 6f 75 6e 74 20 70 72 6f 63 29 20 0a ts-count proc) .
114d0 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
114e0 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 http-mutex*). (
114f0 70 72 6f 63 29 0a 20 20 28 73 65 74 21 20 2a 68 proc). (set! *h
11500 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
11510 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 progress* (- *ht
11520 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
11530 72 6f 67 72 65 73 73 2a 20 31 29 29 0a 20 20 28 rogress* 1)). (
11540 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
11550 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 ttp-mutex*))..(d
11560 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
11570 73 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 sport:dec-reques
11580 74 73 2d 63 6f 75 6e 74 2d 61 6e 64 2d 63 6c 6f ts-count-and-clo
11590 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f se-all-connectio
115a0 6e 73 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 ns). (set! *htt
115b0 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
115c0 6f 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 ogress* (- *http
115d0 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
115e0 67 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6c 65 gress* 1)). (le
115f0 74 20 6c 6f 6f 70 20 28 28 65 74 69 6d 65 20 28 t loop ((etime (
11600 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
11610 64 73 29 20 35 29 29 29 20 3b 3b 20 67 69 76 65 ds) 5))) ;; give
11620 20 75 70 20 69 6e 20 66 69 76 65 20 73 65 63 6f up in five seco
11630 6e 64 73 0a 20 20 20 20 28 69 66 20 28 3e 20 2a nds. (if (> *
11640 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
11650 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 0a 09 28 -progress* 0)..(
11660 69 66 20 28 3e 20 65 74 69 6d 65 20 28 63 75 72 if (> etime (cur
11670 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
11680 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
11690 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
116a0 20 30 2e 30 35 32 29 0a 09 20 20 20 20 20 20 28 0.052).. (
116b0 6c 6f 6f 70 20 65 74 69 6d 65 29 29 0a 09 20 20 loop etime))..
116c0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
116d0 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
116e0 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 20 20 log-port*....
116f0 20 20 20 20 22 72 65 71 75 65 73 74 73 20 73 74 "requests st
11700 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 73 20 ill in progress
11710 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 73 20 after 5 seconds
11720 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 6d 20 of waiting. I'm
11730 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 6f 6e going to pass on
11740 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 74 74 cleaning up htt
11750 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 29 29 p connections"))
11760 0a 09 23 3b 28 63 6c 6f 73 65 2d 69 64 6c 65 2d ..#;(close-idle-
11770 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a connections!))).
11780 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 63 6f (set! *http-co
11790 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 nnections-next-c
117a0 6c 65 61 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 leanup* (+ (curr
117b0 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 ent-seconds) 10)
117c0 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ). (mutex-unloc
117d0 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
117e0 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
117f0 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 -transport:inc-r
11800 65 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 equests-and-prep
11810 2d 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f -to-close-all-co
11820 6e 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 nnections). (mu
11830 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d tex-lock! *http-
11840 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 mutex*). (set!
11850 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
11860 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 n-progress* (+ 1
11870 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
11880 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 29 0a in-progress*))).
11890 0a 3b 3b 20 63 61 72 65 66 75 6c 20 63 6c 6f 73 .;; careful clos
118a0 69 6e 67 20 6f 66 20 63 6f 6e 6e 65 63 74 69 6f ing of connectio
118b0 6e 73 20 73 74 6f 72 65 64 20 69 6e 20 2a 72 75 ns stored in *ru
118c0 6e 72 65 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 nremote*.;;.(def
118d0 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
118e0 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
118f0 74 69 6f 6e 73 20 23 21 6b 65 79 20 28 61 72 65 tions #!key (are
11900 61 2d 64 61 74 20 23 66 29 29 0a 20 20 28 64 65 a-dat #f)). (de
11910 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
11920 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
11930 72 74 2a 20 22 68 74 74 70 2d 74 72 61 6e 73 70 rt* "http-transp
11940 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
11950 74 69 6f 6e 73 20 64 6f 65 73 6e 27 74 20 64 6f tions doesn't do
11960 20 61 6e 79 74 68 69 6e 67 20 6e 6f 77 21 22 29 anything now!")
11970 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 72 ).;; (let* ((r
11980 75 6e 72 65 6d 6f 74 65 20 20 28 6f 72 20 61 72 unremote (or ar
11990 65 61 2d 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 ea-dat *runremot
119a0 65 2a 29 29 0a 3b 3b 20 09 20 28 73 65 72 76 65 e*)).;; . (serve
119b0 72 2d 64 61 74 20 28 69 66 20 72 75 6e 72 65 6d r-dat (if runrem
119c0 6f 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ote.;;
119d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119e0 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 (remote-conndat
119f0 72 75 6e 72 65 6d 6f 74 65 29 0a 3b 3b 20 20 20 runremote).;;
11a00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a10 20 20 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 #f))) ;;
11a20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
11a30 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f default *runremo
11a40 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 te* run-id #f)))
11a50 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 76 65 63 .;; (if (vec
11a60 74 6f 72 3f 20 73 65 72 76 65 72 2d 64 61 74 29 tor? server-dat)
11a70 0a 3b 3b 20 09 28 6c 65 74 20 28 28 61 70 69 2d .;; .(let ((api-
11a80 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dat (http-transp
11a90 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
11aa0 65 74 2d 61 70 69 2d 75 72 69 20 73 65 72 76 65 et-api-uri serve
11ab0 72 2d 64 61 74 29 29 29 0a 3b 3b 20 09 20 20 28 r-dat))).;; . (
11ac0 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
11ad0 73 0a 3b 3b 20 09 20 20 20 20 65 78 6e 0a 3b 3b s.;; . exn.;;
11ae0 20 09 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 . (begin.;;
11af0 09 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 . (print-ca
11b00 6c 6c 2d 63 68 61 69 6e 20 2a 64 65 66 61 75 6c ll-chain *defaul
11b10 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 3b 3b 20 t-log-port*).;;
11b20 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
11b30 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
11b40 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
11b50 20 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63 74 closing connect
11b60 69 6f 6e 20 66 61 69 6c 65 64 20 77 69 74 68 20 ion failed with
11b70 65 72 72 6f 72 3a 20 22 20 28 28 63 6f 6e 64 69 error: " ((condi
11b80 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
11b90 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
11ba0 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 65 78 sage) exn) ", ex
11bb0 6e 3d 22 20 65 78 6e 29 29 0a 3b 3b 20 09 20 20 n=" exn)).;; .
11bc0 20 20 28 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 (close-connect
11bd0 69 6f 6e 21 20 61 70 69 2d 64 61 74 29 0a 3b 3b ion! api-dat).;;
11be0 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
11bf0 63 6c 6f 73 65 2d 69 64 6c 65 2d 63 6f 6e 6e 65 close-idle-conne
11c00 63 74 69 6f 6e 73 21 29 0a 3b 3b 20 09 20 20 20 ctions!).;; .
11c10 20 23 74 29 29 0a 3b 3b 20 09 23 66 29 29 29 0a #t)).;; .#f))).
11c20 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make-
11c30 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
11c40 65 72 76 65 72 2d 64 61 74 29 28 6d 61 6b 65 2d erver-dat)(make-
11c50 76 65 63 74 6f 72 20 36 29 29 0a 28 64 65 66 69 vector 6)).(defi
11c60 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
11c70 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
11c80 74 2d 69 66 61 63 65 20 20 20 20 20 20 20 20 20 t-iface
11c90 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
11ca0 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 ref vec 0)).(de
11cb0 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
11cc0 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
11cd0 67 65 74 2d 70 6f 72 74 20 20 20 20 20 20 20 20 get-port
11ce0 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
11cf0 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 r-ref vec 1)).(
11d00 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
11d10 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
11d20 74 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 20 20 t-get-api-uri
11d30 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
11d40 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 tor-ref vec 2))
11d50 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
11d60 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
11d70 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 6c 20 dat-get-api-url
11d80 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
11d90 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 ector-ref vec 3
11da0 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )).(define (http
11db0 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
11dc0 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 72 65 r-dat-get-api-re
11dd0 71 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 q vec)
11de0 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
11df0 20 34 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 4)).(define (ht
11e00 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
11e10 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 74 ver-dat-get-last
11e20 2d 61 63 63 65 73 73 20 20 20 76 65 63 29 20 20 -access vec)
11e30 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
11e40 65 63 20 35 29 29 0a 3b 28 64 65 66 69 6e 65 20 ec 5)).;(define
11e50 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
11e60 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 server-dat-get-s
11e70 6f 63 6b 65 74 20 20 20 20 20 20 20 20 76 65 63 ocket vec
11e80 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
11e90 20 20 76 65 63 20 36 29 29 0a 28 64 65 66 69 6e vec 6)).(defin
11ea0 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
11eb0 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
11ec0 2d 73 65 72 76 65 72 2d 69 64 20 20 20 20 20 76 -server-id v
11ed0 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
11ee0 65 66 20 20 76 65 63 20 36 29 29 0a 0a 28 64 65 ef vec 6))..(de
11ef0 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
11f00 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
11f10 6d 61 6b 65 2d 75 72 6c 20 76 65 63 29 0a 20 20 make-url vec).
11f20 28 69 66 20 28 61 6e 64 20 28 68 74 74 70 2d 74 (if (and (http-t
11f30 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
11f40 64 61 74 2d 67 65 74 2d 69 66 61 63 65 20 76 65 dat-get-iface ve
11f50 63 29 0a 09 20 20 20 28 68 74 74 70 2d 74 72 61 c).. (http-tra
11f60 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
11f70 74 2d 67 65 74 2d 70 6f 72 74 20 20 76 65 63 29 t-get-port vec)
11f80 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 ). (conc "h
11f90 74 74 70 3a 2f 2f 22 20 0a 09 20 20 20 20 28 68 ttp://" .. (h
11fa0 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
11fb0 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 rver-dat-get-ifa
11fc0 63 65 20 76 65 63 29 0a 09 20 20 20 20 22 3a 22 ce vec).. ":"
11fd0 0a 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e .. (http-tran
11fe0 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
11ff0 2d 67 65 74 2d 70 6f 72 74 20 20 76 65 63 29 29 -get-port vec))
12000 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 . #f))..(de
12010 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
12020 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
12030 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 update-last-acce
12040 73 73 20 76 65 63 29 0a 20 20 28 69 66 20 28 76 ss vec). (if (v
12050 65 63 74 6f 72 3f 20 76 65 63 29 0a 20 20 20 20 ector? vec).
12060 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 (vector-set! v
12070 65 63 20 35 20 28 63 75 72 72 65 6e 74 2d 73 65 ec 5 (current-se
12080 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 28 62 conds)). (b
12090 65 67 69 6e 0a 09 28 70 72 69 6e 74 2d 63 61 6c egin..(print-cal
120a0 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
120b0 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 28 -error-port))..(
120c0 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
120d0 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
120e0 2d 70 6f 72 74 2a 20 22 63 61 6c 6c 20 74 6f 20 -port* "call to
120f0 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
12100 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 74 65 erver-dat-update
12110 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 77 69 74 -last-access wit
12120 68 20 6e 6f 6e 2d 76 65 63 74 6f 72 21 21 22 29 h non-vector!!")
12130 29 29 29 0a 0a 3b 3b 20 69 6e 69 74 69 61 6c 69 )))..;; initiali
12140 7a 65 20 73 65 72 76 64 61 74 20 66 6f 72 20 63 ze servdat for c
12150 6c 69 65 6e 74 20 73 69 64 65 2c 20 73 65 74 75 lient side, setu
12160 70 20 6e 65 65 64 65 64 20 70 61 72 61 6d 65 74 p needed paramet
12170 65 72 73 0a 3b 3b 20 70 61 73 73 20 69 6e 20 23 ers.;; pass in #
12180 66 20 61 73 20 73 64 61 74 2d 69 6e 20 74 6f 20 f as sdat-in to
12190 63 72 65 61 74 65 20 73 64 61 74 0a 3b 3b 0a 23 create sdat.;;.#
121a0 3b 28 64 65 66 69 6e 65 20 28 73 65 72 76 64 61 ;(define (servda
121b0 74 2d 69 6e 69 74 20 73 64 61 74 2d 69 6e 20 69 t-init sdat-in i
121c0 66 61 63 65 20 70 6f 72 74 20 75 75 69 64 29 0a face port uuid).
121d0 20 20 28 6c 65 74 2a 20 28 28 73 64 61 74 20 28 (let* ((sdat (
121e0 6f 72 20 73 64 61 74 2d 69 6e 20 28 6d 61 6b 65 or sdat-in (make
121f0 2d 73 65 72 76 64 61 74 29 29 29 29 0a 20 20 20 -servdat)))).
12200 20 0a 20 20 20 20 28 61 73 73 65 72 74 20 23 66 . (assert #f
12210 20 22 54 68 69 73 20 69 73 20 61 20 62 61 64 20 "This is a bad
12220 69 64 65 61 2e 22 29 0a 0a 20 20 20 20 28 69 66 idea.").. (if
12230 20 75 75 69 64 20 28 73 65 72 76 64 61 74 2d 75 uuid (servdat-u
12240 75 69 64 2d 73 65 74 21 20 73 64 61 74 20 75 75 uid-set! sdat uu
12250 69 64 29 29 0a 20 20 20 20 28 73 65 72 76 64 61 id)). (servda
12260 74 2d 68 6f 73 74 2d 73 65 74 21 20 73 64 61 74 t-host-set! sdat
12270 20 69 66 61 63 65 29 0a 20 20 20 20 28 73 65 72 iface). (ser
12280 76 64 61 74 2d 70 6f 72 74 2d 73 65 74 21 20 73 vdat-port-set! s
12290 64 61 74 20 70 6f 72 74 29 0a 20 20 20 20 28 73 dat port). (s
122a0 65 72 76 64 61 74 2d 61 70 69 2d 75 72 6c 2d 73 ervdat-api-url-s
122b0 65 74 21 20 73 64 61 74 20 28 63 6f 6e 63 20 22 et! sdat (conc "
122c0 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 20 22 http://" iface "
122d0 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 22 29 29 :" port "/api"))
122e0 0a 20 20 20 20 28 73 65 72 76 64 61 74 2d 61 70 . (servdat-ap
122f0 69 2d 75 72 69 2d 73 65 74 21 20 73 64 61 74 20 i-uri-set! sdat
12300 28 75 72 69 2d 72 65 66 65 72 65 6e 63 65 20 28 (uri-reference (
12310 73 65 72 76 64 61 74 2d 61 70 69 2d 75 72 6c 20 servdat-api-url
12320 73 64 61 74 29 29 29 0a 20 20 20 20 28 73 65 72 sdat))). (ser
12330 76 64 61 74 2d 61 70 69 2d 72 65 71 2d 73 65 74 vdat-api-req-set
12340 21 20 73 64 61 74 20 28 6d 61 6b 65 2d 72 65 71 ! sdat (make-req
12350 75 65 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f uest method: 'PO
12360 53 54 0a 09 09 09 09 09 20 20 20 20 20 75 72 69 ST...... uri
12370 3a 20 28 73 65 72 76 64 61 74 2d 61 70 69 2d 75 : (servdat-api-u
12380 72 69 20 73 64 61 74 29 29 29 0a 20 20 20 20 3b ri sdat))). ;
12390 3b 20 73 65 74 20 75 70 20 74 68 65 20 68 74 74 ; set up the htt
123a0 70 2d 63 6c 69 65 6e 74 20 70 61 72 61 6d 65 74 p-client paramet
123b0 65 72 73 0a 20 20 20 20 28 6d 61 78 2d 72 65 74 ers. (max-ret
123c0 72 79 2d 61 74 74 65 6d 70 74 73 20 31 29 0a 20 ry-attempts 1).
123d0 20 20 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 61 ;; consider a
123e0 6c 6c 20 72 65 71 75 65 73 74 73 20 69 6e 64 65 ll requests inde
123f0 6d 70 6f 74 65 6e 74 0a 20 20 20 20 28 72 65 74 mpotent. (ret
12400 72 79 2d 72 65 71 75 65 73 74 3f 20 28 6c 61 6d ry-request? (lam
12410 62 64 61 20 28 72 65 71 75 65 73 74 29 0a 09 09 bda (request)...
12420 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 #f)). (
12430 64 65 74 65 72 6d 69 6e 65 2d 70 72 6f 78 79 20 determine-proxy
12440 28 63 6f 6e 73 74 61 6e 74 6c 79 20 23 66 29 29 (constantly #f))
12450 0a 20 20 20 73 64 61 74 29 29 0a 0a 3b 3b 3d 3d . sdat))..;;==
12460 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12470 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12480 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12490 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
124a0 3d 3d 3d 3d 0a 3b 3b 20 4e 45 57 20 53 45 52 56 ====.;; NEW SERV
124b0 45 52 20 4d 45 54 48 4f 44 0a 3b 3b 3d 3d 3d 3d ER METHOD.;;====
124c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
124d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
124e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
124f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12500 3d 3d 0a 0a 3b 3b 20 6f 6e 6c 79 20 75 73 65 20 ==..;; only use
12510 66 6f 72 20 6d 61 69 6e 2e 64 62 20 2d 20 6e 65 for main.db - ne
12520 65 64 20 74 6f 20 72 65 2d 77 72 69 74 65 20 73 ed to re-write s
12530 6f 6d 65 20 6f 66 20 74 68 69 73 20 3a 28 0a 3b ome of this :(.;
12540 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 6c ;.(define (get-l
12550 6f 63 6b 2d 64 62 20 73 64 61 74 20 64 62 66 69 ock-db sdat dbfi
12560 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 le). (let* ((db
12570 68 20 28 64 62 3a 6f 70 65 6e 2d 72 75 6e 2d 64 h (db:open-run-d
12580 62 20 64 62 66 69 6c 65 20 64 62 3a 69 6e 69 74 b dbfile db:init
12590 69 61 6c 69 7a 65 2d 64 62 29 29 0a 09 20 28 72 ialize-db)).. (r
125a0 65 73 20 28 64 62 3a 67 65 74 2d 69 61 6d 2d 73 es (db:get-iam-s
125b0 65 72 76 65 72 2d 6c 6f 63 6b 20 64 62 68 20 64 erver-lock dbh d
125c0 62 66 69 6c 65 29 29 29 0a 20 20 20 20 28 73 71 bfile))). (sq
125d0 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
125e0 64 62 68 29 0a 20 20 20 20 72 65 73 29 29 0a 0a dbh). res))..
125f0 0a 28 64 65 66 69 6e 65 20 2a 73 72 76 70 6b 74 .(define *srvpkt
12600 73 70 65 63 2a 0a 20 20 60 28 28 73 65 72 76 65 spec*. `((serve
12610 72 20 28 68 6f 73 74 20 20 20 20 2e 20 68 29 0a r (host . h).
12620 09 20 20 20 20 28 70 6f 72 74 20 20 20 20 2e 20 . (port .
12630 70 29 0a 09 20 20 20 20 28 73 65 72 76 6b 65 79 p).. (servkey
12640 20 2e 20 6b 29 0a 09 20 20 20 20 28 70 69 64 20 . k).. (pid
12650 20 20 20 20 2e 20 69 29 0a 09 20 20 20 20 28 69 . i).. (i
12660 70 61 64 64 72 20 20 2e 20 61 29 0a 09 20 20 20 paddr . a)..
12670 20 28 64 62 70 61 74 68 20 20 2e 20 64 29 29 29 (dbpath . d)))
12680 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 65 67 69 )..(define (regi
12690 73 74 65 72 2d 73 65 72 76 65 72 20 70 6b 74 73 ster-server pkts
126a0 2d 64 69 72 20 70 6b 74 2d 73 70 65 63 20 68 6f -dir pkt-spec ho
126b0 73 74 20 70 6f 72 74 20 73 65 72 76 6b 65 79 20 st port servkey
126c0 69 70 61 64 64 72 20 64 62 70 61 74 68 29 0a 20 ipaddr dbpath).
126d0 20 28 6c 65 74 2a 20 28 28 70 6b 74 2d 64 61 74 (let* ((pkt-dat
126e0 20 60 28 28 68 6f 73 74 20 20 20 20 2e 20 2c 68 `((host . ,h
126f0 6f 73 74 29 0a 09 09 20 20 20 20 28 70 6f 72 74 ost)... (port
12700 20 20 20 20 2e 20 2c 70 6f 72 74 29 0a 09 09 20 . ,port)...
12710 20 20 20 28 73 65 72 76 6b 65 79 20 2e 20 2c 73 (servkey . ,s
12720 65 72 76 6b 65 79 29 0a 09 09 20 20 20 20 28 70 ervkey)... (p
12730 69 64 20 20 20 20 20 2e 20 2c 28 63 75 72 72 65 id . ,(curre
12740 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
12750 09 09 20 20 20 20 28 69 70 61 64 64 72 20 20 2e .. (ipaddr .
12760 20 2c 69 70 61 64 64 72 29 0a 09 09 20 20 20 20 ,ipaddr)...
12770 28 64 62 70 61 74 68 20 20 2e 20 2c 64 62 70 61 (dbpath . ,dbpa
12780 74 68 29 29 29 0a 09 20 28 75 75 69 64 20 20 20 th))).. (uuid
12790 20 28 77 72 69 74 65 2d 61 6c 69 73 74 2d 3e 70 (write-alist->p
127a0 6b 74 0a 09 09 20 20 20 70 6b 74 73 2d 64 69 72 kt... pkts-dir
127b0 0a 09 09 20 20 20 70 6b 74 2d 64 61 74 0a 09 09 ... pkt-dat...
127c0 20 20 20 70 6b 74 73 70 65 63 3a 20 70 6b 74 2d pktspec: pkt-
127d0 73 70 65 63 0a 09 09 20 20 20 70 74 79 70 65 3a spec... ptype:
127e0 20 27 73 65 72 76 65 72 29 29 29 0a 20 20 20 20 'server))).
127f0 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
12800 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
12810 2a 20 22 53 65 72 76 65 72 20 6f 6e 20 22 68 6f * "Server on "ho
12820 73 74 22 3a 22 70 6f 72 74 22 20 72 65 67 69 73 st":"port" regis
12830 74 65 72 65 64 20 69 6e 20 70 6b 74 20 22 75 75 tered in pkt "uu
12840 69 64 29 0a 20 20 20 20 75 75 69 64 29 29 0a 0a id). uuid))..
12850 28 64 65 66 69 6e 65 20 28 67 65 74 2d 70 6b 74 (define (get-pkt
12860 73 2d 64 69 72 20 23 21 6f 70 74 69 6f 6e 61 6c s-dir #!optional
12870 20 28 61 70 61 74 68 20 23 66 29 29 0a 20 20 28 (apath #f)). (
12880 6c 65 74 2a 20 28 28 65 66 66 65 63 74 69 76 65 let* ((effective
12890 2d 74 6f 70 70 61 74 68 20 28 6f 72 20 2a 74 6f -toppath (or *to
128a0 70 70 61 74 68 2a 20 61 70 61 74 68 29 29 29 0a ppath* apath))).
128b0 20 20 20 20 28 61 73 73 65 72 74 20 65 66 66 65 (assert effe
128c0 63 74 69 76 65 2d 74 6f 70 70 61 74 68 0a 09 20 ctive-toppath..
128d0 20 20 20 22 45 52 52 4f 52 3a 20 67 65 74 2d 70 "ERROR: get-p
128e0 6b 74 73 2d 64 69 72 20 63 61 6c 6c 65 64 20 77 kts-dir called w
128f0 69 74 68 6f 75 74 20 2a 74 6f 70 70 61 74 68 2a ithout *toppath*
12900 20 73 65 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 set. Exiting.")
12910 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 70 64 69 . (let* ((pdi
12920 72 20 28 63 6f 6e 63 20 65 66 66 65 63 74 69 76 r (conc effectiv
12930 65 2d 74 6f 70 70 61 74 68 20 22 2f 2e 6d 65 74 e-toppath "/.met
12940 61 2f 73 72 76 70 6b 74 73 22 29 29 29 0a 20 20 a/srvpkts"))).
12950 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
12960 69 73 74 73 3f 20 70 64 69 72 29 0a 09 20 20 70 ists? pdir).. p
12970 64 69 72 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 dir.. (begin..
12980 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 (create-direc
12990 74 6f 72 79 20 70 64 69 72 20 23 74 29 0a 09 20 tory pdir #t)..
129a0 20 20 20 70 64 69 72 29 29 29 29 29 0a 0a 3b 3b pdir)))))..;;
129b0 20 67 69 76 65 6e 20 61 20 70 6b 74 73 20 64 69 given a pkts di
129c0 72 20 72 65 61 64 20 0a 3b 3b 0a 28 64 65 66 69 r read .;;.(defi
129d0 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 73 65 72 76 ne (get-all-serv
129e0 65 72 2d 70 6b 74 73 20 70 6b 74 73 64 69 72 2d er-pkts pktsdir-
129f0 69 6e 20 70 6b 74 73 70 65 63 29 0a 20 20 28 6c in pktspec). (l
12a00 65 74 2a 20 28 28 70 6b 74 73 64 69 72 20 20 28 et* ((pktsdir (
12a10 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
12a20 20 70 6b 74 73 64 69 72 2d 69 6e 29 0a 09 09 20 pktsdir-in)...
12a30 20 20 20 20 20 20 70 6b 74 73 64 69 72 2d 69 6e pktsdir-in
12a40 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
12a50 0a 09 09 09 20 28 63 72 65 61 74 65 2d 64 69 72 .... (create-dir
12a60 65 63 74 6f 72 79 20 70 6b 74 73 64 69 72 2d 69 ectory pktsdir-i
12a70 6e 20 23 74 29 0a 09 09 09 20 70 6b 74 73 64 69 n #t).... pktsdi
12a80 72 2d 69 6e 29 29 29 0a 09 20 28 61 6c 6c 2d 70 r-in))).. (all-p
12a90 6b 74 2d 66 69 6c 65 73 20 28 67 6c 6f 62 20 28 kt-files (glob (
12aa0 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f 2a conc pktsdir "/*
12ab0 2e 70 6b 74 22 29 29 29 29 0a 20 20 20 20 28 6d .pkt")))). (m
12ac0 61 70 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 2d ap (lambda (pkt-
12ad0 66 69 6c 65 29 0a 09 20 20 20 28 72 65 61 64 2d file).. (read-
12ae0 70 6b 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d 66 pkt->alist pkt-f
12af0 69 6c 65 20 70 6b 74 73 70 65 63 3a 20 70 6b 74 ile pktspec: pkt
12b00 73 70 65 63 29 29 0a 09 20 61 6c 6c 2d 70 6b 74 spec)).. all-pkt
12b10 2d 66 69 6c 65 73 29 29 29 0a 0a 28 64 65 66 69 -files)))..(defi
12b20 6e 65 20 28 73 65 72 76 65 72 2d 61 64 64 72 65 ne (server-addre
12b30 73 73 20 73 72 76 2d 70 6b 74 29 0a 20 20 28 63 ss srv-pkt). (c
12b40 6f 6e 63 20 28 61 6c 69 73 74 2d 72 65 66 20 27 onc (alist-ref '
12b50 68 6f 73 74 20 73 72 76 2d 70 6b 74 29 20 22 3a host srv-pkt) ":
12b60 22 0a 09 28 61 6c 69 73 74 2d 72 65 66 20 27 70 "..(alist-ref 'p
12b70 6f 72 74 20 73 72 76 2d 70 6b 74 29 29 29 0a 09 ort srv-pkt)))..
12b80 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
12b90 2d 72 65 61 64 79 3f 20 68 6f 73 74 20 70 6f 72 -ready? host por
12ba0 74 20 6b 65 79 29 20 3b 3b 20 73 65 72 76 65 72 t key) ;; server
12bb0 2d 61 64 64 72 65 73 73 20 69 73 20 68 6f 73 74 -address is host
12bc0 3a 70 6f 72 74 0a 20 20 3b 3b 20 70 69 6e 67 20 :port. ;; ping
12bd0 74 68 65 20 73 65 72 76 65 72 20 61 6e 64 20 61 the server and a
12be0 73 6b 20 69 74 0a 20 20 3b 3b 20 69 66 20 69 74 sk it. ;; if it
12bf0 20 72 65 61 64 79 0a 20 20 3b 3b 20 28 6c 65 74 ready. ;; (let
12c00 2a 20 28 28 73 64 61 74 20 28 73 65 72 76 64 61 * ((sdat (servda
12c10 74 2d 69 6e 69 74 20 23 66 20 68 6f 73 74 20 70 t-init #f host p
12c20 6f 72 74 20 23 66 29 29 29 0a 20 20 3b 3b 20 20 ort #f))). ;;
12c30 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
12c40 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 73 64 :send-receive sd
12c50 61 74 20 22 61 62 63 22 20 27 70 69 6e 67 20 27 at "abc" 'ping '
12c60 28 29 29 29 29 0a 0a 20 20 23 3b 28 6c 65 74 2a ()))).. #;(let*
12c70 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 ((res (with-inp
12c80 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 0a ut-from-request.
12c90 09 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 . (conc "h
12ca0 74 74 70 3a 2f 2f 22 68 6f 73 74 22 3a 22 70 6f ttp://"host":"po
12cb0 72 74 22 2f 70 69 6e 67 22 29 20 3b 3b 20 72 65 rt"/ping") ;; re
12cc0 74 75 72 6e 73 20 2a 74 6f 70 70 61 74 68 2a 2f turns *toppath*/
12cd0 64 62 6e 61 6d 65 0a 09 20 20 20 20 20 20 20 23 dbname.. #
12ce0 66 0a 09 20 20 20 20 20 20 20 72 65 61 64 2d 73 f.. read-s
12cf0 74 72 69 6e 67 29 29 29 0a 20 20 20 20 28 69 66 tring))). (if
12d00 20 28 65 71 75 61 6c 3f 20 72 65 73 20 6b 65 79 (equal? res key
12d10 29 0a 09 23 74 0a 09 28 62 65 67 69 6e 0a 09 20 )..#t..(begin..
12d20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
12d30 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
12d40 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 72 2d g-port* "server-
12d50 72 65 61 64 79 3f 20 6b 65 79 3d 22 6b 65 79 22 ready? key="key"
12d60 2c 20 72 65 63 65 69 76 65 64 3d 22 72 65 73 29 , received="res)
12d70 0a 20 20 23 66 29 29 29 0a 0a 20 20 23 66 0a 20 . #f))).. #f.
12d80 20 29 0a 09 20 20 20 20 20 20 0a 28 64 65 66 69 ).. .(defi
12d90 6e 65 20 28 6c 6f 6f 70 2d 74 65 73 74 20 68 6f ne (loop-test ho
12da0 73 74 20 70 6f 72 74 20 64 61 74 61 29 20 3b 3b st port data) ;;
12db0 20 73 65 72 76 65 72 2d 61 64 64 72 65 73 73 20 server-address
12dc0 69 73 20 68 6f 73 74 3a 70 6f 72 74 0a 20 20 3b is host:port. ;
12dd0 3b 20 70 69 6e 67 20 74 68 65 20 73 65 72 76 65 ; ping the serve
12de0 72 20 61 6e 64 20 61 73 6b 20 69 74 0a 20 20 3b r and ask it. ;
12df0 3b 20 69 66 20 69 74 20 72 65 61 64 79 0a 20 20 ; if it ready.
12e00 3b 3b 20 28 6c 65 74 2a 20 28 28 73 64 61 74 20 ;; (let* ((sdat
12e10 28 73 65 72 76 64 61 74 2d 69 6e 69 74 20 23 66 (servdat-init #f
12e20 20 68 6f 73 74 20 70 6f 72 74 20 23 66 29 29 29 host port #f)))
12e30 0a 20 20 3b 3b 20 20 20 28 68 74 74 70 2d 74 72 . ;; (http-tr
12e40 61 6e 73 70 6f 72 74 3a 73 65 6e 64 2d 72 65 63 ansport:send-rec
12e50 65 69 76 65 20 73 64 61 74 20 22 61 62 63 22 20 eive sdat "abc"
12e60 27 70 69 6e 67 20 27 28 29 29 29 29 0a 20 20 23 'ping '()))). #
12e70 3b 28 6c 65 74 2a 20 28 28 70 61 79 6c 6f 61 64 ;(let* ((payload
12e80 20 28 73 65 78 70 72 2d 3e 73 74 72 69 6e 67 20 (sexpr->string
12e90 64 61 74 61 29 29 0a 09 20 28 72 65 73 20 20 20 data)).. (res
12ea0 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
12eb0 6f 6d 2d 72 65 71 75 65 73 74 0a 09 09 20 20 20 om-request...
12ec0 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 68 (conc "http://"h
12ed0 6f 73 74 22 3a 22 70 6f 72 74 22 2f 6c 6f 6f 70 ost":"port"/loop
12ee0 2d 74 65 73 74 22 29 0a 09 09 20 20 20 60 28 28 -test")... `((
12ef0 64 61 74 61 20 2e 20 2c 70 61 79 6c 6f 61 64 29 data . ,payload)
12f00 29 0a 09 09 20 20 20 72 65 61 64 2d 73 74 72 69 )... read-stri
12f10 6e 67 29 29 29 0a 20 20 28 73 74 72 69 6e 67 2d ng))). (string-
12f20 3e 73 65 78 70 72 20 72 65 73 29 29 0a 20 20 23 >sexpr res)). #
12f30 66 0a 20 20 29 0a 09 20 20 20 20 20 20 0a 3b 20 f. ).. .;
12f40 66 72 6f 6d 20 74 68 65 20 70 6b 74 73 20 72 65 from the pkts re
12f50 74 75 72 6e 20 73 65 72 76 65 72 73 20 61 73 73 turn servers ass
12f60 6f 63 69 61 74 65 64 20 77 69 74 68 20 64 62 70 ociated with dbp
12f70 61 74 68 0a 3b 3b 20 4e 4f 54 45 3a 20 4f 6e 6c ath.;; NOTE: Onl
12f80 79 20 6f 6e 65 20 63 61 6e 20 62 65 20 61 6c 69 y one can be ali
12f90 76 65 20 2d 20 68 61 76 65 20 74 6f 20 63 68 65 ve - have to che
12fa0 63 6b 20 6f 6e 20 65 61 63 68 0a 3b 3b 20 20 20 ck on each.;;
12fb0 20 20 20 20 69 6e 20 74 68 65 20 6c 69 73 74 20 in the list
12fc0 6f 66 20 70 6b 74 73 20 72 65 74 75 72 6e 65 64 of pkts returned
12fd0 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .;;.(define (get
12fe0 2d 76 69 61 62 6c 65 2d 73 65 72 76 65 72 73 20 -viable-servers
12ff0 73 65 72 76 2d 70 6b 74 73 20 64 62 70 61 74 68 serv-pkts dbpath
13000 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
13010 74 61 69 6c 20 73 65 72 76 2d 70 6b 74 73 29 0a tail serv-pkts).
13020 09 20 20 20 20 20 28 72 65 73 20 20 27 28 29 29 . (res '())
13030 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
13040 20 74 61 69 6c 29 0a 09 72 65 73 20 3b 3b 20 4e tail)..res ;; N
13050 4f 54 45 3a 20 73 6f 72 74 20 62 79 20 61 67 65 OTE: sort by age
13060 20 73 6f 20 6f 6c 64 65 73 74 20 69 73 20 63 6f so oldest is co
13070 6e 73 69 64 65 72 65 64 20 66 69 72 73 74 0a 09 nsidered first..
13080 28 6c 65 74 2a 20 28 28 73 70 6b 74 20 28 63 61 (let* ((spkt (ca
13090 72 20 74 61 69 6c 29 29 29 0a 09 20 20 28 6c 6f r tail))).. (lo
130a0 6f 70 20 28 63 64 72 20 74 61 69 6c 29 0a 09 09 op (cdr tail)...
130b0 28 69 66 20 28 65 71 75 61 6c 3f 20 64 62 70 61 (if (equal? dbpa
130c0 74 68 20 28 61 6c 69 73 74 2d 72 65 66 20 27 64 th (alist-ref 'd
130d0 62 70 61 74 68 20 73 70 6b 74 29 29 0a 09 09 20 bpath spkt))...
130e0 20 20 20 28 63 6f 6e 73 20 73 70 6b 74 20 72 65 (cons spkt re
130f0 73 29 0a 09 09 20 20 20 20 72 65 73 29 29 29 29 s)... res))))
13100 29 29 0a 0a 3b 3b 20 66 72 6f 6d 20 76 69 61 62 ))..;; from viab
13110 6c 65 20 73 65 72 76 65 72 73 20 67 65 74 20 6f le servers get o
13120 6e 65 20 74 68 61 74 20 69 73 20 61 6c 69 76 65 ne that is alive
13130 20 61 6e 64 20 72 65 61 64 79 0a 3b 3b 0a 28 64 and ready.;;.(d
13140 65 66 69 6e 65 20 28 67 65 74 2d 74 68 65 2d 73 efine (get-the-s
13150 65 72 76 65 72 20 61 70 61 74 68 20 73 65 72 76 erver apath serv
13160 2d 70 6b 74 73 29 0a 20 20 28 6c 65 74 20 6c 6f -pkts). (let lo
13170 6f 70 20 28 28 74 61 69 6c 20 73 65 72 76 2d 70 op ((tail serv-p
13180 6b 74 73 29 29 0a 20 20 20 20 28 69 66 20 28 6e kts)). (if (n
13190 75 6c 6c 3f 20 74 61 69 6c 29 0a 09 23 66 0a 09 ull? tail)..#f..
131a0 28 6c 65 74 2a 20 28 28 73 70 6b 74 20 20 28 63 (let* ((spkt (c
131b0 61 72 20 74 61 69 6c 29 29 0a 09 20 20 20 20 20 ar tail))..
131c0 20 20 28 68 6f 73 74 20 20 28 61 6c 69 73 74 2d (host (alist-
131d0 72 65 66 20 27 69 70 61 64 64 72 20 73 70 6b 74 ref 'ipaddr spkt
131e0 29 29 0a 09 20 20 20 20 20 20 20 28 70 6f 72 74 )).. (port
131f0 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f (alist-ref 'po
13200 72 74 20 73 70 6b 74 29 29 0a 09 20 20 20 20 20 rt spkt))..
13210 20 20 28 64 62 70 74 68 20 28 61 6c 69 73 74 2d (dbpth (alist-
13220 72 65 66 20 27 64 62 70 61 74 68 20 73 70 6b 74 ref 'dbpath spkt
13230 29 29 0a 09 20 20 20 20 20 20 20 28 61 64 64 72 )).. (addr
13240 20 20 28 73 65 72 76 65 72 2d 61 64 64 72 65 73 (server-addres
13250 73 20 73 70 6b 74 29 29 29 0a 09 20 20 28 69 66 s spkt))).. (if
13260 20 28 73 65 72 76 65 72 2d 72 65 61 64 79 3f 20 (server-ready?
13270 68 6f 73 74 20 70 6f 72 74 20 28 63 6f 6e 63 20 host port (conc
13280 61 70 61 74 68 22 2f 22 64 62 70 74 68 29 29 0a apath"/"dbpth)).
13290 09 20 20 20 20 20 20 73 70 6b 74 0a 09 20 20 20 . spkt..
132a0 20 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 74 61 (loop (cdr ta
132b0 69 6c 29 29 29 29 29 29 29 0a 0a 3b 3b 20 61 6d il)))))))..;; am
132c0 20 49 20 74 68 65 20 22 66 69 72 73 74 22 20 69 I the "first" i
132d0 6e 20 6c 69 6e 65 20 73 65 72 76 65 72 3f 20 49 n line server? I
132e0 2e 65 2e 20 6d 79 20 44 20 63 61 72 64 20 69 73 .e. my D card is
132f0 20 73 6d 61 6c 6c 65 73 74 0a 3b 3b 20 75 73 65 smallest.;; use
13300 20 5a 20 63 61 72 64 20 61 73 20 74 69 65 20 62 Z card as tie b
13310 72 65 61 6b 65 72 0a 3b 3b 0a 28 64 65 66 69 6e reaker.;;.(defin
13320 65 20 28 67 65 74 2d 62 65 73 74 2d 63 61 6e 64 e (get-best-cand
13330 69 64 61 74 65 20 73 65 72 76 2d 70 6b 74 73 20 idate serv-pkts
13340 64 62 70 61 74 68 29 0a 20 20 28 69 66 20 28 6e dbpath). (if (n
13350 75 6c 6c 3f 20 73 65 72 76 2d 70 6b 74 73 29 0a ull? serv-pkts).
13360 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
13370 6c 65 74 20 6c 6f 6f 70 20 28 28 74 61 69 6c 20 let loop ((tail
13380 73 65 72 76 2d 70 6b 74 73 29 0a 09 09 20 28 62 serv-pkts)... (b
13390 65 73 74 20 20 28 63 61 72 20 73 65 72 76 2d 70 est (car serv-p
133a0 6b 74 73 29 29 29 0a 09 28 69 66 20 28 6e 75 6c kts)))..(if (nul
133b0 6c 3f 20 74 61 69 6c 29 0a 09 20 20 20 20 62 65 l? tail).. be
133c0 73 74 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 st.. (let* ((
133d0 63 61 6e 64 69 64 61 74 65 20 28 63 61 72 20 74 candidate (car t
133e0 61 69 6c 29 29 0a 09 09 20 20 20 28 63 61 6e 64 ail))... (cand
133f0 69 64 61 74 65 2d 62 64 20 28 73 74 72 69 6e 67 idate-bd (string
13400 2d 3e 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 2d ->number (alist-
13410 72 65 66 20 27 44 20 63 61 6e 64 69 64 61 74 65 ref 'D candidate
13420 29 29 29 0a 09 09 20 20 20 28 62 65 73 74 2d 62 )))... (best-b
13430 64 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e d (string->
13440 6e 75 6d 62 65 72 20 28 61 6c 69 73 74 2d 72 65 number (alist-re
13450 66 20 27 44 20 62 65 73 74 29 29 29 0a 09 09 20 f 'D best)))...
13460 20 20 3b 3b 20 62 69 67 67 65 72 20 6e 75 6d 62 ;; bigger numb
13470 65 72 20 69 73 20 79 6f 75 6e 67 65 72 0a 09 09 er is younger...
13480 20 20 20 28 63 61 6e 64 69 64 61 74 65 2d 7a 20 (candidate-z
13490 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a 20 63 (alist-ref 'Z c
134a0 61 6e 64 69 64 61 74 65 29 29 0a 09 09 20 20 20 andidate))...
134b0 28 62 65 73 74 2d 7a 20 20 20 20 20 20 20 28 61 (best-z (a
134c0 6c 69 73 74 2d 72 65 66 20 27 5a 20 62 65 73 74 list-ref 'Z best
134d0 29 29 0a 09 09 20 20 20 28 6e 65 77 2d 62 65 73 ))... (new-bes
134e0 74 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 t (cond.....
134f0 20 20 28 28 3e 20 62 65 73 74 2d 62 64 20 63 61 ((> best-bd ca
13500 6e 64 69 64 61 74 65 2d 62 64 29 20 3b 3b 20 62 ndidate-bd) ;; b
13510 65 73 74 20 69 73 20 79 6f 75 6e 67 65 72 20 74 est is younger t
13520 68 61 6e 20 63 61 6e 64 69 64 61 74 65 0a 09 09 han candidate...
13530 09 09 20 20 20 63 61 6e 64 69 64 61 74 65 29 0a .. candidate).
13540 09 09 09 09 20 20 28 28 3c 20 62 65 73 74 2d 62 .... ((< best-b
13550 64 20 63 61 6e 64 69 64 61 74 65 2d 62 64 29 20 d candidate-bd)
13560 3b 3b 20 63 61 6e 64 69 64 61 74 65 20 69 73 20 ;; candidate is
13570 79 6f 75 6e 67 65 72 20 74 68 61 6e 20 62 65 73 younger than bes
13580 74 0a 09 09 09 09 20 20 20 62 65 73 74 29 0a 09 t..... best)..
13590 09 09 09 20 20 28 65 6c 73 65 0a 09 09 09 09 20 ... (else.....
135a0 20 20 28 69 66 20 28 73 74 72 69 6e 67 3e 3d 3f (if (string>=?
135b0 20 62 65 73 74 2d 7a 20 63 61 6e 64 69 64 61 74 best-z candidat
135c0 65 2d 7a 29 0a 09 09 09 09 20 20 20 20 20 20 20 e-z).....
135d0 62 65 73 74 0a 09 09 09 09 20 20 20 20 20 20 20 best.....
135e0 63 61 6e 64 69 64 61 74 65 29 29 29 29 29 20 3b candidate))))) ;
135f0 3b 20 75 73 65 20 5a 20 63 61 72 64 20 61 73 20 ; use Z card as
13600 74 69 65 20 62 72 65 61 6b 65 72 0a 09 20 20 20 tie breaker..
13610 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
13620 69 6c 29 0a 09 09 20 20 6e 65 77 2d 62 65 73 74 il)... new-best
13630 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 64 72 20 ... (loop (cdr
13640 74 61 69 6c 29 20 6e 65 77 2d 62 65 73 74 29 29 tail) new-best))
13650 29 29 29 29 29 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d ))))).. ..;;===
13660 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13670 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13680 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13690 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136a0 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4e 45 57 20 53 ===.;; END NEW S
136b0 45 52 56 45 52 20 4d 45 54 48 4f 44 0a 3b 3b 3d ERVER METHOD.;;=
136c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13700 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 66 20 2e 64 62 =====..;; if .db
13710 2f 6d 61 69 6e 2e 64 62 20 63 68 65 63 6b 20 74 /main.db check t
13720 68 65 20 70 6b 74 73 0a 3b 3b 20 0a 28 64 65 66 he pkts.;; .(def
13730 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
13740 6f 72 74 3a 77 61 69 74 2d 66 6f 72 2d 73 65 72 ort:wait-for-ser
13750 76 65 72 20 70 6b 74 73 2d 64 69 72 20 64 62 2d ver pkts-dir db-
13760 66 69 6c 65 20 73 65 72 76 65 72 2d 6b 65 79 29 file server-key)
13770 0a 20 20 28 6c 65 74 2a 20 28 28 73 64 61 74 20 . (let* ((sdat
13780 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 29 0a *server-info*)).
13790 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
137a0 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
137b0 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds))..
137c0 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 20 20 (changed
137d0 20 20 23 74 29 0a 09 20 20 20 20 20 20 20 28 6c #t).. (l
137e0 61 73 74 2d 73 64 61 74 20 20 22 6e 6f 74 20 74 ast-sdat "not t
137f0 68 69 73 22 29 29 0a 20 20 20 20 20 20 28 62 65 his")). (be
13800 67 69 6e 20 3b 3b 20 6c 65 74 20 28 28 73 64 61 gin ;; let ((sda
13810 74 20 23 66 29 29 0a 09 28 74 68 72 65 61 64 2d t #f))..(thread-
13820 73 6c 65 65 70 21 20 30 2e 30 31 29 0a 09 28 64 sleep! 0.01)..(d
13830 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13840 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
13850 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 66 6f ort* "Waiting fo
13860 72 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 r server alive s
13870 69 67 6e 61 74 75 72 65 22 29 0a 09 28 6d 75 74 ignature")..(mut
13880 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
13890 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 28 73 65 eat-mutex*)..(se
138a0 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
138b0 69 6e 66 6f 2a 29 0a 09 28 6d 75 74 65 78 2d 75 info*)..(mutex-u
138c0 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
138d0 74 2d 6d 75 74 65 78 2a 29 0a 09 28 69 66 20 28 t-mutex*)..(if (
138e0 61 6e 64 20 73 64 61 74 0a 09 09 20 28 6e 6f 74 and sdat... (not
138f0 20 63 68 61 6e 67 65 64 29 0a 09 09 20 28 3e 20 changed)... (>
13900 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
13910 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
13920 20 32 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 2)).. (begin
13930 0a 09 20 20 20 20 20 20 28 73 65 72 76 64 61 74 .. (servdat
13940 2d 73 74 61 74 75 73 2d 73 65 74 21 20 73 64 61 -status-set! sda
13950 74 20 27 69 66 61 63 65 2d 73 74 61 62 6c 65 29 t 'iface-stable)
13960 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
13970 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
13980 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
13990 52 65 63 65 69 76 65 64 20 73 65 72 76 65 72 20 Received server
139a0 61 6c 69 76 65 20 73 69 67 6e 61 74 75 72 65 2c alive signature,
139b0 20 6e 6f 77 20 61 74 74 65 6d 70 74 69 6e 67 20 now attempting
139c0 74 6f 20 6c 6f 63 6b 20 69 6e 20 73 65 72 76 65 to lock in serve
139d0 72 22 29 0a 09 20 20 20 20 20 20 3b 3b 20 63 72 r").. ;; cr
139e0 65 61 74 65 20 61 20 73 65 72 76 65 72 20 70 6b eate a server pk
139f0 74 20 69 6e 20 2a 74 6f 70 70 61 74 68 2a 2f 2e t in *toppath*/.
13a00 6d 65 74 61 2f 73 72 76 70 6b 74 73 0a 09 20 20 meta/srvpkts..
13a10 20 20 20 20 0a 09 20 20 20 20 20 20 3b 3b 20 54 .. ;; T
13a20 4f 44 4f 3a 0a 09 20 20 20 20 20 20 3b 3b 20 20 ODO:.. ;;
13a30 20 31 2e 20 63 68 61 6e 67 65 20 73 64 61 74 20 1. change sdat
13a40 74 6f 20 73 74 75 63 74 0a 09 20 20 20 20 20 20 to stuct..
13a50 3b 3b 20 20 20 32 2e 20 61 64 64 20 75 75 69 64 ;; 2. add uuid
13a60 20 74 6f 20 73 74 72 75 63 74 0a 09 20 20 20 20 to struct..
13a70 20 20 3b 3b 20 20 20 33 2e 20 75 70 64 61 74 65 ;; 3. update
13a80 20 75 75 69 64 20 69 6e 20 73 64 61 74 20 68 65 uuid in sdat he
13a90 72 65 0a 09 20 20 20 20 20 20 3b 3b 0a 09 20 20 re.. ;;..
13aa0 20 20 20 20 28 73 65 72 76 64 61 74 2d 75 75 69 (servdat-uui
13ab0 64 2d 73 65 74 21 20 73 64 61 74 0a 09 09 09 09 d-set! sdat.....
13ac0 20 28 72 65 67 69 73 74 65 72 2d 73 65 72 76 65 (register-serve
13ad0 72 0a 09 09 09 09 20 20 70 6b 74 73 2d 64 69 72 r..... pkts-dir
13ae0 20 2a 73 72 76 70 6b 74 73 70 65 63 2a 0a 09 09 *srvpktspec*...
13af0 09 09 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 .. (get-host-na
13b00 6d 65 29 0a 09 09 09 09 20 20 28 73 65 72 76 64 me)..... (servd
13b10 61 74 2d 70 6f 72 74 20 73 64 61 74 29 20 73 65 at-port sdat) se
13b20 72 76 65 72 2d 6b 65 79 0a 09 09 09 09 20 20 28 rver-key..... (
13b30 73 65 72 76 64 61 74 2d 68 6f 73 74 20 73 64 61 servdat-host sda
13b40 74 29 20 64 62 2d 66 69 6c 65 29 29 0a 09 20 20 t) db-file))..
13b50 20 20 20 20 0a 09 20 20 20 20 20 20 3b 3b 20 6e .. ;; n
13b60 6f 77 20 72 65 61 64 20 70 6b 74 73 20 61 6e 64 ow read pkts and
13b70 20 73 65 65 20 69 66 20 77 65 20 61 72 65 20 61 see if we are a
13b80 20 63 6f 6e 74 65 6e 64 65 72 0a 09 20 20 20 20 contender..
13b90 20 20 28 6c 65 74 2a 20 28 28 61 6c 6c 2d 70 6b (let* ((all-pk
13ba0 74 73 20 20 20 20 20 28 67 65 74 2d 61 6c 6c 2d ts (get-all-
13bb0 73 65 72 76 65 72 2d 70 6b 74 73 20 70 6b 74 73 server-pkts pkts
13bc0 2d 64 69 72 20 2a 73 72 76 70 6b 74 73 70 65 63 -dir *srvpktspec
13bd0 2a 29 29 0a 09 09 20 20 20 20 20 28 76 69 61 62 *))... (viab
13be0 6c 65 73 20 20 20 20 20 20 28 67 65 74 2d 76 69 les (get-vi
13bf0 61 62 6c 65 2d 73 65 72 76 65 72 73 20 61 6c 6c able-servers all
13c00 2d 70 6b 74 73 20 64 62 2d 66 69 6c 65 29 29 0a -pkts db-file)).
13c10 09 09 20 20 20 20 20 28 62 65 73 74 2d 73 72 76 .. (best-srv
13c20 20 20 20 20 20 28 67 65 74 2d 62 65 73 74 2d 63 (get-best-c
13c30 61 6e 64 69 64 61 74 65 20 76 69 61 62 6c 65 73 andidate viables
13c40 20 64 62 2d 66 69 6c 65 29 29 0a 09 09 20 20 20 db-file))...
13c50 20 20 28 62 65 73 74 2d 73 72 76 2d 6b 65 79 20 (best-srv-key
13c60 28 69 66 20 62 65 73 74 2d 73 72 76 20 28 61 6c (if best-srv (al
13c70 69 73 74 2d 72 65 66 20 27 73 65 72 76 6b 65 79 ist-ref 'servkey
13c80 20 62 65 73 74 2d 73 72 76 29 20 23 66 29 29 29 best-srv) #f)))
13c90 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
13ca0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
13cb0 6f 72 74 2a 20 22 62 65 73 74 2d 73 72 76 2d 6b ort* "best-srv-k
13cc0 65 79 3a 20 22 62 65 73 74 2d 73 72 76 2d 6b 65 ey: "best-srv-ke
13cd0 79 22 2c 20 73 65 72 76 65 72 2d 6b 65 79 3a 20 y", server-key:
13ce0 22 73 65 72 76 65 72 2d 6b 65 79 29 0a 09 09 3b "server-key)...;
13cf0 3b 20 61 6d 20 49 20 74 68 65 20 62 65 73 74 2d ; am I the best-
13d00 73 72 76 2c 20 63 6f 6d 70 61 72 65 20 73 65 72 srv, compare ser
13d10 76 65 72 2d 6b 65 79 73 20 74 6f 20 6b 6e 6f 77 ver-keys to know
13d20 0a 09 09 28 69 66 20 28 65 71 75 61 6c 3f 20 62 ...(if (equal? b
13d30 65 73 74 2d 73 72 76 2d 6b 65 79 20 73 65 72 76 est-srv-key serv
13d40 65 72 2d 6b 65 79 29 0a 09 09 20 20 20 20 28 69 er-key)... (i
13d50 66 20 28 67 65 74 2d 6c 6f 63 6b 2d 64 62 20 73 f (get-lock-db s
13d60 64 61 74 20 64 62 2d 66 69 6c 65 29 20 3b 3b 20 dat db-file) ;;
13d70 28 64 62 3a 67 65 74 2d 69 61 6d 2d 73 65 72 76 (db:get-iam-serv
13d80 65 72 2d 6c 6f 63 6b 20 2a 64 62 73 74 72 75 63 er-lock *dbstruc
13d90 74 2d 64 62 2a 20 2a 74 6f 70 70 61 74 68 2a 20 t-db* *toppath*
13da0 72 75 6e 2d 69 64 29 0a 09 09 09 28 62 65 67 69 run-id)....(begi
13db0 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 n.... (debug:pr
13dc0 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
13dd0 6f 67 2d 70 6f 72 74 2a 20 22 49 27 6d 20 74 68 og-port* "I'm th
13de0 65 20 73 65 72 76 65 72 21 22 29 0a 09 09 09 20 e server!")....
13df0 20 28 73 65 72 76 64 61 74 2d 64 62 66 69 6c 65 (servdat-dbfile
13e00 2d 73 65 74 21 20 73 64 61 74 20 64 62 2d 66 69 -set! sdat db-fi
13e10 6c 65 29 0a 09 09 09 20 20 28 73 65 72 76 64 61 le).... (servda
13e20 74 2d 73 74 61 74 75 73 2d 73 65 74 21 20 73 64 t-status-set! sd
13e30 61 74 20 27 64 62 2d 6c 6f 63 6b 65 64 29 29 0a at 'db-locked)).
13e40 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
13e50 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
13e60 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
13e70 20 22 49 27 6d 20 6e 6f 74 20 74 68 65 20 73 65 "I'm not the se
13e80 72 76 65 72 2c 20 65 78 69 74 69 6e 67 2e 22 29 rver, exiting.")
13e90 0a 09 09 09 20 20 28 62 64 61 74 2d 74 69 6d 65 .... (bdat-time
13ea0 2d 74 6f 2d 65 78 69 74 2d 73 65 74 21 20 2a 62 -to-exit-set! *b
13eb0 64 61 74 2a 20 23 74 29 0a 09 09 09 20 20 28 74 dat* #t).... (t
13ec0 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
13ed0 29 0a 09 09 09 20 20 28 65 78 69 74 29 29 29 0a ).... (exit))).
13ee0 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
13ef0 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
13f00 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
13f10 2d 70 6f 72 74 2a 0a 09 09 09 09 20 20 20 22 4b -port*..... "K
13f20 65 79 73 20 64 6f 20 6e 6f 74 20 6d 61 74 63 68 eys do not match
13f30 20 22 62 65 73 74 2d 73 72 76 2d 6b 65 79 22 2c "best-srv-key",
13f40 20 22 73 65 72 76 65 72 2d 6b 65 79 22 2c 20 65 "server-key", e
13f50 78 69 74 69 6e 67 2e 22 29 0a 09 09 20 20 20 20 xiting.")...
13f60 20 20 28 62 64 61 74 2d 74 69 6d 65 2d 74 6f 2d (bdat-time-to-
13f70 65 78 69 74 2d 73 65 74 21 20 2a 62 64 61 74 2a exit-set! *bdat*
13f80 20 23 74 29 0a 09 09 20 20 20 20 20 20 28 74 68 #t)... (th
13f90 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 29 read-sleep! 0.2)
13fa0 0a 09 09 20 20 20 20 20 20 28 65 78 69 74 29 29 ... (exit))
13fb0 29 0a 09 09 73 64 61 74 29 29 0a 09 20 20 20 20 )...sdat))..
13fc0 28 62 65 67 69 6e 20 3b 3b 20 73 64 61 74 20 6e (begin ;; sdat n
13fd0 6f 74 20 79 65 74 20 63 6f 6e 74 61 69 6e 73 20 ot yet contains
13fe0 73 65 72 76 65 72 20 69 6e 66 6f 0a 09 20 20 20 server info..
13ff0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
14000 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
14010 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 69 6c 6c log-port* "Still
14020 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 74 2d 73 waiting, last-s
14030 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 61 74 29 dat=" last-sdat)
14040 0a 09 20 20 20 20 20 20 28 73 6c 65 65 70 20 34 .. (sleep 4
14050 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
14060 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
14070 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
14080 20 31 32 30 29 20 3b 3b 20 62 65 65 6e 20 77 61 120) ;; been wa
14090 69 74 69 6e 67 20 66 6f 72 20 74 77 6f 20 6d 69 iting for two mi
140a0 6e 75 74 65 73 0a 09 09 20 20 28 62 65 67 69 6e nutes... (begin
140b0 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
140c0 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
140d0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
140e0 74 72 61 6e 73 70 6f 72 74 20 61 70 70 65 61 72 transport appear
140f0 73 20 74 6f 20 68 61 76 65 20 64 69 65 64 2c 20 s to have died,
14100 65 78 69 74 69 6e 67 20 73 65 72 76 65 72 22 29 exiting server")
14110 0a 09 09 20 20 20 20 28 65 78 69 74 29 29 0a 09 ... (exit))..
14120 09 20 20 28 6c 6f 6f 70 20 73 74 61 72 74 2d 74 . (loop start-t
14130 69 6d 65 0a 09 09 09 28 65 71 75 61 6c 3f 20 73 ime....(equal? s
14140 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 0a 09 dat last-sdat)..
14150 09 09 73 64 61 74 29 29 29 29 29 29 29 29 0a 0a ..sdat))))))))..
14160 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 (define (rmt:reg
14170 69 73 74 65 72 2d 73 65 72 76 65 72 20 72 65 6d ister-server rem
14180 6f 74 65 20 61 70 61 74 68 20 69 66 61 63 65 20 ote apath iface
14190 70 6f 72 74 20 73 65 72 76 65 72 2d 6b 65 79 20 port server-key
141a0 64 62 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 6f dbname). (rmt:o
141b0 70 65 6e 2d 6d 61 69 6e 2d 63 6f 6e 6e 65 63 74 pen-main-connect
141c0 69 6f 6e 20 72 65 6d 6f 74 65 20 61 70 61 74 68 ion remote apath
141d0 29 20 3b 3b 20 77 65 20 6e 65 65 64 20 61 20 63 ) ;; we need a c
141e0 68 61 6e 6e 65 6c 20 74 6f 20 6d 61 69 6e 2e 64 hannel to main.d
141f0 62 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 b. (rmt:send-re
14200 63 65 69 76 65 2d 72 65 61 6c 20 72 65 6d 6f 74 ceive-real remot
14210 65 20 61 70 61 74 68 20 3b 3b 20 70 61 72 61 6d e apath ;; param
14220 73 3a 20 68 6f 73 74 20 70 6f 72 74 20 73 65 72 s: host port ser
14230 76 6b 65 79 20 70 69 64 20 69 70 61 64 64 72 20 vkey pid ipaddr
14240 64 62 70 61 74 68 0a 09 09 09 20 28 64 62 3a 72 dbpath.... (db:r
14250 75 6e 2d 69 64 2d 3e 64 62 6e 61 6d 65 20 23 66 un-id->dbname #f
14260 29 20 27 72 65 67 69 73 74 65 72 2d 73 65 72 76 ) 'register-serv
14270 65 72 20 60 28 2c 69 66 61 63 65 0a 09 09 09 09 er `(,iface.....
14280 09 09 09 09 20 20 20 2c 70 6f 72 74 0a 09 09 09 .... ,port....
14290 09 09 09 09 09 20 20 20 2c 73 65 72 76 65 72 2d ..... ,server-
142a0 6b 65 79 0a 09 09 09 09 09 09 09 09 20 20 20 2c key......... ,
142b0 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
142c0 2d 69 64 29 0a 09 09 09 09 09 09 09 09 20 20 20 -id).........
142d0 2c 69 66 61 63 65 0a 09 09 09 09 09 09 09 09 20 ,iface.........
142e0 20 20 2c 61 70 61 74 68 0a 09 09 09 09 09 09 09 ,apath........
142f0 09 20 20 20 2c 64 62 6e 61 6d 65 29 29 29 0a 0a . ,dbname)))..
14300 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
14310 61 6e 73 70 6f 72 74 3a 77 61 69 74 2d 66 6f 72 ansport:wait-for
14320 2d 73 74 61 62 6c 65 2d 69 6e 74 65 72 66 61 63 -stable-interfac
14330 65 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 6e 75 e #!optional (nu
14340 6d 2d 74 72 69 65 73 2d 61 6c 6c 6f 77 65 64 20 m-tries-allowed
14350 31 30 30 29 29 0a 20 20 3b 3b 20 77 61 69 74 20 100)). ;; wait
14360 75 6e 74 69 6c 20 2a 73 65 72 76 65 72 2d 69 6e until *server-in
14370 66 6f 2a 20 73 74 6f 70 73 20 63 68 61 6e 67 69 fo* stops changi
14380 6e 67 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 69 ng. (let* ((sti
14390 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
143a0 6e 64 73 29 29 29 0a 20 20 20 20 28 6c 65 74 20 nds))). (let
143b0 6c 6f 6f 70 20 28 28 6c 61 73 74 2d 68 6f 73 74 loop ((last-host
143c0 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 6c #f).. (l
143d0 61 73 74 2d 70 6f 72 74 20 20 23 66 29 0a 09 20 ast-port #f)..
143e0 20 20 20 20 20 20 28 74 72 69 65 73 20 30 29 29 (tries 0))
143f0 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 . (let* ((c
14400 75 72 72 2d 68 6f 73 74 20 28 61 6e 64 20 2a 73 urr-host (and *s
14410 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 73 65 72 erver-info* (ser
14420 76 64 61 74 2d 68 6f 73 74 20 2a 73 65 72 76 65 vdat-host *serve
14430 72 2d 69 6e 66 6f 2a 29 29 29 0a 09 20 20 20 20 r-info*)))..
14440 20 28 63 75 72 72 2d 70 6f 72 74 20 28 61 6e 64 (curr-port (and
14450 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 *server-info* (
14460 73 65 72 76 64 61 74 2d 70 6f 72 74 20 2a 73 65 servdat-port *se
14470 72 76 65 72 2d 69 6e 66 6f 2a 29 29 29 29 0a 09 rver-info*))))..
14480 3b 3b 20 66 69 72 73 74 20 77 65 20 76 65 72 69 ;; first we veri
14490 66 79 20 70 6f 72 74 20 61 6e 64 20 69 6e 74 65 fy port and inte
144a0 72 66 61 63 65 2c 20 75 70 64 61 74 65 20 2a 73 rface, update *s
144b0 65 72 76 65 72 2d 69 6e 66 6f 2a 20 69 6e 20 6e erver-info* in n
144c0 65 65 64 20 62 65 2e 0a 09 28 63 6f 6e 64 0a 09 eed be...(cond..
144d0 20 28 28 3e 20 74 72 69 65 73 20 6e 75 6d 2d 74 ((> tries num-t
144e0 72 69 65 73 2d 61 6c 6c 6f 77 65 64 29 0a 09 20 ries-allowed)..
144f0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
14500 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14510 74 2a 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f t* "http-transpo
14520 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 2c rt:keep-running,
14530 20 67 69 76 69 6e 67 20 75 70 20 61 66 74 65 72 giving up after
14540 20 74 72 79 69 6e 67 20 66 6f 72 20 73 65 76 65 trying for seve
14550 72 61 6c 20 6d 69 6e 75 74 65 73 2e 22 29 0a 09 ral minutes.")..
14560 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 28 28 (exit 1)).. ((
14570 6e 6f 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f not *server-info
14580 2a 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c *).. (thread-sl
14590 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 6c eep! 0.25).. (l
145a0 6f 6f 70 20 63 75 72 72 2d 68 6f 73 74 20 63 75 oop curr-host cu
145b0 72 72 2d 70 6f 72 74 20 28 2b 20 74 72 69 65 73 rr-port (+ tries
145c0 20 31 29 29 29 0a 09 20 28 28 6f 72 20 28 6e 6f 1))).. ((or (no
145d0 74 20 6c 61 73 74 2d 68 6f 73 74 29 28 6e 6f 74 t last-host)(not
145e0 20 6c 61 73 74 2d 70 6f 72 74 29 29 0a 09 20 20 last-port))..
145f0 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
14600 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
14610 2a 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 * "http-transpor
14620 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 2c 20 t:keep-running,
14630 73 74 69 6c 6c 20 6e 6f 20 69 6e 74 65 72 66 61 still no interfa
14640 63 65 2c 20 74 72 69 65 73 3d 22 74 72 69 65 73 ce, tries="tries
14650 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ).. (thread-sle
14660 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 6c 6f ep! 0.25).. (lo
14670 6f 70 20 63 75 72 72 2d 68 6f 73 74 20 63 75 72 op curr-host cur
14680 72 2d 70 6f 72 74 20 28 2b 20 74 72 69 65 73 20 r-port (+ tries
14690 31 29 29 29 0a 09 20 28 28 6f 72 20 28 6e 6f 74 1))).. ((or (not
146a0 20 28 65 71 75 61 6c 3f 20 6c 61 73 74 2d 68 6f (equal? last-ho
146b0 73 74 20 63 75 72 72 2d 68 6f 73 74 29 29 0a 09 st curr-host))..
146c0 20 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 (not (equa
146d0 6c 3f 20 6c 61 73 74 2d 70 6f 72 74 20 63 75 72 l? last-port cur
146e0 72 2d 70 6f 72 74 29 29 29 0a 09 20 20 28 64 65 r-port))).. (de
146f0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
14700 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14710 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 69 6e rt* "WARNING: in
14720 74 65 72 66 61 63 65 20 63 68 61 6e 67 65 64 2c terface changed,
14730 20 72 65 66 72 65 73 68 69 6e 67 20 69 66 61 63 refreshing ifac
14740 65 20 61 6e 64 20 70 6f 72 74 20 69 6e 66 6f 22 e and port info"
14750 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ).. (thread-sle
14760 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 6c 6f ep! 0.25).. (lo
14770 6f 70 20 63 75 72 72 2d 68 6f 73 74 20 63 75 72 op curr-host cur
14780 72 2d 70 6f 72 74 20 28 2b 20 74 72 69 65 73 20 r-port (+ tries
14790 31 29 29 29 0a 09 20 28 28 3c 20 28 2d 20 28 63 1))).. ((< (- (c
147a0 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
147b0 73 74 69 6d 65 29 20 31 29 20 3b 3b 20 6b 65 65 stime) 1) ;; kee
147c0 70 20 75 70 20 74 68 65 20 6c 6f 6f 70 69 6e 67 p up the looping
147d0 20 75 6e 74 69 6c 20 61 74 20 6c 65 61 73 74 20 until at least
147e0 33 20 73 65 63 6f 6e 64 73 20 68 61 76 65 20 70 3 seconds have p
147f0 61 73 73 65 64 0a 09 20 20 28 74 68 72 65 61 64 assed.. (thread
14800 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a 09 20 20 -sleep! 0.5)..
14810 28 6c 6f 6f 70 20 63 75 72 72 2d 68 6f 73 74 20 (loop curr-host
14820 63 75 72 72 2d 70 6f 72 74 20 28 2b 20 74 72 69 curr-port (+ tri
14830 65 73 20 31 29 29 29 0a 09 20 28 65 6c 73 65 0a es 1))).. (else.
14840 09 20 20 28 69 66 20 28 6e 6f 74 20 2a 73 65 72 . (if (not *ser
14850 76 65 72 2d 69 64 2a 29 28 73 65 74 21 20 2a 73 ver-id*)(set! *s
14860 65 72 76 65 72 2d 69 64 2a 20 28 73 65 72 76 65 erver-id* (serve
14870 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 r:mk-signature))
14880 29 0a 09 20 20 28 73 65 72 76 64 61 74 2d 73 74 ).. (servdat-st
14890 61 74 75 73 2d 73 65 74 21 20 2a 73 65 72 76 65 atus-set! *serve
148a0 72 2d 69 6e 66 6f 2a 20 27 69 6e 74 65 72 66 61 r-info* 'interfa
148b0 63 65 2d 73 74 61 62 6c 65 29 0a 09 20 20 28 64 ce-stable).. (d
148c0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
148d0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a fault-log-port*.
148e0 09 09 20 20 20 20 20 20 20 22 53 45 52 56 45 52 .. "SERVER
148f0 20 53 54 41 52 54 45 44 3a 20 22 20 63 75 72 72 STARTED: " curr
14900 2d 68 6f 73 74 0a 09 09 20 20 20 20 20 20 20 22 -host... "
14910 3a 22 20 63 75 72 72 2d 70 6f 72 74 0a 09 09 20 :" curr-port...
14920 20 20 20 20 20 20 22 20 41 54 20 22 20 28 63 75 " AT " (cu
14930 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 22 rrent-seconds) "
14940 20 73 65 72 76 65 72 2d 69 64 3a 20 22 20 2a 73 server-id: " *s
14950 65 72 76 65 72 2d 69 64 2a 0a 09 09 20 20 20 20 erver-id*...
14960 20 20 20 22 20 77 69 74 68 20 22 28 73 65 72 76 " with "(serv
14970 64 61 74 2d 74 72 79 6e 75 6d 20 2a 73 65 72 76 dat-trynum *serv
14980 65 72 2d 69 6e 66 6f 2a 29 22 20 70 6f 72 74 20 er-info*)" port
14990 63 68 61 6e 67 65 73 22 29 0a 09 20 20 28 66 6c changes").. (fl
149a0 75 73 68 2d 6f 75 74 70 75 74 20 2a 64 65 66 61 ush-output *defa
149b0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 ult-log-port*)..
149c0 20 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b 20 72 #t))))))..;; r
149d0 75 6e 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 un http-transpor
149e0 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 t:keep-running i
149f0 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 n a parallel thr
14a00 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 ead to monitor t
14a10 68 61 74 20 74 68 65 20 64 62 20 69 73 20 62 65 hat the db is be
14a20 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 ing .;; used and
14a30 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 61 66 74 to shutdown aft
14a40 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 er sometime if i
14a50 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 t is not..;;.(de
14a60 66 69 6e 65 20 28 72 6d 74 3a 6b 65 65 70 2d 72 fine (rmt:keep-r
14a70 75 6e 6e 69 6e 67 20 64 62 6e 61 6d 65 29 20 0a unning dbname) .
14a80 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e ;; if none run
14a90 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 ning or if > 20
14aa0 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 seconds since .
14ab0 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 ;; server last
14ac0 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 used then start
14ad0 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 shutdown. ;; Th
14ae0 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 is thread waits
14af0 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 for the server t
14b00 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 o come alive. (
14b10 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
14b20 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
14b30 70 6f 72 74 2a 20 22 53 74 61 72 74 69 6e 67 20 port* "Starting
14b40 74 68 65 20 73 79 6e 63 2d 62 61 63 6b 2c 20 6b the sync-back, k
14b50 65 65 70 20 61 6c 69 76 65 20 74 68 72 65 61 64 eep alive thread
14b60 20 69 6e 20 73 65 72 76 65 72 22 29 0a 0a 20 20 in server")..
14b70 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 73 (let* ((server-s
14b80 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
14b90 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 nt-seconds)).. (
14ba0 70 6b 74 73 2d 64 69 72 20 20 20 20 20 20 20 20 pkts-dir
14bb0 20 20 28 67 65 74 2d 70 6b 74 73 2d 64 69 72 29 (get-pkts-dir)
14bc0 29 0a 09 20 28 73 65 72 76 65 72 2d 6b 65 79 20 ).. (server-key
14bd0 20 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 6d (server:m
14be0 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 0a 09 20 k-signature))..
14bf0 28 69 73 2d 6d 61 69 6e 20 20 20 20 20 20 20 20 (is-main
14c00 20 20 20 28 65 71 75 61 6c 3f 20 28 61 72 67 73 (equal? (args
14c10 3a 67 65 74 2d 61 72 67 20 22 2d 64 62 22 29 20 :get-arg "-db")
14c20 22 2e 64 62 2f 6d 61 69 6e 2e 64 62 22 29 29 0a ".db/main.db")).
14c30 09 20 28 6c 61 73 74 2d 61 63 63 65 73 73 20 20 . (last-access
14c40 20 20 20 20 20 30 29 0a 09 20 28 73 65 72 76 65 0).. (serve
14c50 72 2d 74 69 6d 65 6f 75 74 20 20 20 20 28 73 65 r-timeout (se
14c60 72 76 65 72 3a 65 78 70 69 72 61 74 69 6f 6e 2d rver:expiration-
14c70 74 69 6d 65 6f 75 74 29 29 29 0a 20 20 20 20 3b timeout))). ;
14c80 3b 20 6d 61 69 6e 20 61 6e 64 20 72 75 6e 20 64 ; main and run d
14c90 62 20 73 65 72 76 65 72 73 20 68 61 76 65 20 62 b servers have b
14ca0 6f 74 68 20 67 6f 74 20 77 61 69 74 20 6c 6f 67 oth got wait log
14cb0 69 63 20 28 63 6f 75 6c 64 2f 73 68 6f 75 6c 64 ic (could/should
14cc0 20 6d 65 72 67 65 20 69 74 29 0a 20 20 20 20 28 merge it). (
14cd0 69 66 20 69 73 2d 6d 61 69 6e 0a 09 28 68 74 74 if is-main..(htt
14ce0 70 2d 74 72 61 6e 73 70 6f 72 74 3a 77 61 69 74 p-transport:wait
14cf0 2d 66 6f 72 2d 73 65 72 76 65 72 20 70 6b 74 73 -for-server pkts
14d00 2d 64 69 72 20 64 62 6e 61 6d 65 20 73 65 72 76 -dir dbname serv
14d10 65 72 2d 6b 65 79 29 0a 09 28 68 74 74 70 2d 74 er-key)..(http-t
14d20 72 61 6e 73 70 6f 72 74 3a 77 61 69 74 2d 66 6f ransport:wait-fo
14d30 72 2d 73 74 61 62 6c 65 2d 69 6e 74 65 72 66 61 r-stable-interfa
14d40 63 65 29 29 0a 20 20 20 20 3b 3b 20 74 68 69 73 ce)). ;; this
14d50 20 69 73 20 6f 75 72 20 66 6f 72 65 76 65 72 20 is our forever
14d60 6c 6f 6f 70 0a 20 20 20 20 28 6c 65 74 2a 20 28 loop. (let* (
14d70 28 69 66 61 63 65 20 20 20 20 20 20 20 20 20 20 (iface
14d80 20 20 20 28 73 65 72 76 64 61 74 2d 68 6f 73 74 (servdat-host
14d90 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 29 *server-info*))
14da0 0a 09 20 20 20 28 70 6f 72 74 20 20 20 20 20 20 .. (port
14db0 20 20 20 20 20 20 20 20 28 73 65 72 76 64 61 74 (servdat
14dc0 2d 70 6f 72 74 20 2a 73 65 72 76 65 72 2d 69 6e -port *server-in
14dd0 66 6f 2a 29 29 29 0a 20 20 20 20 20 20 28 6c 65 fo*))). (le
14de0 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 t loop ((count
14df0 20 20 20 20 20 20 20 30 29 0a 09 09 20 28 62 61 0)... (ba
14e00 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 0a d-sync-count 0).
14e10 09 09 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 .. (start-time
14e20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (current-mill
14e30 69 73 65 63 6f 6e 64 73 29 29 29 0a 09 0a 09 28 iseconds)))....(
14e40 69 66 20 28 6e 6f 74 20 69 73 2d 6d 61 69 6e 29 if (not is-main)
14e50 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
14e60 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
14e70 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 lt-log-port* "se
14e80 72 76 64 61 74 2d 73 74 61 74 75 73 20 69 73 20 rvdat-status is
14e90 22 20 28 73 65 72 76 64 61 74 2d 73 74 61 74 75 " (servdat-statu
14ea0 73 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 s *server-info*)
14eb0 29 29 0a 0a 09 3b 3b 20 73 65 74 20 75 70 20 74 ))...;; set up t
14ec0 68 65 20 64 61 74 61 62 61 73 65 20 68 61 6e 64 he database hand
14ed0 6c 65 0a 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 le..(mutex-lock!
14ee0 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
14ef0 78 2a 29 0a 09 28 69 66 20 28 6e 6f 74 20 2a 64 x*)..(if (not *d
14f00 62 73 74 72 75 63 74 2d 64 62 2a 29 20 3b 3b 20 bstruct-db*) ;;
14f10 6e 6f 20 64 62 20 6f 70 65 6e 65 64 20 79 65 74 no db opened yet
14f20 2c 20 6f 70 65 6e 20 74 68 65 20 64 62 20 61 6e , open the db an
14f30 64 20 72 65 67 69 73 74 65 72 20 77 69 74 68 20 d register with
14f40 6d 61 69 6e 20 69 66 20 61 70 70 72 6f 70 72 69 main if appropri
14f50 61 74 65 0a 09 20 20 20 20 28 6c 65 74 20 28 28 ate.. (let ((
14f60 77 61 74 63 68 64 6f 67 20 28 62 64 61 74 2d 77 watchdog (bdat-w
14f70 61 74 63 68 64 6f 67 20 2a 62 64 61 74 2a 29 29 atchdog *bdat*))
14f80 29 09 09 20 0a 09 20 20 20 20 20 20 28 64 65 62 ).. .. (deb
14f90 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
14fa0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
14fb0 45 52 56 45 52 3a 20 64 62 70 72 65 70 22 29 0a ERVER: dbprep").
14fc0 09 20 20 20 20 20 20 28 64 62 3a 73 65 74 75 70 . (db:setup
14fd0 20 64 62 6e 61 6d 65 29 20 3b 3b 20 73 65 74 73 dbname) ;; sets
14fe0 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 61 *dbstruct-db* a
14ff0 73 20 73 69 64 65 20 65 66 66 65 63 74 0a 09 20 s side effect..
15000 20 20 20 20 20 28 73 65 72 76 64 61 74 2d 73 74 (servdat-st
15010 61 74 75 73 2d 73 65 74 21 20 2a 73 65 72 76 65 atus-set! *serve
15020 72 2d 69 6e 66 6f 2a 20 27 64 62 2d 6f 70 65 6e r-info* 'db-open
15030 65 64 29 0a 09 20 20 20 20 20 20 3b 3b 20 49 46 ed).. ;; IF
15040 46 20 49 27 6d 20 6e 6f 74 20 6d 61 69 6e 2c 20 F I'm not main,
15050 63 61 6c 6c 20 69 6e 74 6f 20 6d 61 69 6e 20 61 call into main a
15060 6e 64 20 72 65 67 69 73 74 65 72 20 73 65 6c 66 nd register self
15070 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 .. (if (not
15080 20 69 73 2d 6d 61 69 6e 29 0a 09 09 20 20 28 6c is-main)... (l
15090 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 72 65 et ((res (rmt:re
150a0 67 69 73 74 65 72 2d 73 65 72 76 65 72 20 2a 72 gister-server *r
150b0 6d 74 3a 72 65 6d 6f 74 65 2a 0a 09 09 09 09 09 mt:remote*......
150c0 09 20 20 2a 74 6f 70 70 61 74 68 2a 20 69 66 61 . *toppath* ifa
150d0 63 65 20 70 6f 72 74 0a 09 09 09 09 09 09 20 20 ce port.......
150e0 73 65 72 76 65 72 2d 6b 65 79 20 64 62 6e 61 6d server-key dbnam
150f0 65 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 72 e)))... (if r
15100 65 73 20 3b 3b 20 77 65 20 61 72 65 20 74 68 65 es ;; we are the
15110 20 73 65 72 76 65 72 0a 09 09 09 28 73 65 72 76 server....(serv
15120 64 61 74 2d 73 74 61 74 75 73 2d 73 65 74 21 20 dat-status-set!
15130 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 27 68 *server-info* 'h
15140 61 76 65 2d 69 6e 74 65 72 66 61 63 65 2d 61 6e ave-interface-an
15150 64 2d 64 62 29 0a 09 09 09 28 62 65 67 69 6e 20 d-db)....(begin
15160 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
15170 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
15180 67 2d 70 6f 72 74 2a 20 22 57 65 20 61 72 65 20 g-port* "We are
15190 6e 6f 74 20 74 68 65 20 73 65 72 76 65 72 20 66 not the server f
151a0 6f 72 20 22 64 62 6e 61 6d 65 22 2c 20 65 78 69 or "dbname", exi
151b0 74 69 6e 67 2e 22 29 0a 09 09 09 20 20 28 65 78 ting.").... (ex
151c0 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 it))))).. (
151d0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
151e0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
151f0 0a 09 09 09 20 20 20 22 53 45 52 56 45 52 3a 20 .... "SERVER:
15200 72 75 6e 6e 69 6e 67 2c 20 64 62 20 22 64 62 6e running, db "dbn
15210 61 6d 65 22 20 6f 70 65 6e 65 64 2c 20 6d 65 67 ame" opened, meg
15220 61 74 65 73 74 20 76 65 72 73 69 6f 6e 3a 20 22 atest version: "
15230 0a 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 .... (common:g
15240 65 74 2d 66 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 et-full-version)
15250 29 0a 09 20 20 20 20 20 20 3b 3b 20 73 74 61 72 ).. ;; star
15260 74 20 74 68 65 20 77 61 74 63 68 64 6f 67 0a 09 t the watchdog..
15270 20 20 20 20 20 20 28 69 66 20 77 61 74 63 68 64 (if watchd
15280 6f 67 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 og... (if (not
15290 28 6d 65 6d 62 65 72 20 28 74 68 72 65 61 64 2d (member (thread-
152a0 73 74 61 74 65 20 77 61 74 63 68 64 6f 67 29 0a state watchdog).
152b0 09 09 09 09 20 20 20 27 28 72 65 61 64 79 20 72 .... '(ready r
152c0 75 6e 6e 69 6e 67 20 62 6c 6f 63 6b 65 64 0a 09 unning blocked..
152d0 09 09 09 09 20 20 20 73 6c 65 65 70 69 6e 67 20 .... sleeping
152e0 64 65 61 64 29 29 29 0a 09 09 20 20 20 20 20 20 dead)))...
152f0 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 (begin....(debug
15300 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
15310 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
15320 20 22 53 74 61 72 74 69 6e 67 20 77 61 74 63 68 "Starting watch
15330 64 6f 67 20 74 68 72 65 61 64 20 28 69 6e 20 73 dog thread (in s
15340 74 61 74 65 20 22 28 74 68 72 65 61 64 2d 73 74 tate "(thread-st
15350 61 74 65 20 77 61 74 63 68 64 6f 67 29 22 29 22 ate watchdog)")"
15360 29 0a 09 09 09 28 74 68 72 65 61 64 2d 73 74 61 )....(thread-sta
15370 72 74 21 20 77 61 74 63 68 64 6f 67 29 29 0a 09 rt! watchdog))..
15380 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
15390 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
153a0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e ult-log-port* "N
153b0 6f 74 20 73 74 61 72 74 69 6e 67 20 77 61 74 63 ot starting watc
153c0 68 64 6f 67 20 74 68 72 65 61 64 20 28 69 6e 20 hdog thread (in
153d0 73 74 61 74 65 20 22 28 74 68 72 65 61 64 2d 73 state "(thread-s
153e0 74 61 74 65 20 77 61 74 63 68 64 6f 67 29 22 29 tate watchdog)")
153f0 22 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 "))... (debug:p
15400 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
15410 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
15420 3a 20 2a 77 61 74 63 68 64 6f 67 2a 20 6e 6f 74 : *watchdog* not
15430 20 73 65 74 75 70 2c 20 63 61 6e 6e 6f 74 20 73 setup, cannot s
15440 74 61 72 74 20 69 74 2e 22 29 29 0a 09 20 20 20 tart it."))..
15450 20 20 20 23 3b 28 6c 6f 6f 70 20 28 2b 20 63 6f #;(loop (+ co
15460 75 6e 74 20 31 29 20 62 61 64 2d 73 79 6e 63 2d unt 1) bad-sync-
15470 63 6f 75 6e 74 20 73 74 61 72 74 2d 74 69 6d 65 count start-time
15480 29 29 29 0a 09 28 6d 75 74 65 78 2d 75 6e 6c 6f )))..(mutex-unlo
15490 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
154a0 75 74 65 78 2a 29 0a 09 0a 09 3b 3b 20 77 68 65 utex*)....;; whe
154b0 6e 20 74 68 69 6e 67 73 20 67 6f 20 77 72 6f 6e n things go wron
154c0 67 20 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 g we don't want
154d0 74 6f 20 62 65 20 64 6f 69 6e 67 20 74 68 65 20 to be doing the
154e0 76 61 72 69 6f 75 73 0a 09 3b 3b 20 71 75 65 72 various..;; quer
154f0 69 65 73 20 74 6f 6f 20 6f 66 74 65 6e 20 73 6f ies too often so
15500 20 77 65 20 73 74 72 69 76 65 20 74 6f 20 72 75 we strive to ru
15510 6e 20 74 68 69 73 20 73 74 75 66 66 20 6f 6e 6c n this stuff onl
15520 79 20 65 76 65 72 79 0a 09 3b 3b 20 66 6f 75 72 y every..;; four
15530 20 73 65 63 6f 6e 64 73 20 6f 72 20 73 6f 2e 0a seconds or so..
15540 09 28 6c 65 74 2a 20 28 28 73 79 6e 63 2d 74 69 .(let* ((sync-ti
15550 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d me (- (current-m
15560 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 illiseconds) sta
15570 72 74 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 20 rt-time))..
15580 20 20 28 72 65 6d 2d 74 69 6d 65 20 20 28 71 75 (rem-time (qu
15590 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 30 20 73 otient (- 4000 s
155a0 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 30 29 29 ync-time) 1000))
155b0 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 3c ).. (if (and (<
155c0 3d 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 09 = rem-time 4)...
155d0 20 20 20 28 3e 20 20 72 65 6d 2d 74 69 6d 65 20 (> rem-time
155e0 30 29 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 0)).. (thre
155f0 61 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 ad-sleep! rem-ti
15600 6d 65 29 29 29 0a 09 0a 09 28 69 66 20 28 3c 20 me)))....(if (<
15610 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 78 33 20 count 1) ;; 3x3
15620 3d 20 39 20 73 65 63 73 20 61 70 72 6f 78 0a 09 = 9 secs aprox..
15630 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 (loop (+ cou
15640 6e 74 20 31 29 20 62 61 64 2d 73 79 6e 63 2d 63 nt 1) bad-sync-c
15650 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 ount (current-mi
15660 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 09 0a lliseconds)))...
15670 09 3b 3b 20 54 72 61 6e 73 66 65 72 20 2a 64 62 .;; Transfer *db
15680 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 74 6f -last-access* to
15690 20 6c 61 73 74 2d 61 63 63 65 73 73 20 74 6f 20 last-access to
156a0 75 73 65 20 69 6e 20 63 68 65 63 6b 69 6e 67 20 use in checking
156b0 74 68 61 74 20 77 65 20 61 72 65 20 73 74 69 6c that we are stil
156c0 6c 20 61 6c 69 76 65 0a 09 28 73 65 74 21 20 6c l alive..(set! l
156d0 61 73 74 2d 61 63 63 65 73 73 20 2a 64 62 2d 6c ast-access *db-l
156e0 61 73 74 2d 61 63 63 65 73 73 2a 29 0a 09 0a 09 ast-access*)....
156f0 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
15700 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 noise-print 60 "
15710 64 62 73 74 61 74 73 22 29 0a 09 20 20 20 20 28 dbstats").. (
15720 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
15730 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
15740 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
15750 53 65 72 76 65 72 20 73 74 61 74 73 3a 22 29 0a Server stats:").
15760 09 20 20 20 20 20 20 28 64 62 3a 70 72 69 6e 74 . (db:print
15770 2d 63 75 72 72 65 6e 74 2d 71 75 65 72 79 2d 73 -current-query-s
15780 74 61 74 73 29 29 29 0a 09 28 6c 65 74 2a 20 28 tats)))..(let* (
15790 28 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 (hrs-since-start
157a0 20 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 (/ (- (current
157b0 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 -seconds) server
157c0 2d 73 74 61 72 74 2d 74 69 6d 65 29 20 33 36 30 -start-time) 360
157d0 30 29 29 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 0))).. (cond..
157e0 20 20 28 28 61 6e 64 20 2a 73 65 72 76 65 72 2d ((and *server-
157f0 72 75 6e 2a 0a 09 09 20 28 3e 20 28 2b 20 6c 61 run*... (> (+ la
15800 73 74 2d 61 63 63 65 73 73 20 73 65 72 76 65 72 st-access server
15810 2d 74 69 6d 65 6f 75 74 29 0a 09 09 20 20 20 20 -timeout)...
15820 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
15830 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 63 6f ))).. (if (co
15840 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
15850 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 72 rint 120 "server
15860 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 09 continuing")...
15870 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
15880 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
15890 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 63 -port* "Server c
158a0 6f 6e 74 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e ontinuing, secon
158b0 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 64 62 ds since last db
158c0 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 28 63 access: " (- (c
158d0 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
158e0 6c 61 73 74 2d 61 63 63 65 73 73 29 29 29 0a 09 last-access)))..
158f0 20 20 20 20 28 6c 6f 6f 70 20 30 20 62 61 64 2d (loop 0 bad-
15900 73 79 6e 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 sync-count (curr
15910 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
15920 29 29 29 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 ))).. (else..
15930 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
15940 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
15950 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 log-port* "Serve
15960 72 20 74 69 6d 65 64 20 6f 75 74 2e 20 73 65 63 r timed out. sec
15970 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 onds since last
15980 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 db access: " (-
15990 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
159a0 29 20 6c 61 73 74 2d 61 63 63 65 73 73 29 29 0a ) last-access)).
159b0 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 . (http-trans
159c0 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 port:server-shut
159d0 64 6f 77 6e 20 70 6f 72 74 29 29 29 29 29 29 29 down port)))))))
159e0 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
159f0 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
15a00 72 2d 73 68 75 74 64 6f 77 6e 20 70 6f 72 74 29 r-shutdown port)
15a10 0a 20 20 28 62 65 67 69 6e 0a 20 20 20 20 3b 3b . (begin. ;;
15a20 28 42 42 3e 20 22 68 74 74 70 2d 74 72 61 6e 73 (BB> "http-trans
15a30 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 port:server-shut
15a40 64 6f 77 6e 20 63 61 6c 6c 65 64 22 29 0a 20 20 down called").
15a50 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
15a60 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
15a70 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 og-port* "Starti
15a80 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 ng to shutdown t
15a90 68 65 20 73 65 72 76 65 72 2e 20 70 69 64 3d 22 he server. pid="
15aa0 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
15ab0 2d 69 64 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 -id)). ;;.
15ac0 20 3b 3b 20 73 74 61 72 74 5f 73 68 75 74 64 6f ;; start_shutdo
15ad0 77 6e 0a 20 20 20 20 3b 3b 0a 0a 20 20 20 20 3b wn. ;;.. ;
15ae0 3b 20 64 65 72 65 67 69 73 74 65 72 20 74 68 65 ; deregister the
15af0 20 73 65 72 76 65 72 0a 0a 20 20 20 20 0a 20 20 server.. .
15b00 20 20 28 62 64 61 74 2d 74 69 6d 65 2d 74 6f 2d (bdat-time-to-
15b10 65 78 69 74 2d 73 65 74 21 20 2a 62 64 61 74 2a exit-set! *bdat*
15b20 20 23 74 29 20 3b 3b 20 74 65 6c 6c 20 6f 6e 2d #t) ;; tell on-
15b30 65 78 69 74 20 74 6f 20 62 65 20 66 61 73 74 20 exit to be fast
15b40 61 73 20 77 65 27 76 65 20 61 6c 72 65 61 64 79 as we've already
15b50 20 63 6c 65 61 6e 65 64 20 75 70 0a 20 20 20 20 cleaned up.
15b60 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e (portlogger:open
15b70 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c -run-close portl
15b80 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 20 70 ogger:set-port p
15b90 6f 72 74 20 22 72 65 6c 65 61 73 65 64 22 29 0a ort "released").
15ba0 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
15bb0 70 21 20 31 29 0a 0a 20 20 20 20 3b 3b 20 28 64 p! 1).. ;; (d
15bc0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
15bd0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
15be0 6f 72 74 2a 20 22 4d 61 78 20 63 61 63 68 65 64 ort* "Max cached
15bf0 20 71 75 65 72 69 65 73 20 77 61 73 20 20 20 20 queries was
15c00 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a " *max-cache-siz
15c10 65 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 e*). ;; (debu
15c20 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
15c30 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
15c40 2a 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 * "Number of cac
15c50 68 65 64 20 77 72 69 74 65 73 20 20 20 22 20 2a hed writes " *
15c60 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
15c70 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 67 *). ;; (debug
15c80 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
15c90 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
15ca0 20 22 41 76 65 72 61 67 65 20 63 61 63 68 65 64 "Average cached
15cb0 20 77 72 69 74 65 20 74 69 6d 65 20 22 0a 20 20 write time ".
15cc0 20 20 3b 3b 20 09 09 20 20 20 20 20 20 28 69 66 ;; .. (if
15cd0 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 (eq? *number-of
15ce0 2d 77 72 69 74 65 73 2a 20 30 29 0a 20 20 20 20 -writes* 0).
15cf0 3b 3b 20 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f ;; ... "n/a (no
15d00 20 77 72 69 74 65 73 29 22 0a 20 20 20 20 3b 3b writes)". ;;
15d10 20 09 09 09 20 20 28 2f 20 2a 77 72 69 74 65 73 ... (/ *writes
15d20 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 20 20 -total-delay*.
15d30 20 20 3b 3b 20 09 09 09 20 20 20 20 20 2a 6e 75 ;; ... *nu
15d40 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 29 mber-of-writes*)
15d50 29 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 ). ;; ..
15d60 20 22 20 6d 73 22 29 0a 20 20 20 20 3b 3b 20 28 " ms"). ;; (
15d70 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
15d80 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
15d90 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 20 6e 6f port* "Number no
15da0 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 65 73 n-cached queries
15db0 20 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d " *number-non-
15dc0 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 0a write-queries*).
15dd0 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
15de0 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
15df0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 ult-log-port* "A
15e00 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 verage non-cache
15e10 64 20 74 69 6d 65 20 20 20 22 0a 20 20 20 20 3b d time ". ;
15e20 3b 20 09 09 20 20 20 20 20 20 28 69 66 20 28 65 ; .. (if (e
15e30 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 q? *number-non-w
15e40 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 29 rite-queries* 0)
15e50 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 22 6e 2f . ;; ... "n/
15e60 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 22 0a a (no queries)".
15e70 20 20 20 20 3b 3b 20 09 09 09 20 20 28 2f 20 2a ;; ... (/ *
15e80 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d total-non-write-
15e90 64 65 6c 61 79 2a 20 0a 20 20 20 20 3b 3b 20 09 delay* . ;; .
15ea0 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e .. *number-n
15eb0 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 on-write-queries
15ec0 2a 29 29 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 *)). ;; ..
15ed0 20 20 20 22 20 6d 73 22 29 0a 20 20 20 20 0a 20 " ms"). .
15ee0 20 20 20 28 64 62 3a 70 72 69 6e 74 2d 63 75 72 (db:print-cur
15ef0 72 65 6e 74 2d 71 75 65 72 79 2d 73 74 61 74 73 rent-query-stats
15f00 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 61 ). (common:sa
15f10 76 65 2d 70 6b 74 20 60 28 28 61 63 74 69 6f 6e ve-pkt `((action
15f20 20 2e 20 65 78 69 74 29 0a 20 20 20 20 20 20 20 . exit).
15f30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15f40 28 54 20 20 20 20 20 20 2e 20 73 65 72 76 65 72 (T . server
15f50 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
15f60 20 20 20 20 20 20 20 20 20 28 70 69 64 20 20 20 (pid
15f70 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d 70 72 6f . ,(current-pro
15f80 63 65 73 73 2d 69 64 29 29 29 0a 20 20 20 20 20 cess-id))).
15f90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15fa0 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 74 29 0a *configdat* #t).
15fb0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
15fc0 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
15fd0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 -log-port* "Serv
15fe0 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 er shutdown comp
15ff0 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 29 0a lete. Exiting").
16000 20 20 20 20 28 65 78 69 74 29 29 29 0a 0a 3b 3b (exit)))..;;
16010 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 Call this to st
16020 61 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 art the actual s
16030 65 72 76 65 72 0a 3b 3b 0a 3b 3b 20 61 6c 6c 20 erver.;;.;; all
16040 72 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 65 routes though he
16050 72 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 2e re end in exit .
16060 2e 2e 0a 3b 3b 0a 3b 3b 20 54 68 69 73 20 69 73 ...;;.;; This is
16070 20 74 68 65 20 70 6f 69 6e 74 20 61 74 20 77 68 the point at wh
16080 69 63 68 20 73 65 72 76 65 72 73 20 61 72 65 20 ich servers are
16090 73 74 61 72 74 65 64 0a 3b 3b 0a 28 64 65 66 69 started.;;.(defi
160a0 6e 65 20 28 72 6d 74 3a 73 65 72 76 65 72 2d 6c ne (rmt:server-l
160b0 61 75 6e 63 68 20 64 62 6e 61 6d 65 29 0a 20 20 aunch dbname).
160c0 28 6c 65 74 2a 20 28 28 74 68 32 20 28 6d 61 6b (let* ((th2 (mak
160d0 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
160e0 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 ().... (deb
160f0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
16100 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
16110 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e 20 74 t* "Server run t
16120 68 72 65 61 64 20 73 74 61 72 74 65 64 22 29 0a hread started").
16130 09 09 09 20 20 20 20 20 28 72 6d 74 3a 72 75 6e ... (rmt:run
16140 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
16150 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 09 rg "-server")...
16160 09 09 09 20 20 28 61 72 67 73 3a 67 65 74 2d 61 ... (args:get-a
16170 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 09 rg "-server")...
16180 09 09 09 20 20 22 2d 22 29 0a 09 09 09 09 20 20 ... "-").....
16190 20 20 20 20 29 29 20 22 53 65 72 76 65 72 20 72 )) "Server r
161a0 75 6e 22 29 29 0a 09 20 28 74 68 33 20 28 6d 61 un")).. (th3 (ma
161b0 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
161c0 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 a ().... (de
161d0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
161e0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
161f0 72 74 2a 20 22 53 65 72 76 65 72 20 6d 6f 6e 69 rt* "Server moni
16200 74 6f 72 20 74 68 72 65 61 64 20 73 74 61 72 74 tor thread start
16210 65 64 22 29 0a 09 09 09 20 20 20 20 20 28 72 6d ed").... (rm
16220 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 64 t:keep-running d
16230 62 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 22 bname).... "
16240 4b 65 65 70 20 72 75 6e 6e 69 6e 67 22 29 29 29 Keep running")))
16250 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 ). (thread-st
16260 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 28 74 art! th2). (t
16270 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
16280 35 32 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 52) ;; give the
16290 73 65 72 76 65 72 20 74 69 6d 65 20 74 6f 20 73 server time to s
162a0 65 74 74 6c 65 20 62 65 66 6f 72 65 20 73 74 61 ettle before sta
162b0 72 74 69 6e 67 20 74 68 65 20 6b 65 65 70 2d 72 rting the keep-r
162c0 75 6e 6e 69 6e 67 20 6d 6f 6e 69 74 6f 72 2e 0a unning monitor..
162d0 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
162e0 74 21 20 74 68 33 29 0a 20 20 20 20 28 73 65 74 t! th3). (set
162f0 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a ! *didsomething*
16300 20 23 74 29 0a 20 20 20 20 28 74 68 72 65 61 64 #t). (thread
16310 2d 6a 6f 69 6e 21 20 74 68 32 29 0a 20 20 28 65 -join! th2). (e
16320 78 69 74 29 29 0a 0a 20 20 23 66 0a 20 20 29 0a xit)).. #f. ).
16330 09 20 20 20 20 0a 3b 3b 20 47 65 6e 65 72 61 74 . .;; Generat
16340 65 20 61 20 75 6e 69 71 75 65 20 73 69 67 6e 61 e a unique signa
16350 74 75 72 65 20 66 6f 72 20 74 68 69 73 20 73 65 ture for this se
16360 72 76 65 72 0a 28 64 65 66 69 6e 65 20 28 73 65 rver.(define (se
16370 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 rver:mk-signatur
16380 65 29 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 e). (message-di
16390 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 gest-string (md5
163a0 2d 70 72 69 6d 69 74 69 76 65 29 20 0a 09 09 09 -primitive) ....
163b0 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
163c0 2d 73 74 72 69 6e 67 0a 09 09 09 20 20 20 28 6c -string.... (l
163d0 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 ambda ()....
163e0 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 28 63 (write (list (c
163f0 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
16400 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
16410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16420 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
16430 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
16440 0a 09 09 09 09 09 20 20 28 61 72 67 76 29 29 29 ...... (argv)))
16450 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
16460 65 72 76 65 72 3a 67 65 74 2d 63 6c 69 65 6e 74 erver:get-client
16470 2d 73 69 67 6e 61 74 75 72 65 29 20 0a 20 20 28 -signature) . (
16480 69 66 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 if *my-client-si
16490 67 6e 61 74 75 72 65 2a 20 2a 6d 79 2d 63 6c 69 gnature* *my-cli
164a0 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 0a 20 ent-signature*.
164b0 20 20 20 20 20 28 6c 65 74 20 28 28 73 69 67 20 (let ((sig
164c0 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 (server:mk-signa
164d0 74 75 72 65 29 29 29 0a 20 20 20 20 20 20 20 20 ture))).
164e0 28 73 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e 74 (set! *my-client
164f0 2d 73 69 67 6e 61 74 75 72 65 2a 20 73 69 67 29 -signature* sig)
16500 0a 20 20 20 20 20 20 20 20 2a 6d 79 2d 63 6c 69 . *my-cli
16510 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 ent-signature*))
16520 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
16530 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
16570 20 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 E R V E R U T
16580 20 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a I L I T I E S .
16590 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
165a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
165b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
165c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
165d0 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 75 6e ========..;; run
165e0 20 70 69 6e 67 20 69 6e 20 73 65 70 61 72 61 74 ping in separat
165f0 65 20 70 72 6f 63 65 73 73 2c 20 73 61 66 65 73 e process, safes
16600 74 20 77 61 79 20 69 6e 20 73 6f 6d 65 20 63 61 t way in some ca
16610 73 65 73 0a 3b 3b 0a 23 3b 28 64 65 66 69 6e 65 ses.;;.#;(define
16620 20 28 73 65 72 76 65 72 3a 70 69 6e 67 2d 73 65 (server:ping-se
16630 72 76 65 72 20 69 66 61 63 65 70 6f 72 74 29 0a rver ifaceport).
16640 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
16650 6f 6d 2d 70 69 70 65 20 0a 20 20 20 28 63 6f 6e om-pipe . (con
16660 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 c (common:get-me
16670 67 61 74 65 73 74 2d 65 78 65 29 20 22 20 2d 70 gatest-exe) " -p
16680 69 6e 67 20 22 20 69 66 61 63 65 70 6f 72 74 29 ing " ifaceport)
16690 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 . (lambda ().
166a0 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
166b0 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 inl (read-line))
166c0 0a 09 09 28 72 65 73 20 22 4e 4f 52 45 50 4c 59 ...(res "NOREPLY
166d0 22 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 ")). (if (
166e0 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
166f0 0a 09 20 20 20 28 63 61 73 65 20 28 73 74 72 69 .. (case (stri
16700 6e 67 2d 3e 73 79 6d 62 6f 6c 20 72 65 73 29 0a ng->symbol res).
16710 09 20 20 20 20 20 28 28 4e 4f 52 45 50 4c 59 29 . ((NOREPLY)
16720 20 20 23 66 29 0a 09 20 20 20 20 20 28 28 4c 4f #f).. ((LO
16730 47 49 4e 5f 4f 4b 29 20 23 74 29 0a 09 20 20 20 GIN_OK) #t)..
16740 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 23 66 (else #f
16750 29 29 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 )).. (loop (re
16760 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 ad-line) inl))))
16770 29 29 0a 0a 3b 3b 20 4e 4f 54 20 55 53 45 44 20 ))..;; NOT USED
16780 28 77 65 6c 6c 2c 20 6f 6b 2c 20 72 65 66 65 72 (well, ok, refer
16790 65 6e 63 65 20 69 6e 20 72 70 63 2d 74 72 61 6e ence in rpc-tran
167a0 73 70 6f 72 74 20 62 75 74 20 6f 74 68 65 72 77 sport but otherw
167b0 69 73 65 20 6e 6f 74 20 75 73 65 64 29 2e 0a 3b ise not used)..;
167c0 3b 0a 23 3b 28 64 65 66 69 6e 65 20 28 73 65 72 ;.#;(define (ser
167d0 76 65 72 3a 6c 6f 67 69 6e 20 74 6f 70 70 61 74 ver:login toppat
167e0 68 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 74 6f h). (lambda (to
167f0 70 70 61 74 68 29 0a 20 20 20 20 28 73 65 74 21 ppath). (set!
16800 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
16810 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
16820 64 73 29 29 20 3b 3b 20 6d 69 67 68 74 20 6e 6f ds)) ;; might no
16830 74 20 62 65 20 6e 65 65 64 65 64 2e 0a 20 20 20 t be needed..
16840 20 28 69 66 20 28 65 71 75 61 6c 3f 20 2a 74 6f (if (equal? *to
16850 70 70 61 74 68 2a 20 74 6f 70 70 61 74 68 29 0a ppath* toppath).
16860 09 23 74 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 28 .#t..#f)))..;; (
16870 64 65 66 69 6e 65 20 73 65 72 76 65 72 3a 73 79 define server:sy
16880 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 6e 20 22 53 nc-lock-token "S
16890 45 52 56 45 52 5f 53 59 4e 43 5f 4c 4f 43 4b 22 ERVER_SYNC_LOCK"
168a0 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 ).;; (define (se
168b0 72 76 65 72 3a 72 65 6c 65 61 73 65 2d 73 79 6e rver:release-syn
168c0 63 2d 6c 6f 63 6b 29 0a 3b 3b 20 20 20 28 64 62 c-lock).;; (db
168d0 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 2a 6e :no-sync-del! *n
168e0 6f 2d 73 79 6e 63 2d 64 62 2a 20 73 65 72 76 65 o-sync-db* serve
168f0 72 3a 73 79 6e 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 r:sync-lock-toke
16900 6e 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 n)).;; (define (
16910 73 65 72 76 65 72 3a 68 61 76 65 2d 73 79 6e 63 server:have-sync
16920 2d 6c 6f 63 6b 3f 29 0a 3b 3b 20 20 20 28 6c 65 -lock?).;; (le
16930 74 2a 20 28 28 68 61 76 65 2d 6c 6f 63 6b 2d 70 t* ((have-lock-p
16940 61 69 72 20 28 64 62 3a 6e 6f 2d 73 79 6e 63 2d air (db:no-sync-
16950 67 65 74 2d 6c 6f 63 6b 20 2a 6e 6f 2d 73 79 6e get-lock *no-syn
16960 63 2d 64 62 2a 20 73 65 72 76 65 72 3a 73 79 6e c-db* server:syn
16970 63 2d 6c 6f 63 6b 2d 74 6f 6b 65 6e 29 29 0a 3b c-lock-token)).;
16980 3b 20 20 20 20 20 20 20 20 20 20 28 68 61 76 65 ; (have
16990 2d 6c 6f 63 6b 3f 20 20 20 20 20 28 63 61 72 20 -lock? (car
169a0 68 61 76 65 2d 6c 6f 63 6b 2d 70 61 69 72 29 29 have-lock-pair))
169b0 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6c 6f .;; (lo
169c0 63 6b 2d 74 69 6d 65 20 20 20 20 20 20 28 63 64 ck-time (cd
169d0 72 20 68 61 76 65 2d 6c 6f 63 6b 2d 70 61 69 72 r have-lock-pair
169e0 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
169f0 6c 6f 63 6b 2d 61 67 65 20 20 20 20 20 20 20 28 lock-age (
16a00 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
16a10 64 73 29 20 6c 6f 63 6b 2d 74 69 6d 65 29 29 29 ds) lock-time)))
16a20 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b .;; (cond.;;
16a30 20 20 20 20 20 20 28 68 61 76 65 2d 6c 6f 63 6b (have-lock
16a40 3f 20 23 74 29 0a 3b 3b 20 20 20 20 20 20 28 28 ? #t).;; ((
16a50 3e 6c 6f 63 6b 2d 61 67 65 0a 3b 3b 20 20 20 20 >lock-age.;;
16a60 20 20 20 20 28 2a 20 33 20 28 63 6f 6e 66 69 67 (* 3 (config
16a70 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 f:lookup-number
16a80 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
16a90 76 65 72 22 20 22 6d 69 6e 69 6d 75 6d 2d 69 6e ver" "minimum-in
16aa0 74 65 72 73 79 6e 63 2d 64 65 6c 61 79 22 20 64 tersync-delay" d
16ab0 65 66 61 75 6c 74 3a 20 31 38 30 29 29 29 0a 3b efault: 180))).;
16ac0 3b 20 20 20 20 20 20 20 28 73 65 72 76 65 72 3a ; (server:
16ad0 72 65 6c 65 61 73 65 2d 73 79 6e 63 2d 6c 6f 63 release-sync-loc
16ae0 6b 29 0a 3b 3b 20 20 20 20 20 20 20 28 73 65 72 k).;; (ser
16af0 76 65 72 3a 68 61 76 65 2d 73 79 6e 63 2d 6c 6f ver:have-sync-lo
16b00 63 6b 3f 29 29 0a 3b 3b 20 20 20 20 20 20 28 65 ck?)).;; (e
16b10 6c 73 65 20 23 66 29 29 29 29 0a 0a 0a 0a 29 0a lse #f))))....).
16b20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
16b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b60 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 54 =========.;; A T
16b70 20 54 20 49 20 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d T I C.;;=======
16b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
16bc0 0a 0a 20 20 20 20 3b 3b 20 28 68 61 6e 64 6c 65 .. ;; (handle
16bd0 2d 64 69 72 65 63 74 6f 72 79 20 73 70 69 66 66 -directory spiff
16be0 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 y-directory-list
16bf0 69 6e 67 29 0a 3b 3b 20 23 3b 28 68 61 6e 64 6c ing).;; #;(handl
16c00 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c 61 6d e-exception (lam
16c10 62 64 61 20 28 65 78 6e 20 63 68 61 69 6e 29 0a bda (exn chain).
16c20 3b 3b 20 09 09 09 28 73 69 67 6e 61 6c 20 28 6d ;; ...(signal (m
16c30 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
16c40 6e 64 69 74 69 6f 6e 0a 3b 3b 20 09 09 09 09 20 ndition.;; ....
16c50 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 (make-property-c
16c60 6f 6e 64 69 74 69 6f 6e 20 0a 3b 3b 20 09 09 09 ondition .;; ...
16c70 09 20 20 27 73 65 72 76 65 72 0a 3b 3b 20 09 09 . 'server.;; ..
16c80 09 09 20 20 27 6d 65 73 73 61 67 65 20 22 73 65 .. 'message "se
16c90 72 76 65 72 20 65 72 72 6f 72 22 29 29 29 29 29 rver error")))))
16ca0 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 53 65 74 75 70 .;; .;; ;; Setup
16cb0 20 74 68 65 20 77 65 62 20 73 65 72 76 65 72 20 the web server
16cc0 61 6e 64 20 61 20 2f 63 74 72 6c 20 69 6e 74 65 and a /ctrl inte
16cd0 72 66 61 63 65 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 rface.;; ;;.;; (
16ce0 76 68 6f 73 74 2d 6d 61 70 20 60 28 28 28 2a 20 vhost-map `(((*
16cf0 61 6e 79 29 20 2e 20 2c 28 6c 61 6d 62 64 61 20 any) . ,(lambda
16d00 28 63 6f 6e 74 69 6e 75 65 29 0a 3b 3b 20 09 09 (continue).;; ..
16d10 09 20 20 20 20 20 20 20 3b 3b 20 6f 70 65 6e 20 . ;; open
16d20 74 68 65 20 64 62 20 6f 6e 20 74 68 65 20 66 69 the db on the fi
16d30 72 73 74 20 63 61 6c 6c 20 0a 3b 3b 20 09 09 09 rst call .;; ...
16d40 09 20 3b 3b 20 54 68 69 73 20 69 73 20 77 65 72 . ;; This is wer
16d50 65 20 77 65 20 73 65 74 20 75 70 20 74 68 65 20 e we set up the
16d60 64 61 74 61 62 61 73 65 20 63 6f 6e 6e 65 63 74 database connect
16d70 69 6f 6e 73 0a 3b 3b 20 09 09 09 20 20 20 20 20 ions.;; ...
16d80 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 28 72 (let* (($ (r
16d90 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f 75 72 equest-vars sour
16da0 63 65 3a 20 27 62 6f 74 68 29 29 0a 3b 3b 20 09 ce: 'both)).;; .
16db0 09 09 09 20 20 20 20 20 20 3b 3b 20 28 64 61 74 ... ;; (dat
16dc0 20 28 24 20 27 64 61 74 29 29 0a 3b 3b 20 09 09 ($ 'dat)).;; ..
16dd0 09 09 20 20 20 20 20 20 28 72 65 73 20 23 66 29 .. (res #f)
16de0 29 0a 3b 3b 20 09 09 09 09 20 28 63 6f 6e 64 0a ).;; .... (cond.
16df0 3b 3b 20 09 09 09 09 20 20 28 28 65 71 75 61 6c ;; .... ((equal
16e00 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
16e10 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
16e20 74 2d 72 65 71 75 65 73 74 29 29 29 0a 3b 3b 20 t-request))).;;
16e30 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 69 ..... '(/ "api
16e40 22 29 29 0a 3b 3b 20 09 09 09 09 20 20 20 28 64 ")).;; .... (d
16e50 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
16e60 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
16e70 22 49 6e 20 61 70 69 20 72 65 71 75 65 73 74 20 "In api request
16e80 24 3d 22 20 24 29 0a 3b 3b 20 09 09 09 09 20 20 $=" $).;; ....
16e90 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
16ea0 3b 3b 20 74 68 65 20 24 20 69 73 20 74 68 65 20 ;; the $ is the
16eb0 72 65 71 75 65 73 74 20 76 61 72 73 20 70 72 6f request vars pro
16ec0 63 0a 3b 3b 20 09 09 09 09 20 20 20 20 62 6f 64 c.;; .... bod
16ed0 79 3a 20 28 68 74 74 70 2d 68 61 6e 64 6c 65 2d y: (http-handle-
16ee0 61 70 69 20 2a 64 62 73 74 72 75 63 74 2d 64 62 api *dbstruct-db
16ef0 2a 20 24 29 0a 3b 3b 20 09 09 09 09 20 20 20 20 * $).;; ....
16f00 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 headers: '((cont
16f10 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c ent-type text/pl
16f20 61 69 6e 29 29 29 0a 3b 3b 20 09 09 09 09 20 20 ain))).;; ....
16f30 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d (set! *db-last-
16f40 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 access* (current
16f50 2d 73 65 63 6f 6e 64 73 29 29 29 0a 3b 3b 20 09 -seconds))).;; .
16f60 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
16f70 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
16f80 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
16f90 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 09 09 09 quest))) .;; ...
16fa0 09 09 20 20 20 27 28 2f 20 22 70 69 6e 67 22 29 .. '(/ "ping")
16fb0 29 0a 3b 3b 20 09 09 09 09 20 20 20 28 73 65 6e ).;; .... (sen
16fc0 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
16fd0 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
16fe0 22 2f 22 28 61 72 67 73 3a 67 65 74 2d 61 72 67 "/"(args:get-arg
16ff0 20 22 2d 64 62 22 29 29 0a 3b 3b 20 09 09 09 09 "-db")).;; ....
17000 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
17010 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 content-type tex
17020 74 2f 70 6c 61 69 6e 29 29 29 29 0a 3b 3b 20 09 t/plain)))).;; .
17030 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
17040 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
17050 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
17060 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 09 09 09 quest))) .;; ...
17070 09 09 20 20 20 27 28 2f 20 22 6c 6f 6f 70 2d 74 .. '(/ "loop-t
17080 65 73 74 22 29 29 0a 3b 3b 20 09 09 09 09 20 20 est")).;; ....
17090 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
170a0 62 6f 64 79 3a 20 28 61 6c 69 73 74 2d 72 65 66 body: (alist-ref
170b0 20 27 64 61 74 61 20 28 24 29 29 0a 3b 3b 20 09 'data ($)).;; .
170c0 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
170d0 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
170e0 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 3b text/plain)))).;
170f0 3b 20 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f ; .... ((equal?
17100 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 (uri-path (requ
17110 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 est-uri (current
17120 2d 72 65 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 -request))) .;;
17130 09 09 09 09 09 20 20 20 27 28 2f 20 22 22 29 29 ..... '(/ ""))
17140 0a 3b 3b 20 09 09 09 09 20 20 20 28 73 65 6e 64 .;; .... (send
17150 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
17160 28 28 68 74 74 70 2d 67 65 74 2d 66 75 6e 63 74 ((http-get-funct
17170 69 6f 6e 20 27 68 74 74 70 2d 74 72 61 6e 73 70 ion 'http-transp
17180 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 ort:main-page)))
17190 29 0a 3b 3b 20 09 09 09 09 20 20 28 28 65 71 75 ).;; .... ((equ
171a0 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
171b0 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
171c0 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a ent-request))) .
171d0 3b 3b 20 09 09 09 09 09 20 20 20 27 28 2f 20 22 ;; ..... '(/ "
171e0 6a 73 6f 6e 5f 61 70 69 22 29 29 0a 3b 3b 20 09 json_api")).;; .
171f0 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
17200 6f 6e 73 65 20 62 6f 64 79 3a 20 28 28 68 74 74 onse body: ((htt
17210 70 2d 67 65 74 2d 66 75 6e 63 74 69 6f 6e 20 27 p-get-function '
17220 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
17230 61 69 6e 2d 70 61 67 65 29 29 29 29 0a 3b 3b 20 ain-page)))).;;
17240 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
17250 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
17260 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
17270 65 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 09 09 equest))) .;; ..
17280 09 09 09 20 20 20 27 28 2f 20 22 72 75 6e 73 22 ... '(/ "runs"
17290 29 29 0a 3b 3b 20 09 09 09 09 20 20 20 28 73 65 )).;; .... (se
172a0 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
172b0 3a 20 28 28 68 74 74 70 2d 67 65 74 2d 66 75 6e : ((http-get-fun
172c0 63 74 69 6f 6e 20 27 68 74 74 70 2d 74 72 61 6e ction 'http-tran
172d0 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 sport:main-page)
172e0 29 29 29 0a 3b 3b 20 09 09 09 09 20 20 28 28 65 ))).;; .... ((e
172f0 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
17300 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
17310 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
17320 20 0a 3b 3b 20 09 09 09 09 09 20 20 20 27 28 2f .;; ..... '(/
17330 20 61 6e 79 29 29 0a 3b 3b 20 09 09 09 09 20 20 any)).;; ....
17340 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
17350 62 6f 64 79 3a 20 22 68 65 79 20 74 68 65 72 65 body: "hey there
17360 21 5c 6e 22 0a 3b 3b 20 09 09 09 09 09 09 20 20 !\n".;; ......
17370 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 headers: '((cont
17380 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c ent-type text/pl
17390 61 69 6e 29 29 29 29 0a 3b 3b 20 09 09 09 09 20 ain)))).;; ....
173a0 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 ((equal? (uri-p
173b0 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 ath (request-uri
173c0 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 (current-reques
173d0 74 29 29 29 20 0a 3b 3b 20 09 09 09 09 09 20 20 t))) .;; .....
173e0 20 27 28 2f 20 22 68 65 79 22 29 29 0a 3b 3b 20 '(/ "hey")).;;
173f0 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 .... (send-res
17400 70 6f 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 ponse body: "hey
17410 20 74 68 65 72 65 21 5c 6e 22 20 0a 3b 3b 20 09 there!\n" .;; .
17420 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
17430 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
17440 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 3b text/plain)))).;
17450 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
17460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17470 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 ((equal? (uri-pa
17480 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 th (request-uri
17490 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 (current-request
174a0 29 29 29 20 0a 3b 3b 20 09 09 09 09 09 20 20 20 ))) .;; .....
174b0 27 28 2f 20 22 6a 71 75 65 72 79 33 2e 31 2e 30 '(/ "jquery3.1.0
174c0 2e 6a 73 22 29 29 0a 3b 3b 20 09 09 09 09 20 20 .js")).;; ....
174d0 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
174e0 62 6f 64 79 3a 20 28 28 68 74 74 70 2d 67 65 74 body: ((http-get
174f0 2d 66 75 6e 63 74 69 6f 6e 20 27 68 74 74 70 2d -function 'http-
17500 74 72 61 6e 73 70 6f 72 74 3a 73 68 6f 77 2d 6a transport:show-j
17510 71 75 65 72 79 29 29 0a 3b 3b 20 09 09 09 09 09 query)).;; .....
17520 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 . headers: '((c
17530 6f 6e 74 65 6e 74 2d 74 79 70 65 20 61 70 70 6c ontent-type appl
17540 69 63 61 74 69 6f 6e 2f 6a 61 76 61 73 63 72 69 ication/javascri
17550 70 74 29 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 pt)))).;;
17560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17570 20 20 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f ((equal?
17580 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 (uri-path (requ
17590 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 est-uri (current
175a0 2d 72 65 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 -request))) .;;
175b0 09 09 09 09 09 20 20 20 27 28 2f 20 22 74 65 73 ..... '(/ "tes
175c0 74 5f 6c 6f 67 22 29 29 0a 3b 3b 20 09 09 09 09 t_log")).;; ....
175d0 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 (send-respons
175e0 65 20 62 6f 64 79 3a 20 28 28 68 74 74 70 2d 67 e body: ((http-g
175f0 65 74 2d 66 75 6e 63 74 69 6f 6e 20 27 68 74 74 et-function 'htt
17600 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c p-transport:html
17610 2d 74 65 73 74 2d 6c 6f 67 29 20 24 29 20 0a 3b -test-log) $) .;
17620 3b 20 09 09 09 09 09 09 20 20 68 65 61 64 65 72 ; ...... header
17630 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 s: '((content-ty
17640 70 65 20 74 65 78 74 2f 48 54 4d 4c 29 29 29 29 pe text/HTML))))
17650 20 20 20 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 .;;
17660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17670 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f 20 28 ((equal? (
17680 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
17690 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
176a0 65 71 75 65 73 74 29 29 29 20 0a 3b 3b 20 09 09 equest))) .;; ..
176b0 09 09 09 20 20 20 27 28 2f 20 22 64 61 73 68 62 ... '(/ "dashb
176c0 6f 61 72 64 22 29 29 0a 3b 3b 20 09 09 09 09 20 oard")).;; ....
176d0 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 (send-response
176e0 20 62 6f 64 79 3a 20 28 28 68 74 74 70 2d 67 65 body: ((http-ge
176f0 74 2d 66 75 6e 63 74 69 6f 6e 20 27 68 74 74 70 t-function 'http
17700 2d 74 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d -transport:html-
17710 64 62 6f 61 72 64 29 20 24 29 0a 3b 3b 20 09 09 dboard) $).;; ..
17720 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 .... headers: '
17730 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 ((content-type t
17740 65 78 74 2f 48 54 4d 4c 29 29 29 29 20 0a 3b 3b ext/HTML)))) .;;
17750 20 09 09 09 09 20 20 28 65 6c 73 65 20 28 63 6f .... (else (co
17760 6e 74 69 6e 75 65 29 29 29 29 29 29 29 29 0a ntinue)))))))).