Artifact b5dec59d452f2bbf2bd4d02e39db4506b60740af:
- File client.scm — part of check-in [cdf61d9fc0] at 2013-07-25 14:33:29 on branch dev — Improved exit handling of state/status for tests. If RUNNING then automatic handling is done. If other than RUNNING, simply preserve the values and roll up if an itemized test. Added to tests to better enforce this behavior. Previous behavior was mostly right but failed in some corner cases. Added database cleanup routine. Properly handle removal of tests and mark tests for a run as deleted if the run is removed (user: mrwellan, size: 5066) [annotate] [blame] [check-ins using]
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20 0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew 0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;; 0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i 0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available 0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G 0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o 0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S 0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany 0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING 00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;; 00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr 00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute 00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA 00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without 00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp 0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of 0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY 0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR 0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;; 0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 3d 3d 3d PURPOSE...;;=== 0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 0190: 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e ===.;; C L I E N 01a0: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;========= 01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================ 01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..( 01f0: 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f require-extensio 0200: 6e 20 28 73 72 66 69 20 31 38 29 20 65 78 74 72 n (srfi 18) extr 0210: 61 73 20 74 63 70 20 73 31 31 6e 29 0a 0a 28 75 as tcp s11n)..(u 0220: 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 69 2d se sqlite3 srfi- 0230: 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 72 65 1 posix regex re 0240: 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d 36 39 gex-case srfi-69 0250: 20 68 6f 73 74 69 6e 66 6f 20 6d 64 35 20 6d 65 hostinfo md5 me 0260: 73 73 61 67 65 2d 64 69 67 65 73 74 29 0a 3b 3b ssage-digest).;; 0270: 20 28 75 73 65 20 7a 6d 71 29 0a 0a 28 69 6d 70 (use zmq)..(imp 0280: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli 0290: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a te3 sqlite3:)).. 02a0: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri- 02b0: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb 02c0: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif 02d0: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 20 fy-request-vars 02e0: 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 uri-common intar 02f0: 77 65 62 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 web)..(declare ( 0300: 75 6e 69 74 20 63 6c 69 65 6e 74 29 29 0a 0a 28 unit client))..( 0310: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co 0320: 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 mmon)).(declare 0330: 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c (uses db)).(decl 0340: 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 are (uses tasks) 0350: 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 77 ) ;; tasks are w 0360: 68 65 72 65 20 73 74 75 66 66 20 69 73 20 6d 61 here stuff is ma 0370: 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 77 intained about w 0380: 68 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a hat is running.. 0390: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo 03a0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm"). 03b0: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec 03c0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 63 ords.scm")..;; c 03d0: 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 6e 61 74 lient:get-signat 03e0: 75 72 65 0a 28 64 65 66 69 6e 65 20 28 63 6c 69 ure.(define (cli 03f0: 65 6e 74 3a 67 65 74 2d 73 69 67 6e 61 74 75 72 ent:get-signatur 0400: 65 29 0a 20 20 28 69 66 20 2a 6d 79 2d 63 6c 69 e). (if *my-cli 0410: 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 2a ent-signature* * 0420: 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 my-client-signat 0430: 75 72 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 ure*. (let 0440: 28 28 73 69 67 20 28 63 6f 6e 63 20 28 67 65 74 ((sig (conc (get 0450: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 22 20 -host-name) " " 0460: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process 0470: 2d 69 64 29 29 29 29 0a 09 28 73 65 74 21 20 2a -id))))..(set! * 0480: 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 my-client-signat 0490: 75 72 65 2a 20 73 69 67 29 0a 09 2a 6d 79 2d 63 ure* sig)..*my-c 04a0: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature* 04b0: 29 29 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 3a 6c )))..;; client:l 04c0: 6f 67 69 6e 20 73 65 72 76 65 72 64 61 74 0a 28 ogin serverdat.( 04d0: 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 6c define (client:l 04e0: 6f 67 69 6e 20 73 65 72 76 65 72 64 61 74 29 0a ogin serverdat). 04f0: 20 20 28 63 64 62 3a 6c 6f 67 69 6e 20 73 65 72 (cdb:login ser 0500: 76 65 72 64 61 74 20 2a 74 6f 70 70 61 74 68 2a verdat *toppath* 0510: 20 28 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 (client:get-sig 0520: 6e 61 74 75 72 65 29 29 29 0a 0a 3b 3b 20 4e 6f nature)))..;; No 0530: 74 20 63 75 72 72 65 6e 74 6c 79 20 75 73 65 64 t currently used 0540: 21 20 42 75 74 2c 20 49 20 74 68 69 6e 6b 20 69 ! But, I think i 0550: 74 20 2a 73 68 6f 75 6c 64 2a 20 62 65 20 75 73 t *should* be us 0560: 65 64 21 21 21 0a 28 64 65 66 69 6e 65 20 28 63 ed!!!.(define (c 0570: 6c 69 65 6e 74 3a 6c 6f 67 6f 75 74 20 73 65 72 lient:logout ser 0580: 76 65 72 64 61 74 29 0a 20 20 28 6c 65 74 20 28 verdat). (let ( 0590: 28 6f 6b 20 28 61 6e 64 20 28 73 6f 63 6b 65 74 (ok (and (socket 05a0: 3f 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 20 ? serverdat)... 05b0: 28 63 64 62 3a 6c 6f 67 6f 75 74 20 73 65 72 76 (cdb:logout serv 05c0: 65 72 64 61 74 20 2a 74 6f 70 70 61 74 68 2a 20 erdat *toppath* 05d0: 28 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 6e (client:get-sign 05e0: 61 74 75 72 65 29 29 29 29 29 0a 20 20 20 20 6f ature))))). o 05f0: 6b 29 29 0a 0a 3b 3b 20 44 6f 20 61 6c 6c 20 74 k))..;; Do all t 0600: 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 77 6f he connection wo 0610: 72 6b 2c 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 rk, look up the 0620: 74 72 61 6e 73 70 6f 72 74 20 74 79 70 65 20 61 transport type a 0630: 6e 64 20 73 65 74 20 75 70 20 74 68 65 0a 3b 3b nd set up the.;; 0640: 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 72 connection if r 0650: 65 71 75 69 72 65 64 2e 0a 3b 3b 0a 3b 3b 20 54 equired..;;.;; T 0660: 68 65 72 65 20 61 72 65 20 74 77 6f 20 73 63 65 here are two sce 0670: 6e 61 72 69 6f 73 2e 20 0a 3b 3b 20 20 20 31 2e narios. .;; 1. 0680: 20 57 65 20 61 72 65 20 61 20 74 65 73 74 20 6d We are a test m 0690: 61 6e 61 67 65 72 20 61 6e 64 20 77 65 20 72 65 anager and we re 06a0: 63 65 69 76 65 64 20 2a 74 72 61 6e 73 70 6f 72 ceived *transpor 06b0: 74 2d 74 79 70 65 2a 20 61 6e 64 20 2a 72 75 6e t-type* and *run 06c0: 72 65 6d 6f 74 65 2a 20 76 69 61 20 63 6d 64 6c remote* via cmdl 06d0: 69 6e 65 0a 3b 3b 20 20 20 32 2e 20 57 65 20 61 ine.;; 2. We a 06e0: 72 65 20 61 20 72 75 6e 20 74 65 73 74 73 2c 20 re a run tests, 06f0: 6c 69 73 74 20 72 75 6e 73 20 6f 72 20 6f 74 68 list runs or oth 0700: 65 72 20 69 6e 74 65 72 61 63 74 69 76 65 20 70 er interactive p 0710: 72 6f 63 65 73 73 20 61 6e 64 20 77 65 20 6d 75 rocess and we mu 0720: 73 68 20 66 69 67 75 72 65 20 6f 75 74 0a 3b 3b sh figure out.;; 0730: 20 20 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 *transport 0740: 2d 74 79 70 65 2a 20 61 6e 64 20 2a 72 75 6e 72 -type* and *runr 0750: 65 6d 6f 74 65 2a 20 66 72 6f 6d 20 74 68 65 20 emote* from the 0760: 6d 6f 6e 69 74 6f 72 2e 64 62 0a 3b 3b 0a 3b 3b monitor.db.;;.;; 0770: 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 28 64 client:setup.(d 0780: 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 65 efine (client:se 0790: 74 75 70 20 23 21 6b 65 79 20 28 6e 75 6d 74 72 tup #!key (numtr 07a0: 69 65 73 20 35 30 29 29 0a 20 20 28 69 66 20 28 ies 50)). (if ( 07b0: 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 not *toppath*). 07c0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 (if (not (s 07d0: 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 etup-for-run)).. 07e0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d 07f0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER 0800: 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 66 ROR: failed to f 0810: 69 6e 64 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e ind megatest.con 0820: 66 69 67 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 fig, exiting").. 0830: 20 20 20 20 28 65 78 69 74 29 29 29 29 0a 20 20 (exit)))). 0840: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director 0850: 79 20 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 y *toppath*) ;; 0860: 54 68 69 73 20 69 73 20 70 72 6f 62 61 62 6c 79 This is probably 0870: 20 4e 4f 54 20 6e 65 65 64 65 64 20 0a 20 20 28 NOT needed . ( 0880: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info 0890: 20 31 31 20 22 2a 74 72 61 6e 73 70 6f 72 74 2d 11 "*transport- 08a0: 74 79 70 65 2a 20 69 73 20 22 20 2a 74 72 61 6e type* is " *tran 08b0: 73 70 6f 72 74 2d 74 79 70 65 2a 20 22 2c 20 2a sport-type* ", * 08c0: 72 75 6e 72 65 6d 6f 74 65 2a 20 69 73 20 22 20 runremote* is " 08d0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 20 20 28 *runremote*). ( 08e0: 6c 65 74 2a 20 28 28 68 6f 73 74 69 6e 66 6f 20 let* ((hostinfo 08f0: 20 28 69 66 20 28 6e 6f 74 20 2a 74 72 61 6e 73 (if (not *trans 0900: 70 6f 72 74 2d 74 79 70 65 2a 29 20 3b 3b 20 49 port-type*) ;; I 0910: 66 20 77 65 20 64 6f 6e 74 27 20 61 6c 72 65 61 f we dont' alrea 0920: 64 79 20 68 61 76 65 20 74 72 61 6e 73 70 6f 72 dy have transpor 0930: 74 20 74 79 70 65 20 73 65 74 20 74 68 65 6e 20 t type set then 0940: 66 69 67 75 72 65 20 69 74 20 6f 75 74 0a 09 09 figure it out... 0950: 09 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 .(open-run-close 0960: 20 74 61 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d tasks:get-best- 0970: 73 65 72 76 65 72 20 74 61 73 6b 73 3a 6f 70 65 server tasks:ope 0980: 6e 2d 64 62 29 0a 09 09 09 23 66 29 29 29 0a 20 n-db)....#f))). 0990: 20 20 20 3b 3b 20 69 66 20 68 61 76 65 20 68 6f ;; if have ho 09a0: 73 74 69 6e 66 6f 20 74 68 65 6e 20 65 78 74 72 stinfo then extr 09b0: 61 63 74 20 74 68 65 20 74 72 61 6e 73 70 6f 72 act the transpor 09c0: 74 20 74 79 70 65 20 0a 20 20 20 20 3b 3b 20 65 t type . ;; e 09d0: 6c 73 65 20 66 61 6c 6c 20 62 61 63 6b 20 74 6f lse fall back to 09e0: 20 66 73 0a 20 20 20 20 28 64 65 62 75 67 3a 70 fs. (debug:p 09f0: 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 43 4c rint-info 11 "CL 0a00: 49 45 4e 54 20 53 45 54 55 50 2c 20 68 6f 73 74 IENT SETUP, host 0a10: 69 6e 66 6f 3d 22 20 68 6f 73 74 69 6e 66 6f 29 info=" hostinfo) 0a20: 0a 20 20 20 20 28 73 65 74 21 20 2a 74 72 61 6e . (set! *tran 0a30: 73 70 6f 72 74 2d 74 79 70 65 2a 20 28 69 66 20 sport-type* (if 0a40: 68 6f 73 74 69 6e 66 6f 20 0a 20 20 20 20 09 09 hostinfo . .. 0a50: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d . (string- 0a60: 3e 73 79 6d 62 6f 6c 20 28 74 61 73 6b 73 3a 68 >symbol (tasks:h 0a70: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 74 72 61 6e ostinfo-get-tran 0a80: 73 70 6f 72 74 20 68 6f 73 74 69 6e 66 6f 29 29 sport hostinfo)) 0a90: 0a 09 09 09 20 20 20 20 20 20 20 27 66 73 29 29 .... 'fs)) 0aa0: 0a 20 20 20 20 3b 3b 20 3b 3b 20 44 45 42 55 47 . ;; ;; DEBUG 0ab0: 20 53 54 55 46 46 0a 20 20 20 20 3b 3b 20 28 69 STUFF. ;; (i 0ac0: 66 20 28 65 71 3f 20 2a 74 72 61 6e 73 70 6f 72 f (eq? *transpor 0ad0: 74 2d 74 79 70 65 2a 20 27 66 73 29 28 62 65 67 t-type* 'fs)(beg 0ae0: 69 6e 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 in (print "ERROR 0af0: 21 21 21 21 21 21 21 20 72 65 66 75 73 69 6e 67 !!!!!!! refusing 0b00: 20 74 6f 20 72 75 6e 20 77 69 74 68 20 74 72 61 to run with tra 0b10: 6e 73 70 6f 72 74 20 22 20 2a 74 72 61 6e 73 70 nsport " *transp 0b20: 6f 72 74 2d 74 79 70 65 2a 29 28 65 78 69 74 20 ort-type*)(exit 0b30: 39 39 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 99))). . ( 0b40: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info 0b50: 20 31 31 20 22 55 73 69 6e 67 20 74 72 61 6e 73 11 "Using trans 0b60: 70 6f 72 74 20 74 79 70 65 20 6f 66 20 22 20 2a port type of " * 0b70: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 transport-type* 0b80: 28 69 66 20 68 6f 73 74 69 6e 66 6f 20 28 63 6f (if hostinfo (co 0b90: 6e 63 20 22 20 74 6f 20 63 6f 6e 6e 65 63 74 20 nc " to connect 0ba0: 74 6f 20 22 20 68 6f 73 74 69 6e 66 6f 29 20 22 to " hostinfo) " 0bb0: 22 29 29 0a 20 20 20 20 28 63 61 73 65 20 2a 74 ")). (case *t 0bc0: 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 0a ransport-type* . 0bd0: 20 20 20 20 20 20 28 28 66 73 29 20 3b 3b 20 28 ((fs) ;; ( 0be0: 69 66 20 28 6e 6f 74 20 2a 6d 65 67 61 74 65 73 if (not *megates 0bf0: 74 2d 64 62 2a 29 28 73 65 74 21 20 2a 6d 65 67 t-db*)(set! *meg 0c00: 61 74 65 73 74 2d 64 62 2a 20 28 6f 70 65 6e 2d atest-db* (open- 0c10: 64 62 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b db)))). ;; 0c20: 20 77 65 20 61 72 65 20 6e 6f 74 20 64 6f 69 6e we are not doin 0c30: 67 20 66 73 20 61 6e 79 20 6c 6f 6e 67 65 72 2e g fs any longer. 0c40: 20 6c 65 74 27 73 20 63 68 65 61 74 20 61 6e 64 let's cheat and 0c50: 20 73 74 61 72 74 20 75 70 20 61 20 73 65 72 76 start up a serv 0c60: 65 72 0a 20 20 20 20 20 20 20 3b 3b 20 69 66 20 er. ;; if 0c70: 77 65 20 61 72 65 20 66 61 6c 6c 69 6e 67 20 62 we are falling b 0c80: 61 63 6b 20 6f 6e 20 66 73 20 28 6e 6f 74 20 31 ack on fs (not 1 0c90: 30 30 25 20 73 75 70 70 6f 72 74 65 64 29 20 64 00% supported) d 0ca0: 6f 20 61 6e 20 61 62 6f 75 74 20 66 61 63 65 20 o an about face 0cb0: 61 6e 64 20 73 74 61 72 74 20 61 20 73 65 72 76 and start a serv 0cc0: 65 72 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e er. (if (n 0cd0: 6f 74 20 28 65 71 75 61 6c 3f 20 28 61 72 67 73 ot (equal? (args 0ce0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 :get-arg "-trans 0cf0: 70 6f 72 74 22 29 20 22 66 73 22 29 29 0a 09 20 port") "fs")).. 0d00: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 (begin.. ( 0d10: 73 65 74 21 20 2a 74 72 61 6e 73 70 6f 72 74 2d set! *transport- 0d20: 74 79 70 65 2a 20 23 66 29 0a 09 20 20 20 20 20 type* #f).. 0d30: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d (system (conc "m 0d40: 65 67 61 74 65 73 74 20 2d 6c 69 73 74 2d 73 65 egatest -list-se 0d50: 72 76 65 72 73 20 7c 20 67 72 65 70 20 22 20 6d rvers | grep " m 0d60: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 egatest-version 0d70: 22 20 7c 20 67 72 65 70 20 61 6c 69 76 65 20 7c " | grep alive | 0d80: 7c 20 6d 65 67 61 74 65 73 74 20 2d 73 65 72 76 | megatest -serv 0d90: 65 72 20 2d 20 2d 64 61 65 6d 6f 6e 69 7a 65 20 er - -daemonize 0da0: 26 26 20 73 6c 65 65 70 20 33 22 29 29 0a 09 20 && sleep 3")).. 0db0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee 0dc0: 70 21 20 31 29 0a 09 20 20 20 20 20 28 69 66 20 p! 1).. (if 0dd0: 28 3e 20 6e 75 6d 74 72 69 65 73 20 30 29 0a 09 (> numtries 0).. 0de0: 09 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 . (client:setup 0df0: 6e 75 6d 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d numtries: (- num 0e00: 74 72 69 65 73 20 31 29 29 29 29 29 29 0a 20 20 tries 1)))))). 0e10: 20 20 20 20 28 28 68 74 74 70 29 0a 20 20 20 20 ((http). 0e20: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo 0e30: 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 rt:client-connec 0e40: 74 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 t (tasks:hostinf 0e50: 6f 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 o-get-interface 0e60: 68 6f 73 74 69 6e 66 6f 29 0a 09 09 09 09 20 20 hostinfo)..... 0e70: 20 20 20 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 (tasks:hosti 0e80: 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 20 68 6f 73 nfo-get-port hos 0e90: 74 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 28 tinfo))). ( 0ea0: 28 7a 6d 71 29 0a 20 20 20 20 20 20 20 28 7a 6d (zmq). (zm 0eb0: 71 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 q-transport:clie 0ec0: 6e 74 2d 63 6f 6e 6e 65 63 74 20 28 74 61 73 6b nt-connect (task 0ed0: 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 s:hostinfo-get-i 0ee0: 6e 74 65 72 66 61 63 65 20 68 6f 73 74 69 6e 66 nterface hostinf 0ef0: 6f 29 0a 09 09 09 09 20 20 20 20 20 28 74 61 73 o)..... (tas 0f00: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get- 0f10: 70 6f 72 74 20 20 20 20 20 20 68 6f 73 74 69 6e port hostin 0f20: 66 6f 29 0a 09 09 09 09 20 20 20 20 20 28 74 61 fo)..... (ta 0f30: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get 0f40: 2d 70 75 62 70 6f 72 74 20 20 20 68 6f 73 74 69 -pubport hosti 0f50: 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 28 65 6c nfo))). (el 0f60: 73 65 20 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 se ;; default t 0f70: 6f 20 66 73 0a 20 20 20 20 20 20 20 28 64 65 62 o fs. (deb 0f80: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO 0f90: 52 3a 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 R: unrecognised 0fa0: 74 72 61 6e 73 70 6f 72 74 20 74 79 70 65 20 22 transport type " 0fb0: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type 0fc0: 2a 20 22 20 61 74 74 65 6d 70 74 69 6e 67 20 74 * " attempting t 0fd0: 6f 20 63 6f 6e 74 69 6e 75 65 20 77 69 74 68 20 o continue with 0fe0: 66 73 22 29 0a 20 20 20 20 20 20 20 28 73 65 74 fs"). (set 0ff0: 21 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 ! *transport-typ 1000: 65 2a 20 27 66 73 29 0a 20 20 20 20 20 20 20 28 e* 'fs). ( 1010: 73 65 74 21 20 2a 6d 65 67 61 74 65 73 74 2d 64 set! *megatest-d 1020: 62 2a 20 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 b* (open-db)) 1030: 29 29 29 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 3a ))))..;; client: 1040: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 0a 28 signal-handler.( 1050: 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 define (client:s 1060: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si 1070: 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d gnum). (handle- 1080: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex 1090: 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e n. (debug:prin 10a0: 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 20 t " ... exiting 10b0: 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 28 ..."). (let (( 10c0: 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th1 (make-thread 10d0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ().... 10e0: 20 20 20 20 22 22 29 20 3b 3b 20 64 6f 20 6e 6f "") ;; do no 10f0: 74 68 69 6e 67 20 66 6f 72 20 6e 6f 77 20 28 77 thing for now (w 1100: 61 73 20 66 6c 75 73 68 20 6f 75 74 20 6c 61 73 as flush out las 1110: 74 20 63 61 6c 6c 20 69 66 20 61 70 70 6c 69 63 t call if applic 1120: 61 62 6c 65 29 0a 09 09 09 20 20 20 22 65 61 74 able).... "eat 1130: 20 72 65 73 70 6f 6e 73 65 22 29 29 0a 09 20 28 response")).. ( 1140: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread 1150: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ().... 1160: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print 1170: 20 30 20 22 45 52 52 4f 52 3a 20 52 65 63 65 69 0 "ERROR: Recei 1180: 76 65 64 20 5e 43 2c 20 61 74 74 65 6d 70 74 69 ved ^C, attempti 1190: 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 ng clean exit. P 11a0: 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 lease be patient 11b0: 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 and wait a few 11c0: 73 65 63 6f 6e 64 73 20 62 65 66 6f 72 65 20 68 seconds before h 11d0: 69 74 74 69 6e 67 20 5e 43 20 61 67 61 69 6e 2e itting ^C again. 11e0: 22 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 ").... (thre 11f0: 61 64 2d 73 6c 65 65 70 21 20 31 29 20 3b 3b 20 ad-sleep! 1) ;; 1200: 67 69 76 65 20 74 68 65 20 66 6c 75 73 68 20 6f give the flush o 1210: 6e 65 20 73 65 63 6f 6e 64 20 74 6f 20 64 6f 20 ne second to do 1220: 69 74 27 73 20 73 74 75 66 66 0a 09 09 09 20 20 it's stuff.... 1230: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print 1240: 30 20 22 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 0 " Done." 1250: 29 0a 09 09 09 20 20 20 20 20 28 65 78 69 74 20 ).... (exit 1260: 34 29 29 0a 09 09 09 20 20 20 22 65 78 69 74 20 4)).... "exit 1270: 6f 6e 20 5e 43 20 74 69 6d 65 72 22 29 29 29 0a on ^C timer"))). 1280: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta 1290: 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 28 74 rt! th2). (t 12a0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 hread-start! th1 12b0: 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a ). (thread-j 12c0: 6f 69 6e 21 20 74 68 32 29 29 29 29 0a 0a 3b 3b oin! th2))))..;; 12d0: 20 63 6c 69 65 6e 74 3a 6c 61 75 6e 63 68 0a 28 client:launch.( 12e0: 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 6c define (client:l 12f0: 61 75 6e 63 68 29 0a 20 20 28 73 65 74 2d 73 69 aunch). (set-si 1300: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 gnal-handler! si 1310: 67 6e 61 6c 2f 69 6e 74 20 63 6c 69 65 6e 74 3a gnal/int client: 1320: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 0a signal-handler). 1330: 20 20 20 28 69 66 20 28 63 6c 69 65 6e 74 3a 73 (if (client:s 1340: 65 74 75 70 29 0a 20 20 20 20 20 20 20 28 64 65 etup). (de 1350: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2 1360: 20 22 63 6f 6e 6e 65 63 74 65 64 20 61 73 20 63 "connected as c 1370: 6c 69 65 6e 74 22 29 0a 20 20 20 20 20 20 20 28 lient"). ( 1380: 62 65 67 69 6e 0a 09 20 28 64 65 62 75 67 3a 70 begin.. (debug:p 1390: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F 13a0: 61 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 ailed to connect 13b0: 20 61 73 20 63 6c 69 65 6e 74 22 29 0a 09 20 28 as client").. ( 13c0: 65 78 69 74 29 29 29 29 0a 0a exit))))..