Artifact
3a2fa3c3cbaa5fb596779b685879eaa7f245a835:
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 20 64 69 72 65 63 74 6f 72 79 2d 75 74 web directory-ut
0300: 69 6c 73 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 ils)..(declare (
0310: 75 6e 69 74 20 63 6c 69 65 6e 74 29 29 0a 0a 28 unit client))..(
0320: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
0330: 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 mmon)).(declare
0340: 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c (uses db)).(decl
0350: 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 are (uses tasks)
0360: 29 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 77 ) ;; tasks are w
0370: 68 65 72 65 20 73 74 75 66 66 20 69 73 20 6d 61 here stuff is ma
0380: 69 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 77 intained about w
0390: 68 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a hat is running..
03a0: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo
03b0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
03c0: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
03d0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 63 ords.scm")..;; c
03e0: 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 6e 61 74 lient:get-signat
03f0: 75 72 65 0a 28 64 65 66 69 6e 65 20 28 63 6c 69 ure.(define (cli
0400: 65 6e 74 3a 67 65 74 2d 73 69 67 6e 61 74 75 72 ent:get-signatur
0410: 65 29 0a 20 20 28 69 66 20 2a 6d 79 2d 63 6c 69 e). (if *my-cli
0420: 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 2a ent-signature* *
0430: 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 my-client-signat
0440: 75 72 65 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 ure*. (let
0450: 28 28 73 69 67 20 28 63 6f 6e 63 20 28 67 65 74 ((sig (conc (get
0460: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 22 20 -host-name) " "
0470: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
0480: 2d 69 64 29 29 29 29 0a 09 28 73 65 74 21 20 2a -id))))..(set! *
0490: 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 my-client-signat
04a0: 75 72 65 2a 20 73 69 67 29 0a 09 2a 6d 79 2d 63 ure* sig)..*my-c
04b0: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
04c0: 29 29 29 0a 0a 3b 3b 20 4e 6f 74 20 63 75 72 72 )))..;; Not curr
04d0: 65 6e 74 6c 79 20 75 73 65 64 21 20 42 75 74 2c ently used! But,
04e0: 20 49 20 74 68 69 6e 6b 20 69 74 20 2a 73 68 6f I think it *sho
04f0: 75 6c 64 2a 20 62 65 20 75 73 65 64 21 21 21 0a uld* be used!!!.
0500: 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a (define (client:
0510: 6c 6f 67 6f 75 74 20 73 65 72 76 65 72 64 61 74 logout serverdat
0520: 29 0a 20 20 28 6c 65 74 20 28 28 6f 6b 20 28 61 ). (let ((ok (a
0530: 6e 64 20 28 73 6f 63 6b 65 74 3f 20 73 65 72 76 nd (socket? serv
0540: 65 72 64 61 74 29 0a 09 09 20 28 63 64 62 3a 6c erdat)... (cdb:l
0550: 6f 67 6f 75 74 20 73 65 72 76 65 72 64 61 74 20 ogout serverdat
0560: 2a 74 6f 70 70 61 74 68 2a 20 28 63 6c 69 65 6e *toppath* (clien
0570: 74 3a 67 65 74 2d 73 69 67 6e 61 74 75 72 65 29 t:get-signature)
0580: 29 29 29 29 0a 20 20 20 20 6f 6b 29 29 0a 0a 28 )))). ok))..(
0590: 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 63 define (client:c
05a0: 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f 72 onnect iface por
05b0: 74 29 0a 20 20 28 63 61 73 65 20 28 73 65 72 76 t). (case (serv
05c0: 65 72 3a 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 er:get-transport
05d0: 29 0a 20 20 20 20 28 28 72 70 63 29 20 20 28 72 ). ((rpc) (r
05e0: 70 63 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 pc:client-connec
05f0: 74 20 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a t iface port)).
0600: 20 20 20 20 28 28 68 74 74 70 29 20 28 68 74 74 ((http) (htt
0610: 70 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 p:client-connect
0620: 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a 20 20 iface port)).
0630: 20 20 28 28 7a 6d 71 29 20 20 28 7a 6d 71 3a 63 ((zmq) (zmq:c
0640: 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 20 69 lient-connect i
0650: 66 61 63 65 20 70 6f 72 74 29 29 0a 20 20 20 20 face port)).
0660: 28 65 6c 73 65 20 20 20 28 72 70 63 3a 63 6c 69 (else (rpc:cli
0670: 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 20 69 66 61 ent-connect ifa
0680: 63 65 20 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 ce port))))..(de
0690: 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 65 74 fine (client:set
06a0: 75 70 20 20 72 75 6e 2d 69 64 20 23 21 6b 65 79 up run-id #!key
06b0: 20 28 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 (remaining-trie
06c0: 73 20 31 30 29 20 28 66 61 69 6c 65 64 2d 63 6f s 10) (failed-co
06d0: 6e 6e 65 63 74 73 20 30 29 29 0a 20 20 28 63 61 nnects 0)). (ca
06e0: 73 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 se (server:get-t
06f0: 72 61 6e 73 70 6f 72 74 29 0a 20 20 20 20 28 28 ransport). ((
0700: 72 70 63 29 20 28 72 70 63 2d 74 72 61 6e 73 70 rpc) (rpc-transp
0710: 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 74 75 70 ort:client-setup
0720: 20 72 75 6e 2d 69 64 29 29 20 3b 3b 28 63 6c 69 run-id)) ;;(cli
0730: 65 6e 74 3a 73 65 74 75 70 2d 72 70 63 20 72 75 ent:setup-rpc ru
0740: 6e 2d 69 64 29 29 0a 20 20 20 20 28 28 68 74 74 n-id)). ((htt
0750: 70 29 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 2d p)(client:setup-
0760: 68 74 74 70 20 72 75 6e 2d 69 64 29 29 0a 20 20 http run-id)).
0770: 20 20 28 65 6c 73 65 20 20 28 72 70 63 2d 74 72 (else (rpc-tr
0780: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 ansport:client-s
0790: 65 74 75 70 20 72 75 6e 2d 69 64 29 29 29 29 20 etup run-id))))
07a0: 3b 3b 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 ;; (client:setup
07b0: 2d 72 70 63 20 72 75 6e 2d 69 64 29 29 29 29 0a -rpc run-id)))).
07c0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6c 69 .;; (define (cli
07d0: 65 6e 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 ent:login-no-aut
07e0: 6f 2d 73 65 74 75 70 20 73 65 72 76 65 72 2d 69 o-setup server-i
07f0: 6e 66 6f 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 nfo run-id).;;
0800: 20 28 63 61 73 65 20 28 73 65 72 76 65 72 3a 67 (case (server:g
0810: 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a 3b 3b et-transport).;;
0820: 20 20 20 20 20 28 28 72 70 63 29 20 20 28 72 70 ((rpc) (rp
0830: 63 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d c:login-no-auto-
0840: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 65 72 client-setup ser
0850: 76 65 72 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 ver-info run-id)
0860: 29 0a 3b 3b 20 20 20 20 20 28 28 68 74 74 70 29 ).;; ((http)
0870: 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 (rmt:login-no-a
0880: 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 uto-client-setup
0890: 20 73 65 72 76 65 72 2d 69 6e 66 6f 20 72 75 6e server-info run
08a0: 2d 69 64 29 29 0a 3b 3b 20 20 20 20 20 28 65 6c -id)).;; (el
08b0: 73 65 20 20 20 28 72 70 63 3a 6c 6f 67 69 6e 2d se (rpc:login-
08c0: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
08d0: 65 74 75 70 20 73 65 72 76 65 72 2d 69 6e 66 6f etup server-info
08e0: 20 72 75 6e 2d 69 64 29 29 29 29 0a 3b 3b 20 0a run-id)))).;; .
08f0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6c 69 65 ;; (define (clie
0900: 6e 74 3a 73 65 74 75 70 2d 72 70 63 20 72 75 6e nt:setup-rpc run
0910: 2d 69 64 29 0a 3b 3b 20 20 20 28 64 65 62 75 67 -id).;; (debug
0920: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
0930: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
0940: 4f 3a 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 O: client:setup
0950: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3d remaining-tries=
0960: 22 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 " remaining-trie
0970: 73 29 0a 3b 3b 20 20 20 28 69 66 20 28 3c 3d 20 s).;; (if (<=
0980: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 remaining-tries
0990: 30 29 0a 3b 3b 20 20 20 20 20 20 20 28 62 65 67 0).;; (beg
09a0: 69 6e 0a 3b 3b 20 09 28 64 65 62 75 67 3a 70 72 in.;; .(debug:pr
09b0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
09c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
09d0: 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 74 20 failed to start
09e0: 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f 20 73 65 or connect to se
09f0: 72 76 65 72 20 66 6f 72 20 72 75 6e 2d 69 64 20 rver for run-id
0a00: 22 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 28 65 " run-id).;; .(e
0a10: 78 69 74 20 31 29 29 0a 3b 3b 20 20 20 20 20 20 xit 1)).;;
0a20: 20 28 6c 65 74 20 28 28 68 6f 73 74 2d 69 6e 66 (let ((host-inf
0a30: 6f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 o (hash-table-re
0a40: 66 2f 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 f/default *runre
0a50: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 mote* run-id #f)
0a60: 29 29 0a 3b 3b 20 09 28 64 65 62 75 67 3a 70 72 )).;; .(debug:pr
0a70: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
0a80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
0a90: 6c 69 65 6e 74 3a 73 65 74 75 70 20 68 6f 73 74 lient:setup host
0aa0: 2d 69 6e 66 6f 3d 22 20 68 6f 73 74 2d 69 6e 66 -info=" host-inf
0ab0: 6f 20 22 2c 20 72 65 6d 61 69 6e 69 6e 67 2d 74 o ", remaining-t
0ac0: 72 69 65 73 3d 22 20 72 65 6d 61 69 6e 69 6e 67 ries=" remaining
0ad0: 2d 74 72 69 65 73 29 0a 3b 3b 20 09 28 69 66 20 -tries).;; .(if
0ae0: 68 6f 73 74 2d 69 6e 66 6f 0a 3b 3b 20 09 20 20 host-info.;; .
0af0: 20 20 28 6c 65 74 2a 20 28 28 69 66 61 63 65 20 (let* ((iface
0b00: 20 20 20 20 28 63 61 72 20 20 68 6f 73 74 2d 69 (car host-i
0b10: 6e 66 6f 29 29 0a 3b 3b 20 09 09 20 20 20 28 70 nfo)).;; .. (p
0b20: 6f 72 74 20 20 20 20 20 20 28 63 61 64 72 20 68 ort (cadr h
0b30: 6f 73 74 2d 69 6e 66 6f 29 29 0a 3b 3b 20 09 09 ost-info)).;; ..
0b40: 20 20 20 28 73 74 61 72 74 2d 72 65 73 20 28 63 (start-res (c
0b50: 6c 69 65 6e 74 3a 63 6f 6e 6e 65 63 74 20 69 66 lient:connect if
0b60: 61 63 65 20 70 6f 72 74 29 29 0a 3b 3b 20 09 09 ace port)).;; ..
0b70: 20 20 20 3b 3b 20 28 70 69 6e 67 2d 72 65 73 20 ;; (ping-res
0b80: 20 28 73 65 72 76 65 72 3a 70 69 6e 67 2d 73 65 (server:ping-se
0b90: 72 76 65 72 20 72 75 6e 2d 69 64 20 69 66 61 63 rver run-id ifac
0ba0: 65 20 70 6f 72 74 29 29 0a 3b 3b 20 09 09 20 20 e port)).;; ..
0bb0: 20 28 70 69 6e 67 2d 72 65 73 20 20 28 63 6c 69 (ping-res (cli
0bc0: 65 6e 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 ent:login-no-aut
0bd0: 6f 2d 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 o-setup start-re
0be0: 73 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 s run-id))).;; .
0bf0: 20 20 20 20 20 20 28 69 66 20 70 69 6e 67 2d 72 (if ping-r
0c00: 65 73 20 20 20 3b 3b 20 73 75 63 65 73 73 66 75 es ;; sucessfu
0c10: 6c 20 6c 6f 67 69 6e 3f 0a 3b 3b 20 09 09 20 20 l login?.;; ..
0c20: 28 62 65 67 69 6e 0a 3b 3b 20 09 09 20 20 20 20 (begin.;; ..
0c30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
0c40: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
0c50: 2d 69 64 20 73 74 61 72 74 2d 72 65 73 29 0a 3b -id start-res).;
0c60: 3b 20 09 09 20 20 20 20 73 74 61 72 74 2d 72 65 ; .. start-re
0c70: 73 29 20 20 3b 3b 20 72 65 74 75 72 6e 20 74 68 s) ;; return th
0c80: 65 20 73 65 72 76 65 72 20 69 6e 66 6f 0a 3b 3b e server info.;;
0c90: 20 09 09 20 20 28 69 66 20 28 6d 65 6d 62 65 72 .. (if (member
0ca0: 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 remaining-tries
0cb0: 20 27 28 33 20 34 20 36 29 29 0a 3b 3b 20 09 09 '(3 4 6)).;; ..
0cc0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 20 20 (begin
0cd0: 3b 3b 20 6c 6f 67 69 6e 20 66 61 69 6c 65 64 0a ;; login failed.
0ce0: 3b 3b 20 09 09 09 28 64 65 62 75 67 3a 70 72 69 ;; ...(debug:pri
0cf0: 6e 74 20 32 35 20 2a 64 65 66 61 75 6c 74 2d 6c nt 25 *default-l
0d00: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
0d10: 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 73 74 61 client:setup sta
0d20: 72 74 2d 72 65 73 3d 22 20 73 74 61 72 74 2d 72 rt-res=" start-r
0d30: 65 73 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 es ", run-id=" r
0d40: 75 6e 2d 69 64 20 22 2c 20 73 65 72 76 65 72 2d un-id ", server-
0d50: 64 61 74 3d 22 20 68 6f 73 74 2d 69 6e 66 6f 29 dat=" host-info)
0d60: 0a 3b 3b 20 09 09 09 28 68 61 73 68 2d 74 61 62 .;; ...(hash-tab
0d70: 6c 65 2d 64 65 6c 65 74 65 21 20 2a 72 75 6e 72 le-delete! *runr
0d80: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 0a 3b emote* run-id).;
0d90: 3b 20 09 09 09 28 6f 70 65 6e 2d 72 75 6e 2d 63 ; ...(open-run-c
0da0: 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 lose tasks:serve
0db0: 72 2d 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 r-force-clean-ru
0dc0: 6e 2d 72 65 63 6f 72 64 0a 3b 3b 20 09 09 09 20 n-record.;; ...
0dd0: 09 09 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 0a ..tasks:open-db.
0de0: 3b 3b 20 09 09 09 20 09 09 72 75 6e 2d 69 64 20 ;; ... ..run-id
0df0: 0a 3b 3b 20 09 09 09 20 09 09 28 63 61 72 20 20 .;; ... ..(car
0e00: 68 6f 73 74 2d 69 6e 66 6f 29 0a 3b 3b 20 09 09 host-info).;; ..
0e10: 09 20 09 09 28 63 61 64 72 20 68 6f 73 74 2d 69 . ..(cadr host-i
0e20: 6e 66 6f 29 0a 3b 3b 20 09 09 09 09 09 22 20 63 nfo).;; ....." c
0e30: 6c 69 65 6e 74 3a 73 65 74 75 70 20 28 68 6f 73 lient:setup (hos
0e40: 74 2d 69 6e 66 6f 3d 23 74 29 22 29 0a 3b 3b 20 t-info=#t)").;;
0e50: 09 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
0e60: 21 20 35 29 0a 3b 3b 20 09 09 09 28 63 6c 69 65 ! 5).;; ...(clie
0e70: 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 20 nt:setup run-id
0e80: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3a remaining-tries:
0e90: 20 31 30 29 29 20 3b 3b 20 28 2d 20 72 65 6d 61 10)) ;; (- rema
0ea0: 69 6e 69 6e 67 2d 74 72 69 65 73 20 31 29 29 29 ining-tries 1)))
0eb0: 0a 3b 3b 20 09 09 20 20 20 20 20 20 28 62 65 67 .;; .. (beg
0ec0: 69 6e 0a 3b 3b 20 09 09 09 28 64 65 62 75 67 3a in.;; ...(debug:
0ed0: 70 72 69 6e 74 20 32 35 20 2a 64 65 66 61 75 6c print 25 *defaul
0ee0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
0ef0: 4f 3a 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 O: client:setup
0f00: 66 61 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 failed to connec
0f10: 74 2c 20 73 74 61 72 74 2d 72 65 73 3d 22 20 73 t, start-res=" s
0f20: 74 61 72 74 2d 72 65 73 20 22 2c 20 72 75 6e 2d tart-res ", run-
0f30: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 68 id=" run-id ", h
0f40: 6f 73 74 2d 69 6e 66 6f 3d 22 20 68 6f 73 74 2d ost-info=" host-
0f50: 69 6e 66 6f 29 0a 3b 3b 20 09 09 09 28 74 68 72 info).;; ...(thr
0f60: 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 3b 3b ead-sleep! 5).;;
0f70: 20 09 09 09 28 63 6c 69 65 6e 74 3a 73 65 74 75 ...(client:setu
0f80: 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 69 6e 69 p run-id remaini
0f90: 6e 67 2d 74 72 69 65 73 3a 20 28 2d 20 72 65 6d ng-tries: (- rem
0fa0: 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 31 29 29 aining-tries 1))
0fb0: 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 3b 3b 20 )))).;; . ;;
0fc0: 59 55 4b 3a 20 72 65 6e 61 6d 65 20 73 65 72 76 YUK: rename serv
0fd0: 65 72 2d 64 61 74 20 68 65 72 65 0a 3b 3b 20 09 er-dat here.;; .
0fe0: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 (let* ((serv
0ff0: 65 72 2d 64 61 74 20 28 6f 70 65 6e 2d 72 75 6e er-dat (open-run
1000: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 -close tasks:get
1010: 2d 73 65 72 76 65 72 20 74 61 73 6b 73 3a 6f 70 -server tasks:op
1020: 65 6e 2d 64 62 20 72 75 6e 2d 69 64 29 29 29 0a en-db run-id))).
1030: 3b 3b 20 09 20 20 20 20 20 20 28 64 65 62 75 67 ;; . (debug
1040: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
1050: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1060: 20 22 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 73 "client:setup s
1070: 65 72 76 65 72 2d 64 61 74 3d 22 20 73 65 72 76 erver-dat=" serv
1080: 65 72 2d 64 61 74 20 22 2c 20 72 65 6d 61 69 6e er-dat ", remain
1090: 69 6e 67 2d 74 72 69 65 73 3d 22 20 72 65 6d 61 ing-tries=" rema
10a0: 69 6e 69 6e 67 2d 74 72 69 65 73 29 0a 3b 3b 20 ining-tries).;;
10b0: 09 20 20 20 20 20 20 28 69 66 20 73 65 72 76 65 . (if serve
10c0: 72 2d 64 61 74 0a 3b 3b 20 09 09 20 20 28 6c 65 r-dat.;; .. (le
10d0: 74 2a 20 28 28 69 66 61 63 65 20 20 20 20 20 28 t* ((iface (
10e0: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
10f0: 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 65 72 et-interface ser
1100: 76 65 72 2d 64 61 74 29 29 0a 3b 3b 20 09 09 09 ver-dat)).;; ...
1110: 20 28 70 6f 72 74 20 20 20 20 20 20 28 74 61 73 (port (tas
1120: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
1130: 70 6f 72 74 20 20 20 20 20 20 73 65 72 76 65 72 port server
1140: 2d 64 61 74 29 29 0a 3b 3b 20 09 09 09 20 28 73 -dat)).;; ... (s
1150: 74 61 72 74 2d 72 65 73 20 28 68 74 74 70 2d 74 tart-res (http-t
1160: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
1170: 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f connect iface po
1180: 72 74 29 29 0a 3b 3b 20 09 09 09 20 3b 3b 20 28 rt)).;; ... ;; (
1190: 70 69 6e 67 2d 72 65 73 20 20 28 73 65 72 76 65 ping-res (serve
11a0: 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 72 75 r:ping-server ru
11b0: 6e 2d 69 64 20 69 66 61 63 65 20 70 6f 72 74 29 n-id iface port)
11c0: 29 0a 3b 3b 20 09 09 09 20 28 70 69 6e 67 2d 72 ).;; ... (ping-r
11d0: 65 73 20 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e es (rmt:login-n
11e0: 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 o-auto-client-se
11f0: 74 75 70 20 73 74 61 72 74 2d 72 65 73 20 72 75 tup start-res ru
1200: 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 09 20 20 20 n-id))).;; ..
1210: 20 28 69 66 20 73 74 61 72 74 2d 72 65 73 0a 3b (if start-res.;
1220: 3b 20 09 09 09 28 62 65 67 69 6e 0a 3b 3b 20 09 ; ...(begin.;; .
1230: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
1240: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
1250: 20 72 75 6e 2d 69 64 20 73 74 61 72 74 2d 72 65 run-id start-re
1260: 73 29 0a 3b 3b 20 09 09 09 20 20 73 74 61 72 74 s).;; ... start
1270: 2d 72 65 73 29 0a 3b 3b 20 09 09 09 28 69 66 20 -res).;; ...(if
1280: 28 6d 65 6d 62 65 72 20 72 65 6d 61 69 6e 69 6e (member remainin
1290: 67 2d 74 72 69 65 73 20 27 28 32 20 35 29 29 0a g-tries '(2 5)).
12a0: 3b 3b 20 09 09 09 20 20 20 20 28 62 65 67 69 6e ;; ... (begin
12b0: 20 20 20 20 3b 3b 20 6c 6f 67 69 6e 20 66 61 69 ;; login fai
12c0: 6c 65 64 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 led.;; ...
12d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 35 20 (debug:print 25
12e0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
12f0: 74 2a 20 22 49 4e 46 4f 3a 20 63 6c 69 65 6e 74 t* "INFO: client
1300: 3a 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 :setup start-res
1310: 3d 22 20 73 74 61 72 74 2d 72 65 73 20 22 2c 20 =" start-res ",
1320: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
1330: 22 2c 20 73 65 72 76 65 72 2d 64 61 74 3d 22 20 ", server-dat="
1340: 73 65 72 76 65 72 2d 64 61 74 29 0a 3b 3b 20 09 server-dat).;; .
1350: 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 .. (hash-ta
1360: 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a 72 75 6e ble-delete! *run
1370: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 0a remote* run-id).
1380: 3b 3b 20 09 09 09 20 20 20 20 20 20 28 6f 70 65 ;; ... (ope
1390: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b n-run-close task
13a0: 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 s:server-force-c
13b0: 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 0a lean-run-record.
13c0: 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 74 61 ;; ..... ta
13d0: 73 6b 73 3a 6f 70 65 6e 2d 64 62 0a 3b 3b 20 09 sks:open-db.;; .
13e0: 09 09 09 09 20 20 20 20 20 20 72 75 6e 2d 69 64 .... run-id
13f0: 20 0a 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 .;; .....
1400: 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d (tasks:hostinfo-
1410: 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 65 get-interface se
1420: 72 76 65 72 2d 64 61 74 29 0a 3b 3b 20 09 09 09 rver-dat).;; ...
1430: 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a 68 .. (tasks:h
1440: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 ostinfo-get-port
1450: 20 20 20 20 20 20 73 65 72 76 65 72 2d 64 61 74 server-dat
1460: 29 0a 3b 3b 20 09 09 09 09 09 20 20 20 20 20 20 ).;; .....
1470: 22 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 28 " client:setup (
1480: 73 65 72 76 65 72 2d 64 61 74 20 3d 20 23 74 29 server-dat = #t)
1490: 22 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 ").;; ... (
14a0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 thread-sleep! 2)
14b0: 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 73 65 .;; ... (se
14c0: 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 rver:try-running
14d0: 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 20 run-id).;; ...
14e0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
14f0: 65 70 21 20 31 30 29 20 3b 3b 20 67 69 76 65 20 ep! 10) ;; give
1500: 73 65 72 76 65 72 20 61 20 6c 69 74 74 6c 65 20 server a little
1510: 74 69 6d 65 20 74 6f 20 73 74 61 72 74 20 75 70 time to start up
1520: 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 28 63 6c .;; ... (cl
1530: 69 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 ient:setup run-i
1540: 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 d remaining-trie
1550: 73 3a 20 31 30 29 29 20 3b 3b 20 28 2d 20 72 65 s: 10)) ;; (- re
1560: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 31 29 maining-tries 1)
1570: 29 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 62 65 )).;; ... (be
1580: 67 69 6e 0a 3b 3b 20 09 09 09 20 20 20 20 20 20 gin.;; ...
1590: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 35 20 (debug:print 25
15a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
15b0: 74 2a 20 22 49 4e 46 4f 3a 20 63 6c 69 65 6e 74 t* "INFO: client
15c0: 3a 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 :setup start-res
15d0: 3d 22 20 73 74 61 72 74 2d 72 65 73 20 22 2c 20 =" start-res ",
15e0: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
15f0: 22 2c 20 73 65 72 76 65 72 2d 64 61 74 3d 22 20 ", server-dat="
1600: 73 65 72 76 65 72 2d 64 61 74 29 0a 3b 3b 20 09 server-dat).;; .
1610: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
1620: 73 6c 65 65 70 21 20 35 29 0a 3b 3b 20 09 09 09 sleep! 5).;; ...
1630: 20 20 20 20 20 20 28 63 6c 69 65 6e 74 3a 73 65 (client:se
1640: 74 75 70 20 72 75 6e 2d 69 64 20 72 65 6d 61 69 tup run-id remai
1650: 6e 69 6e 67 2d 74 72 69 65 73 3a 20 28 2d 20 72 ning-tries: (- r
1660: 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 31 emaining-tries 1
1670: 29 29 29 29 29 29 0a 3b 3b 20 09 09 20 20 28 62 )))))).;; .. (b
1680: 65 67 69 6e 20 20 20 20 3b 3b 20 6e 6f 20 73 65 egin ;; no se
1690: 72 76 65 72 20 72 65 67 69 73 74 65 72 65 64 0a rver registered.
16a0: 3b 3b 20 09 09 20 20 20 20 28 69 66 20 28 65 71 ;; .. (if (eq
16b0: 3f 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 ? remaining-trie
16c0: 73 20 32 29 0a 3b 3b 20 09 09 09 28 62 65 67 69 s 2).;; ...(begi
16d0: 6e 0a 3b 3b 20 09 09 09 20 20 3b 3b 20 28 6f 70 n.;; ... ;; (op
16e0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas
16f0: 6b 73 3a 73 65 72 76 65 72 2d 63 6c 65 61 6e 2d ks:server-clean-
1700: 6f 75 74 2d 6f 6c 64 2d 72 65 63 6f 72 64 73 2d out-old-records-
1710: 66 6f 72 2d 72 75 6e 2d 69 64 20 74 61 73 6b 73 for-run-id tasks
1720: 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 64 20 :open-db run-id
1730: 22 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 28 " client:setup (
1740: 73 65 72 76 65 72 2d 64 61 74 3d 23 66 29 22 29 server-dat=#f)")
1750: 0a 3b 3b 20 09 09 09 20 20 28 63 6c 69 65 6e 74 .;; ... (client
1760: 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 20 72 65 :setup run-id re
1770: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3a 20 31 maining-tries: 1
1780: 30 29 29 0a 3b 3b 20 09 09 09 28 62 65 67 69 6e 0)).;; ...(begin
1790: 0a 3b 3b 20 09 09 09 20 20 28 74 68 72 65 61 64 .;; ... (thread
17a0: 2d 73 6c 65 65 70 21 20 32 29 20 0a 3b 3b 20 09 -sleep! 2) .;; .
17b0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
17c0: 20 32 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 25 *default-log
17d0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 6c -port* "INFO: cl
17e0: 69 65 6e 74 3a 73 65 74 75 70 20 73 74 61 72 74 ient:setup start
17f0: 2d 72 65 73 20 28 6e 6f 74 20 64 65 66 69 6e 65 -res (not define
1800: 64 20 68 65 72 65 29 2c 20 72 75 6e 2d 69 64 3d d here), run-id=
1810: 22 20 72 75 6e 2d 69 64 20 22 2c 20 73 65 72 76 " run-id ", serv
1820: 65 72 2d 64 61 74 3d 22 20 73 65 72 76 65 72 2d er-dat=" server-
1830: 64 61 74 29 0a 3b 3b 20 09 09 09 20 20 28 69 66 dat).;; ... (if
1840: 20 28 3c 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (< (open-run-cl
1850: 6f 73 65 20 74 61 73 6b 73 3a 6e 75 6d 2d 69 6e ose tasks:num-in
1860: 2d 61 76 61 69 6c 61 62 6c 65 2d 73 74 61 74 65 -available-state
1870: 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 tasks:open-db r
1880: 75 6e 2d 69 64 29 20 33 29 0a 3b 3b 20 09 09 09 un-id) 3).;; ...
1890: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 (begin.;;
18a0: 09 09 09 09 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e ....;; (open-run
18b0: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
18c0: 76 65 72 2d 63 6c 65 61 6e 2d 6f 75 74 2d 6f 6c ver-clean-out-ol
18d0: 64 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 72 75 d-records-for-ru
18e0: 6e 2d 69 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d n-id tasks:open-
18f0: 64 62 20 72 75 6e 2d 69 64 20 22 20 63 6c 69 65 db run-id " clie
1900: 6e 74 3a 73 65 74 75 70 20 28 73 65 72 76 65 72 nt:setup (server
1910: 2d 64 61 74 3d 23 66 29 22 29 0a 3b 3b 20 09 09 -dat=#f)").;; ..
1920: 09 09 28 73 65 72 76 65 72 3a 74 72 79 2d 72 75 ..(server:try-ru
1930: 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 29 29 0a nning run-id))).
1940: 3b 3b 20 09 09 09 20 20 28 74 68 72 65 61 64 2d ;; ... (thread-
1950: 73 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 67 69 sleep! 10) ;; gi
1960: 76 65 20 73 65 72 76 65 72 20 61 20 6c 69 74 74 ve server a litt
1970: 6c 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 74 le time to start
1980: 20 75 70 0a 3b 3b 20 09 09 09 20 20 28 63 6c 69 up.;; ... (cli
1990: 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 ent:setup run-id
19a0: 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 remaining-tries
19b0: 3a 20 28 2d 20 72 65 6d 61 69 6e 69 6e 67 2d 74 : (- remaining-t
19c0: 72 69 65 73 20 31 29 29 29 29 29 29 29 29 29 29 ries 1))))))))))
19d0: 29 0a 0a 3b 3b 20 44 6f 20 61 6c 6c 20 74 68 65 )..;; Do all the
19e0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 77 6f 72 6b connection work
19f0: 2c 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 74 72 , look up the tr
1a00: 61 6e 73 70 6f 72 74 20 74 79 70 65 20 61 6e 64 ansport type and
1a10: 20 73 65 74 20 75 70 20 74 68 65 0a 3b 3b 20 63 set up the.;; c
1a20: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 72 65 71 onnection if req
1a30: 75 69 72 65 64 2e 0a 3b 3b 0a 3b 3b 20 54 68 65 uired..;;.;; The
1a40: 72 65 20 61 72 65 20 74 77 6f 20 73 63 65 6e 61 re are two scena
1a50: 72 69 6f 73 2e 20 0a 3b 3b 20 20 20 31 2e 20 57 rios. .;; 1. W
1a60: 65 20 61 72 65 20 61 20 74 65 73 74 20 6d 61 6e e are a test man
1a70: 61 67 65 72 20 61 6e 64 20 77 65 20 72 65 63 65 ager and we rece
1a80: 69 76 65 64 20 2a 74 72 61 6e 73 70 6f 72 74 2d ived *transport-
1a90: 74 79 70 65 2a 20 61 6e 64 20 2a 72 75 6e 72 65 type* and *runre
1aa0: 6d 6f 74 65 2a 20 76 69 61 20 63 6d 64 6c 69 6e mote* via cmdlin
1ab0: 65 0a 3b 3b 20 20 20 32 2e 20 57 65 20 61 72 65 e.;; 2. We are
1ac0: 20 61 20 72 75 6e 20 74 65 73 74 73 2c 20 6c 69 a run tests, li
1ad0: 73 74 20 72 75 6e 73 20 6f 72 20 6f 74 68 65 72 st runs or other
1ae0: 20 69 6e 74 65 72 61 63 74 69 76 65 20 70 72 6f interactive pro
1af0: 63 65 73 73 20 61 6e 64 20 77 65 20 6d 75 73 74 cess and we must
1b00: 20 66 69 67 75 72 65 20 6f 75 74 0a 3b 3b 20 20 figure out.;;
1b10: 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 *transport-t
1b20: 79 70 65 2a 20 61 6e 64 20 2a 72 75 6e 72 65 6d ype* and *runrem
1b30: 6f 74 65 2a 20 66 72 6f 6d 20 74 68 65 20 6d 6f ote* from the mo
1b40: 6e 69 74 6f 72 2e 64 62 0a 3b 3b 0a 3b 3b 20 63 nitor.db.;;.;; c
1b50: 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b 3b 0a 3b lient:setup.;;.;
1b60: 3b 20 6c 6f 6f 6b 75 70 5f 73 65 72 76 65 72 2c ; lookup_server,
1b70: 20 6e 65 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 need to remove
1b80: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 73 74 75 66 *runremote* stuf
1b90: 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6c f.;;.(define (cl
1ba0: 69 65 6e 74 3a 73 65 74 75 70 2d 68 74 74 70 20 ient:setup-http
1bb0: 72 75 6e 2d 69 64 20 23 21 6b 65 79 20 28 72 65 run-id #!key (re
1bc0: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 31 30 maining-tries 10
1bd0: 29 20 28 66 61 69 6c 65 64 2d 63 6f 6e 6e 65 63 ) (failed-connec
1be0: 74 73 20 30 29 29 0a 20 20 28 64 65 62 75 67 3a ts 0)). (debug:
1bf0: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
1c00: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1c10: 22 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 72 65 "client:setup re
1c20: 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 3d 22 20 maining-tries="
1c30: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 29 remaining-tries)
1c40: 0a 20 20 28 6c 65 74 2a 20 28 28 74 64 62 64 61 . (let* ((tdbda
1c50: 74 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 t (tasks:open-db
1c60: 29 29 29 0a 20 20 20 20 28 69 66 20 28 3c 3d 20 ))). (if (<=
1c70: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 20 remaining-tries
1c80: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 0)..(begin.. (d
1c90: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
1ca0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1cb0: 70 6f 72 74 2a 20 22 66 61 69 6c 65 64 20 74 6f port* "failed to
1cc0: 20 73 74 61 72 74 20 6f 72 20 63 6f 6e 6e 65 63 start or connec
1cd0: 74 20 74 6f 20 73 65 72 76 65 72 20 66 6f 72 20 t to server for
1ce0: 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 29 run-id " run-id)
1cf0: 0a 09 20 20 28 65 78 69 74 20 31 29 29 0a 09 28 .. (exit 1))..(
1d00: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 64 61 let* ((server-da
1d10: 74 20 28 74 61 73 6b 73 3a 67 65 74 2d 73 65 72 t (tasks:get-ser
1d20: 76 65 72 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 ver (db:delay-if
1d30: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 72 75 -busy tdbdat) ru
1d40: 6e 2d 69 64 29 29 29 0a 09 20 20 28 64 65 62 75 n-id))).. (debu
1d50: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
1d60: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1d70: 2a 20 22 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 * "client:setup
1d80: 73 65 72 76 65 72 2d 64 61 74 3d 22 20 73 65 72 server-dat=" ser
1d90: 76 65 72 2d 64 61 74 20 22 2c 20 72 65 6d 61 69 ver-dat ", remai
1da0: 6e 69 6e 67 2d 74 72 69 65 73 3d 22 20 72 65 6d ning-tries=" rem
1db0: 61 69 6e 69 6e 67 2d 74 72 69 65 73 29 0a 09 20 aining-tries)..
1dc0: 20 28 69 66 20 73 65 72 76 65 72 2d 64 61 74 0a (if server-dat.
1dd0: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 . (let* ((i
1de0: 66 61 63 65 20 20 20 20 20 28 74 61 73 6b 73 3a face (tasks:
1df0: 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 hostinfo-get-int
1e00: 65 72 66 61 63 65 20 73 65 72 76 65 72 2d 64 61 erface server-da
1e10: 74 29 29 0a 09 09 20 20 20 20 20 28 68 6f 73 74 t))... (host
1e20: 6e 61 6d 65 20 20 28 74 61 73 6b 73 3a 68 6f 73 name (tasks:hos
1e30: 74 69 6e 66 6f 2d 67 65 74 2d 68 6f 73 74 6e 61 tinfo-get-hostna
1e40: 6d 65 20 20 73 65 72 76 65 72 2d 64 61 74 29 29 me server-dat))
1e50: 0a 09 09 20 20 20 20 20 28 70 6f 72 74 20 20 20 ... (port
1e60: 20 20 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e (tasks:hostin
1e70: 66 6f 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 20 fo-get-port
1e80: 20 73 65 72 76 65 72 2d 64 61 74 29 29 0a 09 09 server-dat))...
1e90: 20 20 20 20 20 28 73 74 61 72 74 2d 72 65 73 20 (start-res
1ea0: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
1eb0: 2d 74 79 70 65 2a 0a 09 09 09 09 20 20 28 28 68 -type*..... ((h
1ec0: 74 74 70 29 28 68 74 74 70 2d 74 72 61 6e 73 70 ttp)(http-transp
1ed0: 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 ort:client-conne
1ee0: 63 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 0a ct iface port)).
1ef0: 09 09 09 09 20 20 28 28 6e 6d 73 67 29 28 6e 6d .... ((nmsg)(nm
1f00: 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 sg-transport:cli
1f10: 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 68 6f 73 74 ent-connect host
1f20: 6e 61 6d 65 20 70 6f 72 74 29 29 29 29 0a 09 09 name port))))...
1f30: 20 20 20 20 20 28 70 69 6e 67 2d 72 65 73 20 20 (ping-res
1f40: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
1f50: 2d 74 79 70 65 2a 20 0a 09 09 09 09 20 20 28 28 -type* ..... ((
1f60: 68 74 74 70 29 28 72 6d 74 3a 6c 6f 67 69 6e 2d http)(rmt:login-
1f70: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
1f80: 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 20 72 etup start-res r
1f90: 75 6e 2d 69 64 29 29 0a 09 09 09 09 20 20 28 28 un-id))..... ((
1fa0: 6e 6d 73 67 29 28 6c 65 74 20 28 28 6c 6f 67 69 nmsg)(let ((logi
1fb0: 6e 69 6e 66 6f 20 28 72 6d 74 3a 6c 6f 67 69 6e ninfo (rmt:login
1fc0: 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d -no-auto-client-
1fd0: 73 65 74 75 70 20 73 74 61 72 74 2d 72 65 73 20 setup start-res
1fe0: 72 75 6e 2d 69 64 29 29 29 0a 20 09 09 09 09 09 run-id))). .....
1ff0: 20 20 20 28 69 66 20 6c 6f 67 69 6e 69 6e 66 6f (if logininfo
2000: 0a 20 09 09 09 09 09 20 20 20 20 20 20 20 28 63 . ..... (c
2010: 61 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6c ar (vector-ref l
2020: 6f 67 69 6e 69 6e 66 6f 20 31 29 29 0a 20 09 09 ogininfo 1)). ..
2030: 09 09 09 20 20 20 20 20 20 20 23 66 29 29 29 29 ... #f))))
2040: 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 73 74 ))...(if (and st
2050: 61 72 74 2d 72 65 73 0a 09 09 09 20 70 69 6e 67 art-res.... ping
2060: 2d 72 65 73 29 0a 09 09 20 20 20 20 28 62 65 67 -res)... (beg
2070: 69 6e 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 in... (hash
2080: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 72 75 6e -table-set! *run
2090: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 73 remote* run-id s
20a0: 74 61 72 74 2d 72 65 73 29 0a 09 09 20 20 20 20 tart-res)...
20b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
20c0: 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
20d0: 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 65 63 og-port* "connec
20e0: 74 65 64 20 74 6f 20 22 20 28 68 74 74 70 2d 74 ted to " (http-t
20f0: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
2100: 64 61 74 2d 6d 61 6b 65 2d 75 72 6c 20 73 74 61 dat-make-url sta
2110: 72 74 2d 72 65 73 29 29 0a 09 09 20 20 20 20 20 rt-res))...
2120: 20 73 74 61 72 74 2d 72 65 73 29 0a 09 09 20 20 start-res)...
2130: 20 20 28 62 65 67 69 6e 20 20 20 20 3b 3b 20 6c (begin ;; l
2140: 6f 67 69 6e 20 66 61 69 6c 65 64 20 62 75 74 20 ogin failed but
2150: 68 61 76 65 20 61 20 73 65 72 76 65 72 20 72 65 have a server re
2160: 63 6f 72 64 2c 20 63 6c 65 61 6e 20 6f 75 74 20 cord, clean out
2170: 74 68 65 20 72 65 63 6f 72 64 20 61 6e 64 20 74 the record and t
2180: 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 ry again...
2190: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
21a0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
21b0: 67 2d 70 6f 72 74 2a 20 22 63 6c 69 65 6e 74 3a g-port* "client:
21c0: 73 65 74 75 70 2c 20 6c 6f 67 69 6e 20 66 61 69 setup, login fai
21d0: 6c 65 64 2c 20 77 69 6c 6c 20 61 74 74 65 6d 70 led, will attemp
21e0: 74 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 t to start serve
21f0: 72 20 2e 2e 2e 20 73 74 61 72 74 2d 72 65 73 3d r ... start-res=
2200: 22 20 73 74 61 72 74 2d 72 65 73 20 22 2c 20 72 " start-res ", r
2210: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
2220: 2c 20 73 65 72 76 65 72 2d 64 61 74 3d 22 20 73 , server-dat=" s
2230: 65 72 76 65 72 2d 64 61 74 29 0a 09 09 20 20 20 erver-dat)...
2240: 20 20 20 28 63 61 73 65 20 2a 74 72 61 6e 73 70 (case *transp
2250: 6f 72 74 2d 74 79 70 65 2a 20 0a 09 09 09 28 28 ort-type* ....((
2260: 68 74 74 70 29 28 68 74 74 70 2d 74 72 61 6e 73 http)(http-trans
2270: 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 port:close-conne
2280: 63 74 69 6f 6e 73 20 72 75 6e 2d 69 64 29 29 29 ctions run-id)))
2290: 0a 09 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 ... (hash-t
22a0: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a 72 75 able-delete! *ru
22b0: 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 nremote* run-id)
22c0: 0a 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a ... (tasks:
22d0: 6b 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d kill-server-run-
22e0: 69 64 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 id run-id)...
22f0: 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 (tasks:server
2300: 2d 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e -force-clean-run
2310: 2d 72 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 -record (db:dela
2320: 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 y-if-busy tdbdat
2330: 29 0a 09 09 09 09 09 09 09 20 20 20 72 75 6e 2d )........ run-
2340: 69 64 20 0a 09 09 09 09 09 09 09 20 20 20 28 74 id ........ (t
2350: 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 asks:hostinfo-ge
2360: 74 2d 69 6e 74 65 72 66 61 63 65 20 73 65 72 76 t-interface serv
2370: 65 72 2d 64 61 74 29 0a 09 09 09 09 09 09 09 20 er-dat)........
2380: 20 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 (tasks:hostinf
2390: 6f 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 20 20 o-get-port
23a0: 73 65 72 76 65 72 2d 64 61 74 29 0a 09 09 09 09 server-dat).....
23b0: 09 09 09 20 20 20 22 20 63 6c 69 65 6e 74 3a 73 ... " client:s
23c0: 65 74 75 70 20 28 73 65 72 76 65 72 2d 64 61 74 etup (server-dat
23d0: 20 3d 20 23 74 29 22 29 0a 09 09 20 20 20 20 20 = #t)")...
23e0: 20 28 69 66 20 28 3e 20 72 65 6d 61 69 6e 69 6e (if (> remainin
23f0: 67 2d 74 72 69 65 73 20 38 29 0a 09 09 09 20 20 g-tries 8)....
2400: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
2410: 2b 20 31 20 28 72 61 6e 64 6f 6d 20 35 29 29 29 + 1 (random 5)))
2420: 20 3b 3b 20 73 70 72 65 61 64 20 6f 75 74 20 74 ;; spread out t
2430: 68 65 20 73 74 61 72 74 73 20 61 20 6c 69 74 74 he starts a litt
2440: 6c 65 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d le.... (thread-
2450: 73 6c 65 65 70 21 20 28 2b 20 31 35 20 28 72 61 sleep! (+ 15 (ra
2460: 6e 64 6f 6d 20 32 30 29 29 29 29 20 3b 3b 20 69 ndom 20)))) ;; i
2470: 74 20 69 73 6e 27 74 20 67 6f 69 6e 67 20 77 65 t isn't going we
2480: 6c 6c 2e 20 67 69 76 65 20 69 74 20 70 6c 65 6e ll. give it plen
2490: 74 79 20 6f 66 20 74 69 6d 65 0a 09 09 20 20 20 ty of time...
24a0: 20 20 20 28 73 65 72 76 65 72 3a 74 72 79 2d 72 (server:try-r
24b0: 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a 09 unning run-id)..
24c0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
24d0: 6c 65 65 70 21 20 35 29 20 20 20 3b 3b 20 67 69 leep! 5) ;; gi
24e0: 76 65 20 73 65 72 76 65 72 20 61 20 6c 69 74 74 ve server a litt
24f0: 6c 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 74 le time to start
2500: 20 75 70 0a 09 09 20 20 20 20 20 20 28 63 6c 69 up... (cli
2510: 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 ent:setup run-id
2520: 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 remaining-tries
2530: 3a 20 28 2d 20 72 65 6d 61 69 6e 69 6e 67 2d 74 : (- remaining-t
2540: 72 69 65 73 20 31 29 29 0a 09 09 20 20 20 20 20 ries 1))...
2550: 20 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 ))).. (beg
2560: 69 6e 20 20 20 20 3b 3b 20 6e 6f 20 73 65 72 76 in ;; no serv
2570: 65 72 20 72 65 67 69 73 74 65 72 65 64 0a 09 09 er registered...
2580: 28 6c 65 74 20 28 28 6e 75 6d 2d 61 76 61 69 6c (let ((num-avail
2590: 61 62 6c 65 20 28 74 61 73 6b 73 3a 6e 75 6d 2d able (tasks:num-
25a0: 69 6e 2d 61 76 61 69 6c 61 62 6c 65 2d 73 74 61 in-available-sta
25b0: 74 65 20 28 64 62 3a 64 62 64 61 74 2d 67 65 74 te (db:dbdat-get
25c0: 2d 64 62 20 74 64 62 64 61 74 29 20 72 75 6e 2d -db tdbdat) run-
25d0: 69 64 29 29 29 0a 09 09 20 20 28 64 65 62 75 67 id)))... (debug
25e0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
25f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2600: 20 22 63 6c 69 65 6e 74 3a 73 65 74 75 70 2c 20 "client:setup,
2610: 6e 6f 20 73 65 72 76 65 72 20 72 65 67 69 73 74 no server regist
2620: 65 72 65 64 2c 20 72 65 6d 61 69 6e 69 6e 67 2d ered, remaining-
2630: 74 72 69 65 73 3d 22 20 72 65 6d 61 69 6e 69 6e tries=" remainin
2640: 67 2d 74 72 69 65 73 20 22 20 6e 75 6d 2d 61 76 g-tries " num-av
2650: 61 69 6c 61 62 6c 65 3d 22 20 6e 75 6d 2d 61 76 ailable=" num-av
2660: 61 69 6c 61 62 6c 65 29 0a 09 09 20 20 28 69 66 ailable)... (if
2670: 20 28 3c 20 6e 75 6d 2d 61 76 61 69 6c 61 62 6c (< num-availabl
2680: 65 20 32 29 0a 09 09 20 20 20 20 20 20 28 73 65 e 2)... (se
2690: 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 rver:try-running
26a0: 20 72 75 6e 2d 69 64 29 29 0a 09 09 20 20 28 74 run-id))... (t
26b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 hread-sleep! (+
26c0: 35 20 28 72 61 6e 64 6f 6d 20 28 2d 20 32 30 20 5 (random (- 20
26d0: 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 29 remaining-tries)
26e0: 29 29 29 20 20 3b 3b 20 67 69 76 65 20 73 65 72 ))) ;; give ser
26f0: 76 65 72 20 61 20 6c 69 74 74 6c 65 20 74 69 6d ver a little tim
2700: 65 20 74 6f 20 73 74 61 72 74 20 75 70 2c 20 72 e to start up, r
2710: 61 6e 64 6f 6d 69 7a 65 20 61 20 6c 69 74 74 6c andomize a littl
2720: 65 20 74 6f 20 61 76 6f 69 64 20 73 74 61 72 74 e to avoid start
2730: 20 73 74 6f 72 6d 73 2e 0a 09 09 20 20 28 63 6c storms.... (cl
2740: 69 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 ient:setup run-i
2750: 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 d remaining-trie
2760: 73 3a 20 28 2d 20 72 65 6d 61 69 6e 69 6e 67 2d s: (- remaining-
2770: 74 72 69 65 73 20 31 29 29 29 29 29 29 29 29 29 tries 1)))))))))
2780: 0a 0a 3b 3b 20 6b 65 65 70 20 74 68 69 73 20 61 ..;; keep this a
2790: 73 20 61 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 s a function to
27a0: 65 61 73 65 20 66 75 74 75 72 65 20 0a 28 64 65 ease future .(de
27b0: 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a 73 74 61 fine (client:sta
27c0: 72 74 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 rt run-id server
27d0: 2d 69 6e 66 6f 29 0a 20 20 28 68 74 74 70 2d 74 -info). (http-t
27e0: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
27f0: 63 6f 6e 6e 65 63 74 20 28 74 61 73 6b 73 3a 68 connect (tasks:h
2800: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 ostinfo-get-inte
2810: 72 66 61 63 65 20 73 65 72 76 65 72 2d 69 6e 66 rface server-inf
2820: 6f 29 0a 09 09 09 09 20 28 74 61 73 6b 73 3a 68 o)..... (tasks:h
2830: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 ostinfo-get-port
2840: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 0a server-info))).
2850: 0a 3b 3b 20 3b 3b 20 63 6c 69 65 6e 74 3a 73 69 .;; ;; client:si
2860: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 0a 3b 3b 20 gnal-handler.;;
2870: 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e 74 3a (define (client:
2880: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 signal-handler s
2890: 69 67 6e 75 6d 29 0a 3b 3b 20 20 20 28 73 69 67 ignum).;; (sig
28a0: 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d nal-mask! signum
28b0: 29 0a 3b 3b 20 20 20 28 73 65 74 21 20 2a 74 69 ).;; (set! *ti
28c0: 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a me-to-exit* #t).
28d0: 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ;; (handle-exc
28e0: 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 eptions.;; ex
28f0: 6e 0a 3b 3b 20 20 20 20 28 64 65 62 75 67 3a 70 n.;; (debug:p
2900: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2910: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 log-port* " ...
2920: 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 3b 3b exiting ...").;;
2930: 20 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 (let ((th1 (
2940: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
2950: 62 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 20 bda ().;; ...
2960: 20 20 22 22 29 20 3b 3b 20 64 6f 20 6e 6f 74 68 "") ;; do noth
2970: 69 6e 67 20 66 6f 72 20 6e 6f 77 20 28 77 61 73 ing for now (was
2980: 20 66 6c 75 73 68 20 6f 75 74 20 6c 61 73 74 20 flush out last
2990: 63 61 6c 6c 20 69 66 20 61 70 70 6c 69 63 61 62 call if applicab
29a0: 6c 65 29 0a 3b 3b 20 09 09 09 20 20 20 22 65 61 le).;; ... "ea
29b0: 74 20 72 65 73 70 6f 6e 73 65 22 29 29 0a 3b 3b t response")).;;
29c0: 20 09 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 . (th2 (make-th
29d0: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
29e0: 3b 3b 20 09 09 09 20 20 20 20 20 28 64 65 62 75 ;; ... (debu
29f0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
2a00: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2a10: 74 2a 20 22 52 65 63 65 69 76 65 64 20 5e 43 2c t* "Received ^C,
2a20: 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 attempting clea
2a30: 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 n exit. Please b
2a40: 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 e patient and wa
2a50: 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 it a few seconds
2a60: 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 before hitting
2a70: 5e 43 20 61 67 61 69 6e 2e 22 29 0a 3b 3b 20 09 ^C again.").;; .
2a80: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
2a90: 6c 65 65 70 21 20 31 29 20 3b 3b 20 67 69 76 65 leep! 1) ;; give
2aa0: 20 74 68 65 20 66 6c 75 73 68 20 6f 6e 65 20 73 the flush one s
2ab0: 65 63 6f 6e 64 20 74 6f 20 64 6f 20 69 74 27 73 econd to do it's
2ac0: 20 73 74 75 66 66 0a 3b 3b 20 09 09 09 20 20 20 stuff.;; ...
2ad0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2ae0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2af0: 72 74 2a 20 22 20 20 20 20 20 20 20 44 6f 6e 65 rt* " Done
2b00: 2e 22 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 .").;; ... (
2b10: 65 78 69 74 20 34 29 29 0a 3b 3b 20 09 09 09 20 exit 4)).;; ...
2b20: 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 69 "exit on ^C ti
2b30: 6d 65 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 20 mer"))).;;
2b40: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
2b50: 68 32 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 72 h2).;; (thr
2b60: 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a ead-start! th1).
2b70: 3b 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ;; (thread-
2b80: 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 0a 3b 3b join! th2)))).;;
2b90: 20 0a 3b 3b 20 3b 3b 20 63 6c 69 65 6e 74 3a 6c .;; ;; client:l
2ba0: 61 75 6e 63 68 0a 3b 3b 20 3b 3b 20 4e 65 65 64 aunch.;; ;; Need
2bb0: 20 74 6f 20 73 65 74 20 74 68 65 20 73 69 67 6e to set the sign
2bc0: 61 6c 20 68 61 6e 64 6c 65 72 20 73 6f 6d 65 77 al handler somew
2bd0: 68 65 72 65 20 6f 74 68 65 72 20 74 68 61 6e 20 here other than
2be0: 68 65 72 65 20 61 73 20 74 68 69 73 0a 3b 3b 20 here as this.;;
2bf0: 3b 3b 20 72 6f 75 74 69 6e 65 20 77 69 6c 6c 20 ;; routine will
2c00: 67 6f 20 61 77 61 79 2e 0a 3b 3b 20 3b 3b 0a 3b go away..;; ;;.;
2c10: 3b 20 28 64 65 66 69 6e 65 20 28 63 6c 69 65 6e ; (define (clien
2c20: 74 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 64 29 t:launch run-id)
2c30: 0a 3b 3b 20 20 20 28 73 65 74 2d 73 69 67 6e 61 .;; (set-signa
2c40: 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
2c50: 6c 2f 69 6e 74 20 20 63 6c 69 65 6e 74 3a 73 69 l/int client:si
2c60: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b gnal-handler).;;
2c70: 20 20 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 (set-signal-h
2c80: 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 andler! signal/t
2c90: 65 72 6d 20 63 6c 69 65 6e 74 3a 73 69 67 6e 61 erm client:signa
2ca0: 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 20 20 l-handler).;;
2cb0: 28 69 66 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 (if (client:setu
2cc0: 70 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 20 p run-id).;;
2cd0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2ce0: 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d info 2 *default-
2cf0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6e 6e 65 log-port* "conne
2d00: 63 74 65 64 20 61 73 20 63 6c 69 65 6e 74 22 29 cted as client")
2d10: 0a 3b 3b 20 20 20 20 20 20 20 28 62 65 67 69 6e .;; (begin
2d20: 0a 3b 3b 20 09 28 64 65 62 75 67 3a 70 72 69 6e .;; .(debug:prin
2d30: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
2d40: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 lt-log-port* "Fa
2d50: 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 iled to connect
2d60: 61 73 20 63 6c 69 65 6e 74 22 29 0a 3b 3b 20 09 as client").;; .
2d70: 28 65 78 69 74 29 29 29 29 0a 3b 3b 20 0a (exit)))).;; .