Artifact
cbdbeb9ff49e474cd92c1dfa5ace848ea64ddefc:
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 72 66 69 2d 31 20 70 6f 73 69 78 20 se srfi-1 posix
0230: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
0240: 20 73 72 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 srfi-69 hostinf
0250: 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 69 o md5 message-di
0260: 67 65 73 74 29 0a 3b 3b 20 28 75 73 65 20 7a 6d gest).;; (use zm
0270: 71 29 0a 0a 28 75 73 65 20 28 70 72 65 66 69 78 q)..(use (prefix
0280: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
0290: 3a 29 29 0a 0a 28 75 73 65 20 73 70 69 66 66 79 :))..(use spiffy
02a0: 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 uri-common inta
02b0: 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 6e 74 rweb http-client
02c0: 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 74 2d spiffy-request-
02d0: 76 61 72 73 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 vars uri-common
02e0: 69 6e 74 61 72 77 65 62 20 64 69 72 65 63 74 6f intarweb directo
02f0: 72 79 2d 75 74 69 6c 73 29 0a 0a 28 64 65 63 6c ry-utils)..(decl
0300: 61 72 65 20 28 75 6e 69 74 20 63 6c 69 65 6e 74 are (unit client
0310: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 ))..(declare (us
0320: 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 es common)).(dec
0330: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0340: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0350: 61 73 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 asks)) ;; tasks
0360: 61 72 65 20 77 68 65 72 65 20 73 74 75 66 66 20 are where stuff
0370: 69 73 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 is maintained ab
0380: 6f 75 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e out what is runn
0390: 69 6e 67 2e 0a 0a 28 69 6e 63 6c 75 64 65 20 22 ing...(include "
03a0: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
03b0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 cm").(include "d
03c0: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a b_records.scm").
03d0: 0a 3b 3b 20 63 6c 69 65 6e 74 3a 67 65 74 2d 73 .;; client:get-s
03e0: 69 67 6e 61 74 75 72 65 0a 28 64 65 66 69 6e 65 ignature.(define
03f0: 20 28 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 (client:get-sig
0400: 6e 61 74 75 72 65 29 0a 20 20 28 69 66 20 2a 6d nature). (if *m
0410: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
0420: 72 65 2a 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 re* *my-client-s
0430: 69 67 6e 61 74 75 72 65 2a 0a 20 20 20 20 20 20 ignature*.
0440: 28 6c 65 74 20 28 28 73 69 67 20 28 63 6f 6e 63 (let ((sig (conc
0450: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
0460: 20 22 20 22 20 28 63 75 72 72 65 6e 74 2d 70 72 " " (current-pr
0470: 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 28 73 ocess-id))))..(s
0480: 65 74 21 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 et! *my-client-s
0490: 69 67 6e 61 74 75 72 65 2a 20 73 69 67 29 0a 09 ignature* sig)..
04a0: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
04b0: 74 75 72 65 2a 29 29 29 0a 0a 3b 3b 20 4e 6f 74 ture*)))..;; Not
04c0: 20 63 75 72 72 65 6e 74 6c 79 20 75 73 65 64 21 currently used!
04d0: 20 42 75 74 2c 20 49 20 74 68 69 6e 6b 20 69 74 But, I think it
04e0: 20 2a 73 68 6f 75 6c 64 2a 20 62 65 20 75 73 65 *should* be use
04f0: 64 21 21 21 0a 28 64 65 66 69 6e 65 20 28 63 6c d!!!.(define (cl
0500: 69 65 6e 74 3a 6c 6f 67 6f 75 74 20 73 65 72 76 ient:logout serv
0510: 65 72 64 61 74 29 0a 20 20 28 6c 65 74 20 28 28 erdat). (let ((
0520: 6f 6b 20 28 61 6e 64 20 28 73 6f 63 6b 65 74 3f ok (and (socket?
0530: 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 20 28 serverdat)... (
0540: 63 64 62 3a 6c 6f 67 6f 75 74 20 73 65 72 76 65 cdb:logout serve
0550: 72 64 61 74 20 2a 74 6f 70 70 61 74 68 2a 20 28 rdat *toppath* (
0560: 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 6e 61 client:get-signa
0570: 74 75 72 65 29 29 29 29 29 0a 20 20 20 20 6f 6b ture))))). ok
0580: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6c 69 ))..(define (cli
0590: 65 6e 74 3a 63 6f 6e 6e 65 63 74 20 69 66 61 63 ent:connect ifac
05a0: 65 20 70 6f 72 74 29 0a 20 20 28 63 61 73 65 20 e port). (case
05b0: 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 61 6e (server:get-tran
05c0: 73 70 6f 72 74 29 0a 20 20 20 20 28 28 72 70 63 sport). ((rpc
05d0: 29 20 20 28 72 70 63 3a 63 6c 69 65 6e 74 2d 63 ) (rpc:client-c
05e0: 6f 6e 6e 65 63 74 20 20 69 66 61 63 65 20 70 6f onnect iface po
05f0: 72 74 29 29 0a 20 20 20 20 28 28 68 74 74 70 29 rt)). ((http)
0600: 20 28 68 74 74 70 3a 63 6c 69 65 6e 74 2d 63 6f (http:client-co
0610: 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f 72 74 nnect iface port
0620: 29 29 0a 20 20 20 20 28 28 7a 6d 71 29 20 20 28 )). ((zmq) (
0630: 7a 6d 71 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 zmq:client-conne
0640: 63 74 20 20 69 66 61 63 65 20 70 6f 72 74 29 29 ct iface port))
0650: 0a 20 20 20 20 28 65 6c 73 65 20 20 20 28 72 70 . (else (rp
0660: 63 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 c:client-connect
0670: 20 20 69 66 61 63 65 20 70 6f 72 74 29 29 29 29 iface port))))
0680: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e ..(define (clien
0690: 74 3a 73 65 74 75 70 20 20 72 75 6e 2d 69 64 20 t:setup run-id
06a0: 23 21 6b 65 79 20 28 72 65 6d 61 69 6e 69 6e 67 #!key (remaining
06b0: 2d 74 72 69 65 73 20 31 30 29 20 28 66 61 69 6c -tries 10) (fail
06c0: 65 64 2d 63 6f 6e 6e 65 63 74 73 20 30 29 29 0a ed-connects 0)).
06d0: 20 20 28 63 61 73 65 20 28 73 65 72 76 65 72 3a (case (server:
06e0: 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a 20 get-transport).
06f0: 20 20 20 28 28 72 70 63 29 20 28 72 70 63 2d 74 ((rpc) (rpc-t
0700: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
0710: 73 65 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d setup run-id rem
0720: 61 69 6e 69 6e 67 2d 74 72 69 65 73 3a 20 72 65 aining-tries: re
0730: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 66 61 maining-tries fa
0740: 69 6c 65 64 2d 63 6f 6e 6e 65 63 74 73 3a 20 66 iled-connects: f
0750: 61 69 6c 65 64 2d 63 6f 6e 6e 65 63 74 73 29 29 ailed-connects))
0760: 20 3b 3b 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 ;;(client:setup
0770: 2d 72 70 63 20 72 75 6e 2d 69 64 29 29 0a 20 20 -rpc run-id)).
0780: 20 20 28 28 68 74 74 70 29 28 63 6c 69 65 6e 74 ((http)(client
0790: 3a 73 65 74 75 70 2d 68 74 74 70 20 72 75 6e 2d :setup-http run-
07a0: 69 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 id remaining-tri
07b0: 65 73 3a 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 es: remaining-tr
07c0: 69 65 73 20 66 61 69 6c 65 64 2d 63 6f 6e 6e 65 ies failed-conne
07d0: 63 74 73 3a 20 66 61 69 6c 65 64 2d 63 6f 6e 6e cts: failed-conn
07e0: 65 63 74 73 29 29 0a 20 20 20 20 28 65 6c 73 65 ects)). (else
07f0: 20 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 (rpc-transport
0800: 3a 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 72 75 :client-setup ru
0810: 6e 2d 69 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 n-id remaining-t
0820: 72 69 65 73 3a 20 72 65 6d 61 69 6e 69 6e 67 2d ries: remaining-
0830: 74 72 69 65 73 20 66 61 69 6c 65 64 2d 63 6f 6e tries failed-con
0840: 6e 65 63 74 73 3a 20 66 61 69 6c 65 64 2d 63 6f nects: failed-co
0850: 6e 6e 65 63 74 73 29 29 29 29 20 3b 3b 20 28 63 nnects)))) ;; (c
0860: 6c 69 65 6e 74 3a 73 65 74 75 70 2d 72 70 63 20 lient:setup-rpc
0870: 72 75 6e 2d 69 64 29 29 29 29 0a 0a 3b 3b 20 28 run-id))))..;; (
0880: 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 6c define (client:l
0890: 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 73 65 74 ogin-no-auto-set
08a0: 75 70 20 73 65 72 76 65 72 2d 69 6e 66 6f 20 72 up server-info r
08b0: 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 28 63 61 73 un-id).;; (cas
08c0: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 72 e (server:get-tr
08d0: 61 6e 73 70 6f 72 74 29 0a 3b 3b 20 20 20 20 20 ansport).;;
08e0: 28 28 72 70 63 29 20 20 28 72 70 63 3a 6c 6f 67 ((rpc) (rpc:log
08f0: 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e in-no-auto-clien
0900: 74 2d 73 65 74 75 70 20 73 65 72 76 65 72 2d 69 t-setup server-i
0910: 6e 66 6f 20 72 75 6e 2d 69 64 29 29 0a 3b 3b 20 nfo run-id)).;;
0920: 20 20 20 20 28 28 68 74 74 70 29 20 28 72 6d 74 ((http) (rmt
0930: 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 :login-no-auto-c
0940: 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 65 72 76 lient-setup serv
0950: 65 72 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 29 er-info run-id))
0960: 0a 3b 3b 20 20 20 20 20 28 65 6c 73 65 20 20 20 .;; (else
0970: 28 72 70 63 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 (rpc:login-no-au
0980: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
0990: 73 65 72 76 65 72 2d 69 6e 66 6f 20 72 75 6e 2d server-info run-
09a0: 69 64 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 id)))).;; .;; (d
09b0: 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 65 efine (client:se
09c0: 74 75 70 2d 72 70 63 20 72 75 6e 2d 69 64 29 0a tup-rpc run-id).
09d0: 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
09e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
09f0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 6c -port* "INFO: cl
0a00: 69 65 6e 74 3a 73 65 74 75 70 20 72 65 6d 61 69 ient:setup remai
0a10: 6e 69 6e 67 2d 74 72 69 65 73 3d 22 20 72 65 6d ning-tries=" rem
0a20: 61 69 6e 69 6e 67 2d 74 72 69 65 73 29 0a 3b 3b aining-tries).;;
0a30: 20 20 20 28 69 66 20 28 3c 3d 20 72 65 6d 61 69 (if (<= remai
0a40: 6e 69 6e 67 2d 74 72 69 65 73 20 30 29 0a 3b 3b ning-tries 0).;;
0a50: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
0a60: 20 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 .(debug:print-e
0a70: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
0a80: 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c 65 log-port* "faile
0a90: 64 20 74 6f 20 73 74 61 72 74 20 6f 72 20 63 6f d to start or co
0aa0: 6e 6e 65 63 74 20 74 6f 20 73 65 72 76 65 72 20 nnect to server
0ab0: 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e for run-id " run
0ac0: 2d 69 64 29 0a 3b 3b 20 09 28 65 78 69 74 20 31 -id).;; .(exit 1
0ad0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 )).;; (let
0ae0: 20 28 28 68 6f 73 74 2d 69 6e 66 6f 20 28 68 61 ((host-info (ha
0af0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0b00: 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ault *runremote*
0b10: 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 3b 3b run-id #f))).;;
0b20: 20 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 .(debug:print-i
0b30: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
0b40: 6f 67 2d 70 6f 72 74 2a 20 22 63 6c 69 65 6e 74 og-port* "client
0b50: 3a 73 65 74 75 70 20 68 6f 73 74 2d 69 6e 66 6f :setup host-info
0b60: 3d 22 20 68 6f 73 74 2d 69 6e 66 6f 20 22 2c 20 =" host-info ",
0b70: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3d remaining-tries=
0b80: 22 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 " remaining-trie
0b90: 73 29 0a 3b 3b 20 09 28 69 66 20 68 6f 73 74 2d s).;; .(if host-
0ba0: 69 6e 66 6f 0a 3b 3b 20 09 20 20 20 20 28 6c 65 info.;; . (le
0bb0: 74 2a 20 28 28 69 66 61 63 65 20 20 20 20 20 28 t* ((iface (
0bc0: 63 61 72 20 20 68 6f 73 74 2d 69 6e 66 6f 29 29 car host-info))
0bd0: 0a 3b 3b 20 09 09 20 20 20 28 70 6f 72 74 20 20 .;; .. (port
0be0: 20 20 20 20 28 63 61 64 72 20 68 6f 73 74 2d 69 (cadr host-i
0bf0: 6e 66 6f 29 29 0a 3b 3b 20 09 09 20 20 20 28 73 nfo)).;; .. (s
0c00: 74 61 72 74 2d 72 65 73 20 28 63 6c 69 65 6e 74 tart-res (client
0c10: 3a 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 :connect iface p
0c20: 6f 72 74 29 29 0a 3b 3b 20 09 09 20 20 20 3b 3b ort)).;; .. ;;
0c30: 20 28 70 69 6e 67 2d 72 65 73 20 20 28 73 65 72 (ping-res (ser
0c40: 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 ver:ping-server
0c50: 72 75 6e 2d 69 64 20 69 66 61 63 65 20 70 6f 72 run-id iface por
0c60: 74 29 29 0a 3b 3b 20 09 09 20 20 20 28 70 69 6e t)).;; .. (pin
0c70: 67 2d 72 65 73 20 20 28 63 6c 69 65 6e 74 3a 6c g-res (client:l
0c80: 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 73 65 74 ogin-no-auto-set
0c90: 75 70 20 73 74 61 72 74 2d 72 65 73 20 72 75 6e up start-res run
0ca0: 2d 69 64 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 -id))).;; .
0cb0: 20 28 69 66 20 70 69 6e 67 2d 72 65 73 20 20 20 (if ping-res
0cc0: 3b 3b 20 73 75 63 65 73 73 66 75 6c 20 6c 6f 67 ;; sucessful log
0cd0: 69 6e 3f 0a 3b 3b 20 09 09 20 20 28 62 65 67 69 in?.;; .. (begi
0ce0: 6e 0a 3b 3b 20 09 09 20 20 20 20 28 68 61 73 68 n.;; .. (hash
0cf0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 72 75 6e -table-set! *run
0d00: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 73 remote* run-id s
0d10: 74 61 72 74 2d 72 65 73 29 0a 3b 3b 20 09 09 20 tart-res).;; ..
0d20: 20 20 20 73 74 61 72 74 2d 72 65 73 29 20 20 3b start-res) ;
0d30: 3b 20 72 65 74 75 72 6e 20 74 68 65 20 73 65 72 ; return the ser
0d40: 76 65 72 20 69 6e 66 6f 0a 3b 3b 20 09 09 20 20 ver info.;; ..
0d50: 28 69 66 20 28 6d 65 6d 62 65 72 20 72 65 6d 61 (if (member rema
0d60: 69 6e 69 6e 67 2d 74 72 69 65 73 20 27 28 33 20 ining-tries '(3
0d70: 34 20 36 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 4 6)).;; ..
0d80: 20 28 62 65 67 69 6e 20 20 20 20 3b 3b 20 6c 6f (begin ;; lo
0d90: 67 69 6e 20 66 61 69 6c 65 64 0a 3b 3b 20 09 09 gin failed.;; ..
0da0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 35 .(debug:print 25
0db0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0dc0: 72 74 2a 20 22 49 4e 46 4f 3a 20 63 6c 69 65 6e rt* "INFO: clien
0dd0: 74 3a 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 t:setup start-re
0de0: 73 3d 22 20 73 74 61 72 74 2d 72 65 73 20 22 2c s=" start-res ",
0df0: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
0e00: 20 22 2c 20 73 65 72 76 65 72 2d 64 61 74 3d 22 ", server-dat="
0e10: 20 68 6f 73 74 2d 69 6e 66 6f 29 0a 3b 3b 20 09 host-info).;; .
0e20: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 ..(hash-table-de
0e30: 6c 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f 74 65 lete! *runremote
0e40: 2a 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 * run-id).;; ...
0e50: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
0e60: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 66 6f 72 tasks:server-for
0e70: 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 ce-clean-run-rec
0e80: 6f 72 64 0a 3b 3b 20 09 09 09 20 09 09 74 61 73 ord.;; ... ..tas
0e90: 6b 73 3a 6f 70 65 6e 2d 64 62 0a 3b 3b 20 09 09 ks:open-db.;; ..
0ea0: 09 20 09 09 72 75 6e 2d 69 64 20 0a 3b 3b 20 09 . ..run-id .;; .
0eb0: 09 09 20 09 09 28 63 61 72 20 20 68 6f 73 74 2d .. ..(car host-
0ec0: 69 6e 66 6f 29 0a 3b 3b 20 09 09 09 20 09 09 28 info).;; ... ..(
0ed0: 63 61 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 0a cadr host-info).
0ee0: 3b 3b 20 09 09 09 09 09 22 20 63 6c 69 65 6e 74 ;; ....." client
0ef0: 3a 73 65 74 75 70 20 28 68 6f 73 74 2d 69 6e 66 :setup (host-inf
0f00: 6f 3d 23 74 29 22 29 0a 3b 3b 20 09 09 09 28 74 o=#t)").;; ...(t
0f10: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a hread-sleep! 5).
0f20: 3b 3b 20 09 09 09 28 63 6c 69 65 6e 74 3a 73 65 ;; ...(client:se
0f30: 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 69 tup run-id remai
0f40: 6e 69 6e 67 2d 74 72 69 65 73 3a 20 31 30 29 29 ning-tries: 10))
0f50: 20 3b 3b 20 28 2d 20 72 65 6d 61 69 6e 69 6e 67 ;; (- remaining
0f60: 2d 74 72 69 65 73 20 31 29 29 29 0a 3b 3b 20 09 -tries 1))).;; .
0f70: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b . (begin.;;
0f80: 20 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ...(debug:print
0f90: 20 32 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 25 *default-log
0fa0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 6c -port* "INFO: cl
0fb0: 69 65 6e 74 3a 73 65 74 75 70 20 66 61 69 6c 65 ient:setup faile
0fc0: 64 20 74 6f 20 63 6f 6e 6e 65 63 74 2c 20 73 74 d to connect, st
0fd0: 61 72 74 2d 72 65 73 3d 22 20 73 74 61 72 74 2d art-res=" start-
0fe0: 72 65 73 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 res ", run-id="
0ff0: 72 75 6e 2d 69 64 20 22 2c 20 68 6f 73 74 2d 69 run-id ", host-i
1000: 6e 66 6f 3d 22 20 68 6f 73 74 2d 69 6e 66 6f 29 nfo=" host-info)
1010: 0a 3b 3b 20 09 09 09 28 74 68 72 65 61 64 2d 73 .;; ...(thread-s
1020: 6c 65 65 70 21 20 35 29 0a 3b 3b 20 09 09 09 28 leep! 5).;; ...(
1030: 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 72 75 6e client:setup run
1040: 2d 69 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 -id remaining-tr
1050: 69 65 73 3a 20 28 2d 20 72 65 6d 61 69 6e 69 6e ies: (- remainin
1060: 67 2d 74 72 69 65 73 20 31 29 29 29 29 29 29 0a g-tries 1)))))).
1070: 3b 3b 20 09 20 20 20 20 3b 3b 20 59 55 4b 3a 20 ;; . ;; YUK:
1080: 72 65 6e 61 6d 65 20 73 65 72 76 65 72 2d 64 61 rename server-da
1090: 74 20 68 65 72 65 0a 3b 3b 20 09 20 20 20 20 28 t here.;; . (
10a0: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 64 61 let* ((server-da
10b0: 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 t (open-run-clos
10c0: 65 20 74 61 73 6b 73 3a 67 65 74 2d 73 65 72 76 e tasks:get-serv
10d0: 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 er tasks:open-db
10e0: 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 20 run-id))).;; .
10f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1100: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
1110: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6c 69 t-log-port* "cli
1120: 65 6e 74 3a 73 65 74 75 70 20 73 65 72 76 65 72 ent:setup server
1130: 2d 64 61 74 3d 22 20 73 65 72 76 65 72 2d 64 61 -dat=" server-da
1140: 74 20 22 2c 20 72 65 6d 61 69 6e 69 6e 67 2d 74 t ", remaining-t
1150: 72 69 65 73 3d 22 20 72 65 6d 61 69 6e 69 6e 67 ries=" remaining
1160: 2d 74 72 69 65 73 29 0a 3b 3b 20 09 20 20 20 20 -tries).;; .
1170: 20 20 28 69 66 20 73 65 72 76 65 72 2d 64 61 74 (if server-dat
1180: 0a 3b 3b 20 09 09 20 20 28 6c 65 74 2a 20 28 28 .;; .. (let* ((
1190: 69 66 61 63 65 20 20 20 20 20 28 74 61 73 6b 73 iface (tasks
11a0: 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 6e :hostinfo-get-in
11b0: 74 65 72 66 61 63 65 20 73 65 72 76 65 72 2d 64 terface server-d
11c0: 61 74 29 29 0a 3b 3b 20 09 09 09 20 28 70 6f 72 at)).;; ... (por
11d0: 74 20 20 20 20 20 20 28 74 61 73 6b 73 3a 68 6f t (tasks:ho
11e0: 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 20 stinfo-get-port
11f0: 20 20 20 20 20 73 65 72 76 65 72 2d 64 61 74 29 server-dat)
1200: 29 0a 3b 3b 20 09 09 09 20 28 73 74 61 72 74 2d ).;; ... (start-
1210: 72 65 73 20 28 68 74 74 70 2d 74 72 61 6e 73 70 res (http-transp
1220: 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 ort:client-conne
1230: 63 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a ct iface port)).
1240: 3b 3b 20 09 09 09 20 3b 3b 20 28 70 69 6e 67 2d ;; ... ;; (ping-
1250: 72 65 73 20 20 28 73 65 72 76 65 72 3a 70 69 6e res (server:pin
1260: 67 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 g-server run-id
1270: 69 66 61 63 65 20 70 6f 72 74 29 29 0a 3b 3b 20 iface port)).;;
1280: 09 09 09 20 28 70 69 6e 67 2d 72 65 73 20 20 28 ... (ping-res (
1290: 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 rmt:login-no-aut
12a0: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 o-client-setup s
12b0: 74 61 72 74 2d 72 65 73 20 72 75 6e 2d 69 64 29 tart-res run-id)
12c0: 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 69 66 20 )).;; .. (if
12d0: 73 74 61 72 74 2d 72 65 73 0a 3b 3b 20 09 09 09 start-res.;; ...
12e0: 28 62 65 67 69 6e 0a 3b 3b 20 09 09 09 20 20 28 (begin.;; ... (
12f0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1300: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
1310: 69 64 20 73 74 61 72 74 2d 72 65 73 29 0a 3b 3b id start-res).;;
1320: 20 09 09 09 20 20 73 74 61 72 74 2d 72 65 73 29 ... start-res)
1330: 0a 3b 3b 20 09 09 09 28 69 66 20 28 6d 65 6d 62 .;; ...(if (memb
1340: 65 72 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 er remaining-tri
1350: 65 73 20 27 28 32 20 35 29 29 0a 3b 3b 20 09 09 es '(2 5)).;; ..
1360: 09 20 20 20 20 28 62 65 67 69 6e 20 20 20 20 3b . (begin ;
1370: 3b 20 6c 6f 67 69 6e 20 66 61 69 6c 65 64 0a 3b ; login failed.;
1380: 3b 20 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ; ... (debu
1390: 67 3a 70 72 69 6e 74 20 32 35 20 2a 64 65 66 61 g:print 25 *defa
13a0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
13b0: 4e 46 4f 3a 20 63 6c 69 65 6e 74 3a 73 65 74 75 NFO: client:setu
13c0: 70 20 73 74 61 72 74 2d 72 65 73 3d 22 20 73 74 p start-res=" st
13d0: 61 72 74 2d 72 65 73 20 22 2c 20 72 75 6e 2d 69 art-res ", run-i
13e0: 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 73 65 d=" run-id ", se
13f0: 72 76 65 72 2d 64 61 74 3d 22 20 73 65 72 76 65 rver-dat=" serve
1400: 72 2d 64 61 74 29 0a 3b 3b 20 09 09 09 20 20 20 r-dat).;; ...
1410: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 (hash-table-d
1420: 65 6c 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f 74 elete! *runremot
1430: 65 2a 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 e* run-id).;; ..
1440: 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e . (open-run
1450: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
1460: 76 65 72 2d 66 6f 72 63 65 2d 63 6c 65 61 6e 2d ver-force-clean-
1470: 72 75 6e 2d 72 65 63 6f 72 64 0a 3b 3b 20 09 09 run-record.;; ..
1480: 09 09 09 20 20 20 20 20 20 74 61 73 6b 73 3a 6f ... tasks:o
1490: 70 65 6e 2d 64 62 0a 3b 3b 20 09 09 09 09 09 20 pen-db.;; .....
14a0: 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 3b 3b 20 run-id .;;
14b0: 09 09 09 09 09 20 20 20 20 20 20 28 74 61 73 6b ..... (task
14c0: 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 s:hostinfo-get-i
14d0: 6e 74 65 72 66 61 63 65 20 73 65 72 76 65 72 2d nterface server-
14e0: 64 61 74 29 0a 3b 3b 20 09 09 09 09 09 20 20 20 dat).;; .....
14f0: 20 20 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e (tasks:hostin
1500: 66 6f 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 20 fo-get-port
1510: 20 73 65 72 76 65 72 2d 64 61 74 29 0a 3b 3b 20 server-dat).;;
1520: 09 09 09 09 09 20 20 20 20 20 20 22 20 63 6c 69 ..... " cli
1530: 65 6e 74 3a 73 65 74 75 70 20 28 73 65 72 76 65 ent:setup (serve
1540: 72 2d 64 61 74 20 3d 20 23 74 29 22 29 0a 3b 3b r-dat = #t)").;;
1550: 20 09 09 09 20 20 20 20 20 20 28 74 68 72 65 61 ... (threa
1560: 64 2d 73 6c 65 65 70 21 20 32 29 0a 3b 3b 20 09 d-sleep! 2).;; .
1570: 09 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a .. (server:
1580: 74 72 79 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d try-running run-
1590: 69 64 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 id).;; ...
15a0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
15b0: 30 29 20 3b 3b 20 67 69 76 65 20 73 65 72 76 65 0) ;; give serve
15c0: 72 20 61 20 6c 69 74 74 6c 65 20 74 69 6d 65 20 r a little time
15d0: 74 6f 20 73 74 61 72 74 20 75 70 0a 3b 3b 20 09 to start up.;; .
15e0: 09 09 20 20 20 20 20 20 28 63 6c 69 65 6e 74 3a .. (client:
15f0: 73 65 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d setup run-id rem
1600: 61 69 6e 69 6e 67 2d 74 72 69 65 73 3a 20 31 30 aining-tries: 10
1610: 29 29 20 3b 3b 20 28 2d 20 72 65 6d 61 69 6e 69 )) ;; (- remaini
1620: 6e 67 2d 74 72 69 65 73 20 31 29 29 29 0a 3b 3b ng-tries 1))).;;
1630: 20 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 3b ... (begin.;
1640: 3b 20 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ; ... (debu
1650: 67 3a 70 72 69 6e 74 20 32 35 20 2a 64 65 66 61 g:print 25 *defa
1660: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
1670: 4e 46 4f 3a 20 63 6c 69 65 6e 74 3a 73 65 74 75 NFO: client:setu
1680: 70 20 73 74 61 72 74 2d 72 65 73 3d 22 20 73 74 p start-res=" st
1690: 61 72 74 2d 72 65 73 20 22 2c 20 72 75 6e 2d 69 art-res ", run-i
16a0: 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 73 65 d=" run-id ", se
16b0: 72 76 65 72 2d 64 61 74 3d 22 20 73 65 72 76 65 rver-dat=" serve
16c0: 72 2d 64 61 74 29 0a 3b 3b 20 09 09 09 20 20 20 r-dat).;; ...
16d0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
16e0: 21 20 35 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 ! 5).;; ...
16f0: 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 72 (client:setup r
1700: 75 6e 2d 69 64 20 72 65 6d 61 69 6e 69 6e 67 2d un-id remaining-
1710: 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 61 69 6e tries: (- remain
1720: 69 6e 67 2d 74 72 69 65 73 20 31 29 29 29 29 29 ing-tries 1)))))
1730: 29 0a 3b 3b 20 09 09 20 20 28 62 65 67 69 6e 20 ).;; .. (begin
1740: 20 20 20 3b 3b 20 6e 6f 20 73 65 72 76 65 72 20 ;; no server
1750: 72 65 67 69 73 74 65 72 65 64 0a 3b 3b 20 09 09 registered.;; ..
1760: 20 20 20 20 28 69 66 20 28 65 71 3f 20 72 65 6d (if (eq? rem
1770: 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 32 29 0a aining-tries 2).
1780: 3b 3b 20 09 09 09 28 62 65 67 69 6e 0a 3b 3b 20 ;; ...(begin.;;
1790: 09 09 09 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 ... ;; (open-ru
17a0: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
17b0: 72 76 65 72 2d 63 6c 65 61 6e 2d 6f 75 74 2d 6f rver-clean-out-o
17c0: 6c 64 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 72 ld-records-for-r
17d0: 75 6e 2d 69 64 20 74 61 73 6b 73 3a 6f 70 65 6e un-id tasks:open
17e0: 2d 64 62 20 72 75 6e 2d 69 64 20 22 20 63 6c 69 -db run-id " cli
17f0: 65 6e 74 3a 73 65 74 75 70 20 28 73 65 72 76 65 ent:setup (serve
1800: 72 2d 64 61 74 3d 23 66 29 22 29 0a 3b 3b 20 09 r-dat=#f)").;; .
1810: 09 09 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 .. (client:setu
1820: 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 69 6e 69 p run-id remaini
1830: 6e 67 2d 74 72 69 65 73 3a 20 31 30 29 29 0a 3b ng-tries: 10)).;
1840: 3b 20 09 09 09 28 62 65 67 69 6e 0a 3b 3b 20 09 ; ...(begin.;; .
1850: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
1860: 70 21 20 32 29 20 0a 3b 3b 20 09 09 09 20 20 28 p! 2) .;; ... (
1870: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 35 20 2a debug:print 25 *
1880: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1890: 2a 20 22 49 4e 46 4f 3a 20 63 6c 69 65 6e 74 3a * "INFO: client:
18a0: 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 20 setup start-res
18b0: 28 6e 6f 74 20 64 65 66 69 6e 65 64 20 68 65 72 (not defined her
18c0: 65 29 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e e), run-id=" run
18d0: 2d 69 64 20 22 2c 20 73 65 72 76 65 72 2d 64 61 -id ", server-da
18e0: 74 3d 22 20 73 65 72 76 65 72 2d 64 61 74 29 0a t=" server-dat).
18f0: 3b 3b 20 09 09 09 20 20 28 69 66 20 28 3c 20 28 ;; ... (if (< (
1900: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
1910: 61 73 6b 73 3a 6e 75 6d 2d 69 6e 2d 61 76 61 69 asks:num-in-avai
1920: 6c 61 62 6c 65 2d 73 74 61 74 65 20 74 61 73 6b lable-state task
1930: 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 64 s:open-db run-id
1940: 29 20 33 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 ) 3).;; ...
1950: 20 28 62 65 67 69 6e 0a 3b 3b 20 09 09 09 09 3b (begin.;; ....;
1960: 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 ; (open-run-clos
1970: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 63 e tasks:server-c
1980: 6c 65 61 6e 2d 6f 75 74 2d 6f 6c 64 2d 72 65 63 lean-out-old-rec
1990: 6f 72 64 73 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ords-for-run-id
19a0: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 tasks:open-db ru
19b0: 6e 2d 69 64 20 22 20 63 6c 69 65 6e 74 3a 73 65 n-id " client:se
19c0: 74 75 70 20 28 73 65 72 76 65 72 2d 64 61 74 3d tup (server-dat=
19d0: 23 66 29 22 29 0a 3b 3b 20 09 09 09 09 28 73 65 #f)").;; ....(se
19e0: 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 rver:try-running
19f0: 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 09 run-id))).;; ..
1a00: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
1a10: 21 20 31 30 29 20 3b 3b 20 67 69 76 65 20 73 65 ! 10) ;; give se
1a20: 72 76 65 72 20 61 20 6c 69 74 74 6c 65 20 74 69 rver a little ti
1a30: 6d 65 20 74 6f 20 73 74 61 72 74 20 75 70 0a 3b me to start up.;
1a40: 3b 20 09 09 09 20 20 28 63 6c 69 65 6e 74 3a 73 ; ... (client:s
1a50: 65 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 etup run-id rema
1a60: 69 6e 69 6e 67 2d 74 72 69 65 73 3a 20 28 2d 20 ining-tries: (-
1a70: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 remaining-tries
1a80: 31 29 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 1)))))))))))..;;
1a90: 20 44 6f 20 61 6c 6c 20 74 68 65 20 63 6f 6e 6e Do all the conn
1aa0: 65 63 74 69 6f 6e 20 77 6f 72 6b 2c 20 6c 6f 6f ection work, loo
1ab0: 6b 20 75 70 20 74 68 65 20 74 72 61 6e 73 70 6f k up the transpo
1ac0: 72 74 20 74 79 70 65 20 61 6e 64 20 73 65 74 20 rt type and set
1ad0: 75 70 20 74 68 65 0a 3b 3b 20 63 6f 6e 6e 65 63 up the.;; connec
1ae0: 74 69 6f 6e 20 69 66 20 72 65 71 75 69 72 65 64 tion if required
1af0: 2e 0a 3b 3b 0a 3b 3b 20 54 68 65 72 65 20 61 72 ..;;.;; There ar
1b00: 65 20 74 77 6f 20 73 63 65 6e 61 72 69 6f 73 2e e two scenarios.
1b10: 20 0a 3b 3b 20 20 20 31 2e 20 57 65 20 61 72 65 .;; 1. We are
1b20: 20 61 20 74 65 73 74 20 6d 61 6e 61 67 65 72 20 a test manager
1b30: 61 6e 64 20 77 65 20 72 65 63 65 69 76 65 64 20 and we received
1b40: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
1b50: 20 61 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a and *runremote*
1b60: 20 76 69 61 20 63 6d 64 6c 69 6e 65 0a 3b 3b 20 via cmdline.;;
1b70: 20 20 32 2e 20 57 65 20 61 72 65 20 61 20 72 75 2. We are a ru
1b80: 6e 20 74 65 73 74 73 2c 20 6c 69 73 74 20 72 75 n tests, list ru
1b90: 6e 73 20 6f 72 20 6f 74 68 65 72 20 69 6e 74 65 ns or other inte
1ba0: 72 61 63 74 69 76 65 20 70 72 6f 63 65 73 73 20 ractive process
1bb0: 61 6e 64 20 77 65 20 6d 75 73 74 20 66 69 67 75 and we must figu
1bc0: 72 65 20 6f 75 74 0a 3b 3b 20 20 20 20 20 20 2a re out.;; *
1bd0: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 transport-type*
1be0: 61 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 and *runremote*
1bf0: 66 72 6f 6d 20 74 68 65 20 6d 6f 6e 69 74 6f 72 from the monitor
1c00: 2e 64 62 0a 3b 3b 0a 3b 3b 20 63 6c 69 65 6e 74 .db.;;.;; client
1c10: 3a 73 65 74 75 70 0a 3b 3b 0a 3b 3b 20 6c 6f 6f :setup.;;.;; loo
1c20: 6b 75 70 5f 73 65 72 76 65 72 2c 20 6e 65 65 64 kup_server, need
1c30: 20 74 6f 20 72 65 6d 6f 76 65 20 2a 72 75 6e 72 to remove *runr
1c40: 65 6d 6f 74 65 2a 20 73 74 75 66 66 0a 3b 3b 0a emote* stuff.;;.
1c50: 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a (define (client:
1c60: 73 65 74 75 70 2d 68 74 74 70 20 72 75 6e 2d 69 setup-http run-i
1c70: 64 20 23 21 6b 65 79 20 28 72 65 6d 61 69 6e 69 d #!key (remaini
1c80: 6e 67 2d 74 72 69 65 73 20 31 30 29 20 28 66 61 ng-tries 10) (fa
1c90: 69 6c 65 64 2d 63 6f 6e 6e 65 63 74 73 20 30 29 iled-connects 0)
1ca0: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
1cb0: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
1cc0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6c 69 65 -log-port* "clie
1cd0: 6e 74 3a 73 65 74 75 70 20 72 65 6d 61 69 6e 69 nt:setup remaini
1ce0: 6e 67 2d 74 72 69 65 73 3d 22 20 72 65 6d 61 69 ng-tries=" remai
1cf0: 6e 69 6e 67 2d 74 72 69 65 73 29 0a 20 20 28 6c ning-tries). (l
1d00: 65 74 2a 20 28 28 74 64 62 64 61 74 20 28 74 61 et* ((tdbdat (ta
1d10: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 sks:open-db))).
1d20: 20 20 20 28 69 66 20 28 3c 3d 20 72 65 6d 61 69 (if (<= remai
1d30: 6e 69 6e 67 2d 74 72 69 65 73 20 30 29 0a 09 28 ning-tries 0)..(
1d40: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
1d50: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
1d60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1d70: 20 22 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 "failed to star
1d80: 74 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f 20 t or connect to
1d90: 73 65 72 76 65 72 20 66 6f 72 20 72 75 6e 2d 69 server for run-i
1da0: 64 20 22 20 72 75 6e 2d 69 64 29 0a 09 20 20 28 d " run-id).. (
1db0: 65 78 69 74 20 31 29 29 0a 09 28 6c 65 74 2a 20 exit 1))..(let*
1dc0: 28 28 73 65 72 76 65 72 2d 64 61 74 20 28 74 61 ((server-dat (ta
1dd0: 73 6b 73 3a 67 65 74 2d 73 65 72 76 65 72 20 28 sks:get-server (
1de0: 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 db:delay-if-busy
1df0: 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 29 tdbdat) run-id)
1e00: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
1e10: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
1e20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6c lt-log-port* "cl
1e30: 69 65 6e 74 3a 73 65 74 75 70 20 73 65 72 76 65 ient:setup serve
1e40: 72 2d 64 61 74 3d 22 20 73 65 72 76 65 72 2d 64 r-dat=" server-d
1e50: 61 74 20 22 2c 20 72 65 6d 61 69 6e 69 6e 67 2d at ", remaining-
1e60: 74 72 69 65 73 3d 22 20 72 65 6d 61 69 6e 69 6e tries=" remainin
1e70: 67 2d 74 72 69 65 73 29 0a 09 20 20 28 69 66 20 g-tries).. (if
1e80: 73 65 72 76 65 72 2d 64 61 74 0a 09 20 20 20 20 server-dat..
1e90: 20 20 28 6c 65 74 2a 20 28 28 69 66 61 63 65 20 (let* ((iface
1ea0: 20 20 20 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 (tasks:hosti
1eb0: 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 nfo-get-interfac
1ec0: 65 20 73 65 72 76 65 72 2d 64 61 74 29 29 0a 09 e server-dat))..
1ed0: 09 20 20 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 . (hostname
1ee0: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
1ef0: 2d 67 65 74 2d 68 6f 73 74 6e 61 6d 65 20 20 73 -get-hostname s
1f00: 65 72 76 65 72 2d 64 61 74 29 29 0a 09 09 20 20 erver-dat))...
1f10: 20 20 20 28 70 6f 72 74 20 20 20 20 20 20 28 74 (port (t
1f20: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
1f30: 74 2d 70 6f 72 74 20 20 20 20 20 20 73 65 72 76 t-port serv
1f40: 65 72 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 er-dat))...
1f50: 28 73 74 61 72 74 2d 72 65 73 20 28 63 61 73 65 (start-res (case
1f60: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
1f70: 2a 0a 09 09 09 09 20 20 28 28 68 74 74 70 29 28 *..... ((http)(
1f80: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
1f90: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 lient-connect if
1fa0: 61 63 65 20 70 6f 72 74 29 29 0a 09 09 09 09 20 ace port)).....
1fb0: 20 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d ;;((nmsg)(nmsg-
1fc0: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
1fd0: 2d 63 6f 6e 6e 65 63 74 20 68 6f 73 74 6e 61 6d -connect hostnam
1fe0: 65 20 70 6f 72 74 29 29 0a 20 20 20 20 20 20 20 e port)).
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2000: 20 20 20 20 20 20 20 20 20 20 20 29 29 0a 09 09 ))...
2010: 20 20 20 20 20 28 70 69 6e 67 2d 72 65 73 20 20 (ping-res
2020: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
2030: 2d 74 79 70 65 2a 20 0a 09 09 09 09 20 20 28 28 -type* ..... ((
2040: 68 74 74 70 29 28 72 6d 74 3a 6c 6f 67 69 6e 2d http)(rmt:login-
2050: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
2060: 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 29 29 etup start-res))
2070: 0a 09 09 09 09 20 20 3b 3b 20 28 28 6e 6d 73 67 ..... ;; ((nmsg
2080: 29 28 6c 65 74 20 28 28 6c 6f 67 69 6e 69 6e 66 )(let ((logininf
2090: 6f 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d o (rmt:login-no-
20a0: 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 auto-client-setu
20b0: 70 20 73 74 61 72 74 2d 72 65 73 20 72 75 6e 2d p start-res run-
20c0: 69 64 29 29 29 0a 20 09 09 09 09 20 20 3b 3b 20 id))). .... ;;
20d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 (if log
20e0: 69 6e 69 6e 66 6f 0a 20 09 09 09 09 20 20 3b 3b ininfo. .... ;;
20f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2100: 61 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6c ar (vector-ref l
2110: 6f 67 69 6e 69 6e 66 6f 20 31 29 29 0a 20 09 09 ogininfo 1)). ..
2120: 09 09 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 .. ;;
2130: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 #f))).
2140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2150: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
2160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
2180: 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 73 74 ))...(if (and st
2190: 61 72 74 2d 72 65 73 0a 09 09 09 20 70 69 6e 67 art-res.... ping
21a0: 2d 72 65 73 29 0a 09 09 20 20 20 20 28 62 65 67 -res)... (beg
21b0: 69 6e 0a 09 09 20 20 20 20 20 20 28 72 65 6d 6f in... (remo
21c0: 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 te-conndat-set!
21d0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 73 74 61 72 *runremote* star
21e0: 74 2d 72 65 73 29 20 3b 3b 20 28 68 61 73 68 2d t-res) ;; (hash-
21f0: 74 61 62 6c 65 2d 73 65 74 21 20 2a 72 75 6e 72 table-set! *runr
2200: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 73 74 emote* run-id st
2210: 61 72 74 2d 72 65 73 29 0a 09 09 20 20 20 20 20 art-res)...
2220: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2230: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
2240: 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 65 63 74 g-port* "connect
2250: 65 64 20 74 6f 20 22 20 28 68 74 74 70 2d 74 72 ed to " (http-tr
2260: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
2270: 61 74 2d 6d 61 6b 65 2d 75 72 6c 20 73 74 61 72 at-make-url star
2280: 74 2d 72 65 73 29 29 0a 09 09 20 20 20 20 20 20 t-res))...
2290: 73 74 61 72 74 2d 72 65 73 29 0a 09 09 20 20 20 start-res)...
22a0: 20 28 62 65 67 69 6e 20 20 20 20 3b 3b 20 6c 6f (begin ;; lo
22b0: 67 69 6e 20 66 61 69 6c 65 64 20 62 75 74 20 68 gin failed but h
22c0: 61 76 65 20 61 20 73 65 72 76 65 72 20 72 65 63 ave a server rec
22d0: 6f 72 64 2c 20 63 6c 65 61 6e 20 6f 75 74 20 74 ord, clean out t
22e0: 68 65 20 72 65 63 6f 72 64 20 61 6e 64 20 74 72 he record and tr
22f0: 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 20 y again...
2300: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2310: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2320: 2d 70 6f 72 74 2a 20 22 63 6c 69 65 6e 74 3a 73 -port* "client:s
2330: 65 74 75 70 2c 20 6c 6f 67 69 6e 20 66 61 69 6c etup, login fail
2340: 65 64 2c 20 77 69 6c 6c 20 61 74 74 65 6d 70 74 ed, will attempt
2350: 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 to start server
2360: 20 2e 2e 2e 20 73 74 61 72 74 2d 72 65 73 3d 22 ... start-res="
2370: 20 73 74 61 72 74 2d 72 65 73 20 22 2c 20 72 75 start-res ", ru
2380: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c n-id=" run-id ",
2390: 20 73 65 72 76 65 72 2d 64 61 74 3d 22 20 73 65 server-dat=" se
23a0: 72 76 65 72 2d 64 61 74 29 0a 09 09 20 20 20 20 rver-dat)...
23b0: 20 20 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f (case *transpo
23c0: 72 74 2d 74 79 70 65 2a 20 0a 09 09 09 28 28 68 rt-type* ....((h
23d0: 74 74 70 29 28 68 74 74 70 2d 74 72 61 6e 73 70 ttp)(http-transp
23e0: 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
23f0: 74 69 6f 6e 73 20 72 75 6e 2d 69 64 29 29 29 0a tions run-id))).
2400: 09 09 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d .. (remote-
2410: 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 2a 72 75 conndat-set! *ru
2420: 6e 72 65 6d 6f 74 65 2a 20 23 66 29 20 20 3b 3b nremote* #f) ;;
2430: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
2440: 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ete! *runremote*
2450: 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 run-id)...
2460: 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 (tasks:kill-ser
2470: 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 ver-run-id run-i
2480: 64 29 0a 09 09 20 20 20 20 20 20 28 74 61 73 6b d)... (task
2490: 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 s:server-force-c
24a0: 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 lean-run-record
24b0: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
24c0: 79 20 74 64 62 64 61 74 29 0a 09 09 09 09 09 09 y tdbdat).......
24d0: 09 20 20 20 72 75 6e 2d 69 64 20 0a 09 09 09 09 . run-id .....
24e0: 09 09 09 20 20 20 28 74 61 73 6b 73 3a 68 6f 73 ... (tasks:hos
24f0: 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 tinfo-get-interf
2500: 61 63 65 20 73 65 72 76 65 72 2d 64 61 74 29 0a ace server-dat).
2510: 09 09 09 09 09 09 09 20 20 20 28 74 61 73 6b 73 ....... (tasks
2520: 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f :hostinfo-get-po
2530: 72 74 20 20 20 20 20 20 73 65 72 76 65 72 2d 64 rt server-d
2540: 61 74 29 0a 09 09 09 09 09 09 09 20 20 20 22 20 at)........ "
2550: 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 28 73 65 client:setup (se
2560: 72 76 65 72 2d 64 61 74 20 3d 20 23 74 29 22 29 rver-dat = #t)")
2570: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ... (if (>
2580: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 remaining-tries
2590: 38 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d 8).... (thread-
25a0: 73 6c 65 65 70 21 20 28 2b 20 31 20 28 72 61 6e sleep! (+ 1 (ran
25b0: 64 6f 6d 20 35 29 29 29 20 3b 3b 20 73 70 72 65 dom 5))) ;; spre
25c0: 61 64 20 6f 75 74 20 74 68 65 20 73 74 61 72 74 ad out the start
25d0: 73 20 61 20 6c 69 74 74 6c 65 0a 09 09 09 20 20 s a little....
25e0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
25f0: 2b 20 31 35 20 28 72 61 6e 64 6f 6d 20 32 30 29 + 15 (random 20)
2600: 29 29 29 20 3b 3b 20 69 74 20 69 73 6e 27 74 20 ))) ;; it isn't
2610: 67 6f 69 6e 67 20 77 65 6c 6c 2e 20 67 69 76 65 going well. give
2620: 20 69 74 20 70 6c 65 6e 74 79 20 6f 66 20 74 69 it plenty of ti
2630: 6d 65 0a 09 09 20 20 20 20 20 20 28 73 65 72 76 me... (serv
2640: 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 20 2a er:try-running *
2650: 74 6f 70 70 61 74 68 2a 29 0a 09 09 20 20 20 20 toppath*)...
2660: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
2670: 20 35 29 20 20 20 3b 3b 20 67 69 76 65 20 73 65 5) ;; give se
2680: 72 76 65 72 20 61 20 6c 69 74 74 6c 65 20 74 69 rver a little ti
2690: 6d 65 20 74 6f 20 73 74 61 72 74 20 75 70 0a 09 me to start up..
26a0: 09 20 20 20 20 20 20 28 63 6c 69 65 6e 74 3a 73 . (client:s
26b0: 65 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 etup run-id rema
26c0: 69 6e 69 6e 67 2d 74 72 69 65 73 3a 20 28 2d 20 ining-tries: (-
26d0: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 remaining-tries
26e0: 31 29 29 0a 09 09 20 20 20 20 20 20 29 29 29 0a 1))... ))).
26f0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 20 . (begin
2700: 20 3b 3b 20 6e 6f 20 73 65 72 76 65 72 20 72 65 ;; no server re
2710: 67 69 73 74 65 72 65 64 0a 09 09 28 6c 65 74 20 gistered...(let
2720: 28 28 6e 75 6d 2d 61 76 61 69 6c 61 62 6c 65 20 ((num-available
2730: 28 74 61 73 6b 73 3a 6e 75 6d 2d 69 6e 2d 61 76 (tasks:num-in-av
2740: 61 69 6c 61 62 6c 65 2d 73 74 61 74 65 20 28 64 ailable-state (d
2750: 62 3a 64 62 64 61 74 2d 67 65 74 2d 64 62 20 74 b:dbdat-get-db t
2760: 64 62 64 61 74 29 20 72 75 6e 2d 69 64 29 29 29 dbdat) run-id)))
2770: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
2780: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
2790: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6c 69 t-log-port* "cli
27a0: 65 6e 74 3a 73 65 74 75 70 2c 20 6e 6f 20 73 65 ent:setup, no se
27b0: 72 76 65 72 20 72 65 67 69 73 74 65 72 65 64 2c rver registered,
27c0: 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 remaining-tries
27d0: 3d 22 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 =" remaining-tri
27e0: 65 73 20 22 20 6e 75 6d 2d 61 76 61 69 6c 61 62 es " num-availab
27f0: 6c 65 3d 22 20 6e 75 6d 2d 61 76 61 69 6c 61 62 le=" num-availab
2800: 6c 65 29 0a 09 09 20 20 28 69 66 20 28 3c 20 6e le)... (if (< n
2810: 75 6d 2d 61 76 61 69 6c 61 62 6c 65 20 32 29 0a um-available 2).
2820: 09 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a .. (server:
2830: 74 72 79 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 try-running *top
2840: 70 61 74 68 2a 29 29 0a 09 09 20 20 28 74 68 72 path*))... (thr
2850: 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 ead-sleep! (+ 5
2860: 28 72 61 6e 64 6f 6d 20 28 2d 20 32 30 20 72 65 (random (- 20 re
2870: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 29 29 29 maining-tries)))
2880: 29 20 20 3b 3b 20 67 69 76 65 20 73 65 72 76 65 ) ;; give serve
2890: 72 20 61 20 6c 69 74 74 6c 65 20 74 69 6d 65 20 r a little time
28a0: 74 6f 20 73 74 61 72 74 20 75 70 2c 20 72 61 6e to start up, ran
28b0: 64 6f 6d 69 7a 65 20 61 20 6c 69 74 74 6c 65 20 domize a little
28c0: 74 6f 20 61 76 6f 69 64 20 73 74 61 72 74 20 73 to avoid start s
28d0: 74 6f 72 6d 73 2e 0a 09 09 20 20 28 63 6c 69 65 torms.... (clie
28e0: 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 20 nt:setup run-id
28f0: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3a remaining-tries:
2900: 20 28 2d 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 (- remaining-tr
2910: 69 65 73 20 31 29 29 29 29 29 29 29 29 29 0a 0a ies 1)))))))))..
2920: 3b 3b 20 6b 65 65 70 20 74 68 69 73 20 61 73 20 ;; keep this as
2930: 61 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 65 61 a function to ea
2940: 73 65 20 66 75 74 75 72 65 20 0a 28 64 65 66 69 se future .(defi
2950: 6e 65 20 28 63 6c 69 65 6e 74 3a 73 74 61 72 74 ne (client:start
2960: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 run-id server-i
2970: 6e 66 6f 29 0a 20 20 28 68 74 74 70 2d 74 72 61 nfo). (http-tra
2980: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f nsport:client-co
2990: 6e 6e 65 63 74 20 28 74 61 73 6b 73 3a 68 6f 73 nnect (tasks:hos
29a0: 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 tinfo-get-interf
29b0: 61 63 65 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 ace server-info)
29c0: 0a 09 09 09 09 20 28 74 61 73 6b 73 3a 68 6f 73 ..... (tasks:hos
29d0: 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 20 73 tinfo-get-port s
29e0: 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 0a 0a 3b erver-info)))..;
29f0: 3b 20 3b 3b 20 63 6c 69 65 6e 74 3a 73 69 67 6e ; ;; client:sign
2a00: 61 6c 2d 68 61 6e 64 6c 65 72 0a 3b 3b 20 28 64 al-handler.;; (d
2a10: 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 69 efine (client:si
2a20: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 gnal-handler sig
2a30: 6e 75 6d 29 0a 3b 3b 20 20 20 28 73 69 67 6e 61 num).;; (signa
2a40: 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a l-mask! signum).
2a50: 3b 3b 20 20 20 28 73 65 74 21 20 2a 74 69 6d 65 ;; (set! *time
2a60: 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 3b 3b -to-exit* #t).;;
2a70: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
2a80: 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e 0a tions.;; exn.
2a90: 3b 3b 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
2aa0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2ab0: 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 65 78 g-port* " ... ex
2ac0: 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 3b 3b 20 20 iting ...").;;
2ad0: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
2ae0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
2af0: 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 a ().;; ...
2b00: 22 22 29 20 3b 3b 20 64 6f 20 6e 6f 74 68 69 6e "") ;; do nothin
2b10: 67 20 66 6f 72 20 6e 6f 77 20 28 77 61 73 20 66 g for now (was f
2b20: 6c 75 73 68 20 6f 75 74 20 6c 61 73 74 20 63 61 lush out last ca
2b30: 6c 6c 20 69 66 20 61 70 70 6c 69 63 61 62 6c 65 ll if applicable
2b40: 29 0a 3b 3b 20 09 09 09 20 20 20 22 65 61 74 20 ).;; ... "eat
2b50: 72 65 73 70 6f 6e 73 65 22 29 29 0a 3b 3b 20 09 response")).;; .
2b60: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
2b70: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ad (lambda ().;;
2b80: 20 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
2b90: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
2ba0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2bb0: 20 22 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 "Received ^C, a
2bc0: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
2bd0: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
2be0: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
2bf0: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 a few seconds b
2c00: 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 efore hitting ^C
2c10: 20 61 67 61 69 6e 2e 22 29 0a 3b 3b 20 09 09 09 again.").;; ...
2c20: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
2c30: 65 70 21 20 31 29 20 3b 3b 20 67 69 76 65 20 74 ep! 1) ;; give t
2c40: 68 65 20 66 6c 75 73 68 20 6f 6e 65 20 73 65 63 he flush one sec
2c50: 6f 6e 64 20 74 6f 20 64 6f 20 69 74 27 73 20 73 ond to do it's s
2c60: 74 75 66 66 0a 3b 3b 20 09 09 09 20 20 20 20 20 tuff.;; ...
2c70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2c80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2c90: 2a 20 22 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 * " Done."
2ca0: 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 65 78 ).;; ... (ex
2cb0: 69 74 20 34 29 29 0a 3b 3b 20 09 09 09 20 20 20 it 4)).;; ...
2cc0: 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 69 6d 65 "exit on ^C time
2cd0: 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 20 28 74 r"))).;; (t
2ce0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
2cf0: 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 72 65 61 ).;; (threa
2d00: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 3b 3b d-start! th1).;;
2d10: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f (thread-jo
2d20: 69 6e 21 20 74 68 32 29 29 29 29 0a 3b 3b 20 0a in! th2)))).;; .
2d30: 3b 3b 20 3b 3b 20 63 6c 69 65 6e 74 3a 6c 61 75 ;; ;; client:lau
2d40: 6e 63 68 0a 3b 3b 20 3b 3b 20 4e 65 65 64 20 74 nch.;; ;; Need t
2d50: 6f 20 73 65 74 20 74 68 65 20 73 69 67 6e 61 6c o set the signal
2d60: 20 68 61 6e 64 6c 65 72 20 73 6f 6d 65 77 68 65 handler somewhe
2d70: 72 65 20 6f 74 68 65 72 20 74 68 61 6e 20 68 65 re other than he
2d80: 72 65 20 61 73 20 74 68 69 73 0a 3b 3b 20 3b 3b re as this.;; ;;
2d90: 20 72 6f 75 74 69 6e 65 20 77 69 6c 6c 20 67 6f routine will go
2da0: 20 61 77 61 79 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 away..;; ;;.;;
2db0: 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a (define (client:
2dc0: 6c 61 75 6e 63 68 20 72 75 6e 2d 69 64 29 0a 3b launch run-id).;
2dd0: 3b 20 20 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d ; (set-signal-
2de0: 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f handler! signal/
2df0: 69 6e 74 20 20 63 6c 69 65 6e 74 3a 73 69 67 6e int client:sign
2e00: 61 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 20 al-handler).;;
2e10: 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e (set-signal-han
2e20: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 dler! signal/ter
2e30: 6d 20 63 6c 69 65 6e 74 3a 73 69 67 6e 61 6c 2d m client:signal-
2e40: 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 20 20 28 69 handler).;; (i
2e50: 66 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 f (client:setup
2e60: 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 20 20 20 run-id).;;
2e70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2e80: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
2e90: 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 65 63 74 g-port* "connect
2ea0: 65 64 20 61 73 20 63 6c 69 65 6e 74 22 29 0a 3b ed as client").;
2eb0: 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b ; (begin.;
2ec0: 3b 20 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ; .(debug:print-
2ed0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
2ee0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c -log-port* "Fail
2ef0: 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 61 73 ed to connect as
2f00: 20 63 6c 69 65 6e 74 22 29 0a 3b 3b 20 09 28 65 client").;; .(e
2f10: 78 69 74 29 29 29 29 0a 3b 3b 20 0a xit)))).;; .